Merge branch 'development' into null_uint_test

.github/FUNDING.yml

@@ -0,0 +1,4 @@
+# These are supported funding model platforms
+
+open_collective: haxe
+custom: ['https://haxe.org/foundation/support-plans.html', 'https://haxe.org/foundation/donate.html']

.gitignore

@@ -8,6 +8,7 @@
 *.a
 *.exe
 .*.swp
+.haxelib
 /out
 /installer
 
@@ -26,6 +27,7 @@
 /haxelib*
 /haxedoc*
 /lib
+/prebuild
 
 /src/syntax/lexer.ml
 /libs/xml-light/xml_lexer.ml
@@ -64,6 +66,9 @@
 /tests/unit/unit.n
 /tests/unit/node_modules/
 
+/tests/nullsafety/bin
+/tests/nullsafety/dump
+
 /haxe.sublime*
 .idea
 build.bat
@@ -73,11 +78,13 @@ tests/unit/compile.php.hxml
 !/extra/build-haxesetup.xml
 tests/optimization/testopt.js
 tests/misc/pythonImport/native_python/__pycache__
+tests/misc/python/pythonImport/native_python/__pycache__
 tests/unit/unit.py
 tests/unit/unit.py.res1.txt
 tests/unit/unit.py.res2.bin
 tests/sys/bin/
 /tests/sys/dump/
+/tests/sys/test-res/
 tests/optimization/dump/
 tests/misc/projects/*/*.n
 tests/misc/*/*/*.lua
@@ -97,6 +104,7 @@ tests/misc/projects/Issue4070/cpp/
 *.vscode/
 
 /tests/sys/temp
+/tests/sys/temp-unicode
 *.dll
 _build/
 Makefile.dependencies
@@ -106,10 +114,22 @@ Makefile.modules
 
 /tests/unit/compiler_loops/log.txt
 tests/benchs/mandelbrot/bin/
-tests/server/test/cases/
-tests/server/test.js
 
-tests/unit/pypy3-*
+tests/unit/pypy3*
 tmp.tmp
 
-dev-display.hxml
+dev-display.hxml
+
+.DS_Store
+.history
+tests/sourcemaps/bin
+/*_plugin.ml
+tests/benchs/export/
+tests/benchs/dump/
+tests/display/.unittest/
+tests/unit/.unittest/
+tests/threads/export/
+tests/server/test.js.map
+*.merlin
+lib.sexp
+src/compiler/version.ml

.gitmodules

@@ -1,6 +1,3 @@
-[submodule "libs"]
-	path = libs
-	url = https://github.com/HaxeFoundation/ocamllibs.git
 [submodule "extra/haxelib_src"]
 	path = extra/haxelib_src
 	url = https://github.com/HaxeFoundation/haxelib.git

.merlin

@@ -1,12 +0,0 @@
-S src/**
-B _build/src/**
-S libs/**
-B libs/**
-B +threads
-PKG rope
-PKG ptmap
-PKG sedlex
-PKG extlib
-PKG camlzip
-PKG xml-light
-FLG -safe-string

.travis.yml

@@ -1,223 +0,0 @@
-cache:
-  timeout: 1000
-  directories:
-    - $HOME/.opam
-    - $HOME/neko
-    - $HOME/apt-cache
-    - $HOME/hxcache
-    - $HOME/lua_env
-    - $HOME/.luarocks
-
-before_cache:
-  - if [ $TRAVIS_OS_NAME = 'linux' ]; then
-      sudo apt-get autoclean;
-      sudo rm -f $HOME/apt-cache/lock || true;
-    fi
-  # somehow these files are recreated everytime
-  - rm -f $HOME/lua_env/lib/liblua51.a
-  - rm -f $HOME/lua_env/lib/liblua52.a
-  - rm -f $HOME/lua_env/lib/liblua53.a
-  - rm -f $HOME/lua_env/lib/libluajit-5.1.a
-  #- if [ $TRAVIS_OS_NAME = 'osx' ]; then brew cleanup; fi
-
-env:
-  global:
-    - OPAMYES=1
-    # make variables
-    - ADD_REVISION=1
-    # nightly builds submit
-    - secure: "UoGjYvQqt66GWmeLC4Pih1iue5AufVgW8XQOd2Bx839NN/2mQQ9bD1HuONJe+taWBJ+PHInkAjYROYYaiCQUA7B1SXs3oQD7Og6arVcR7kY7XOdAQ2t8ZkxJHTnuYGWW/2gNFBESv+3H17bkXG4rzaSn2LV5PJLOxSjw0ziBUMY="
-    - secure: "ugpxt+zeYiAiMYKLK96f5TLSxbQAtmDWiumdwaLHl88fIUeefxJJPIF1Xm0AHeYEJE7sD8dLE1dMbRSzOpXFfTmJoQZv19Wjv+2N5B+DaabKjGj1nZG7q3blGa3nUYzWVfFNFiIpM9c5fvW8yiUFzacZE5itEY8+lZQeGsNh+WQ="
-
-sudo: required
-dist: trusty
-
-install_linux: &install_linux
-  # Install dependencies
-  - export APT_CACHE_DIR=~/apt-cache && mkdir -pv $APT_CACHE_DIR
-  - sudo apt-get install --reinstall ca-certificates # workaround for "Cannot add PPA: 'ppa:haxe/ocaml'. Please check that the PPA name or format is correct."
-  - sudo add-apt-repository ppa:haxe/ocaml -y
-  - sudo apt-get update -y
-  - sudo apt-get -o dir::cache::archives="$APT_CACHE_DIR" install -y
-      ocaml
-      ocaml-native-compilers
-      ocaml-findlib
-      libpcre3-dev
-      zlib1g-dev
-      libgtk2.0-dev
-      ninja-build
-      awscli
-      $JOB_DEPENDENCIES
-  - wget https://raw.github.com/ocaml/opam/master/shell/opam_installer.sh -O - | sh -s /usr/local/bin system
-  - opam update
-  - opam pin add haxe . --no-action
-  - opam install haxe --deps-only
-  # install neko
-  - if [ ! $DEPLOY_NIGHTLIES ]; then
-      sudo add-apt-repository ppa:haxe/snapshots -y;
-      sudo apt-get -o dir::cache::archives="$APT_CACHE_DIR" install -y neko neko-dev;
-    else
-      if [ ! -d "$HOME/neko" ]; then
-        mkdir $HOME/neko;
-        pushd $HOME/neko;
-        git clone https://github.com/HaxeFoundation/neko.git .;
-        git submodule update --init --recursive;
-      else
-        pushd $HOME/neko;
-        if [ ! -d "$HOME/neko/.git" ]; then
-          git clone https://github.com/HaxeFoundation/neko.git .;
-          git submodule update --init --recursive;
-        else
-          git fetch --all;
-          git reset --hard origin/master;
-          git submodule update --init --recursive;
-        fi;
-      fi;
-      cmake . -DSTATIC_DEPS=all -G Ninja || (git clean -dfx && cmake . -DSTATIC_DEPS=all -G Ninja);
-      ninja download_static_deps || ninja download_static_deps || ninja download_static_deps;
-      ninja -j 4;
-      sudo ninja install;
-      popd;
-    fi
-  # Setup JDK
-  - jdk_switcher use oraclejdk7
-  - java -version
-  # Build haxe
-  - make package_src -s
-  - opam config exec -- make -s STATICLINK=1 libs
-  - opam config exec -- make -s -j STATICLINK=1 haxe
-  - opam config exec -- make -s haxelib
-  - make package_bin -s
-  - ls -l out
-  - ldd -v ./haxe
-  - ldd -v ./haxelib
-  - export PATH="$PATH:$TRAVIS_BUILD_DIR"
-  - export HAXE_STD_PATH="$TRAVIS_BUILD_DIR/std"
-
-install_osx: &install_osx
-  # Install dependencies
-  - travis_retry brew update --merge
-  - brew uninstall --force brew-cask # https://github.com/caskroom/homebrew-cask/pull/15381
-  - travis_retry brew tap Homebrew/bundle
-  - travis_retry brew bundle --file=tests/Brewfile
-  - opam init
-  - eval `opam config env`
-  - opam update
-  - opam pin add ptmap https://github.com/andyli/ptmap.git#ocaml406 --no-action # https://github.com/backtracking/ptmap/pull/8
-  - opam pin add haxe . --no-action
-  - opam install haxe --deps-only
-  # install neko
-  - if [ ! $DEPLOY_NIGHTLIES ]; then
-      brew install neko --HEAD;
-    else
-      if [ ! -d "$HOME/neko" ]; then
-        mkdir $HOME/neko;
-        pushd $HOME/neko;
-        git clone https://github.com/HaxeFoundation/neko.git .;
-        git submodule update --init --recursive;
-      else
-        pushd $HOME/neko;
-        if [ ! -d "$HOME/neko/.git" ]; then
-          git clone https://github.com/HaxeFoundation/neko.git .;
-          git submodule update --init --recursive;
-        else
-          git fetch --all;
-          git reset --hard origin/master;
-          git submodule update --init --recursive;
-        fi;
-      fi;
-      cmake . -DSTATIC_DEPS=all -G Ninja || (git clean -dfx && cmake . -DSTATIC_DEPS=all -G Ninja);
-      ninja download_static_deps || ninja download_static_deps || ninja download_static_deps;
-      ninja -j 4;
-      sudo ninja install;
-      popd;
-    fi
-  # Build haxe
-  - make -s STATICLINK=1 "LIB_PARAMS=/usr/local/opt/zlib/lib/libz.a /usr/local/lib/libpcre.a" libs
-  - make -s -j STATICLINK=1 "LIB_PARAMS=/usr/local/opt/zlib/lib/libz.a /usr/local/lib/libpcre.a" haxe
-  - make -s haxelib
-  - make package_bin -s
-  - ls -l out
-  - otool -L ./haxe
-  - otool -L ./haxelib
-  - export PATH="$PATH:$TRAVIS_BUILD_DIR"
-  - export HAXE_STD_PATH="$TRAVIS_BUILD_DIR/std"
-
-matrix:
-  include:
-    #########
-    # linux #
-    #########
-    - os: linux
-      env:
-        - TEST=neko
-        - DEPLOY_API_DOCS=1
-        - DEPLOY_NIGHTLIES=1
-        # haxeci_decrypt (Deploy source package to ppa:haxe/snapshots.)
-        - secure: "Mw3p6bDZuqVQ6u7GrwLQfje5hhIOA4+mdqqLXYHP79UKdhgqb91Dn6IbG9vQ1VXVe64W4YZbQAMBMMRX5kEPDl6JvTVGSBhg00Mi69oO5qrCMcBI6f9FntG72YaVvLf+PA7co+vKrnJzaP2M9pe4SH9Ztbhy0YNxULp7NQ8FLsM="
-      addons:
-        ssh_known_hosts:
-          - haxe.org
-          - api.haxe.org
-      before_install:
-        - eval `ssh-agent -s` # for deployment to haxe.org
-      install: *install_linux
-
-    - os: linux
-      env:
-        - TEST=macro,js,php,flash9,as3,java,cs,python,lua
-        - SAUCE=1
-      addons:
-        sauce_connect: true
-      before_install:
-        - "export DISPLAY=:99.0"
-        - "sh -e /etc/init.d/xvfb start"
-        - "export AUDIODEV=null"
-      install: *install_linux
-
-    - os: linux
-      env:
-        - TEST=cpp
-        - HXCPP_COMPILE_THREADS=4
-        - HXCPP_COMPILE_CACHE=~/hxcache
-        - JOB_DEPENDENCIES="gcc-multilib g++-multilib"
-      install: *install_linux
-
-    #######
-    # osx #
-    #######
-    - os: osx
-      osx_image: xcode7.3 # to compile binaries that support older versions of Mac, and 10.11 is the min version that brew provides bottles
-      env:
-        - TEST=neko
-        - DEPLOY_NIGHTLIES=1
-      install: *install_osx
-
-    - os: osx
-      osx_image: xcode9.1 # to compile faster
-      env:
-        - TEST=macro,java,cs,lua,js,php,flash9,python
-      install: *install_osx
-
-    - os: osx
-      osx_image: xcode9.1 # to compile faster
-      env:
-        - TEST=cpp
-        - HXCPP_COMPILE_CACHE=~/hxcache
-        - HXCPP_COMPILE_THREADS=4
-      install: *install_osx
-
-script:
-  - pushd tests
-  - mkdir ~/haxelib && haxelib setup ~/haxelib
-  - haxe -version
-  - haxe RunCi.hxml
-  - popd
-
-notifications:
-  webhooks:
-    urls:
-      - https://webhooks.gitter.im/e/95a5fa471c27beee8e7c
-    on_success: change  # options: [always|never|change] default: always
-    on_failure: always  # options: [always|never|change] default: always
-    on_start: false     # default: false

.vscode/schemas/define.schema.json

@@ -0,0 +1,68 @@
+{
+	"$schema": "http://json-schema.org/draft-07/schema#",
+	"type": "array",
+	"items": {
+		"type": "object",
+		"additionalProperties": false,
+		"properties": {
+			"name": {
+				"type": "string",
+				"markdownDescription": "OCaml name of the define."
+			},
+			"define": {
+				"type": "string",
+				"markdownDescription": "Actual name of the define as it's used in `-D` on the CLI and in Haxe code."
+			},
+			"doc": {
+				"type": "string",
+				"markdownDescription": "Documentation for the define that is shown in `--help-defines`."
+			},
+			"platforms": {
+				"type": "array",
+				"markdownDescription": "Platforms on which this define has an effect.",
+				"minItems": 1,
+				"items": {
+					"enum": [
+						"js",
+						"lua",
+						"neko",
+						"flash",
+						"php",
+						"cpp",
+						"cs",
+						"java",
+						"python",
+						"hl",
+						"eval"
+					]
+				}
+			},
+			"params": {
+				"type": "array",
+				"markdownDescription": "Parameters this define takes.",
+				"minItems": 1,
+				"items": {
+					"type": "string"
+				}
+			},
+			"devcomment": {
+				"type": "string",
+				"markdownDescription": "Internal comment that is not exposed."
+			},
+			"links": {
+				"type": "array",
+				"markdownDescription": "Relevant URLs.",
+				"minItems": 1,
+				"items": {
+					"type": "string",
+					"format": "uri"
+				}
+			}
+		},
+		"required": [
+			"name",
+			"define",
+			"doc"
+		]
+	}
+}

.vscode/schemas/meta.schema.json

@@ -0,0 +1,90 @@
+{
+	"$schema": "http://json-schema.org/draft-07/schema#",
+	"type": "array",
+	"items": {
+		"type": "object",
+		"additionalProperties": false,
+		"properties": {
+			"name": {
+				"type": "string",
+				"markdownDescription": "OCaml name of the meta."
+			},
+			"metadata": {
+				"type": "string",
+				"markdownDescription": "Actual name of the meta as it's used in Haxe code."
+			},
+			"doc": {
+				"type": "string",
+				"markdownDescription": "Documentation for the meta that is shown in `--help-metas` and IDE hints."
+			},
+			"platforms": {
+				"type": "array",
+				"markdownDescription": "Platforms on which this meta has an effect.",
+				"minItems": 1,
+				"items": {
+					"enum": [
+						"js",
+						"lua",
+						"neko",
+						"flash",
+						"php",
+						"cpp",
+						"cs",
+						"java",
+						"python",
+						"hl",
+						"eval"
+					]
+				}
+			},
+			"params": {
+				"type": "array",
+				"markdownDescription": "Parameters this meta takes.",
+				"minItems": 1,
+				"items": {
+					"type": "string"
+				}
+			},
+			"devcomment": {
+				"type": "string",
+				"markdownDescription": "Internal comment that is not exposed."
+			},
+			"internal": {
+				"type": "boolean",
+				"markdownDescription": "Whether this define is for internal use only, in which case it is not exposed to the CLI and the `--display` protocol."
+			},
+			"targets": {
+				"type": "array",
+				"markdownDescription": "On what the meta can be used.",
+				"minItems": 1,
+				"items": {
+					"enum": [
+						"TClass",
+						"TClassField",
+						"TAbstract",
+						"TAbstractField",
+						"TEnum",
+						"TTypedef",
+						"TExpr",
+						"TTypeParameter",
+						"TAnyField"
+					]
+				}
+			},
+			"links": {
+				"type": "array",
+				"markdownDescription": "Relevant URLs.",
+				"minItems": 1,
+				"items": {
+					"type": "string",
+					"format": "uri"
+				}
+			}
+		},
+		"required": [
+			"name",
+			"metadata",
+			"doc"
+		]
+	}
+}

.vscode/settings.json

@@ -1,7 +1,8 @@
 {
 	"files.associations": {
 		"*.mly": "ocaml",
-		"*.ml": "ocaml"
+		"*.ml": "ocaml",
+		"Makefile.*": "makefile"
 	},
 	"[ocaml]": {
 		"editor.tabSize": 4
@@ -9,5 +10,23 @@
 	"files.exclude": {
 		"**/_build": true
 	},
-	"reason.server.languages": ["ocaml"]
+	"reason.server.languages": [
+		"ocaml"
+	],
+	"haxe.diagnosticsPathFilter": "${workspaceRoot}/std",
+	"npm.autoDetect": "off",
+	"json.schemas": [
+		{
+			"fileMatch": [
+				"src-json/define.json"
+			],
+			"url": "./.vscode/schemas/define.schema.json"
+		},
+		{
+			"fileMatch": [
+				"src-json/meta.json"
+			],
+			"url": "./.vscode/schemas/meta.schema.json"
+		}
+	]
 }

.vscode/tasks.json

@@ -0,0 +1,51 @@
+{
+	"version": "2.0.0",
+	"tasks": [
+		{
+			"label": "make: haxe",
+			"type": "shell",
+			"command": "make ADD_REVISION=1 -s -j haxe",
+			"windows": {
+				"command": "make ADD_REVISION=1 -f Makefile.win -s -j haxe"
+			},
+			"problemMatcher": [],
+			"group": {
+				"kind": "build",
+				"isDefault": true
+			}
+		},
+		{
+			"label": "make: libs",
+			"type": "shell",
+			"command": "make -s -j libs",
+			"windows": {
+				"command": "make -f Makefile.win -s -j libs"
+			},
+			"problemMatcher": []
+		},
+		{
+			"label": "make: haxelib",
+			"type": "shell",
+			"command": "make -s haxelib",
+			"windows": {
+				"command": "make -f Makefile.win -s haxelib"
+			},
+			"problemMatcher": ["$haxe", "$haxe-absolute"]
+		},
+		{
+			"label": "make: all",
+			"type": "shell",
+			"command": "make s -j libs && make ADD_REVISION=1 -s -j haxe && make -s haxelib",
+			"windows": {
+				"command": "make -f Makefile.win -s -j libs && make ADD_REVISION=1 -f Makefile.win -s -j haxe && make -f Makefile.win -s haxelib"
+			},
+			"problemMatcher": ["$haxe", "$haxe-absolute"]
+		},
+		{
+			"label": "make: clean",
+			"type": "shell",
+			"command": "make clean",
+			"problemMatcher": []
+		}
+	]
+}

CONTRIBUTING.md

@@ -15,6 +15,56 @@ This repository is about the Haxe compiler itself and the Haxe standard library.
 * Something on api.haxe.org: For content this is probably the right repository. If it's about the representation, try <https://github.com/HaxeFoundation/dox/issues> instead.
 * Something else on haxe.org: <https://github.com/HaxeFoundation/haxe.org/issues>
 
+## Submitting a Pull-Request
+
+Thank you for your interest in contributing to Haxe! Haxe is a
+community-driven project and your help is vital and appreciated!
+
+When preparing to submit a pull-request, please make your PR as easy
+as possible for core devs to evaluate and merge. To that end:
+
+  * In your PR comments, include:
+
+      * the reason for your proposed changes (What problem are you fixing?)
+      * some possible solutions, and rationale for the one you chose
+      * a summary of the code changes in your PR
+      * any pros and cons to note about the solution you implemented
+      * links to any relevant GitHub issues, PR's, and/or forum
+        discussions
+
+  * If you've found and fixed a bug, have you also included a
+    corresponding test for it?
+  * Does your code formatting match that of the rest of the project?
+  * If your changes require updates to the documentation, does your PR
+    include those as well?
+
+Please also bear the following in mind:
+
+  * Evaluating PR's takes time and effort. Even taking a look at a PR
+    in order to request more info or clarification is not zero-cost.
+  * Most members of the core team are volunteers too, and at any given time
+    are typically already busy working on other areas of Haxe.
+  * It's no fun providing negative feedback to a PR. The better you
+    can craft and champion your PR, the more likely it is to be
+    speedily evaluated.
+
+
+## Debugging Hints
+
+### Using a debugger
+
+To debug the Haxe compiler, you can use either a system debugger (`gdb`/`lldb`), or [ocamldebug](http://caml.inria.fr/pub/docs/manual-ocaml/debugger.html). `ocamldebug` provides a better debugging experience. To use it, compile with `make BYTECODE=1`.
+
+### Using printf
+
+To print information about a type, you can add the following before most lines:
+
+```ocaml
+Printf.printf "%s\n" (s_type_kind t);
+```
+
+There are lots of other stringifying functions, search for "Printing" in `src/core/type.ml` and scroll down to find them.
+
 ## Other remarks:
 
 - Sometimes people try to be particularly helpful by not only including broken parts in their code, but also "similar" code which is working. More often than not this is more distracting than helpful. If you want to highlight something like this, consider adding the working code commented out.

Makefile

@@ -21,53 +21,28 @@ PACKAGE_SRC_EXTENSION=.tar.gz
 MAKEFILENAME?=Makefile
 PLATFORM?=unix
 
-OUTPUT=haxe
+DUNE_COMMAND=dune
+HAXE_OUTPUT=haxe
+HAXELIB_OUTPUT=haxelib
+PREBUILD_OUTPUT=prebuild
 EXTENSION=
 LFLAGS=
 STATICLINK?=0
 
-# Configuration
-
-HAXE_DIRECTORIES=core syntax context codegen codegen/gencommon generators optimization filters macro macro/eval typing compiler
-EXTLIB_LIBS=extlib-leftovers extc neko javalib swflib ttflib ilib objsize pcre ziplib
-OCAML_LIBS=unix str threads dynlink
-OPAM_LIBS=sedlex xml-light extlib rope ptmap
-
-FINDLIB_LIBS=$(OCAML_LIBS)
-FINDLIB_LIBS+=$(OPAM_LIBS)
-
-# Includes, packages and compiler
-
-HAXE_INCLUDES=$(HAXE_DIRECTORIES:%=-I _build/src/%)
-EXTLIB_INCLUDES=$(EXTLIB_LIBS:%=-I libs/%)
-ALL_INCLUDES=$(EXTLIB_INCLUDES) $(HAXE_INCLUDES)
-FINDLIB_PACKAGES=$(FINDLIB_LIBS:%=-package %)
-CFLAGS=
-ALL_CFLAGS=-bin-annot -safe-string -thread -g -w -3 $(CFLAGS) $(ALL_INCLUDES) $(FINDLIB_PACKAGES)
-
-MESSAGE_FILTER=sed -e 's/_build\/src\//src\//' tmp.tmp
-
-ifeq ($(BYTECODE),1)
-	TARGET_FLAG = bytecode
-	COMPILER = ocamlfind ocamlc
-	LIB_EXT = cma
-	MODULE_EXT = cmo
-	NATIVE_LIB_FLAG = -custom
+SYSTEM_NAME=Unknown
+ifeq ($(OS),Windows_NT)
+	SYSTEM_NAME=Windows
 else
-	TARGET_FLAG = native
-	COMPILER = ocamlfind ocamlopt
-	LIB_EXT = cmxa
-	MODULE_EXT = cmx
-	OCAMLDEP_FLAGS = -native
+	UNAME_S := $(shell uname -s)
+	ifeq ($(UNAME_S),Linux)
+		SYSTEM_NAME=Linux
+	endif
+	ifeq ($(UNAME_S),Darwin)
+		SYSTEM_NAME=Mac
+	endif
 endif
 
-CC_CMD = ($(COMPILER) $(ALL_CFLAGS) -c $< 2>tmp.tmp && $(MESSAGE_FILTER)) || ($(MESSAGE_FILTER) && exit 1)
-
-# Meta information
-
-BUILD_DIRECTORIES := $(HAXE_DIRECTORIES:%=_build/src/%)
-HAXE_SRC := $(wildcard $(HAXE_DIRECTORIES:%=src/%/*.ml))
-BUILD_SRC := $(HAXE_SRC:%=_build/%)
+# Configuration
 
 ADD_REVISION?=0
 
@@ -81,80 +56,35 @@ COMMIT_DATE=$(shell \
 	fi \
 )
 PACKAGE_FILE_NAME=haxe_$(COMMIT_DATE)_$(COMMIT_SHA)
-HAXE_VERSION=$(shell $(OUTPUT) -version 2>&1 | awk '{print $$1;}')
-
-# using $(CURDIR) on Windows will not work since it might be a Cygwin path
-ifdef SYSTEMROOT
-	EXTENSION=.exe
-else
-	export HAXE_STD_PATH=$(CURDIR)/std
-endif
-
-# Native libraries
+HAXE_VERSION=$(shell $(CURDIR)/$(HAXE_OUTPUT) -version 2>&1 | awk '{print $$1;}')
+HAXE_VERSION_SHORT=$(shell echo "$(HAXE_VERSION)" | grep -oE "^[0-9]+\.[0-9]+\.[0-9]+")
 
 ifneq ($(STATICLINK),0)
-	LIB_PARAMS= -cclib '-Wl,-Bstatic -lpcre -lz -Wl,-Bdynamic '
+	LIB_PARAMS= -cclib '-Wl,-Bstatic -lpcre -lz -lmbedtls -lmbedx509 -lmbedcrypto -Wl,-Bdynamic '
 else
-	LIB_PARAMS?= -cclib -lpcre -cclib -lz
+	LIB_PARAMS?= -cclib -lpcre -cclib -lz -cclib -lmbedtls -cclib -lmbedx509 -cclib -lmbedcrypto
 endif
-
-NATIVE_LIBS=-thread -cclib libs/extc/extc_stubs.o -cclib libs/extc/process_stubs.o -cclib libs/objsize/c_objsize.o -cclib libs/pcre/pcre_stubs.o -ccopt -L/usr/local/lib $(LIB_PARAMS)
-
-# Modules
-
--include Makefile.modules
-
-# Rules
-
-all: libs haxe tools
-
-libs:
-	$(foreach lib,$(EXTLIB_LIBS),$(MAKE) -C libs/$(lib) $(TARGET_FLAG) &&) true
-
-_build/%:%
-	mkdir -p $(dir $@)
-	cp $< $@
-
-build_dirs:
-	@mkdir -p $(BUILD_DIRECTORIES)
-
-_build/src/syntax/grammar.ml:src/syntax/grammar.mly
-	camlp4o -impl $< -o $@
-
-_build/src/compiler/version.ml: FORCE
-ifneq ($(ADD_REVISION),0)
-	$(MAKE) -f Makefile.version_extra -s --no-print-directory ADD_REVISION=$(ADD_REVISION) BRANCH=$(BRANCH) COMMIT_SHA=$(COMMIT_SHA) COMMIT_DATE=$(COMMIT_DATE) > _build/src/compiler/version.ml
-else
-	echo let version_extra = None > _build/src/compiler/version.ml
+ifeq ($(SYSTEM_NAME),Mac)
+	LIB_PARAMS+= -cclib '-framework Security -framework CoreFoundation'
 endif
 
-build_src: | $(BUILD_SRC) _build/src/syntax/grammar.ml _build/src/compiler/version.ml
+all: haxe tools
 
-haxe: build_src
-	$(MAKE) -f $(MAKEFILENAME) build_pass_1
-	$(MAKE) -f $(MAKEFILENAME) build_pass_2
-	$(MAKE) -f $(MAKEFILENAME) build_pass_3
-	$(MAKE) -f $(MAKEFILENAME) build_pass_4
+haxe:
+	$(DUNE_COMMAND) build --workspace dune-workspace.dev src-prebuild/prebuild.exe
+	_build/default/src-prebuild/prebuild.exe libparams $(LIB_PARAMS) > lib.sexp
+	_build/default/src-prebuild/prebuild.exe version $(ADD_REVISION) $(BRANCH) $(COMMIT_SHA) > src/compiler/version.ml
+	$(DUNE_COMMAND) build --workspace dune-workspace.dev src/haxe.exe
+	cp -f _build/default/src/haxe.exe ./${HAXE_OUTPUT}
 
-build_pass_1:
-	printf MODULES= > Makefile.modules
-	ls -1 $(HAXE_DIRECTORIES:%=_build/src/%/*.ml) | tr '\n' ' ' >> Makefile.modules
+plugin: haxe
+	$(DUNE_COMMAND) build --workspace dune-workspace.dev plugins/$(PLUGIN)/$(PLUGIN).cmxs
+	mkdir -p plugins/$(PLUGIN)/cmxs/$(SYSTEM_NAME)
+	cp -f _build/default/plugins/$(PLUGIN)/$(PLUGIN).cmxs plugins/$(PLUGIN)/cmxs/$(SYSTEM_NAME)/plugin.cmxs
 
-build_pass_2:
-	printf MODULES= > Makefile.modules
-	ocamlfind ocamldep -sort -slash $(HAXE_INCLUDES) $(MODULES) | sed -e "s/\.ml//g" >> Makefile.modules
-
-build_pass_3:
-	ocamlfind ocamldep -slash $(OCAMLDEP_FLAGS) $(HAXE_INCLUDES) $(MODULES:%=%.ml) > Makefile.dependencies
-
-build_pass_4: $(MODULES:%=%.$(MODULE_EXT))
-	$(COMPILER) -safe-string -linkpkg -o $(OUTPUT) $(NATIVE_LIBS) $(NATIVE_LIB_FLAG) $(LFLAGS) $(FINDLIB_PACKAGES) $(EXTLIB_INCLUDES) $(EXTLIB_LIBS:=.$(LIB_EXT)) $(MODULES:%=%.$(MODULE_EXT))
-
-plugin:
-ifeq ($(BYTECODE),1)
-	$(CC_CMD) $(PLUGIN).ml
-else
-	$(COMPILER) $(ALL_CFLAGS) -shared -o $(PLUGIN).cmxs $(PLUGIN).ml
+kill_exe_win:
+ifdef SYSTEMROOT
+	-@taskkill /F /IM haxe.exe 2>/dev/null
 endif
 
 # Only use if you have only changed gencpp.ml
@@ -171,19 +101,19 @@ copy_haxetoolkit: /cygdrive/c/HaxeToolkit/haxe/haxe.exe
 endif
 
 haxelib:
-	(cd $(CURDIR)/extra/haxelib_src && $(CURDIR)/$(OUTPUT) client.hxml && nekotools boot run.n)
-	mv extra/haxelib_src/run$(EXTENSION) haxelib$(EXTENSION)
+	(cd $(CURDIR)/extra/haxelib_src && $(CURDIR)/$(HAXE_OUTPUT) client.hxml && nekotools boot run.n)
+	mv extra/haxelib_src/run$(EXTENSION) $(HAXELIB_OUTPUT)
 
 tools: haxelib
 
 install: uninstall
 	mkdir -p "$(DESTDIR)$(INSTALL_BIN_DIR)"
-	cp haxe haxelib "$(DESTDIR)$(INSTALL_BIN_DIR)"
+	cp $(HAXE_OUTPUT) $(HAXELIB_OUTPUT) "$(DESTDIR)$(INSTALL_BIN_DIR)"
 	mkdir -p "$(DESTDIR)$(INSTALL_STD_DIR)"
 	cp -r std/* "$(DESTDIR)$(INSTALL_STD_DIR)"
 
 uninstall:
-	rm -rf $(DESTDIR)$(INSTALL_BIN_DIR)/haxe $(DESTDIR)$(INSTALL_BIN_DIR)/haxelib
+	rm -rf $(DESTDIR)$(INSTALL_BIN_DIR)/$(HAXE_OUTPUT) $(DESTDIR)$(INSTALL_BIN_DIR)/$(HAXELIB_OUTPUT)
 	if [ -d "$(DESTDIR)$(INSTALL_LIB_DIR)/lib" ] && find "$(DESTDIR)$(INSTALL_LIB_DIR)/lib" -mindepth 1 -print -quit | grep -q .; then \
 		echo "The local haxelib repo at $(DESTDIR)$(INSTALL_LIB_DIR)/lib will not be removed. Remove it manually if you want."; \
 		find $(DESTDIR)$(INSTALL_LIB_DIR)/ ! -name 'lib' -mindepth 1 -maxdepth 1 -exec rm -rf {} +; \
@@ -193,14 +123,16 @@ uninstall:
 	rm -rf $(DESTDIR)$(INSTALL_STD_DIR)
 
 opam_install:
-	opam install $(OPAM_LIBS) camlp4 ocamlfind --yes
-
-# Dependencies
+	opam install camlp5 ocamlfind dune --yes
 
--include Makefile.dependencies
+haxe_deps:
+	opam pin add haxe . --no-action
+	opam install haxe --deps-only --yes
 
 # Package
 
+package_env: opam_install haxe_deps
+
 package_src:
 	mkdir -p $(PACKAGE_OUT_DIR)
 	# use git-archive-all since we have submodules
@@ -213,7 +145,7 @@ package_unix:
 	rm -rf $(PACKAGE_FILE_NAME) $(PACKAGE_FILE_NAME).tar.gz
 	# Copy the package contents to $(PACKAGE_FILE_NAME)
 	mkdir -p $(PACKAGE_FILE_NAME)
-	cp -r $(OUTPUT) haxelib$(EXTENSION) std extra/LICENSE.txt extra/CONTRIB.txt extra/CHANGES.txt $(PACKAGE_FILE_NAME)
+	cp -r $(HAXE_OUTPUT) $(HAXELIB_OUTPUT) std extra/LICENSE.txt extra/CONTRIB.txt extra/CHANGES.txt $(PACKAGE_FILE_NAME)
 	# archive
 	tar -zcf $(PACKAGE_OUT_DIR)/$(PACKAGE_FILE_NAME)_bin.tar.gz $(PACKAGE_FILE_NAME)
 	rm -r $(PACKAGE_FILE_NAME)
@@ -221,23 +153,25 @@ package_unix:
 package_bin: package_$(PLATFORM)
 
 xmldoc:
-	haxelib path hxcpp  || haxelib git hxcpp  https://github.com/HaxeFoundation/hxcpp
-	haxelib path hxjava || haxelib git hxjava https://github.com/HaxeFoundation/hxjava
-	haxelib path hxcs   || haxelib git hxcs   https://github.com/HaxeFoundation/hxcs
-	cd extra && haxe doc.hxml
+	cd extra && \
+	$(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):
 	mkdir -p $(INSTALLER_TMP_DIR)
 
 $(INSTALLER_TMP_DIR)/neko-osx64.tar.gz: $(INSTALLER_TMP_DIR)
-	wget http://nekovm.org/media/neko-2.1.0-osx64.tar.gz -O installer/neko-osx64.tar.gz
+	wget -nv https://github.com/HaxeFoundation/neko/releases/download/v2-3-0/neko-2.3.0-osx64.tar.gz -O installer/neko-osx64.tar.gz
 
 # Installer
 
 package_installer_mac: $(INSTALLER_TMP_DIR)/neko-osx64.tar.gz package_unix
 	$(eval OUTFILE := $(shell pwd)/$(PACKAGE_OUT_DIR)/$(PACKAGE_FILE_NAME)_installer.tar.gz)
 	$(eval PACKFILE := $(shell pwd)/$(PACKAGE_OUT_DIR)/$(PACKAGE_FILE_NAME)_bin.tar.gz)
-	$(eval VERSION := $(shell haxe -version 2>&1))
+	$(eval VERSION := $(shell $(CURDIR)/$(HAXE_OUTPUT) -version 2>&1))
 	$(eval NEKOVER := $(shell neko -version 2>&1))
 	bash -c "rm -rf $(INSTALLER_TMP_DIR)/{resources,pkg,tgz,haxe.tar.gz}"
 	mkdir $(INSTALLER_TMP_DIR)/resources
@@ -280,16 +214,13 @@ package_installer_mac: $(INSTALLER_TMP_DIR)/neko-osx64.tar.gz package_unix
 
 # Clean
 
-clean: clean_libs clean_haxe clean_tools clean_package
-
-clean_libs:
-	$(foreach lib,$(EXTLIB_LIBS),$(MAKE) -C libs/$(lib) clean &&) true
+clean: clean_haxe clean_tools clean_package
 
 clean_haxe:
-	rm -f -r _build $(OUTPUT)
+	rm -f -r _build $(HAXE_OUTPUT) $(PREBUILD_OUTPUT)
 
 clean_tools:
-	rm -f $(OUTPUT) haxelib
+	rm -f $(HAXE_OUTPUT) $(PREBUILD_OUTPUT) $(HAXELIB_OUTPUT)
 
 clean_package:
 	rm -rf $(PACKAGE_OUT_DIR)
@@ -304,4 +235,4 @@ FORCE:
 .ml.cmo:
 	$(CC_CMD)
 
-.PHONY: haxe libs haxelib
+.PHONY: haxe haxelib

Makefile.version_extra

@@ -1,11 +0,0 @@
-# A hack to print the content of version.ml consistently across Windows (cygwin / command prompt) and Unix.
-# The hack: http://stackoverflow.com/a/7284135/267998
-# The issue: https://github.com/HaxeFoundation/haxe/commit/4f8f6a99ddf810ea045492cdd6d40c55abc03e15#commitcomment-10660400
-
-all: ;
-
-ifneq ($(ADD_REVISION),0)
-	$(info let version_extra = Some "(git build $(BRANCH) @ $(COMMIT_SHA))")
-else
-	$(info let version_extra = None)
-endif

Makefile.win

@@ -1,9 +1,17 @@
 PLATFORM=win
 MAKEFILENAME=Makefile.win
 include Makefile
-OUTPUT=haxe.exe
+HAXE_OUTPUT=haxe.exe
+HAXELIB_OUTPUT=haxelib.exe
+PREBUILD_OUTPUT=prebuild.exe
 EXTENSION=.exe
 PACKAGE_SRC_EXTENSION=.zip
+ARCH?=32
+DUNE_COMMAND=dune.exe
+
+ifeq ($(ARCH),64)
+NEKO_ARCH_STR=64
+endif
 
 kill:
 	-@taskkill /F /IM haxe.exe
@@ -32,10 +40,21 @@ endif
 
 ifdef FILTER
 CC_CMD=($(COMPILER) $(ALL_CFLAGS) -c $< 2>tmp.cmi && $(FILTER)) || ($(FILTER) && exit 1)
-CC_PARSER_CMD=($(COMPILER) -pp camlp4o $(ALL_CFLAGS) -c src/syntax/parser.ml 2>tmp.cmi && $(FILTER)) || ($(FILTER) && exit 1)
 endif
 
-PACKAGE_FILES=$(OUTPUT) haxelib$(EXTENSION) std "$$(cygpath -w "$$(which zlib1.dll)")" "$$(cygpath -w "$$(which libpcre-1.dll)")"
+ifeq ($(STATICLINK),0)
+	LIB_PARAMS = -cclib -lpcre -cclib -lz -cclib -lcrypt32 -cclib -lmbedtls -cclib -lmbedcrypto -cclib -lmbedx509
+endif
+
+PACKAGE_FILES=$(HAXE_OUTPUT) $(HAXELIB_OUTPUT) std \
+	"$$(cygcheck $(CURDIR)/$(HAXE_OUTPUT) | grep zlib1.dll | sed -e 's/^\s*//')" \
+	"$$(cygcheck $(CURDIR)/$(HAXE_OUTPUT) | grep libpcre-1.dll | sed -e 's/^\s*//')" \
+	"$$(cygcheck $(CURDIR)/$(HAXE_OUTPUT) | grep libmbedcrypto.dll | sed -e 's/^\s*//')" \
+	"$$(cygcheck $(CURDIR)/$(HAXE_OUTPUT) | grep libmbedtls.dll | sed -e 's/^\s*//')" \
+	"$$(cygcheck $(CURDIR)/$(HAXE_OUTPUT) | grep libmbedx509.dll | sed -e 's/^\s*//')"
+
+echo_package_files:
+	echo $(PACKAGE_FILES)
 
 package_win:
 	mkdir -p out
@@ -56,17 +75,16 @@ package_choco:
 	mkdir -p OUTPUT
 	7z x -y out/$(PACKAGE_FILE_NAME)_bin.zip -oout > log.txt || type log.txt
 	mv out/$(PACKAGE_FILE_NAME) out/choco
-	sed -e 's/@SNAPSHOT_VERSION@/$(HAXE_VERSION)-SNAP$(COMMIT_DATE)/g' extra/choco/haxe.nuspec > out/choco/haxe.nuspec
+	sed -e 's/@SNAPSHOT_VERSION@/$(HAXE_VERSION_SHORT)-SNAP$(COMMIT_DATE)/g' extra/choco/haxe.nuspec > out/choco/haxe.nuspec
 	cd out/choco && choco pack
 	mv out/choco/haxe.*.nupkg out
 	rm -rf out/choco
 
 $(INSTALLER_TMP_DIR)/neko-win.zip: $(INSTALLER_TMP_DIR)
-	wget http://nekovm.org/media/neko-2.1.0-win.zip -O installer/neko-win.zip
+	wget -nv https://github.com/HaxeFoundation/neko/releases/download/v2-3-0/neko-2.3.0-win$(NEKO_ARCH_STR).zip -O installer/neko-win.zip
 
 package_installer_win: $(INSTALLER_TMP_DIR)/neko-win.zip package_win
 	$(eval OUTFILE := $(PACKAGE_OUT_DIR)/$(PACKAGE_FILE_NAME)_installer.zip)
-	$(eval VERSION := $(shell haxe -version 2>&1 | cut -d ' ' -f1))
 	rm -rf $(INSTALLER_TMP_DIR)/resources
 	# neko
 	mkdir $(INSTALLER_TMP_DIR)/resources
@@ -76,18 +94,16 @@ package_installer_win: $(INSTALLER_TMP_DIR)/neko-win.zip package_win
 	# haxe
 	7z x -y $(PACKAGE_OUT_DIR)/$(PACKAGE_FILE_NAME)_bin.zip -o$(INSTALLER_TMP_DIR)/resources
 	mv $(INSTALLER_TMP_DIR)/resources/haxe* $(INSTALLER_TMP_DIR)/resources/haxe
-	# haxesetup.exe
-	haxelib path hxcpp || haxelib install hxcpp
-	cd extra; haxelib run hxcpp build-haxesetup.xml
-	cp extra/haxesetup.exe $(INSTALLER_TMP_DIR)/resources/haxe
+	# WinSetup.hx
+	cp extra/WinSetup.hx $(INSTALLER_TMP_DIR)/resources/haxe
 	# extra
 	cp extra/*.nsi $(INSTALLER_TMP_DIR)
 	cp extra/*.nsh $(INSTALLER_TMP_DIR)
 	cp -rf extra/images $(INSTALLER_TMP_DIR)
 	# nsis
-	sed -i "s/%%VERSION%%/$(VERSION)/g" $(INSTALLER_TMP_DIR)/installer.nsi
-	sed -i "s/%%VERSTRING%%/$(VERSION)/g" $(INSTALLER_TMP_DIR)/installer.nsi
-	sed -i "s/%%VERLONG%%/$(VERSION)/g" $(INSTALLER_TMP_DIR)/installer.nsi
+	sed -i "s/%%VERSION%%/$(HAXE_VERSION_SHORT)/g" $(INSTALLER_TMP_DIR)/installer.nsi
+	sed -i "s/%%VERSTRING%%/$(HAXE_VERSION)/g" $(INSTALLER_TMP_DIR)/installer.nsi
+	sed -i "s/%%VERLONG%%/$(HAXE_VERSION)/g" $(INSTALLER_TMP_DIR)/installer.nsi
 	cd $(INSTALLER_TMP_DIR) && makensis installer.nsi
 	7z a -r -tzip $(OUTFILE) $(INSTALLER_TMP_DIR)/*.exe
 	dir $(PACKAGE_OUT_DIR)

README.md

@@ -1,9 +1,15 @@
+<p align="center">
+  <a href="https://haxe.org/" title="haxe.org"><img src="extra/images/Readme.png" /></a>
+</p>
 
-# [<img src="https://haxe.org/img/haxe-logo-horizontal.svg" alt="Haxe logo" width="140">](https://haxe.org) - [The Cross-Platform Toolkit](https://haxe.org)
-[![TravisCI Build Status](https://travis-ci.org/HaxeFoundation/haxe.svg?branch=development)](https://travis-ci.org/HaxeFoundation/haxe)
-[![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/HaxeFoundation/haxe?branch=development&svg=true)](https://ci.appveyor.com/project/HaxeFoundation/haxe)
-[![SauceLabs Test Status](https://saucelabs.com/buildstatus/haxe)](https://saucelabs.com/u/haxe)
-[![Gitter](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/HaxeFoundation/haxe?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge)
+<p align="center">
+	<a href="https://dev.azure.com/HaxeFoundation/GitHubPublic/_build/latest?definitionId=1&branchName=development"><img src="https://dev.azure.com/HaxeFoundation/GitHubPublic/_apis/build/status/HaxeFoundation.haxe?branchName=development" alt="Azure Pipelines Build Status"></a>
+	<a href="https://saucelabs.com/u/haxe"><img src="https://saucelabs.com/buildstatus/haxe" alt="SauceLabs Test Status"></a>
+	<a href="https://gitter.im/HaxeFoundation/haxe?utm_source=badge&amp;utm_medium=badge&amp;utm_campaign=pr-badge"><img src="https://badges.gitter.im/Join%20Chat.svg" alt="Gitter"></a>
+	<a href="https://discordapp.com/invite/0uEuWH3spjck73Lo"><img src="https://img.shields.io/discord/162395145352904705.svg?logo=discord" alt="Discord"></a>
+</p>
+
+#
 
 Haxe is an open source toolkit that allows you to easily build cross-platform tools and applications that target many mainstream platforms. The Haxe toolkit includes:
 
@@ -16,18 +22,19 @@ Haxe allows you to compile for the following targets:
  * JavaScript
  * C++
  * C#
- * [HashLink](http://hashlink.haxe.org/)
  * Java
+ * JVM
  * Lua
- * PHP
+ * PHP 7
  * Python 3
- * [NekoVM](http://nekovm.org/)
- * Flash
- * ActionScript 3
+ * [HashLink](https://hashlink.haxe.org/)
+ * [NekoVM](https://nekovm.org/)
+ * Flash (SWF Bytecode)
+ * And its own [interpreter](https://haxe.org/blog/eval/)
 
 You can try Haxe directly from your browser at [try.haxe.org](https://try.haxe.org)!
 
-For more information about Haxe, head to the [offical Haxe website](https://haxe.org).
+For more information about Haxe, head to the [official Haxe website](https://haxe.org).
 
 ## License
 
@@ -55,16 +62,11 @@ Automated development builds are available from [build.haxe.org](http://build.ha
 
 ## Building from source
 
- 1. Clone the repository using git. Be sure to initialize and fetch the submodules.
-
-        git clone --recursive git://github.com/HaxeFoundation/haxe.git
-        cd haxe
-
- 2. Follow the [documentation on building Haxe for your platform](https://haxe.org/documentation/introduction/building-haxe.html).
+See [extra/BUILDING.md](extra/BUILDING.md).
 
 ## Using Haxe
 
-For information on on using Haxe, consult the [Haxe documentation](https://haxe.org/documentation/):
+For information on using Haxe, consult the [Haxe documentation](https://haxe.org/documentation/):
 
  * [Haxe Introduction](https://haxe.org/documentation/introduction/), an introduction to the Haxe toolkit
  * [The Haxe Manual](https://haxe.org/manual/), the reference manual for the Haxe language
@@ -78,22 +80,22 @@ You can get help and talk with fellow Haxers from around the world via:
 
  * [Haxe Community Forum](http://community.haxe.org)
  * [Haxe on Stack Overflow](https://stackoverflow.com/questions/tagged/haxe)
- * [Haxe Gittr chatroom](https://gitter.im/HaxeFoundation/haxe/)
+ * [Haxe Gitter chatroom](https://gitter.im/HaxeFoundation/haxe/)
+ * [Haxe Discord server](https://discordapp.com/invite/0uEuWH3spjck73Lo)
  * [#haxe on Twitter](https://twitter.com/hashtag/haxe?src=hash)
 
 :+1: Get notified of the latest Haxe news, follow us on [Twitter](https://twitter.com/haxelang), [Facebook](https://www.facebook.com/haxe.org) and don't forget to read the [Haxe roundups](https://haxe.io/).
 
 ## Version compatibility
 
-Haxe   | neko
-----   | -----
-2.*    | 1.*
-3.0.0  | 2.0.0
-3.1.3  | 2.0.0
-3.2.0  | 2.0.0
-3.3.0  | 2.1.0
-3.4.0  | 2.1.0
-
+Haxe            | Neko  | SWF   | Python | HL   | PHP  | Lua |
+--------------- | ----- | ----- | ------ | ---- | ---- | --- |
+2.*             | 1.*   | 8-10  | -      | -    | -    | -   |
+3.0.0           | 2.0.0 |       | -      | -    | 5.1+ | -   |
+3.2.0           |       | 12-14 | 3.2+   | -    |      | -   |
+3.3.0           | 2.1.0 | 21    |        | -    |      | 5.1, 5.2, 5.3, LuaJIT 2.0, 2.1 |
+3.4.0           |       |       |        | 1.1  | 5.4+ and 7.0+ (with `-D php7`) |     |
+4.0.0           | 2.3.0 |       |        | 1.11 | 7.0+ |     |
 
 ## Contributing
 

appveyor.yml

@@ -1,83 +0,0 @@
-version: "{build}"
-
-environment:
-    global:
-        HAXELIB_ROOT: C:/projects/haxelib
-        CYG_ROOT: C:/cygwin64
-        ADD_REVISION: 1
-        MYSQL_PATH: C:\Program Files\MySQL\MySQL Server 5.7
-        MYSQL_USER: root
-        MYSQL_PASSWORD: Password12!
-        HXBUILDS_AWS_ACCESS_KEY_ID:
-          secure: fggQXlr5xGGl0znUi0UkqPWd6LviHnk0TR6YxJmuV3U=
-        HXBUILDS_AWS_SECRET_ACCESS_KEY:
-          secure: ewwkKcjnSKl/Vtrz1SXmI6XKk1ENmJDyzm5YaR2wi03foRhTke29TvymB21rDTSl
-    matrix:
-        - ARCH: 64
-          TEST: "neko,python,cs,java,php,macro"
-          DEPLOY_NIGHTLIES: 1
-        - ARCH: 64
-          TEST: "cpp"
-        - ARCH: 32
-          TEST: "macro"
-          DEPLOY_NIGHTLIES: 1
-
-cache:
-    - opam.tar.xz -> appveyor.yml
-
-install:
-    - 'git submodule update --init --recursive'
-    - '%CYG_ROOT%/bin/bash -lc "echo initialize"'
-    # http://help.appveyor.com/discussions/problems/5616-not-able-to-build-due-to-problem-in-chocolateyinstallps1
-    - ps: Set-Service wuauserv -StartupType Manual
-    - choco install curl nsis.portable wget awscli -y
-    # Install ocaml
-    - curl -fsSL -o cygwin-setup.exe --retry 3 https://cygwin.com/setup-x86_64.exe
-    - 'cygwin-setup.exe -g -q -R "%CYG_ROOT%" -P make -P git -P mingw64-x86_64-zlib -P mingw64-i686-zlib -P rsync -P patch -P diffutils -P curl -P unzip -P m4 -P perl -P mingw64-x86_64-gcc-core -P mingw64-i686-gcc-core -P mingw64-x86_64-pcre -P mingw64-i686-pcre'
-    - if not exist "opam.tar.xz" (
-        curl -fsSL -o "opam.tar.xz" --retry 3 https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.1/opam%ARCH%.tar.xz
-      )
-    - 7z x "opam.tar.xz" -so | 7z x -aoa -si -ttar
-    - '%CYG_ROOT%/bin/bash -lc "cd \"$OLDPWD\" && bash opam${ARCH}/install.sh"'
-    - '%CYG_ROOT%/bin/bash -lc "opam init mingw \"https://github.com/fdopen/opam-repository-mingw.git\" --comp 4.02.3+mingw${ARCH}c --switch 4.02.3+mingw${ARCH}c --auto-setup --yes"'
-    - '%CYG_ROOT%/bin/bash -lc "opam update --yes"'
-    - '%CYG_ROOT%/bin/bash -lc "opam pin add haxe \"$APPVEYOR_BUILD_FOLDER\" --no-action --yes"'
-    - '%CYG_ROOT%/bin/bash -lc "opam install haxe --deps-only --yes"'
-    # Install neko
-    - choco install neko --prerelease --ignore-dependencies -s 'https://ci.appveyor.com/nuget/neko' -y
-    # Install php
-    - choco install php -y
-    - echo extension=php_openssl.dll >> C:\tools\php71\php.ini
-    - RefreshEnv
-    # setup python
-    - cmd: mklink C:\Python34-x64\python3.exe C:\Python34-x64\python.exe
-    - set PATH=%PATH%;C:\Python34-x64
-    # expose the dll files
-    - if "%ARCH%" EQU "32" (
-        set "PATH=%CYG_ROOT%/usr/i686-w64-mingw32/sys-root/mingw/bin;%PATH%"
-      ) else (
-        set "PATH=%CYG_ROOT%/usr/x86_64-w64-mingw32/sys-root/mingw/bin;%PATH%"
-      )
-    - neko -version
-
-build_script:
-    - 'cd %APPVEYOR_BUILD_FOLDER%'
-    - '%CYG_ROOT%/bin/bash -lc "cd \"$OLDPWD\" && make -s -f Makefile.win libs && make -j -s -f Makefile.win haxe && make -s -f Makefile.win haxelib"'
-    - 'set PATH=%PATH%;%APPVEYOR_BUILD_FOLDER%'
-    - 'set HAXEPATH=%APPVEYOR_BUILD_FOLDER%'
-    - '%CYG_ROOT%/bin/bash -lc "cd \"$OLDPWD\" && make -s -f Makefile.win package_bin"'
-    - '%CYG_ROOT%/bin/bash -lc "cd \"$OLDPWD\" && make -s -f Makefile.win package_choco"'
-    - move out\haxe.*.nupkg .
-    - dir %APPVEYOR_BUILD_FOLDER%\out
-    - cd %APPVEYOR_BUILD_FOLDER%/tests/
-    - mkdir "%HAXELIB_ROOT%"
-    - haxelib setup "%HAXELIB_ROOT%"
-
-test_script:
-    - cd %APPVEYOR_BUILD_FOLDER%/tests/
-    - haxe -version
-    - haxe RunCi.hxml
-
-artifacts:
-    - path: 'out/*.zip'
-    - path: '*.nupkg'

azure-pipelines.yml

@@ -0,0 +1,315 @@
+variables:
+  - group: variables-haxe
+  - name: AZURE_PIPELINES_REPO_URL
+    value: $(Build.Repository.Uri)
+  - name: AZURE_PIPELINES_BRANCH
+    value: $(Build.SourceBranchName)
+
+trigger:
+  branches:
+    include:
+      - '*'
+  tags:
+    include:
+      - '*'
+
+stages:
+  - stage: StageTest
+    jobs:
+      - template: extra/azure-pipelines/build-linux.yml
+        parameters:
+          name: BuildLinux
+
+      - template: extra/azure-pipelines/build-mac.yml
+        parameters:
+          name: BuildMac
+
+      - template: extra/azure-pipelines/build-windows.yml
+        parameters:
+          name: BuildWin64
+          arch: '64'
+
+      - template: extra/azure-pipelines/build-windows.yml
+        parameters:
+          name: BuildWin32
+          arch: '32'
+
+      - job: TestLinux
+        dependsOn: BuildLinux
+        pool:
+          vmImage: 'ubuntu-16.04'
+        strategy:
+          matrix:
+            macro:
+              TEST: macro
+            neko:
+              TEST: neko
+            hl:
+              TEST: hl
+              APT_PACKAGES: cmake ninja-build
+            cpp:
+              TEST: cpp
+              HXCPP_COMPILE_CACHE: ~/hxcache
+              APT_PACKAGES: gcc-multilib g++-multilib
+            java:
+              TEST: java,jvm
+            cs:
+              TEST: cs
+            js:
+              TEST: js
+              SAUCE: 1
+              SAUCE_TUNNEL_ID: $(Agent.JobName)
+              SAUCE_BUILD: $(Build.BuildNumber)
+            php:
+              TEST: php
+            flash:
+              TEST: flash9
+              APT_PACKAGES: libglib2.0 libfreetype6 xvfb
+              DISPLAY: ':99.0'
+              AUDIODEV: 'null'
+            python:
+              TEST: python
+            lua:
+              TEST: lua
+              APT_PACKAGES: ncurses-dev
+        steps:
+          - checkout: self
+            fetchDepth: 20
+          - template: extra/azure-pipelines/install-neko-snapshot.yaml
+            parameters:
+              platform: linux64
+          - task: DownloadPipelineArtifact@0
+            inputs:
+              artifactName: 'linuxBinaries'
+              targetPath: linuxBinaries
+          - script: |
+              set -ex
+              tar -xf linuxBinaries/*_bin.tar.gz -C linuxBinaries --strip-components=1
+              sudo mkdir -p /usr/local/bin/
+              sudo mkdir -p /usr/local/share/haxe/
+              sudo ln -s `pwd`/linuxBinaries/haxe /usr/local/bin/haxe
+              sudo ln -s `pwd`/linuxBinaries/haxelib /usr/local/bin/haxelib
+              sudo ln -s `pwd`/linuxBinaries/std /usr/local/share/haxe/std
+            displayName: Setup Haxe
+          - script: haxe -version
+            displayName: Print Haxe version
+          - script: |
+              set -ex
+              mkdir ~/haxelib
+              haxelib setup ~/haxelib
+            displayName: Setup haxelib
+          - script: |
+              set -ex
+              sudo apt update -qqy
+              sudo apt install -qqy $APT_PACKAGES
+            condition: and(succeeded(), variables['APT_PACKAGES'])
+            displayName: Install apt packages
+          - script: haxe RunCi.hxml
+            condition: and(succeeded(), not(and(variables['SAUCE'], variables['SAUCE_ACCESS_KEY'])))
+            workingDirectory: $(Build.SourcesDirectory)/tests
+            displayName: Test
+          - script: haxe RunCi.hxml
+            condition: and(succeeded(), variables['SAUCE'], variables['SAUCE_ACCESS_KEY'])
+            workingDirectory: $(Build.SourcesDirectory)/tests
+            env:
+              SAUCE_ACCESS_KEY: $(SAUCE_ACCESS_KEY)
+            displayName: Test (with SauceLabs)
+
+      - job: TestMac
+        dependsOn: BuildMac
+        pool:
+          vmImage: 'macOS-10.13'
+        strategy:
+          matrix:
+            macro:
+              TEST: macro
+            neko:
+              TEST: neko
+            hl:
+              TEST: hl
+              BREW_PACKAGES: ninja
+            cpp:
+              TEST: cpp
+              HXCPP_COMPILE_CACHE: ~/hxcache
+            java:
+              TEST: java,jvm
+            cs:
+              TEST: cs
+            js:
+              TEST: js
+            php:
+              TEST: php
+            flash:
+              TEST: flash9
+            python:
+              TEST: python
+            lua:
+              TEST: lua
+        steps:
+          - checkout: self
+            fetchDepth: 20
+          - template: extra/azure-pipelines/install-neko-snapshot.yaml
+            parameters:
+              platform: mac
+          - task: DownloadPipelineArtifact@0
+            inputs:
+              artifactName: 'macBinaries'
+              targetPath: macBinaries
+          - script: |
+              set -ex
+              tar -xf macBinaries/*_bin.tar.gz -C macBinaries --strip-components=1
+              sudo mkdir -p /usr/local/bin/
+              sudo mkdir -p /usr/local/share/haxe/
+              sudo ln -s `pwd`/macBinaries/haxe /usr/local/bin/haxe
+              sudo ln -s `pwd`/macBinaries/haxelib /usr/local/bin/haxelib
+              sudo ln -s `pwd`/macBinaries/std /usr/local/share/haxe/std
+            displayName: Setup Haxe
+          - script: haxe -version
+            displayName: Print Haxe version
+          - script: |
+              set -ex
+              mkdir ~/haxelib
+              haxelib setup ~/haxelib
+            displayName: Setup haxelib
+          - script: brew install $BREW_PACKAGES
+            condition: and(succeeded(), variables['BREW_PACKAGES'])
+            displayName: Install homebrew packages
+          - script: haxe RunCi.hxml
+            workingDirectory: $(Build.SourcesDirectory)/tests
+            displayName: Test
+
+      - template: extra/azure-pipelines/test-windows.yml
+        parameters:
+          name: TestWin64
+          arch: '64'
+
+      - template: extra/azure-pipelines/test-windows.yml
+        parameters:
+          name: TestWin32
+          arch: '32'
+
+  - stage: StageDeploy
+    condition: and(succeeded(), not(variables['System.PullRequest.PullRequestId']))
+    jobs:
+      - job: S3
+        condition: and(succeeded(), variables['HXBUILDS_AWS_ACCESS_KEY_ID'], variables['HXBUILDS_S3ADDR'])
+        pool:
+          vmImage: 'ubuntu-16.04'
+        steps:
+          - checkout: self
+            fetchDepth: 20
+          - task: DownloadPipelineArtifact@0
+            inputs:
+              artifactName: 'linuxBinaries'
+              targetPath: linuxBinaries
+            displayName: Download linuxBinaries
+          - task: DownloadPipelineArtifact@0
+            inputs:
+              artifactName: 'macBinaries'
+              targetPath: macBinaries
+            displayName: Download macBinaries
+          - task: DownloadPipelineArtifact@0
+            inputs:
+              artifactName: 'win64Binaries'
+              targetPath: win64Binaries
+            displayName: Download win64Binaries
+          - task: DownloadPipelineArtifact@0
+            inputs:
+              artifactName: 'win32Binaries'
+              targetPath: win32Binaries
+            displayName: Download win32Binaries
+          - template: extra/azure-pipelines/install-neko-snapshot.yaml
+            parameters:
+              platform: linux64
+          - script: |
+              set -ex
+              tar -xf linuxBinaries/*_bin.tar.gz -C linuxBinaries --strip-components=1
+              sudo mkdir -p /usr/local/bin/
+              sudo mkdir -p /usr/local/share/haxe/
+              sudo ln -s `pwd`/linuxBinaries/haxe /usr/local/bin/haxe
+              sudo ln -s `pwd`/linuxBinaries/haxelib /usr/local/bin/haxelib
+              sudo ln -s `pwd`/linuxBinaries/std /usr/local/share/haxe/std
+            displayName: Setup Haxe
+          - script: |
+              set -ex
+              sudo apt-get update -qqy
+              sudo apt-get install -qqy awscli
+            displayName: "Install awscli"
+          - script: |
+              set -ex
+              COMMIT_HASH=`git rev-parse HEAD`
+              COMMIT_HASH_SHORT=${COMMIT_HASH:0:7}
+              COMMIT_DATE=`TZ=UTC git show --quiet --date='format-local:%Y-%m-%d' --format="%cd"`
+              FILE_NAME=haxe_${COMMIT_DATE}_$(Build.SourceBranchName)_${COMMIT_HASH_SHORT}
+              aws s3 cp linuxBinaries/*_bin.tar.gz      $(HXBUILDS_S3ADDR)/haxe/linux64/${FILE_NAME}.tar.gz
+              aws s3 cp macBinaries/*_bin.tar.gz        $(HXBUILDS_S3ADDR)/haxe/mac/${FILE_NAME}.tar.gz
+              aws s3 cp macBinaries/*_installer.tar.gz  $(HXBUILDS_S3ADDR)/haxe/mac-installer/${FILE_NAME}.tar.gz
+              aws s3 cp win64Binaries/*_bin.zip         $(HXBUILDS_S3ADDR)/haxe/windows64/${FILE_NAME}.zip
+              aws s3 cp win64Binaries/*_installer.zip   $(HXBUILDS_S3ADDR)/haxe/windows64-installer/${FILE_NAME}.zip
+              aws s3 cp win64Binaries/*.nupkg           $(HXBUILDS_S3ADDR)/haxe/windows64-choco/
+              aws s3 cp win32Binaries/*_bin.zip         $(HXBUILDS_S3ADDR)/haxe/windows/${FILE_NAME}.zip
+              aws s3 cp win32Binaries/*_installer.zip   $(HXBUILDS_S3ADDR)/haxe/windows-installer/${FILE_NAME}.zip
+              aws s3 cp win32Binaries/*.nupkg           $(HXBUILDS_S3ADDR)/haxe/windows-choco/
+            env:
+              AWS_ACCESS_KEY_ID: $(HXBUILDS_AWS_ACCESS_KEY_ID)
+              AWS_SECRET_ACCESS_KEY: $(HXBUILDS_AWS_SECRET_ACCESS_KEY)
+            displayName: Upload binaries
+          - script: |
+              set -ex
+              aws s3 cp linuxBinaries/*_bin.tar.gz      $(HXBUILDS_S3ADDR)/haxe/linux64/haxe_latest.tar.gz
+              aws s3 cp macBinaries/*_bin.tar.gz        $(HXBUILDS_S3ADDR)/haxe/mac/haxe_latest.tar.gz
+              aws s3 cp macBinaries/*_installer.tar.gz        $(HXBUILDS_S3ADDR)/haxe/mac-installer/haxe_latest.tar.gz
+              aws s3 cp win64Binaries/*_bin.zip         $(HXBUILDS_S3ADDR)/haxe/windows64/haxe_latest.zip
+              aws s3 cp win64Binaries/*_installer.zip   $(HXBUILDS_S3ADDR)/haxe/windows64-installer/haxe_latest.zip
+              aws s3 cp win32Binaries/*_bin.zip         $(HXBUILDS_S3ADDR)/haxe/windows/haxe_latest.zip
+              aws s3 cp win32Binaries/*_installer.zip   $(HXBUILDS_S3ADDR)/haxe/windows-installer/haxe_latest.zip
+
+              # Chocolatey packages have to be named with version number,
+              # so let's use web redirection to keep the original file name.
+              [[ "$HXBUILDS_S3ADDR" =~ s3://([^/]+)(.*) ]] && HXBUILDS_S3BUCKET="${BASH_REMATCH[1]}" && HXBUILDS_S3PATH="${BASH_REMATCH[2]}"
+              [[ `echo win64Binaries/*.nupkg` =~ win64Binaries/(.+) ]] && FILE_NAME="${BASH_REMATCH[1]}"
+              aws s3 cp $(HXBUILDS_S3ADDR)/haxe/windows64-choco/${FILE_NAME} $(HXBUILDS_S3ADDR)/haxe/windows64-choco/haxe_latest.nupkg --acl public-read --website-redirect "${HXBUILDS_S3PATH}/haxe/windows64-choco/${FILE_NAME}"
+              [[ `echo win32Binaries/*.nupkg` =~ win32Binaries/(.+) ]] && FILE_NAME="${BASH_REMATCH[1]}"
+              aws s3 cp $(HXBUILDS_S3ADDR)/haxe/windows-choco/${FILE_NAME}   $(HXBUILDS_S3ADDR)/haxe/windows-choco/haxe_latest.nupkg   --acl public-read --website-redirect "${HXBUILDS_S3PATH}/haxe/windows-choco/${FILE_NAME}"
+            env:
+              AWS_ACCESS_KEY_ID: $(HXBUILDS_AWS_ACCESS_KEY_ID)
+              AWS_SECRET_ACCESS_KEY: $(HXBUILDS_AWS_SECRET_ACCESS_KEY)
+            condition: and(succeeded(), eq(variables['Build.SourceBranchName'], 'development'))
+            displayName: Update "latest"
+
+      - job: ApiHaxeOrg
+        condition: and(succeeded(), variables['GHP_USERNAME'], variables['GHP_EMAIL'])
+        pool:
+          vmImage: 'ubuntu-16.04'
+        steps:
+          - checkout: none
+          - template: extra/azure-pipelines/install-neko-snapshot.yaml
+            parameters:
+              platform: linux64
+          - task: DownloadPipelineArtifact@0
+            inputs:
+              artifactName: 'linuxBinaries'
+              targetPath: linuxBinaries
+            displayName: Download linuxBinaries
+          - script: |
+              set -ex
+              tar -xf linuxBinaries/*_bin.tar.gz -C linuxBinaries --strip-components=1
+              sudo mkdir -p /usr/local/bin/
+              sudo mkdir -p /usr/local/share/haxe/
+              sudo ln -s `pwd`/linuxBinaries/haxe /usr/local/bin/haxe
+              sudo ln -s `pwd`/linuxBinaries/haxelib /usr/local/bin/haxelib
+              sudo ln -s `pwd`/linuxBinaries/std /usr/local/share/haxe/std
+            displayName: Setup Haxe
+          - task: DownloadPipelineArtifact@0
+            inputs:
+              artifactName: 'xmldoc'
+              targetPath: xmldoc
+            displayName: Download xmldoc
+          - script: |
+              set -ex
+              LOCAL="`pwd`/extra/api.haxe.org"
+              git clone "${GHP_REMOTE}" "${LOCAL}"
+              haxe --cwd "${LOCAL}" --run ImportXml "`pwd`/xmldoc"
+            env:
+              GHP_REMOTE: $(GHP_REMOTE)
+            displayName: Deploy to api.haxe.org

dune

@@ -0,0 +1 @@
+(data_only_dirs extra lib std tests)

dune-project

@@ -0,0 +1,10 @@
+(lang dune 1.11)
+(name haxe)
+
+(package
+	(name haxe)
+)
+
+(package
+	(name haxe_prebuild)
+)

dune-workspace.dev

@@ -0,0 +1,2 @@
+(lang dune 1.11)
+(profile release)

extra/BUILDING.md

@@ -0,0 +1,79 @@
+# Building Haxe from source
+
+## Obtaining the source
+
+The Haxe compiler source files are hosted on GitHub under the [HaxeFoundation account](https://github.com/HaxeFoundation). The [Haxe repository](https://github.com/HaxeFoundation/haxe) has several submodules, so cloning it should be done with the `--recursive` flag like so:
+
+```
+git clone --recursive https://github.com/HaxeFoundation/haxe.git
+```
+
+Alternatively, source .zip archives or tarballs can be obtained from the [GitHub Haxe release overview](https://github.com/HaxeFoundation/haxe/releases). However, the git submodules are not included, so you will have to manually place the source code of [submodules](https://github.com/HaxeFoundation/haxe/blob/development/.gitmodules) into appropriate sub-folders.
+
+## Setting up OCaml
+
+The Haxe compiler is written in OCaml, so you have to set up an OCaml development environment. In addition, we make use of a number of OCaml libraries. We recommend using OPAM, which is an OCaml package manager that can also manage OCaml installations.
+
+The Haxe compiler requires OCaml version 4.02 or higher. Since some of the OCaml libraries Haxe depends on were uploaded in the OPAM 2 format, you should use OPAM 2.x instead of OPAM 1.x.
+
+To install OPAM on Unix (e.g. Mac, Linux) systems, follow the [instruction given by OPAM](https://opam.ocaml.org/doc/Install.html). On Windows, we recommend using the [Cygwin/MinGW-based OPAM environment provided by fdopen](https://fdopen.github.io/opam-repository-mingw/installation/), choose the 64-bit versions of everything, also make sure to [use the OPAM 2 version](https://github.com/fdopen/opam-repository-mingw/issues/48).
+
+In case you messed up the OPAM installation, you can uninstall OPAM and remove `~/.opam`, which contains the OCaml switches (OCaml compilers and libraries), and start over.
+
+Also note that since OPAM 2 on Linux will try to use bubblewrap, which uses Linux user namespaces, which might not be available on environments like Docker or Windows Subsystem for Linux (WSL). In case of encountering related errors, use `--disable-sandboxing` during `opam init`.
+
+## Installing dependencies
+
+You need to install some native libraries as well as some OCaml libraries.
+
+ * Native libraries
+    * PCRE
+    * zlib
+    * Neko (for building haxelib)
+ * OCaml libraries
+    * listed in the `opam` file at the repository root
+
+To install the native libraries, use the appropriate system package manager.
+
+ * Mac OS X
+    * Use [Homebrew](https://brew.sh/), `brew install zlib pcre`.
+ * Debian / Ubuntu
+    * `sudo apt install libpcre3-dev zlib1g-dev`.
+ * Windows (Cygwin)
+    * Run the Cygwin [setup-x86_64.exe](https://cygwin.com/install.html) against the Cygwin installation directory. Install `make`, `git`, `zlib-devel`, `libpcre-devel`, `mingw64-x86_64-gcc-core`, `mingw64-x86_64-zlib`, and `mingw64-x86_64-pcre`. You may need to select "Not Installed" in the dropdown list to see the packages. Copy `zlib1.dll` and `libpcre-1.dll` from `path/to/cygwin/usr/x86_64-w64-mingw32/sys-root/mingw/bin` to the checked out Haxe source directory.
+    * Install Neko by either
+      * Download the [Neko binaries](https://nekovm.org/download/), and add the extracted directory to the beginning of PATH.
+      * Install the [Chocolatey Neko package](https://chocolatey.org/packages/neko).
+
+To install the OCaml libraries, use OPAM as follows:
+
+```sh
+# pin the haxe package to the checked out Haxe source directory
+opam pin add haxe path/to/haxe --kind=path --no-action
+
+# install the haxe package dependencies (as listed in the `opam` file)
+opam install haxe --deps-only
+```
+
+## Compile
+
+In the checked out Haxe source directory,
+```sh
+# On Unix
+make
+
+# On Windows (Cygwin)
+make -f Makefile.win
+```
+
+## Install
+
+Generally, you should remove any existing Haxe installation to avoid conflict. You should at least make sure that the `HAXE_STD_PATH` environment variable is not set.
+
+To install the freshly built Haxe,
+
+ * On Unix (e.g. Mac and Linux),
+    ```sh
+    sudo make install
+    ```
+ * On Windows, add the checked out Haxe source directory to the beginning of PATH.

extra/CHANGES.txt

@@ -1,15 +1,467 @@
-????-??-??: 4.0.0-preview.3
+????-??-??: 4.1.0
+
+	General improvements:
+
+	js : use abstract type name for generating its implementation class (#9006)
+	js : improve haxe.ds.StringMap implementation (#8909)
+
+2019-12-17: 4.0.5
+
+	Bugfixes:
+
+	java : fix boolean arguments for `Type.createInstance(cls, args)` (#9025)
+	jvm : fix static overloads (#9034)
+	java/cs : fixed `Reflect.makeVarArgs(fn)` for calls of `fn` without arguments (#9037)
+	js : fix multiple appearances of the first object added to `ObjectMap` is passed to `ObjectMap.set(obj, v)` multiple times (#9026)
+	js : automatically wrap compound expressions with parentheses when passed to `js.Syntax.code()` (#9024)
+	windows : fix adding neko to PATH env var running windows installer (#9021)
+
+2019-11-29: 4.0.3
+
+	General improvements:
+
+	hl : profiler API
+
+	Bugfixes:
+
+	all : fixed EnumValue handling in constant propagation with analyzer enabled (#8959)
+	all : fixed compiler crash upon Void items in array declarations (#8972)
+	hl : fixed `sys.thread.Lock` implementation for Hashlink 1.11+ (#8699)
+	js/eval/java/jvm/cs/python/lua : fixed `Std.parseInt()` for hexadecimals with leading whitespaces (#8978)
+	java/cs : fixed `Reflect.callMethod(o, method, args)` for `args` not containing optional arguments (#8975)
+	cs : fixed Json.stringify for @:struct-annotated classes (#8979)
+	cs : fixed bitwise shifts for `cs.types.Int64` (#8978)
+	python : fixed invalid generation of some inlined code blocks (#8971)
+	std : fixed an exception from `haxe.zip.Huffman` on reading a zip (#8875)
+	windows : workaround windows installer being detected as a malware by some anti-virus software (#8951)
+	windows : fix PATH env var modification when running windows installer without admin privileges (#8870)
+	all : fixed null-safety checker for field access on a call to inlined function
+
+2019-11-11: 4.0.2
+
+	General improvements and optimizations:
+
+	php : improved performance of `haxe.io.Bytes.get()` (#8938)
+	php : improved performance of serialization/unserialization of `haxe.io.Bytes` (#8943)
+	php : improved performance of enum-related methods in `Type` class of standard library
+
+	Bugfixes:
+
+	haxelib : Fixed too strict requirements to haxelib.json data for private libs
+	all : fixed `@:using` static extensions on `Null<SomeType>` (#8928)
+	php : fixed static methods with the same name in parent and child classes (#8944)
+
+2019-11-04: 4.0.1
+
+	Bugfixes:
+
+	haxelib : fixed git dependencies in haxelib.json
+	neko : updated windows & osx installer to install Neko 2.3.0 (#8906)
+	jvm : fixed compilation failure caused by a specific usage of `Array<Dynamic>` (#8872)
+	all : fixed compiler crash on loops with `continue` in all branches of the body (#8912)
+	all : fixed erasing typedef in AST on field access to forwarded abstract fields (#8919)
+
+
+2019-10-26: 4.0.0
+
+	General improvements:
+
+	js : updated externs for `Float32Array` and `Float64Array` (#8864)
+	php : added array access to `php.NativeStructArray` (#8893)
+
+	Bugfixes:
+
+	cs : fixed "This expression may be invalid" false warning (#8589)
+	php : fixed iterator fields on maps being removed (#8851)
+	php : fixed `-2147483648` as init value for static vars (#5289)
+	python : fixed modulo by a negative number (#8845)
+	java : fixed backslash escaping on `EReg.replace` (#3430)
+	lua : fixed `EReg.map` for unicode (#8861)
+	hl : fixed sqlite connection on OSX/Linux (#8878)
+
+2019-09-12: 4.0.0-rc.5
+
+	General improvements and optimizations:
+
+	eval: improved performance of regular expressions (#8693)
+
+	Bugfixes:
+
+	all: fixed regression, which caused compiler to crash on enum abstracts with explicit casting (#8765)
+	all: fixed regression of macro `@:from` methods on abstracts (#8779)
+	all: fixed switching on `this` (#8781)
+
+2019-09-04: 4.0.0-rc.4
+
+	Standard Library:
+
+	all : added Map.clear (#8681)
+	all : improved Date API (#8508)
+	all : added JSON-RPC protocol types to haxe.display package (#8610)
+	all : added default timeout to HTTP sockets (#8646)
+	macro : added Context.info (#8478)
+	macro : added Context.getMessages and Context.filterMessages (#8471)
+	macro : added function kind to EFunction (#8653)
+	macro : added string literal kind to CString (#8668)
+	flash : added flash.AnyType (#8549)
+
+	General improvements and optimizations:
+
+	all : allowed enum constructors without arguments as static inline var (#8187)
+	all : improved handling of default values when inlining (#8397)
+	all : made various improvements to the display API as usual
+	all : detect invalid #tokens in inactive code (#7108)
+	all : allowed function types in @:generic (#3697)
+	all : improved --help-defines and --help-metas
+	all : improved overall file finding (#8202)
+	all : improved server reaction to added and removed files (#8451)
+	all : improved memory handling of the compilation server (8727)
+	all : improved handling of native libraries on the compilation server (#8629)
+	all : support partial completion results (#8642)
+	all : improved support of hovering over inactive conditional compilation blocks
+	all : improved completion support in .platform.hx files
+	all : support hovering conditional compilation identifiers
+	all : improved and unified identifier checks for names, fields and types (#8708)
+	all : improved --times performance (#8733)
+	all : remove some redundant cast expressions (#8725)
+	all : added --server-connect (#8730)
+	lua : improved -D lua-vanilla
+	js : improved HTML externs
+
+	Bugfixes :
+
+	all : fixed various position and replace ranges in the display API
+	all : fixed compiler hang related to @:arrayAccess (#5525)
+	all : fixed bug regarding abstract `this` modification in inline methods (#8454)
+	all : fixed `from Dynamic` on abstracts (#8425)
+	all : fixed overeager recursive inline check (#8489)
+	all : fixed the pattern matcher allowing inexhaustive switches in value-places (#8277)
+	all : fixed pattern matcher allowing invalid abstract unification (#8579)
+	all : fixed local variable type information being lost on the compilation server (#8511)
+	all : don't generate return expressions in Void lambda functions (#6503)
+	all : fixed unification of recursive typedefs again (#8523)
+	all : fixed various hangs related to abstracts (#8588)
+	all : fixed various GADT-related problems (#7672)
+	all : fixed macro `@:from` methods allowing any return type (#8463)
+	macro : fixed Sys.programPath assertion failure (#8466)
+	js : fixed typed array APIs (#8422)
+	java : fixed Std.is on non-reference and unrelated types (#5168)
+	java/macro : fixed null-pointer exception in Reflect.getProperty (#4934)
+	java/jvm : fix switch on null string (#4481)
+	jvm : fixed boxed vs. unboxed comparison (#8577)
+	jvm : generate toplevel types to haxe.root like genjava does (#8590)
+	jvm : improved 32bit support (#8601)
+	cs/python : fixed various issues with code generation
+	cs : fixed NativeArray casting (#3949)
+
+2019-06-13: 4.0.0-rc.3
+
+	New features:
+
+	all : added JVM target
+
+	General improvements and optimizations:
+
+	all : create temp vars in pattern matcher to avoid duplicate access (#8064)
+	all : support parsing dots in conditional compilation, e.g. `#if target.sys`
+	all : added `@:bypassAccessor`
+	all : improved various aspects of the display API
+	all : properly error on `@:op(a = b)` (#6903)
+	all : made `@:using` actually work
+	all : properly disallowed some modifier combinations related to `final` (#8335)
+	all : support `@:pure(false)` on variable fields (#8338)
+	flash : updated Flash externs to version 32.0 (now using `final`, `enum abstract` and `haxe.extern.Rest`)
+	flash : rework support for native Flash properties (#8241)
+	php : improved performance of various parser implementations (#8083)
+	cs : support .NET core target (#8391)
+	cs : generate native type parameter constraints (#8311, #7863)
+
+	Standard Library:
+
+	all : added StringTools.contains (#7608)
+	all : turned sys.thread.Thread into abstracts (#8130)
+	all : introduced `Std.downcast` as replacement for `Std.instance` (#8301)
+	all : introduced `UnicodeString`, deprecated `haxe.Utf8` (#8298)
+	java : added java.NativeString (#8163)
+	cs : added sys.thread implementations (#8166)
+	js : moved various classes to js.lib (#7390)
+
+	Bugfixes
+
+	all : fixed issue with `@:generic` type parameters not being bound to Dynamic (#8102)
+	all : fixed various issues related to `@:structInit`
+	all : fixed top-down inference on abstract setters (#7674)
+	all : fixed DCE issue related to closures (#8200)
+	all : fixed and restricted various Unicode-related issues in String literals
+	all : fixed various priority issues regarding loops and iterators
+	all : fixed cast handling in try-catch expressions (#8257)
+	all : fixed `inline new` handling (#8240)
+	all : fixed pattern matcher issue with wildcards in or-patterns (#8296)
+	all : fixed `@:allow(package)` allowing too much (#8306)
+	all : fixed various issues with startIndex handling on String.indexOf and String.lastIndexOf
+	all : fixed infinite recursion related to printing of objects with circular references (#8113)
+	sys : fixed various Unicode issues (#8135)
+	macro : fixed Array.pop handling (#8075)
+	macro : fixed assertion failure when throwing exception (#8039)
+	macro : fixed various uncatchable exceptions being thrown
+	php : error on case-insensitive name clashes (#8219)
+	lua : fixed issue where Process output occasionally is missing some data
+	hl : fixed various String Unicode issues
+	java : fixed null exception in CallStack.exceptionStack (#8322)
+	js : fixed code generation issue related to negative abstract values (#8318)
+	flash : fix various issues, including native `protected` handling and method overloading
+
+	Removals:
+
+	all : remove support for `@:fakeEnum` enums
+	all : disallowed `\x` with values > 0x7F (#8141)
+	all : consistently disallowed metadata in lambda function arguments (#7800)
+	all : removed `--gen-hx-classes` (#8237)
+
+2019-03-22: 4.0.0-rc.2
 
 	New features:
 
-	all : added new function type notation (#6645)
+	all : added strictness settings for the null-safety checker, using loose checking by default (#7811)
+	js : added ES6 class generation with `-D js-es=6` (#7806)
+
+	General improvements and optimizations:
+
+	all : inherit `@:native` for overriden methods (#7844)
+	all : standardized identifiers allowed in markup literals (#7558)
+	all : show typo suggestions when declaring `override` field (#7847)
+	all : improved parser error messages (#7912)
+	all : improved diagnostics of syntax errors (#7940)
+	all : improved positions of `switch` and `case` expressions (#7947)
+	all : allow parsing `#if (a.b)` (#8005)
+	eval : improved performance of various string operations (#7982)
+	eval : fixed many error positions
+	eval : greatly improved debugger interaction (#7839)
+	eval : properly support threads when debugging (#7991)
+	eval : improved handling of capture variables (#8017)
+	js : generate dot-access for "keyword" field names (#7645)
+	js : optimized run-time type checking against interfaces (#7834)
+	js : skip generation of interfaces when no run-time type checking needed (#7843)
+
+	Standard Library:
+
+	all : unified various Thread APIs in sys.thread (#7999)
+	all : moved typed arrays from `js.html` to `js.lib` (#7894)
+	all : added `iterator()` to `haxe.DynamicAccess` (#7892)
+	all : added `keyValueIterator()` to `haxe.DynamicAccess` (#7769)
+	eval : completed Thread API
+
+	Bugfixes:
+
+	all : fixed argument default value checking for externs (#7752)
+	all : fixed optional status of overloaded arguments with default values (#7794)
+	all : fixed DCE compilation server state issue (#7805)
+	all : fixed compilation server module dependency issue related to macros (#7448)
+	all : fixed call-site inlining on abstracts (#7886)
+	all : fixed Constructible not checking constraints properly (#6714)
+	all : fixed @:structInit not being compatible with `final` fields (#7182)
+	all : fixed capture variables being allowed in `.match` (#7921)
+	all : fixed infinite recursion on `@:generic` field access (#6430)
+	all : fixed `-D no-deprecation-warnings` for typedefs and enums
+	js : fixed bad stack handling on `Map` constraint checks (#7781)
+	js : fixed DCE issues related to haxe.CallStack (#7908)
+	cpp : fixed Socket flags not being preserved (#7989)
+	lua : fixed broken output when compiling through the compilation server (#7851)
+	lua : fixed `StringTools.fastCodeAt` with `-D lua-vanilla` (#7589)
+	lua : fixed `@:expose` for classes inside packages (#7849)
+
+2019-02-01: 4.0.0-rc.1
+
+	New features:
+
+	all : added experimental null-safety feature through `--macro nullSafety("package")` (#7717)
+
+	General improvements and optimizations:
+
+	all : improved unification error messages (#7547)
+	all : added `haxe4` define
+	all : do not require semicolon for markup literals (#7438)
+	all : made `@:expose` imply `@:keep` (#7695)
+	all : unified cast, catch and Std.is behavior of null-values (#7532)
+	macro : static variables are now always re-initialized when using the compilation server (#5746)
+	macro : support `@:persistent` to keep macro static values across compilations
+	js : improve js.Promise extern: now `then` callback argument types can be properly inferred (#7644)
+
+	Bugfixes:
+
+	all : fixed various pattern matching problems
+	all : fixed various wrong positions when encoding data to macros
+	all : specified String.indexOf with out-of-bounds indices (#7601)
+	all : fixed various problems related to DCE and feature-handling (#7694)
+	all : fixed bad unary operator optimization (#7704)
+	js : fixed syntax problem related to `instanceof` (#7653)
+	flash : fixed var field access on interfaces being uncast (#7727)
+	cpp : fixed various issues related to casts
+	cpp : fixed some leftover unicode issues
+	php : fixed class naming conflicts (#7716)
+	eval : fixed Socket.setTimeout (#7682)
+	eval : fixed int switch bug related to overflows
+
+	Removals:
+
+	macro : deprecated Context.registerModuleReuseCall and onMacroContextReused (#5746)
+
+2018-10-13: 4.0.0-preview.5
+	New features:
+
+	all : support Unicode strings properly on all targets
+	all : support `for (key => value in e)` syntax for key-value iterators
+	all : added keyValueIterator to Map and its implementations
+	all : support loop-unrolling on `for (i in 0...5)` (#7365)
+	all : added support for write-mode `@:op(a.b)`
+	all : support `inline call()` and `inline new` expressions (#7425)
+	all : support `@:using` on type declarations (#7462)
+	all : support markup literal strings but require them to be macro-processed (#7438)
+	all : allow enum values without arguments as default function argument values (#7439)
+	lua : add -D lua-vanilla, which emits code with reduced functionality but no additional lib dependencies
+
+	General improvements and optimizations:
+
+	all : [breaking] reserved `operator` and `overload` as keywords (#7413)
+	all : made `final` on structure fields invariant (#7039)
+	all : [breaking] disallowed static variables that have no type-hint and expression (#6440)
+	all : added display/typeDefinition to display protocol (#7266)
+	all : fixed various display-related problems
+	all : made parser in display mode much more tolerant
+	all : allowed assigning `[]` where `Map` is expected (#7426)
+	all : unified various parts of the String API across all targets
+	php : Optimized haxe.ds.Vector (VectorData is not Array anymore)
+	php : Optimized `Map.copy()` and `Array.copy()`
+	php : Optimized iterators of `Map` and native arrays.
+	php : Support native PHP generators. See `php.Syntax.yield()` and `php.Generator`
+	js : updated HTML externs
+	eval : improved object prototype field handling (#7393)
+	eval : optimized int switches (#7481)
+	eval : improved IntMap and StringMap performance
+	eval : improved performance of instance calls
+
+	Removals :
+
+	all : disallowed get_x/set_x property syntax, use get/set instead (#4699)
+	all : disallowed default values on interface variables (#4087)
+	all : disallowed `implements Dynamic` on non-extern classes (#6191)
+	all : warn about expressions in extern non-inline fields (#5898)
+	all : removed `-D use-rtti-doc`, always store documentation instead (#7493)
+	all : disallowed macro-in-macro calls (#7496)
+	js : removed jQuery and swfobject externs (#7494)
+
+	Bugfixes:
+
+	all : fix GC compacting too often in server mode
+	all : [breaking] `function () { }(e)` is no longer parsed as a call (#5854)
+	all : fixed various minor inlining issues
+	all : disallowed `return null` from Void-functions (#7198)
+	all : fixed various pattern matching problems
+	all : fixed compiler hang in display mode (#7236)
+	all : fixed the XML printer trimming CDATA content (#7454)
+	all : fixed invalid visibility unification with statics (#7527)
+	php : Escape `$` in field names of anonymous objects (#7230)
+	php : Generate `switch` as `if...else if...else...` to avoid loose comparison (#7257)
+	cs : fixed bad evaluation order in structures (#7531)
+	eval : fixed various problems with the debugger
+	eval : fixed Vector.fromArrayCopy (#7492)
+	eval : fixed bad string conversions on invalid + operations
+
+	Standard Library:
+
+	all : [breaking] made Lambda functions return Array instead of List (#7097)
+	all : added haxe.iterators package
+	all : improved StringTools.lpad/rpad/htmlEscape implementation
+
+2018-06-12: 4.0.0-preview.4
+
+	New features:
+
+	all : added JSON-RPC-based display protocol
+	all : allow `enum abstract` syntax instead of `@:enum abstract` (#4282)
+	all : allow `extern` on fields instead of `@:extern`
+	all : support signature completion on incomplete structures (#5767)
+	all : support auto-numbering and auto-stringification in enum abstracts (#7139)
+	all : support `Type1 & Type2` intersection syntax for type parameter constraints and structures (#7127)
+
+	General improvements and optimizations:
+
+	all : reworked CLI usage/help output (#6862)
+	all : implemented `for` loop unrolling (#3784)
+	all : metadata can now use `.`, e.g. `@:a.b`. This is represented as a string (#3959)
+	all : [breaking] disallow static extensions through abstract field casts (#5924)
+	all : [breaking] disallow static extensions on implicit `this` (#6036)
+	all : allow true and false expressions as type parameters (#6958)
+	all : improved display support in many areas
+	all : support `override |` completion
+	all : make display/references and display/toplevel actually work sometimes
+	all : allow `var ?x` and `final ?x` parsing in structures (#6947)
+	all : improved overall robustness of the parser in display mode
+	all : allow `@:commutative` on non-static abstract functions (#5599)
+	js : added externs for js.Date (#6855)
+	js : respect `-D source-map` flag to generate source maps in release builds
+	js : enums are now generated as objects instead of arrays (#6350)
+	eval : improved debugger, support conditional breakpoints
+
+	Removals:
+
+	all : moved haxe.remoting to hx3compat
+	js : moved js.XMLSocket to hx3compat
+	neko : moved neko.net to hx3compat
+	all : removed support for `T:(A, B)` constraint syntax
+
+	Bugfixes:
+
+	all : fixed various issues with diagnostics
+	all : fixed fields with default values for `@:structInit` classes (#5449)
+	all : fixed `Null<T>` inconsistency in if/ternary expressions (#6955)
+	all : fixed visibility check related to private constructors of sibling classes (#6957)
+	all : fixed @:generic naming (#6968)
+	all : fixed handling of type parameters in local functions (#6560)
+	all : fixed resolution order between `untyped` and type parameters (#7113)
+	all : fixed unification behavior in try/catch expressions (#7120)
+	all : fixed field type being lost for Int expressions on Float fields (#7132)
+	all : cleaned up `inline` handling (#7155)
+	display : fixed completion in packages starting with underscore (#5417)
+	php : fixed Reflect.callMethod with classes as first argument (#7106)
+	eval : fixed internal exception surfacing in some context calls (#7007)
+	eval : fixed Type.enumEq (#6710)
+	flash : fixed silently swallowing exceptions in getters/setters when invoked with Reflect methods (#5460, #6871)
+
+	Standard Library:
+
+	all : added `resize` to Array (#6869)
+	all : [breaking] removed `return this` from some haxe.Http methods (#6980)
+
+2018-02-23: 4.0.0-preview.3
+
+	See full commit history at https://github.com/HaxeFoundation/haxe/compare/4.0.0-preview.2...4.0.0-preview.3, notable changes below:
+
+	New features:
+
+	all : added new function type syntax (`(a:Int, b:String)->Void`) (#6645)
+	all : added column to StackItem.FilePos (#6665)
+	all : added `-D warn-var-shadowing`
+	all : added haxe.Log.formatOutput (#6738)
+	js : added js.Syntax class for generating unsupported JavaScript syntax in a type-safe analyzer-friendly way
+	js : added js.Map and js.Set and js.JsIterator extern definitions (ES6)
+	hl : added hl.Format.digest, use it for native Sha1/Md5
 
 	General improvements and optimizations:
 
 	all : made all non-warning/non-error compiler messages output to stdout (#4480)
+	all : make DCE keep constructor if any instance field is kept (#6690)
+	all : make `final` in structures use class notation
+	display : added `this` and `super` to toplevel completion (#6051)
 	php : implemented direct method comparison. No need to use `Reflect.compareMethods()`
 	php : added `php.Syntax.code()` instead of deprecated `untyped __php__()` (#6708)
 	php : added methods to `php.Syntax` for each php operator: `??`, `?:`, `**` etc. (#6708)
+	python : add ssl support for http requests
+	python : improve Sys.print(ln) code generation (#6184)
+	js : generate faster code for `x.iterator()` calls (#6669)
+	js : rework exception handling, added js.Lib.getOriginalException (#6713)
+	js : generate `value instanceof MyClass` instead of `Std.is(value, MyClass)` (#6687)
+	js : use lazy getter for HaxeError.message instead of calling String(val) in the ctor (#6754)
 
 	Removals:
 
@@ -21,20 +473,32 @@
 
 	Bugfixes:
 
+	all : delay interface accessor generation properly (#6225, #6672)
+	all : fixed unbound variable error in anonymous functions (#6674)
+	all : fixed abstract `@:to` used when `from` is available in a specific case (#6751)
+	all : sys.Http: fix chunked encoding handling (#6763)
+	all : fix some invalid Json being accepted by haxe.format.JsonParser (#6734)
+	all : fixed haxe.format.JsonPrinter for instances of classes to make it produce consistent result across targets (#6801)
+	all : fixed autogenerated constructor for extending @:structInit classes (#6822, #6078)
 	js : fixed saving setter to `tmp` var before invocation (#6672)
+	lua : fix toString behavior in the case of -0 (#6652)
+	lua : properly bind field functions when passed as arguments (#6722)
 	php : don't fail on generating import aliases for classes with the similar names (#6680)
 	php : fixed `Sys.environment()` to also return variables set by `Sys.putEnv()`
 	php : fixed `sys.net.Socket.bind()` (#6693)
 	php : fixed appending "sqlite:" prefix to the names of files created by `sys.db.Sqlite.open()` (#6692)
 	php : made php.Lib.objectOfAssociativeArray() recursive (#6698)
 	php : fixed php error on parsing expressions like `a == b == c` (#6720)
+	php : fixed multiple file uploads in php.Web.parseMultiPart() (#4173)
+	php : fixed an issue with "Object" used as a class name for PHP 7.2 (it's a new keyword in php) (#6838)
+	eval : don't lose dynamic function inits from parent classes (#6660)
+	cs : fix order-dependent enum type parameter issue (#6016)
 
 2017-10-08: 4.0.0-preview.2
 
 	New features:
 
 	all : added final keyword (#6596)
-	all : added new function type notation (#6645)
 
 	General improvements and optimizations:
 
@@ -53,7 +517,7 @@
 	Bugfixes:
 
 	all : fixed issue with various functions not being displayed in macro context (#6000)
-	all : fixed invalid  static extension lookup on `super` (#3607)
+	all : fixed invalid static extension lookup on `super` (#3607)
 	all : fixed typing error when constructing enums with abstracts over functions (#6609)
 	all : fixed bug that skipped checking @:from typing in some cases (#6564)
 	all : fixed Int64 parsing of negative numbers that end in a zero (#5493)
@@ -115,6 +579,22 @@
 	all : added `EReg.escape` (#5098)
 	all : `BalancedTree implements `haxe.Constraints.IMap` (#6231)
 
+2018-01-31: 3.4.5
+
+	General improvements and optimizations:
+
+	dce : optimized DCE performance (#6181)
+
+	Bugfixes:
+
+	dce : don't remove constructor if any instance field is kept (#6062)
+	js : fixed saving setter to `tmp` var before invocation (#6672)
+	php7 : don't fail on generating import aliases for classes with the similar names (#6680)
+	php7 : fixed appending "sqlite:" prefix to the names of files created by `sys.db.Sqlite.open()` (#6692)
+	php7 : made php.Lib.objectOfAssociativeArray() recursive (#6698)
+	php7 : fixed php error on parsing expressions like `a == b == c` (#6720)
+	php/php7 : fixed `sys.net.Socket.bind()` (#6693)
+
 2017-10-08: 3.4.4
 
 	Bugfixes:

extra/FileAssociation.nsh

@@ -0,0 +1,190 @@
+/*
+_____________________________________________________________________________
+
+                       File Association
+_____________________________________________________________________________
+
+ Based on code taken from http://nsis.sourceforge.net/File_Association
+
+ Usage in script:
+ 1. !include "FileAssociation.nsh"
+ 2. [Section|Function]
+      ${FileAssociationFunction} "Param1" "Param2" "..." $var
+    [SectionEnd|FunctionEnd]
+
+ FileAssociationFunction=[RegisterExtension|UnRegisterExtension]
+
+_____________________________________________________________________________
+
+ ${RegisterExtension} "[executable]" "[extension]" "[description]"
+
+"[executable]"     ; executable which opens the file format
+                   ;
+"[extension]"      ; extension, which represents the file format to open
+                   ;
+"[description]"    ; description for the extension. This will be display in Windows Explorer.
+                   ;
+
+
+ ${UnRegisterExtension} "[extension]" "[description]"
+
+"[extension]"      ; extension, which represents the file format to open
+                   ;
+"[description]"    ; description for the extension. This will be display in Windows Explorer.
+                   ;
+
+_____________________________________________________________________________
+
+                         Macros
+_____________________________________________________________________________
+
+ Change log window verbosity (default: 3=no script)
+
+ Example:
+ !include "FileAssociation.nsh"
+ !insertmacro RegisterExtension
+ ${FileAssociation_VERBOSE} 4   # all verbosity
+ !insertmacro UnRegisterExtension
+ ${FileAssociation_VERBOSE} 3   # no script
+*/
+
+
+!ifndef FileAssociation_INCLUDED
+!define FileAssociation_INCLUDED
+
+!include Util.nsh
+
+!verbose push
+!verbose 3
+!ifndef _FileAssociation_VERBOSE
+  !define _FileAssociation_VERBOSE 3
+!endif
+!verbose ${_FileAssociation_VERBOSE}
+!define FileAssociation_VERBOSE `!insertmacro FileAssociation_VERBOSE`
+!verbose pop
+
+!macro FileAssociation_VERBOSE _VERBOSE
+  !verbose push
+  !verbose 3
+  !undef _FileAssociation_VERBOSE
+  !define _FileAssociation_VERBOSE ${_VERBOSE}
+  !verbose pop
+!macroend
+
+
+
+!macro RegisterExtensionCall _EXECUTABLE _EXTENSION _DESCRIPTION
+  !verbose push
+  !verbose ${_FileAssociation_VERBOSE}
+  Push `${_DESCRIPTION}`
+  Push `${_EXTENSION}`
+  Push `${_EXECUTABLE}`
+  ${CallArtificialFunction} RegisterExtension_
+  !verbose pop
+!macroend
+
+!macro UnRegisterExtensionCall _EXTENSION _DESCRIPTION
+  !verbose push
+  !verbose ${_FileAssociation_VERBOSE}
+  Push `${_EXTENSION}`
+  Push `${_DESCRIPTION}`
+  ${CallArtificialFunction} UnRegisterExtension_
+  !verbose pop
+!macroend
+
+
+
+!define RegisterExtension `!insertmacro RegisterExtensionCall`
+!define un.RegisterExtension `!insertmacro RegisterExtensionCall`
+
+!macro RegisterExtension
+!macroend
+
+!macro un.RegisterExtension
+!macroend
+
+!macro RegisterExtension_
+  !verbose push
+  !verbose ${_FileAssociation_VERBOSE}
+
+  Exch $R2 ;exe
+  Exch
+  Exch $R1 ;ext
+  Exch
+  Exch 2
+  Exch $R0 ;desc
+  Exch 2
+  Push $0
+  Push $1
+
+  ReadRegStr $1 HKCR $R1 ""  ; read current file association
+  StrCmp "$1" "" NoBackup  ; is it empty
+  StrCmp "$1" "$R0" NoBackup  ; is it our own
+    WriteRegStr HKCR $R1 "backup_val" "$1"  ; backup current value
+NoBackup:
+  WriteRegStr HKCR $R1 "" "$R0"  ; set our file association
+
+  ReadRegStr $0 HKCR $R0 ""
+  StrCmp $0 "" 0 Skip
+    WriteRegStr HKCR "$R0" "" "$R0"
+    WriteRegStr HKCR "$R0\shell" "" "open"
+    WriteRegStr HKCR "$R0\DefaultIcon" "" "$R2,0"
+Skip:
+  WriteRegStr HKCR "$R0\shell\open\command" "" '"$R2" "%1"'
+  WriteRegStr HKCR "$R0\shell\edit" "" "Edit $R0"
+  WriteRegStr HKCR "$R0\shell\edit\command" "" '"$R2" "%1"'
+
+  Pop $1
+  Pop $0
+  Pop $R2
+  Pop $R1
+  Pop $R0
+
+  !verbose pop
+!macroend
+
+
+
+!define UnRegisterExtension `!insertmacro UnRegisterExtensionCall`
+!define un.UnRegisterExtension `!insertmacro UnRegisterExtensionCall`
+
+!macro UnRegisterExtension
+!macroend
+
+!macro un.UnRegisterExtension
+!macroend
+
+!macro UnRegisterExtension_
+  !verbose push
+  !verbose ${_FileAssociation_VERBOSE}
+
+  Exch $R1 ;desc
+  Exch
+  Exch $R0 ;ext
+  Exch
+  Push $0
+  Push $1
+
+  ReadRegStr $1 HKCR $R0 ""
+  StrCmp $1 $R1 0 NoOwn ; only do this if we own it
+  ReadRegStr $1 HKCR $R0 "backup_val"
+  StrCmp $1 "" 0 Restore ; if backup="" then delete the whole key
+  DeleteRegKey HKCR $R0
+  Goto NoOwn
+
+Restore:
+  WriteRegStr HKCR $R0 "" $1
+  DeleteRegValue HKCR $R0 "backup_val"
+  DeleteRegKey HKCR $R1 ;Delete key with association name settings
+
+NoOwn:
+
+  Pop $1
+  Pop $0
+  Pop $R1
+  Pop $R0
+
+  !verbose pop
+!macroend
+
+!endif # !FileAssociation_INCLUDED

extra/ImportAll.hx

@@ -1,5 +1,5 @@
 /*
- * Copyright (C)2005-2017 Haxe Foundation
+ * Copyright (C)2005-2018 Haxe Foundation
  *
  * Permission is hereby granted, free of charge, to any person obtaining a
  * copy of this software and associated documentation files (the "Software"),
@@ -52,8 +52,12 @@ class ImportAll {
 			return;
 		case "sys":
 			if(!isSysTarget()) return;
+		case "sys.thread":
+			if ( !Context.defined("target.threaded") ) return;
 		case "java":
 			if( !Context.defined("java") ) return;
+		case "jvm":
+			if( !Context.defined("jvm") ) return;
 		case "cs":
 			if( !Context.defined("cs") ) return;
 		case "python":
@@ -66,7 +70,7 @@ class ImportAll {
 			if( !Context.defined("eval") ) return;
 		case "ssl":
 			if (!Context.defined("neko") && !Context.defined("cpp")) return;
-		case "tools", "build-tool": return;
+		case "tools", "build-tool", "jar-tool": return;
 		}
 		for( p in Context.getClassPath() ) {
 			if( p == "/" )

extra/WinSetup.hx

@@ -0,0 +1,132 @@
+import sys.io.Process;
+
+using haxe.io.Path;
+using StringTools;
+using sys.FileSystem;
+using WinSetup;
+
+enum abstract RegDataType<T>(String) to String {
+	var REG_EXPAND_SZ:RegDataType<String>;
+	var REG_SZ:RegDataType<String>;
+}
+
+class AccessDenied {
+	public var message:String;
+	public function new(msg:String) message = msg;
+	public function toString() return message;
+}
+
+class WinSetup {
+	static inline var HAXEPATH = 'HAXEPATH';
+	static inline var NEKO_INSTPATH = 'NEKO_INSTPATH';
+
+	static inline var REG_HKLM_ENVIRONMENT = 'HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment';
+	static inline var REG_HKCU_ENVIRONMENT = 'HKEY_CURRENT_USER\\Environment';
+
+	static function main() {
+		try {
+			try {
+				run(REG_HKLM_ENVIRONMENT);
+			} catch(e:AccessDenied) {
+				run(REG_HKCU_ENVIRONMENT);
+			}
+		} catch(e:Dynamic) {
+			Sys.stderr().writeString(Std.string(e) + '\n');
+			#if debug
+				Sys.stderr().writeString(haxe.CallStack.toString(haxe.CallStack.exceptionStack()) + '\n');
+			#end
+			Sys.stderr().flush();
+			#if debug
+			Sys.println('Press any key to exit...');
+			Sys.getChar(false);
+			#end
+			Sys.exit(1);
+		}
+	}
+
+	static function envVar(name:String):String {
+		return '%$name%';
+	}
+
+	static function run(regDir:String) {
+		var haxePath = Sys.getCwd().removeTrailingSlashes();
+		var addHaxe = '$haxePath\\haxe.exe'.exists();
+		if(addHaxe) {
+			setRegValue(regDir, HAXEPATH, REG_SZ, haxePath);
+		}
+
+		var nekoPath = Path.join([Path.directory(haxePath), 'neko']).replace('/', '\\');
+		var addNeko = '$nekoPath\\neko.exe'.exists();
+		if(addNeko) {
+			setRegValue(regDir, NEKO_INSTPATH, REG_SZ, nekoPath);
+		}
+
+		if(!addHaxe && !addNeko) {
+			return;
+		}
+
+		var paths = readPath(regDir).split(';');
+		addHaxe = paths.indexOf(HAXEPATH.envVar()) < 0 && addHaxe;
+		if(addHaxe) {
+			paths.push(HAXEPATH.envVar());
+		}
+		addNeko = paths.indexOf(NEKO_INSTPATH.envVar()) < 0 && addNeko;
+		if(addNeko) {
+			paths.push(NEKO_INSTPATH.envVar());
+		}
+		if(addHaxe || addNeko) {
+			setRegValue(regDir, 'path', REG_EXPAND_SZ, paths.join(';'));
+		}
+	}
+
+	static function readPath(regDir:String):String {
+		var p = new Process('reg', ['query', regDir, '/v', 'path']);
+		if(p.exitCode() != 0) {
+			var error = p.stderr.readAll().toString();
+			p.close();
+			throw 'Cannot query reg.exe for PATH:\n$error';
+		}
+		/**
+		 * Sample response:
+		 *
+		 *	HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\Environment
+		 *	    path    REG_EXPAND_SZ    %SystemRoot%\system32;%SystemRoot%;%SystemRoo<...>
+		 */
+		var response = p.stdout.readAll().toString();
+		p.close();
+		var lines = response.split('\n');
+		for(line in lines) {
+			line = line.trim();
+			if(line.substr(0, 'path'.length).toLowerCase() == 'path') {
+				var column = 0;
+				var wasSpace = false;
+				for(pos in 0...line.length) {
+					var isSpace = line.isSpace(pos);
+					if(wasSpace && !isSpace) {
+						column++;
+						if(column == 2) {
+							return line.substr(pos);
+						}
+					}
+					wasSpace = isSpace;
+				}
+			}
+		}
+		throw 'Cannot parse a query to reg.exe for PATH value:\n$response';
+	}
+
+	static function setRegValue<T>(regDir:String, name:String, dataType:RegDataType<T>, value:T) {
+		var p = new Process('reg', ['add', regDir, '/v', name, '/t', dataType, '/d', '$value', '/f']);
+		if(p.exitCode() != 0) {
+			var error = p.stderr.readAll().toString();
+			p.close();
+			var msg = 'Cannot set a value for $name via reg.exe:\n$error';
+			if(~/access(.*)denied/i.match(error)) {
+				throw new AccessDenied(msg);
+			} else {
+				throw msg;
+			}
+		}
+		p.close();
+	}
+}

extra/all.hxml

@@ -15,7 +15,7 @@
 
 -swf all9.swf
 -xml flash9.xml
--swf-version 11.4
+--swf-version 11.4
 
 --next
 
@@ -26,19 +26,21 @@
 
 -cpp all_cpp
 -xml cpp.xml
--D xmldoc
 -D HXCPP_MULTI_THREADED
 
 --next
 -java all_java
 -xml java.xml
--D xmldoc
+
+--next
+-java all_jvm
+-D jvm
+-xml jvm.xml
 
 --next
 -cs all_cs
 -D unsafe
 -xml cs.xml
--D xmldoc
 
 --next
 -python all_python

extra/azure-pipelines/build-linux.yml

@@ -0,0 +1,61 @@
+parameters:
+  name: 'BuildLinux'
+  vmImage: 'ubuntu-16.04'
+
+jobs:
+  - job: ${{ parameters.name }}
+    pool:
+      vmImage: ${{ parameters.vmImage }}
+    variables:
+      OPAMYES: 1
+      ${{ if not(startsWith(variables['Build.SourceBranch'], 'refs/tags/')) }}:
+        ADD_REVISION: 1
+    steps:
+      - checkout: self
+        submodules: recursive
+      - script: |
+          set -ex
+          sudo add-apt-repository ppa:avsm/ppa -y # provides OPAM 2
+          sudo add-apt-repository ppa:haxe/ocaml -y # provides newer version of mbedtls
+          sudo apt-get update -qqy
+          sudo apt-get install -qqy ocaml-nox camlp5 opam libpcre3-dev zlib1g-dev libgtk2.0-dev libmbedtls-dev ninja-build
+        displayName: Install dependencies
+      - template: install-neko-snapshot.yaml
+        parameters:
+          platform: linux64
+      - script: |
+          set -ex
+          opam init
+          opam update
+          opam pin add haxe . --no-action
+          opam install haxe --deps-only
+          opam list
+          ocamlopt -v
+        displayName: Install OCaml libraries
+      - script: |
+          set -ex
+          opam config exec -- make -s -j`nproc` STATICLINK=1 haxe
+          opam config exec -- make -s haxelib
+          make -s package_bin
+          ls -l out
+          ldd -v ./haxe
+          ldd -v ./haxelib
+        displayName: Build Haxe
+      - task: PublishPipelineArtifact@0
+        inputs:
+          artifactName: 'linuxBinaries'
+          targetPath: out
+      - script: |
+          set -ex
+          make -s xmldoc
+          cat >extra/doc/info.json <<EOL
+            {
+              "commit": "$(Build.SourceVersion)",
+              "branch": "$(Build.SourceBranchName)"
+            }
+          EOL
+        displayName: Build xmldoc
+      - task: PublishPipelineArtifact@0
+        inputs:
+          artifactName: 'xmldoc'
+          targetPath: extra/doc

extra/azure-pipelines/build-mac.yml

@@ -0,0 +1,46 @@
+parameters:
+  name: 'BuildMac'
+  vmImage: 'macOS-10.13'
+
+jobs:
+  - job: ${{ parameters.name }}
+    pool:
+      vmImage: ${{ parameters.vmImage }}
+    variables:
+      OPAMYES: 1
+      ${{ if not(startsWith(variables['Build.SourceBranch'], 'refs/tags/')) }}:
+        ADD_REVISION: 1
+    steps:
+      - checkout: self
+        submodules: recursive
+      - script: |
+          set -ex
+          brew update || brew update || brew update
+          brew unlink python@2
+          brew bundle --file=tests/Brewfile --no-upgrade
+        displayName: Install dependencies
+      - template: install-neko-snapshot.yaml
+        parameters:
+          platform: mac
+      - script: |
+          set -ex
+          opam init
+          opam update
+          opam pin add haxe . --no-action
+          opam install haxe --deps-only
+          opam list
+          ocamlopt -v
+        displayName: Install OCaml libraries
+      - script: |
+          set -ex
+          opam config exec -- make -s -j`sysctl -n hw.ncpu` STATICLINK=1 "LIB_PARAMS=/usr/local/opt/zlib/lib/libz.a /usr/local/lib/libpcre.a /usr/local/lib/libmbedtls.a /usr/local/lib/libmbedcrypto.a /usr/local/lib/libmbedx509.a -cclib '-framework Security -framework CoreFoundation'" haxe
+          opam config exec -- make -s haxelib
+          make -s package_bin package_installer_mac
+          ls -l out
+          otool -L ./haxe
+          otool -L ./haxelib
+        displayName: Build Haxe
+      - task: PublishPipelineArtifact@0
+        inputs:
+          artifactName: 'macBinaries'
+          targetPath: out

extra/azure-pipelines/build-windows.yml

@@ -0,0 +1,72 @@
+parameters:
+  name: 'BuildWindows'
+  vmImage: 'windows-2019'
+  arch: '64' # or '32'
+
+jobs:
+  - job: ${{ parameters.name }}
+    pool:
+      vmImage: ${{ parameters.vmImage }}
+    variables:
+      OPAMYES: 1
+      ${{ if not(startsWith(variables['Build.SourceBranch'], 'refs/tags/')) }}:
+        ADD_REVISION: 1
+      CYG_MIRROR: http://mirrors.kernel.org/sourceware/cygwin/
+      ${{ if eq(parameters.arch, '64') }}:
+        ARCH: 64
+        MINGW_ARCH: x86_64
+        CYGWIN_SETUP: https://cygwin.com/setup-x86_64.exe
+        CYG_ROOT: C:/cygwin64
+      ${{ if eq(parameters.arch, '32') }}:
+        ARCH: 32
+        MINGW_ARCH: i686
+        CYGWIN_SETUP: https://cygwin.com/setup-x86.exe
+        CYG_ROOT: C:/cygwin
+    steps:
+      - checkout: self
+        submodules: recursive
+      - powershell: |
+          Set-PSDebug -Trace 1
+          choco install --no-progress nsis.portable --version 3.02 -y
+          choco install --no-progress curl wget 7zip.portable -y
+        displayName: Install dependencies
+      - powershell: Write-Host "##vso[task.prependpath]C:\ProgramData\chocolatey\bin"
+        displayName: Prepend Chocolatey path
+      - template: install-neko-snapshot.yaml
+        parameters:
+          ${{ if eq(parameters.arch, '64') }}:
+            platform: windows64
+          ${{ if eq(parameters.arch, '32') }}:
+            platform: windows
+      - powershell: |
+          Set-PSDebug -Trace 1
+          curl.exe -fsSL -o cygwin-setup.exe --retry 3 $(CYGWIN_SETUP)
+          Start-Process -FilePath "cygwin-setup.exe" -ArgumentList "-B -q -R $(CYG_ROOT) -l C:/tmp -s $(CYG_MIRROR) -P default -P make -P git -P zlib-devel -P rsync -P patch -P diffutils -P curl -P unzip -P tar -P m4 -P perl -P libpcre-devel -P mbedtls-devel -P mingw64-$(MINGW_ARCH)-zlib -P mingw64-$(MINGW_ARCH)-gcc-core -P mingw64-$(MINGW_ARCH)-pcre" -Wait
+          curl.exe -fsSL -o "opam.tar.xz" --retry 3 https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.2/opam$(ARCH).tar.xz
+          curl.exe -fsSL -o "libmbedtls.tar.xz" --retry 3 https://github.com/Simn/mingw64-mbedtls/releases/download/2.16.3/mingw64-$(MINGW_ARCH)-mbedtls-2.16.3-1.tar.xz
+          & "$(CYG_ROOT)/bin/bash.exe" @('-lc', 'echo "$OLDPWD"')
+          & "$(CYG_ROOT)/bin/bash.exe" @('-lc', 'cd "$OLDPWD" && tar -C / -xvf libmbedtls.tar.xz')
+          & "$(CYG_ROOT)/bin/bash.exe" @('-lc', 'cd "$OLDPWD" && tar -xf opam.tar.xz')
+          & "$(CYG_ROOT)/bin/bash.exe" @('-lc', 'cd "$OLDPWD" && bash opam$(ARCH)/install.sh')
+          & "$(CYG_ROOT)/bin/bash.exe" @('-lc', 'opam init mingw "https://github.com/fdopen/opam-repository-mingw.git#opam2" --comp 4.07.0+mingw$(ARCH)c --switch 4.07.0+mingw$(ARCH)c --auto-setup --yes 2>&1')
+          & "$(CYG_ROOT)/bin/bash.exe" @('-lc', 'opam update --yes 2>&1')
+          & "$(CYG_ROOT)/bin/bash.exe" @('-lc', 'cd "$OLDPWD" && opam pin add haxe . --kind=path --no-action --yes 2>&1')
+          & "$(CYG_ROOT)/bin/bash.exe" @('-lc', 'opam install haxe --deps-only --yes 2>&1')
+          & "$(CYG_ROOT)/bin/bash.exe" @('-lc', 'opam list')
+          & "$(CYG_ROOT)/bin/bash.exe" @('-lc', 'ocamlopt -v')
+        displayName: Install OCaml and OCaml libraries
+      - powershell: Write-Host "##vso[task.prependpath]${env:CYG_ROOT}/usr/$(MINGW_ARCH)-w64-mingw32/sys-root/mingw/bin"
+        displayName: Expose mingw dll files
+      - powershell: |
+          Set-PSDebug -Trace 1
+          & "$(CYG_ROOT)/bin/bash.exe" @('-lc', 'cd "$OLDPWD" && opam config exec -- make -s -f Makefile.win -j`nproc` haxe 2>&1')
+          & "$(CYG_ROOT)/bin/bash.exe" @('-lc', 'cd "$OLDPWD" && opam config exec -- make -s -f Makefile.win haxelib 2>&1')
+          & "$(CYG_ROOT)/bin/bash.exe" @('-lc', 'cd "$OLDPWD" && opam config exec -- make -f Makefile.win echo_package_files package_bin package_installer_win package_choco 2>&1')
+          dir out
+          & "$(CYG_ROOT)/bin/bash.exe" @('-lc', 'cd "$OLDPWD" && cygcheck ./haxe.exe')
+          & "$(CYG_ROOT)/bin/bash.exe" @('-lc', 'cd "$OLDPWD" && cygcheck ./haxelib.exe')
+        displayName: Build Haxe
+      - task: PublishPipelineArtifact@0
+        inputs:
+          artifactName: 'win$(ARCH)Binaries'
+          targetPath: out

extra/azure-pipelines/install-neko-snapshot.yaml

@@ -0,0 +1,33 @@
+parameters:
+  platform: '' # can be linux64, mac, windows, or windows64
+
+steps:
+  - ${{ if startsWith(parameters.platform, 'windows') }}:
+    - powershell: |
+        Invoke-WebRequest https://build.haxe.org/builds/neko/${{parameters.platform}}/neko_latest.zip -OutFile $(Agent.TempDirectory)/neko_latest.zip
+        Expand-Archive $(Agent.TempDirectory)/neko_latest.zip -DestinationPath $(Agent.TempDirectory)
+        $NEKOPATH = Get-ChildItem $(Agent.TempDirectory)/neko-*-*
+        Write-Host "##vso[task.prependpath]$NEKOPATH"
+        Write-Host "##vso[task.setvariable variable=NEKOPATH]$NEKOPATH"
+      displayName: Install Neko using snapshot from S3
+  - ${{ if not(startsWith(parameters.platform, 'windows')) }}:
+    - bash: |
+        set -ex
+        DOWNLOADDIR=$(Agent.TempDirectory)
+        curl -sSL https://build.haxe.org/builds/neko/${{parameters.platform}}/neko_latest.tar.gz -o $(Agent.TempDirectory)/neko_latest.tar.gz
+        tar -xf $(Agent.TempDirectory)/neko_latest.tar.gz -C $(Agent.TempDirectory)
+        NEKOPATH=`echo $(Agent.TempDirectory)/neko-*-*`
+        sudo mkdir -p /usr/local/bin
+        sudo mkdir -p /usr/local/lib/neko
+        sudo ln -s $NEKOPATH/{neko,nekoc,nekoml,nekotools}  /usr/local/bin/
+        sudo ln -s $NEKOPATH/libneko.*                      /usr/local/lib/
+        sudo ln -s $NEKOPATH/*.ndll                         /usr/local/lib/neko/
+        set +x
+        echo "##vso[task.prependpath]$NEKOPATH"
+        echo "##vso[task.setvariable variable=NEKOPATH]$NEKOPATH"
+      displayName: Install Neko using snapshot from S3
+  - ${{ if eq(parameters.platform, 'linux64') }}:
+    - bash: sudo ldconfig
+      displayName: ldconfig
+  - script: neko -version 2>&1
+    displayName: Print Neko version

extra/azure-pipelines/test-windows.yml

@@ -0,0 +1,87 @@
+parameters:
+  name: 'TestWindows'
+  vmImage: 'windows-2019'
+  arch: '64' # or '32'
+
+jobs:
+  - job: ${{ parameters.name }}
+    dependsOn: BuildWin${{ parameters.arch }}
+    pool:
+      vmImage: ${{ parameters.vmImage }}
+    variables:
+      HAXELIB_ROOT: C:/haxelib
+    strategy:
+      matrix:
+        # https://github.com/HaxeFoundation/haxe/issues/8600
+        ${{ if eq(parameters.arch, '64') }}:
+          macro:
+            TEST: macro
+        neko:
+          TEST: neko
+        hl:
+          TEST: hl
+        cpp:
+          TEST: cpp
+          HXCPP_COMPILE_CACHE: C:/hxcache
+        java:
+          # https://github.com/HaxeFoundation/haxe/issues/8601
+          ${{ if eq(parameters.arch, '64') }}:
+            TEST: java,jvm
+          ${{ if eq(parameters.arch, '32') }}:
+            TEST: java
+        cs:
+          TEST: cs
+        js:
+          TEST: js
+        php:
+          TEST: php
+        # TODO. flash has never been enabled on our AppVeyor builds.
+        # flash:
+        #   TEST: flash9
+        python:
+          TEST: python
+        # TODO. Lua has never been enabled on our AppVeyor builds.
+        # lua:
+        #   TEST: lua
+    steps:
+      - checkout: self
+        fetchDepth: 20
+      - template: install-neko-snapshot.yaml
+        parameters:
+          ${{ if eq(parameters.arch, '64') }}:
+            platform: windows64
+          ${{ if eq(parameters.arch, '32') }}:
+            platform: windows
+      - task: DownloadPipelineArtifact@0
+        inputs:
+          artifactName: 'win${{ parameters.arch }}Binaries'
+          targetPath: win${{ parameters.arch }}Binaries
+      - powershell: |
+          Set-PSDebug -Trace 1
+          7z x win${{ parameters.arch }}Binaries/*_bin.zip -owin${{ parameters.arch }}Binaries
+          $dir = Get-ChildItem win${{ parameters.arch }}Binaries/* -Name -Directory
+          Rename-Item win${{ parameters.arch }}Binaries/$dir haxe
+          $dir = '' + ( get-location ) + '\win${{ parameters.arch }}Binaries\haxe'
+          dir $dir
+          Set-PSDebug -Trace 0
+          Write-Host "##vso[task.prependpath]$dir"
+        displayName: Setup Haxe
+      - script: haxe -version
+        displayName: Print Haxe version
+      - task: UsePythonVersion@0
+        inputs:
+          versionSpec: '3.7'
+      - powershell: |
+          Set-PSDebug -Trace 1
+          $pypath = python -c "import sys; print(sys.executable)"
+          $py3path = $pypath.replace("python.exe","python3.exe")
+          cmd /c mklink $py3path $pypath
+          python3 -V
+        displayName: "Make Python 3 be available as python3 in the cmdline"
+      - script: |
+          mkdir "$(HAXELIB_ROOT)"
+          haxelib setup "$(HAXELIB_ROOT)"
+        displayName: Setup haxelib
+      - script: haxe RunCi.hxml
+        workingDirectory: $(Build.SourcesDirectory)/tests
+        displayName: Test

extra/brew-flash-update.md

@@ -0,0 +1,16 @@
+# How to update flash player signatures in Brew
+
+It's easiest to use a mac to do the update since there is a developer script provided by homebrew-cask that can semi-automate the thing.
+
+Steps:
+1. clone https://github.com/Homebrew/homebrew-cask
+2. Run ./developer/bin/update_cask_family flash $NEW_VERSION_STRING
+
+If homebrew-cask's CI succeed, the PR will be automatically merged by a bot, and our CI is saved.
+
+The super annoying thing is that, homebrew-cask's CI will check Adobe's appcast for the version string, but the appcast is usually outdated until about a day after the new Flash Player release.
+
+See https://github.com/Homebrew/homebrew-cask/pull/73950#issuecomment-563920561
+
+----
+Example PR: https://github.com/Homebrew/homebrew-cask/pull/73952

extra/build-haxesetup.xml

@@ -1,16 +0,0 @@
-<xml>
-
-<include name="${HXCPP}/build-tool/BuildCommon.xml"/>
-<set name="static_link" value="1" />
-<set name="no_console" value="1" />
-
-<files id="haxesetup">
-  <file name="setup.cpp" />
-</files>
-
-<target id="default" output="haxesetup" tool="linker" toolid="exe">
-  <lib name="advapi32.lib" />
-  <files id="haxesetup" />
-</target>
-
-</xml>

extra/doc.hxml

@@ -1,6 +1,6 @@
 --no-output
 --macro ImportAll.run()
--dce no
+--dce no
 -D doc-gen
 
 --each
@@ -17,7 +17,7 @@
 
 -swf all9.swf
 -xml doc/flash.xml
--swf-version 11.4
+--swf-version 11.4
 
 --next
 
@@ -28,24 +28,20 @@
 
 -cpp all_cpp
 -xml doc/cpp.xml
--D xmldoc
 -D HXCPP_MULTI_THREADED
 
 --next
 -java all_java
 -xml doc/java.xml
--D xmldoc
 
 --next
 -cs all_cs
 -D unsafe
 -xml doc/cs.xml
--D xmldoc
 
 --next
 -python all_py
 -xml doc/python.xml
--D xmldoc
 
 --next
 --interp

extra/extract.hxml

@@ -4,9 +4,9 @@
 # - Run haxe extract.hxml
 # - Restore removed haxe/std/flash/DIR directories
 # - Copy directories from hxclasses/flash to haxe/std/flash, overwriting restored ones
--debug
--swf-lib library.swf
+--debug
+--swf-lib library.swf
 -swf test.swf
--swf-version 15
+--swf-version 15
 --macro patchTypes("../extra/extract.patch")
---gen-hx-classes
+-D gen-hx-classes

extra/haxelib_src

@@ -1 +1 @@
-Subproject commit 93f6a205bdf4012a2615957b766e7a34efe9f0b6
+Subproject commit 4b27f91d8a4ff279d9903091680fee2c93a0d574

extra/installer.nsi

@@ -11,6 +11,7 @@
 !include "WordFunc.nsh"
 !include "winmessages.nsh"
 !include "EnvVarUpdate.nsh"
+!include "FileAssociation.nsh"
 
 ;--------------------------------
 
@@ -20,12 +21,12 @@
 !define VERLONG "%%VERLONG%%"
 
 ; Define Neko info
-!define NEKO_VERSION "2.1.0"
+!define NEKO_VERSION "2.3.0"
 
 ; Installer details
 VIAddVersionKey "CompanyName" "Haxe Foundation"
 VIAddVersionKey "ProductName" "Haxe Installer"
-VIAddVersionKey "LegalCopyright" "Haxe Foundation 2005-2017"
+VIAddVersionKey "LegalCopyright" "Haxe Foundation 2005-2019"
 VIAddVersionKey "FileDescription" "Haxe Installer"
 VIAddVersionKey "ProductVersion" "${VERSION}.0"
 VIAddVersionKey "FileVersion" "${VERSION}.0"
@@ -127,7 +128,7 @@ Section "Haxe ${VERSION}" Main
 
 	File /r /x .svn /x *.db /x Exceptions.log /x .local /x .multi /x *.pdb /x *.vshost.exe /x *.vshost.exe.config /x *.vshost.exe.manifest "resources\haxe\*.*"
 
-	ExecWait "$INSTDIR\haxe\haxesetup.exe -silent"
+	${registerExtension} "$INSTDIR\haxe\haxe.exe --prompt" ".hxml" "Haxe compiler arguments list"
 
 	WriteUninstaller "$INSTDIR\Uninstall.exe"
 
@@ -144,6 +145,12 @@ Section "Neko ${NEKO_VERSION}" Neko
 
 SectionEnd
 
+Section "-Update PATH"
+
+	ExecWait '"$INSTDIR\haxe\haxe.exe" --cwd "$INSTDIR\haxe" -x WinSetup.hx'
+	SendMessage ${HWND_BROADCAST} ${WM_SETTINGCHANGE} 0 "STR:Environment" /TIMEOUT=5000
+
+SectionEnd
 
 
 
@@ -163,6 +170,7 @@ SectionEnd
 Section "un.Haxe" UninstMain
 
 	RMDir /r "$INSTDIR\haxe"
+	${unregisterExtension} ".hxml" "Haxe compiler arguments list"
 	${un.EnvVarUpdate} $0 "PATH" "R" "HKLM" "%HAXEPATH%"
 	DeleteRegValue ${env_hklm} HAXEPATH
 	SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=5000

extra/release-checklist.txt

@@ -3,19 +3,23 @@
 - 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 osx & windows installers has the latest neko release in "Makefile" and "Makefile.win" files
 
 # Making the release
 
 - Make sure CHANGES.txt has a proper date set!
 - Make sure `version` in globals.ml has the correct value
-- Wait for the CI to build (check https://builds.haxe.org)
-- Make an empty GitHub release in https://github.com/HaxeFoundation/haxe/releases
+- Check if the protocolVersion in displayJson.ml has to be updated
+- Make an empty GitHub release in https://github.com/HaxeFoundation/haxe/releases (do this first because we need the tag for the builds)
+- Wait for the CI to build (check https://build.haxe.org/builds/haxe/)
 - Get https://github.com/simn/hxgithub
-- Run it with something like this: `neko release.n -t personal_access_token -h 4.0.0-preview.2 -u -uw -ur -doc --dry`
+- Store your GitHub personal access token in .github-token
+- Run something like this: `neko release.n -h 4.0.0-rc.1 -u -uw -ur -d haxe_2019-02-01_development_1fdd3d5.zip --dry`
+- Tell yourself that you're gonna fix `-doc` generation next time
 - Write the announcement to `./haxe-version/RELEASE.md`
-- If everything was working, run the command again without `--dry`
+- If everything was working, run the command again without `--dry` (and probably without the `-d`)
 - Update https://github.com/HaxeFoundation/haxe.org/blob/staging/downloads/versions.json
 
 # Announcing the release
 
-- Post announcement post to haxelang
+- Find someone to announce the release on our various communication channels

extra/setup.cpp

@@ -1,71 +0,0 @@
-/*
-	Haxe Setup
-	Copyright (C) 2005-2016  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 is a small program that do basic Haxe setup on Windows
-#include <windows.h>
-
-static void Set( HKEY k, const char *name, DWORD t, const char *data ) {
-	RegSetValueEx(k,name,0,t,(const BYTE*)data,(DWORD)strlen(data)+1);
-}
-
-int WINAPI WinMain( HINSTANCE inst, HINSTANCE prev, LPSTR lpCmdLine, int nCmdShow ) {
-	char path[MAX_PATH];
-	*path = '"';
-	GetModuleFileName(NULL,path+1,MAX_PATH);
-
-	// register .hxml extension
-	char *s = strrchr(path,'\\') + 1;
-	strcpy(s,"haxe.exe\" -prompt \"%1\"");
-	HKEY k;
-	RegCreateKey(HKEY_CLASSES_ROOT,".hxml\\shell\\Compile\\command",&k);
-	RegSetValueEx(k,NULL,0,REG_SZ,(const BYTE*)path,(DWORD)(strlen(path)+1));
-	*s = 0;
-
-	// add %HAXEPATH% to PATH and set HAXEPATH to current path
-	DWORD ktype;
-	DWORD ksize = 16000;
-	char *kdata = new char[16000];
-	memset(kdata,0,ksize);
-	RegOpenKey(HKEY_LOCAL_MACHINE,"SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment",&k);	
-	RegQueryValueEx(k,"PATH",NULL,&ktype,(LPBYTE)kdata,&ksize);
-	if( strstr(kdata,"%HAXEPATH%") == NULL ) {
-		char *s = kdata + strlen(kdata);
-		strcpy(s,";%HAXEPATH%");
-		Set(k,"PATH",REG_EXPAND_SZ,kdata);		
-	}
-	if( strstr(kdata,"%NEKO_INSTPATH%") == NULL ) {
-		char *s = kdata + strlen(kdata);
-		strcpy(s,";%NEKO_INSTPATH%");
-		Set(k,"PATH",REG_EXPAND_SZ,kdata);
-	}
-	Set(k,"HAXEPATH",REG_SZ,path + 1);	
-	s[-1] = 0;
-	strcpy(strrchr(path,'\\'),"\\neko");
-	Set(k,"NEKO_INSTPATH",REG_SZ,path+1);
-	RegCloseKey(k);
-
-	// inform running apps of env changes (W2K/NT systems only ?)
-	DWORD unused;
-	SendMessageTimeout(HWND_BROADCAST,WM_SETTINGCHANGE, 0, (LPARAM)"Environment", SMTO_ABORTIFHUNG, 5000, &unused );
-
-	// delete kdata;
-	// // register 
-	// if( strcmp(lpCmdLine,"-silent") != 0 )
-	// 	MessageBox(NULL,"Setup completed, you can start using Haxe now","haxesetup",MB_OK | MB_ICONINFORMATION);
-	return 0;
-}

extra/setup.sln

@@ -1,21 +0,0 @@
-Microsoft Visual Studio Solution File, Format Version 8.00
-Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "setup", "setup.vcproj", "{6E869222-35FF-4BC0-B5AA-E63BCB8803A6}"
-	ProjectSection(ProjectDependencies) = postProject
-	EndProjectSection
-EndProject
-Global
-	GlobalSection(SolutionConfiguration) = preSolution
-		Debug = Debug
-		Release = Release
-	EndGlobalSection
-	GlobalSection(ProjectConfiguration) = postSolution
-		{6E869222-35FF-4BC0-B5AA-E63BCB8803A6}.Debug.ActiveCfg = Debug|Win32
-		{6E869222-35FF-4BC0-B5AA-E63BCB8803A6}.Debug.Build.0 = Debug|Win32
-		{6E869222-35FF-4BC0-B5AA-E63BCB8803A6}.Release.ActiveCfg = Release|Win32
-		{6E869222-35FF-4BC0-B5AA-E63BCB8803A6}.Release.Build.0 = Release|Win32
-	EndGlobalSection
-	GlobalSection(ExtensibilityGlobals) = postSolution
-	EndGlobalSection
-	GlobalSection(ExtensibilityAddIns) = postSolution
-	EndGlobalSection
-EndGlobal

extra/setup.vcproj

@@ -1,120 +0,0 @@
-<?xml version="1.0" encoding="Windows-1252"?>
-<VisualStudioProject
-	ProjectType="Visual C++"
-	Version="7.10"
-	Name="setup"
-	ProjectGUID="{6E869222-35FF-4BC0-B5AA-E63BCB8803A6}"
-	Keyword="Win32Proj">
-	<Platforms>
-		<Platform
-			Name="Win32"/>
-	</Platforms>
-	<Configurations>
-		<Configuration
-			Name="Debug|Win32"
-			OutputDirectory="Debug"
-			IntermediateDirectory="Debug"
-			ConfigurationType="1"
-			CharacterSet="2">
-			<Tool
-				Name="VCCLCompilerTool"
-				Optimization="0"
-				PreprocessorDefinitions="WIN32;_DEBUG;_WINDOWS"
-				MinimalRebuild="TRUE"
-				BasicRuntimeChecks="3"
-				RuntimeLibrary="5"
-				UsePrecompiledHeader="0"
-				WarningLevel="3"
-				Detect64BitPortabilityProblems="TRUE"
-				DebugInformationFormat="4"/>
-			<Tool
-				Name="VCCustomBuildTool"/>
-			<Tool
-				Name="VCLinkerTool"
-				OutputFile="$(OutDir)/haxesetup.exe"
-				LinkIncremental="2"
-				GenerateDebugInformation="TRUE"
-				ProgramDatabaseFile="$(OutDir)/setup.pdb"
-				SubSystem="2"
-				TargetMachine="1"/>
-			<Tool
-				Name="VCMIDLTool"/>
-			<Tool
-				Name="VCPostBuildEventTool"/>
-			<Tool
-				Name="VCPreBuildEventTool"/>
-			<Tool
-				Name="VCPreLinkEventTool"/>
-			<Tool
-				Name="VCResourceCompilerTool"/>
-			<Tool
-				Name="VCWebServiceProxyGeneratorTool"/>
-			<Tool
-				Name="VCXMLDataGeneratorTool"/>
-			<Tool
-				Name="VCWebDeploymentTool"/>
-			<Tool
-				Name="VCManagedWrapperGeneratorTool"/>
-			<Tool
-				Name="VCAuxiliaryManagedWrapperGeneratorTool"/>
-		</Configuration>
-		<Configuration
-			Name="Release|Win32"
-			OutputDirectory="Release"
-			IntermediateDirectory="Release"
-			ConfigurationType="1"
-			CharacterSet="2">
-			<Tool
-				Name="VCCLCompilerTool"
-				PreprocessorDefinitions="WIN32;NDEBUG;_WINDOWS"
-				RuntimeLibrary="2"
-				BufferSecurityCheck="FALSE"
-				UsePrecompiledHeader="0"
-				WarningLevel="3"
-				Detect64BitPortabilityProblems="TRUE"
-				DebugInformationFormat="3"/>
-			<Tool
-				Name="VCCustomBuildTool"/>
-			<Tool
-				Name="VCLinkerTool"
-				AdditionalDependencies="msvcrt60.lib"
-				OutputFile="$(OutDir)/haxesetup.exe"
-				LinkIncremental="1"
-				IgnoreDefaultLibraryNames="MSVCRT"
-				GenerateDebugInformation="TRUE"
-				SubSystem="2"
-				OptimizeReferences="2"
-				EnableCOMDATFolding="2"
-				TargetMachine="1"/>
-			<Tool
-				Name="VCMIDLTool"/>
-			<Tool
-				Name="VCPostBuildEventTool"/>
-			<Tool
-				Name="VCPreBuildEventTool"/>
-			<Tool
-				Name="VCPreLinkEventTool"/>
-			<Tool
-				Name="VCResourceCompilerTool"/>
-			<Tool
-				Name="VCWebServiceProxyGeneratorTool"/>
-			<Tool
-				Name="VCXMLDataGeneratorTool"/>
-			<Tool
-				Name="VCWebDeploymentTool"/>
-			<Tool
-				Name="VCManagedWrapperGeneratorTool"/>
-			<Tool
-				Name="VCAuxiliaryManagedWrapperGeneratorTool"/>
-		</Configuration>
-	</Configurations>
-	<References>
-	</References>
-	<Files>
-		<File
-			RelativePath=".\setup.cpp">
-		</File>
-	</Files>
-	<Globals>
-	</Globals>
-</VisualStudioProject>

haxe.hxproj

@@ -1,436 +0,0 @@
-<?xml version="1.0" encoding="utf-8"?>
-<project version="2">
-  <!-- Output SWF options -->
-  <output>
-    <movie outputType="CustomBuild" />
-    <movie input="" />
-    <movie path="" />
-    <movie fps="30" />
-    <movie width="800" />
-    <movie height="600" />
-    <movie version="10" />
-    <movie minorVersion="3" />
-    <movie platform="Flash Player" />
-    <movie background="#FFFFFF" />
-  </output>
-  <!-- Other classes to be compiled into your SWF -->
-  <classpaths>
-    <class path="std" />
-  </classpaths>
-  <!-- Build options -->
-  <build>
-    <option directives="" />
-    <option flashStrict="False" />
-    <option noInlineOnDebug="False" />
-    <option mainClass="" />
-    <option enabledebug="False" />
-    <option additional="" />
-  </build>
-  <!-- haxelib libraries -->
-  <haxelib>
-    <!-- example: <library name="..." /> -->
-  </haxelib>
-  <!-- Class files to compile (other referenced classes will automatically be included) -->
-  <compileTargets>
-    <!-- example: <compile path="..." /> -->
-  </compileTargets>
-  <!-- Assets to embed into the output SWF -->
-  <library>
-    <!-- example: <asset path="..." id="..." update="..." glyphs="..." mode="..." place="..." sharepoint="..." /> -->
-  </library>
-  <!-- Paths to exclude from the Project Explorer tree -->
-  <hiddenPaths>
-    <hidden path="ast.cmi" />
-    <hidden path="ast.cmx" />
-    <hidden path="typer.cmi" />
-    <hidden path="haxe.vcxproj.user" />
-    <hidden path="haxesetup.exe" />
-    <hidden path="interp.cmi" />
-    <hidden path="interp.cmx" />
-    <hidden path="interp.obj" />
-    <hidden path="lexer.cmi" />
-    <hidden path="lexer.cmx" />
-    <hidden path="lexer.ml" />
-    <hidden path="lexer.obj" />
-    <hidden path="main.cmi" />
-    <hidden path="main.cmx" />
-    <hidden path="main.obj" />
-    <hidden path="optimizer.cmi" />
-    <hidden path="optimizer.cmx" />
-    <hidden path="optimizer.obj" />
-    <hidden path="parser.cmi" />
-    <hidden path="parser.cmx" />
-    <hidden path="parser.obj" />
-    <hidden path="tmp.cmi" />
-    <hidden path="type.cmi" />
-    <hidden path="type.cmx" />
-    <hidden path="type.obj" />
-    <hidden path="typecore.cmi" />
-    <hidden path="typecore.cmx" />
-    <hidden path="typecore.obj" />
-    <hidden path="typeload.cmi" />
-    <hidden path="typeload.cmx" />
-    <hidden path="typeload.obj" />
-    <hidden path="haxe.vcproj" />
-    <hidden path="typer.obj" />
-    <hidden path="gencpp.cmi" />
-    <hidden path="gencpp.cmx" />
-    <hidden path="gencpp.obj" />
-    <hidden path="gencs.cmi" />
-    <hidden path="gencs.cmx" />
-    <hidden path="gencs.obj" />
-    <hidden path="genjava.cmi" />
-    <hidden path="genjava.cmx" />
-    <hidden path="genjava.obj" />
-    <hidden path="genjs.cmi" />
-    <hidden path="genjs.cmx" />
-    <hidden path="genjs.obj" />
-    <hidden path="genneko.cmi" />
-    <hidden path="genneko.cmx" />
-    <hidden path="genneko.obj" />
-    <hidden path="genphp.cmi" />
-    <hidden path="genphp.cmx" />
-    <hidden path="genphp.obj" />
-    <hidden path="genswf.cmi" />
-    <hidden path="genswf.cmx" />
-    <hidden path="genswf.obj" />
-    <hidden path="genswf8.cmi" />
-    <hidden path="genswf8.cmx" />
-    <hidden path="genswf8.obj" />
-    <hidden path="genswf9.cmi" />
-    <hidden path="genswf9.cmx" />
-    <hidden path="genswf9.obj" />
-    <hidden path="genxml.cmi" />
-    <hidden path="genxml.cmx" />
-    <hidden path="genxml.obj" />
-    <hidden path="haxe.exe" />
-    <hidden path="haxe.sdf" />
-    <hidden path="haxe.sln" />
-    <hidden path="haxe.suo" />
-    <hidden path="typer.cmx" />
-    <hidden path="gencommon.obj" />
-    <hidden path="codegen.cmi" />
-    <hidden path="codegen.cmx" />
-    <hidden path="codegen.obj" />
-    <hidden path="common.cmi" />
-    <hidden path="common.cmx" />
-    <hidden path="common.obj" />
-    <hidden path="dce.cmi" />
-    <hidden path="dce.cmx" />
-    <hidden path="dce.obj" />
-    <hidden path="genas3.cmi" />
-    <hidden path="genas3.cmx" />
-    <hidden path="genas3.obj" />
-    <hidden path="gencommon.cmi" />
-    <hidden path="gencommon.cmx" />
-    <hidden path="ast.obj" />
-    <hidden path="haxelib.exe" />
-    <hidden path="haxe.hxml" />
-    <hidden path="matcher.obj" />
-    <hidden path="matcher.cmx" />
-    <hidden path="matcher.cmi" />
-    <hidden path="version.obj" />
-    <hidden path="version.cmi" />
-    <hidden path="version.cmx" />
-    <hidden path="haxe.exe.manifest" />
-    <hidden path="obj" />
-    <hidden path="filters.obj" />
-    <hidden path="filters.cmi" />
-    <hidden path="filters.cmx" />
-    <hidden path="genpy.obj" />
-    <hidden path="genpy.cmi" />
-    <hidden path="genpy.cmx" />
-    <hidden path="analyzer.cmi" />
-    <hidden path="analyzer.cmx" />
-    <hidden path="analyzer.obj" />
-    <hidden path="CONTRIBUTING.md" />
-    <hidden path="README.md" />
-    <hidden path="Makefile" />
-    <hidden path="Makefile.win" />
-    <hidden path="appveyor.yml" />
-    <hidden path="version.ml" />
-    <hidden path="lib" />
-    <hidden path="Makefile.version_extra" />
-    <hidden path="genheaps.cmx" />
-    <hidden path="genheaps.obj" />
-    <hidden path="genheaps.cmi" />
-    <hidden path="genhl.cmx" />
-    <hidden path="genhl.obj" />
-    <hidden path="genhl.cmi" />
-    <hidden path="src\version.obj" />
-    <hidden path="src\version.cmi" />
-    <hidden path="src\version.cmx" />
-    <hidden path="src\main.obj" />
-    <hidden path="src\main.cmx" />
-    <hidden path="src\main.cmi" />
-    <hidden path="src\typing\typer.obj" />
-    <hidden path="src\typing\typer.cmx" />
-    <hidden path="src\typing\typer.cmi" />
-    <hidden path="src\typing\typeload.obj" />
-    <hidden path="src\typing\typeload.cmx" />
-    <hidden path="src\typing\typeload.cmi" />
-    <hidden path="src\typing\typecore.obj" />
-    <hidden path="src\typing\typecore.cmx" />
-    <hidden path="src\typing\typecore.cmi" />
-    <hidden path="src\typing\type.obj" />
-    <hidden path="src\typing\type.cmx" />
-    <hidden path="src\typing\type.cmi" />
-    <hidden path="src\typing\matcher.obj" />
-    <hidden path="src\typing\matcher.cmx" />
-    <hidden path="src\typing\matcher.cmi" />
-    <hidden path="src\typing\common.obj" />
-    <hidden path="src\typing\common.cmx" />
-    <hidden path="src\typing\common.cmi" />
-    <hidden path="src\syntax\parser.obj" />
-    <hidden path="src\syntax\parser.cmx" />
-    <hidden path="src\syntax\parser.cmi" />
-    <hidden path="src\syntax\lexer.obj" />
-    <hidden path="src\syntax\lexer.ml" />
-    <hidden path="src\syntax\lexer.cmx" />
-    <hidden path="src\syntax\lexer.cmi" />
-    <hidden path="src\syntax\ast.obj" />
-    <hidden path="src\syntax\ast.cmx" />
-    <hidden path="src\syntax\ast.cmi" />
-    <hidden path="src\optimization\optimizer.obj" />
-    <hidden path="src\optimization\optimizer.cmx" />
-    <hidden path="src\optimization\optimizer.cmi" />
-    <hidden path="src\optimization\filters.obj" />
-    <hidden path="src\optimization\filters.cmx" />
-    <hidden path="src\optimization\filters.cmi" />
-    <hidden path="src\optimization\dce.obj" />
-    <hidden path="src\optimization\dce.cmi" />
-    <hidden path="src\optimization\analyzer.obj" />
-    <hidden path="src\optimization\dce.cmx" />
-    <hidden path="src\optimization\analyzer.cmx" />
-    <hidden path="src\optimization\analyzer.cmi" />
-    <hidden path="src\macro\interp.obj" />
-    <hidden path="src\macro\interp.cmx" />
-    <hidden path="src\macro\interp.cmi" />
-    <hidden path="src\generators\genxml.obj" />
-    <hidden path="src\generators\genxml.cmx" />
-    <hidden path="src\generators\genxml.cmi" />
-    <hidden path="src\generators\genswf9.obj" />
-    <hidden path="src\generators\genswf9.cmi" />
-    <hidden path="src\generators\genswf9.cmx" />
-    <hidden path="src\generators\genswf.obj" />
-    <hidden path="src\generators\genswf.cmx" />
-    <hidden path="src\generators\genswf.cmi" />
-    <hidden path="src\generators\genpy.obj" />
-    <hidden path="src\generators\genpy.cmx" />
-    <hidden path="src\generators\genpy.cmi" />
-    <hidden path="src\generators\genphp.obj" />
-    <hidden path="src\generators\genphp.cmx" />
-    <hidden path="src\generators\genneko.obj" />
-    <hidden path="src\generators\genphp.cmi" />
-    <hidden path="src\generators\genneko.cmx" />
-    <hidden path="src\generators\genneko.cmi" />
-    <hidden path="src\generators\genjs.obj" />
-    <hidden path="src\generators\genjs.cmx" />
-    <hidden path="src\generators\genjs.cmi" />
-    <hidden path="src\generators\genjava.obj" />
-    <hidden path="src\generators\genjava.cmx" />
-    <hidden path="src\generators\genjava.cmi" />
-    <hidden path="src\generators\genhl.obj" />
-    <hidden path="src\generators\genhl.cmx" />
-    <hidden path="src\generators\genhl.cmi" />
-    <hidden path="src\generators\gencs.obj" />
-    <hidden path="src\generators\gencs.cmx" />
-    <hidden path="src\generators\gencs.cmi" />
-    <hidden path="src\generators\gencpp.obj" />
-    <hidden path="src\generators\gencpp.cmx" />
-    <hidden path="src\generators\gencpp.cmi" />
-    <hidden path="src\generators\gencommon.obj" />
-    <hidden path="src\generators\gencommon.cmx" />
-    <hidden path="src\generators\gencommon.cmi" />
-    <hidden path="src\generators\genas3.obj" />
-    <hidden path="src\generators\genas3.cmx" />
-    <hidden path="src\generators\genas3.cmi" />
-    <hidden path="src\generators\codegen.obj" />
-    <hidden path="src\generators\codegen.cmx" />
-    <hidden path="src\generators\codegen.cmi" />
-    <hidden path="src\optimization\analyzerConfig.cmi" />
-    <hidden path="src\optimization\analyzerConfig.cmx" />
-    <hidden path="src\optimization\analyzerConfig.obj" />
-    <hidden path="src\optimization\analyzerTexpr.cmi" />
-    <hidden path="src\optimization\analyzerTexpr.cmx" />
-    <hidden path="src\optimization\analyzerTexpr.obj" />
-    <hidden path="src\optimization\analyzerTexprTransformer.cmi" />
-    <hidden path="src\optimization\analyzerTexprTransformer.cmx" />
-    <hidden path="src\optimization\analyzerTexprTransformer.obj" />
-    <hidden path="src\optimization\analyzerTypes.cmi" />
-    <hidden path="src\optimization\analyzerTypes.cmx" />
-    <hidden path="src\optimization\analyzerTypes.obj" />
-    <hidden path="src\json.cmi" />
-    <hidden path="src\json.cmx" />
-    <hidden path="src\json.o" />
-    <hidden path="src\main.o" />
-    <hidden path="src\version.o" />
-    <hidden path="src\display\display.cmx" />
-    <hidden path="src\display\display.o" />
-    <hidden path="src\display\display.cmi" />
-    <hidden path="src\generators\codegen.o" />
-    <hidden path="src\generators\genas3.o" />
-    <hidden path="src\generators\gencommon.o" />
-    <hidden path="src\generators\gencpp.o" />
-    <hidden path="src\generators\gencs.o" />
-    <hidden path="src\generators\genhl.o" />
-    <hidden path="src\generators\genjava.o" />
-    <hidden path="src\generators\genjs.o" />
-    <hidden path="src\generators\genlua.cmi" />
-    <hidden path="src\generators\genlua.cmx" />
-    <hidden path="src\generators\genlua.o" />
-    <hidden path="src\generators\genneko.o" />
-    <hidden path="src\generators\genphp.o" />
-    <hidden path="src\generators\genpy.o" />
-    <hidden path="src\generators\genswf.o" />
-    <hidden path="src\generators\genswf9.o" />
-    <hidden path="src\generators\genxml.o" />
-    <hidden path="src\macro\interp.o" />
-    <hidden path="src\optimization\analyzer.o" />
-    <hidden path="src\optimization\analyzerConfig.o" />
-    <hidden path="src\optimization\analyzerTexpr.o" />
-    <hidden path="src\optimization\analyzerTexprTransformer.o" />
-    <hidden path="src\optimization\analyzerTypes.o" />
-    <hidden path="src\optimization\dce.o" />
-    <hidden path="src\optimization\filters.o" />
-    <hidden path="src\optimization\optimizer.o" />
-    <hidden path="src\syntax\ast.o" />
-    <hidden path="src\syntax\lexer.o" />
-    <hidden path="src\syntax\parser.o" />
-    <hidden path="src\typing\common.o" />
-    <hidden path="src\typing\matcher.o" />
-    <hidden path="src\typing\type.o" />
-    <hidden path="src\typing\typecore.o" />
-    <hidden path="src\typing\typeload.o" />
-    <hidden path="src\typing\typer.o" />
-    <hidden path=".travis" />
-    <hidden path="src\json.obj" />
-    <hidden path="src\display\display.obj" />
-    <hidden path="src\generators\genlua.obj" />
-    <hidden path="src\display\display.cmt" />
-    <hidden path="src\display\displayTypes.cmt" />
-    <hidden path="src\display\displayTypes.cmi" />
-    <hidden path="src\display\displayTypes.cmx" />
-    <hidden path="src\display\displayTypes.o" />
-    <hidden path="src\generators\codegen.cmt" />
-    <hidden path="src\generators\genas3.cmt" />
-    <hidden path="src\generators\gencommon.cmt" />
-    <hidden path="src\generators\gencpp.cmt" />
-    <hidden path="src\generators\gencs.cmt" />
-    <hidden path="src\generators\genhl.cmt" />
-    <hidden path="src\generators\genjava.cmt" />
-    <hidden path="src\generators\genjs.cmt" />
-    <hidden path="src\generators\genlua.cmt" />
-    <hidden path="src\generators\genneko.cmt" />
-    <hidden path="src\generators\genphp.cmt" />
-    <hidden path="src\generators\genpy.cmt" />
-    <hidden path="src\generators\genswf.cmt" />
-    <hidden path="src\generators\genswf9.cmt" />
-    <hidden path="src\generators\genxml.cmt" />
-    <hidden path="src\macro\interp.cmt" />
-    <hidden path="src\optimization\analyzer.cmt" />
-    <hidden path="src\optimization\analyzerConfig.cmt" />
-    <hidden path="src\optimization\analyzerTexpr.cmt" />
-    <hidden path="src\optimization\analyzerTexprTransformer.cmt" />
-    <hidden path="src\optimization\analyzerTypes.cmt" />
-    <hidden path="src\optimization\dce.cmt" />
-    <hidden path="src\optimization\filters.cmt" />
-    <hidden path="src\optimization\optimizer.cmt" />
-    <hidden path="src\syntax\ast.cmt" />
-    <hidden path="src\syntax\lexer.cmt" />
-    <hidden path="src\syntax\parser.cmt" />
-    <hidden path="src\typing\common.cmt" />
-    <hidden path="src\typing\matcher.cmt" />
-    <hidden path="src\typing\type.cmt" />
-    <hidden path="src\typing\typecore.cmt" />
-    <hidden path="src\typing\typeload.cmt" />
-    <hidden path="src\typing\typer.cmt" />
-    <hidden path="src\globals.cmi" />
-    <hidden path="src\globals.cmt" />
-    <hidden path="src\globals.cmx" />
-    <hidden path="src\globals.o" />
-    <hidden path="src\main.cmt" />
-    <hidden path="src\path.cmi" />
-    <hidden path="src\path.cmt" />
-    <hidden path="src\path.cmx" />
-    <hidden path="src\path.o" />
-    <hidden path="src\server.cmi" />
-    <hidden path="src\server.cmt" />
-    <hidden path="src\server.cmx" />
-    <hidden path="src\server.o" />
-    <hidden path="src\typing\overloads.cmi" />
-    <hidden path="src\typing\overloads.cmt" />
-    <hidden path="src\typing\overloads.cmx" />
-    <hidden path="src\typing\overloads.o" />
-    <hidden path="src\display\displayOutput.cmi" />
-    <hidden path="src\display\displayOutput.cmt" />
-    <hidden path="src\display\displayOutput.cmx" />
-    <hidden path="src\display\displayOutput.o" />
-    <hidden path="src\generators\hlcode.cmt" />
-    <hidden path="src\generators\hlinterp.cmt" />
-    <hidden path="src\generators\hlcode.o" />
-    <hidden path="src\generators\hlcode.cmi" />
-    <hidden path="src\generators\hlcode.cmx" />
-    <hidden path="src\typing\error.cmi" />
-    <hidden path="src\typing\error.cmt" />
-    <hidden path="src\typing\error.cmx" />
-    <hidden path="src\typing\error.o" />
-    <hidden path="src\generators\hl2c.cmt" />
-    <hidden path="src\generators\hlinterp.cmi" />
-    <hidden path="src\generators\hlinterp.cmx" />
-    <hidden path="src\generators\hlinterp.o" />
-    <hidden path="src\generators\hl2c.cmi" />
-    <hidden path="src\generators\hl2c.cmx" />
-    <hidden path="src\generators\hl2c.o" />
-    <hidden path="src\optimization\optimizerTexpr.cmi" />
-    <hidden path="src\optimization\optimizerTexpr.cmt" />
-    <hidden path="src\optimization\optimizerTexpr.cmx" />
-    <hidden path="src\optimization\optimizerTexpr.o" />
-    <hidden path="src\generators\hlopt.cmi" />
-    <hidden path="src\generators\hlopt.cmt" />
-    <hidden path="src\generators\hlopt.cmx" />
-    <hidden path="src\generators\hlopt.o" />
-    <hidden path="src\json.cmt" />
-    <hidden path="src\version.cmt" />
-    <hidden path="src\context\common.cmi" />
-    <hidden path="src\context\common.cmt" />
-    <hidden path="src\context\common.cmx" />
-    <hidden path="src\context\common.o" />
-    <hidden path="src\context\meta.cmi" />
-    <hidden path="src\context\meta.cmt" />
-    <hidden path="src\context\meta.cmx" />
-    <hidden path="src\context\meta.o" />
-    <hidden path="src\typing\abstract.cmi" />
-    <hidden path="src\typing\abstract.cmt" />
-    <hidden path="src\typing\abstract.cmx" />
-    <hidden path="src\typing\abstract.o" />
-    <hidden path="src\macro\macroContext.cmt" />
-    <hidden path="src\macro\macroContext.cmi" />
-    <hidden path="src\macro\macroContext.cmx" />
-    <hidden path="src\macro\macroContext.o" />
-    <hidden path="src\macro\hlmacro.cmi" />
-    <hidden path="src\macro\hlmacro.cmt" />
-    <hidden path="src\macro\hlmacro.cmx" />
-    <hidden path="src\macro\hlmacro.o" />
-    <hidden path="src\macro\macroApi.cmi" />
-    <hidden path="src\macro\macroApi.cmt" />
-    <hidden path="src\macro\macroApi.cmx" />
-    <hidden path="src\macro\macroApi.o" />
-    <hidden path="src\generators\genphp7.cmi" />
-    <hidden path="src\generators\genphp7.cmt" />
-    <hidden path="src\generators\genphp7.cmx" />
-    <hidden path="src\generators\genphp7.o" />
-  </hiddenPaths>
-  <!-- Executed before build -->
-  <preBuildCommand>make -j4 FD_OUTPUT=1 -f Makefile.win kill haxe</preBuildCommand>
-  <!-- Executed after build -->
-  <postBuildCommand alwaysRun="False" />
-  <!-- Other project options -->
-  <options>
-    <option showHiddenPaths="False" />
-    <option testMovie="Custom" />
-    <option testMovieCommand="" />
-  </options>
-  <!-- Plugin storage -->
-  <storage />
-</project>

libs

@@ -1 +0,0 @@
-Subproject commit c368bdc1c7b7dc4fb85613ffcc08578e23f40a6a

libs/.gitignore

@@ -0,0 +1,18 @@
+*.obj
+*.o
+*.cmx
+*.cmi
+*.cmxa
+*.a
+*.exe
+.*.swp
+*.lib
+
+/xml-light/doc
+/xml-light/xml_lexer.ml
+/xml-light/xml_parser.ml
+/xml-light/xml_parser.mli
+
+/ilib/dump
+*.cmo
+*.cma

libs/Makefile

@@ -0,0 +1,24 @@
+OCAMLOPT = ocamlopt
+OCAMLC = ocamlc
+TARGET_FLAG = all
+LIBS=extlib-leftovers extc neko javalib ilib swflib ttflib objsize pcre ziplib
+
+all: $(LIBS)
+$(LIBS):
+	$(MAKE) -C $@ OCAMLOPT=$(OCAMLOPT) OCAMLC=$(OCAMLC) $(TARGET_FLAG)
+
+clean:
+	$(MAKE) -C extlib-leftovers clean
+	$(MAKE) -C extc clean
+	$(MAKE) -C neko clean
+	$(MAKE) -C javalib clean
+	$(MAKE) -C ilib clean
+	$(MAKE) -C swflib clean
+	$(MAKE) -C ttflib clean
+	$(MAKE) -C objsize clean
+	$(MAKE) -C pcre clean
+	$(MAKE) -C ziplib clean
+
+.PHONY: all clean $(LIBS)
+
+Makefile: ;

libs/README.md

@@ -0,0 +1,5 @@
+# ocamllibs
+
+[![TravisCI Build Status](https://travis-ci.org/HaxeFoundation/ocamllibs.svg?branch=master)](https://travis-ci.org/HaxeFoundation/ocamllibs)
+
+Various OCaml libraries.

libs/extc/LICENSE

@@ -0,0 +1,339 @@
+                    GNU GENERAL PUBLIC LICENSE
+                       Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.,
+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+                            Preamble
+
+  The licenses for most software are designed to take away your
+freedom to share and change it.  By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users.  This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it.  (Some other Free Software Foundation software is covered by
+the GNU Lesser General Public License instead.)  You can apply it to
+your programs, too.
+
+  When we speak of free software, we are referring to freedom, not
+price.  Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+  To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+  For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have.  You must make sure that they, too, receive or can get the
+source code.  And you must show them these terms so they know their
+rights.
+
+  We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+  Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software.  If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+  Finally, any free program is threatened constantly by software
+patents.  We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary.  To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.
+
+                    GNU GENERAL PUBLIC LICENSE
+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+  0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License.  The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language.  (Hereinafter, translation is included without limitation in
+the term "modification".)  Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope.  The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+  1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+  2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+    a) You must cause the modified files to carry prominent notices
+    stating that you changed the files and the date of any change.
+
+    b) You must cause any work that you distribute or publish, that in
+    whole or in part contains or is derived from the Program or any
+    part thereof, to be licensed as a whole at no charge to all third
+    parties under the terms of this License.
+
+    c) If the modified program normally reads commands interactively
+    when run, you must cause it, when started running for such
+    interactive use in the most ordinary way, to print or display an
+    announcement including an appropriate copyright notice and a
+    notice that there is no warranty (or else, saying that you provide
+    a warranty) and that users may redistribute the program under
+    these conditions, and telling the user how to view a copy of this
+    License.  (Exception: if the Program itself is interactive but
+    does not normally print such an announcement, your work based on
+    the Program is not required to print an announcement.)
+
+These requirements apply to the modified work as a whole.  If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works.  But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+  3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+    a) Accompany it with the complete corresponding machine-readable
+    source code, which must be distributed under the terms of Sections
+    1 and 2 above on a medium customarily used for software interchange; or,
+
+    b) Accompany it with a written offer, valid for at least three
+    years, to give any third party, for a charge no more than your
+    cost of physically performing source distribution, a complete
+    machine-readable copy of the corresponding source code, to be
+    distributed under the terms of Sections 1 and 2 above on a medium
+    customarily used for software interchange; or,
+
+    c) Accompany it with the information you received as to the offer
+    to distribute corresponding source code.  (This alternative is
+    allowed only for noncommercial distribution and only if you
+    received the program in object code or executable form with such
+    an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it.  For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable.  However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+  4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License.  Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+  5. You are not required to accept this License, since you have not
+signed it.  However, nothing else grants you permission to modify or
+distribute the Program or its derivative works.  These actions are
+prohibited by law if you do not accept this License.  Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+  6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions.  You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+  7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all.  For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices.  Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+  8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded.  In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+  9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time.  Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number.  If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation.  If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+  10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission.  For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this.  Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+                            NO WARRANTY
+
+  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+                     END OF TERMS AND CONDITIONS
+
+            How to Apply These Terms to Your New Programs
+
+  If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+  To do so, attach the following notices to the program.  It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+    <one line to give the program's name and a brief idea of what it does.>
+    Copyright (C) <year>  <name of author>
+
+    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.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+    Gnomovision version 69, Copyright (C) year name of author
+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+    This is free software, and you are welcome to redistribute it
+    under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License.  Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary.  Here is a sample; alter the names:
+
+  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+  `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+  <signature of Ty Coon>, 1 April 1989
+  Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs.  If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library.  If this is what you want to do, use the GNU Lesser General
+Public License instead of this License.

libs/extc/Makefile

@@ -0,0 +1,30 @@
+ALL_CFLAGS = $(CFLAGS)
+OCAMLOPT=ocamlopt
+OCAMLC=ocamlc
+SRC = extc.ml process.ml extc_stubs.c process_stubs.c
+
+all: bytecode native
+
+bytecode: extc.cma
+
+native: extc.cmxa
+
+extc.cma: extc_stubs.o process_stubs.o extc.ml process.ml
+	ocamlfind $(OCAMLC) -safe-string -a -o extc.cma -package extlib extc.ml process.ml
+
+extc.cmxa: extc.ml process.ml extc_stubs.o process_stubs.o
+	ocamlfind $(OCAMLOPT) -safe-string -a -o extc.cmxa -package extlib extc.ml process.ml
+
+extc_stubs.o: extc_stubs.c
+	ocamlfind $(OCAMLC) -safe-string $(ALL_CFLAGS) extc_stubs.c
+
+process_stubs.o: process_stubs.c
+	ocamlfind $(OCAMLC) -safe-string $(ALL_CFLAGS) process_stubs.c
+
+clean:
+	rm -f extc.cma extc.cmi extc.cmx extc.cmxa extc.o extc.obj extc.lib extc_stubs.obj extc_stubs.o process.cmx process.obj process.cmi process.o process_stubs.obj process_stubs.o
+	rm -f extc.a libextc.a libextc.lib extc.cmo process.cmo
+
+.PHONY: all bytecode native clean
+Makefile: ;
+$(SRC): ;

libs/extc/dune

@@ -0,0 +1,16 @@
+(include_subdirs no)
+
+(library
+	(name extc)
+	(libraries extlib)
+	(c_names extc_stubs)
+	(modules extc)
+	(wrapped false)
+)
+
+(library
+	(name extproc)
+	(c_names process_stubs)
+	(modules process)
+	(wrapped false)
+)

libs/extc/extc.ml

@@ -0,0 +1,188 @@
+(*
+ *  Extc : C common OCaml bindings
+ *  Copyright (c)2004 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+
+type zstream
+
+type zflush =
+	| Z_NO_FLUSH
+	| Z_PARTIAL_FLUSH
+	| Z_SYNC_FLUSH
+	| Z_FULL_FLUSH
+	| Z_FINISH
+
+
+type zresult = {
+	z_finish : bool;
+	z_read : int;
+	z_wrote : int;
+}
+
+external zlib_deflate_init2 : int -> int -> zstream = "zlib_deflate_init2"
+external zlib_deflate : zstream -> src:string -> spos:int -> slen:int -> dst:bytes -> dpos:int -> dlen:int -> zflush -> zresult = "zlib_deflate_bytecode" "zlib_deflate"
+external zlib_deflate_end : zstream -> unit = "zlib_deflate_end"
+
+external zlib_inflate_init2 : int -> zstream = "zlib_inflate_init"
+external zlib_inflate : zstream -> src:string -> spos:int -> slen:int -> dst:bytes -> dpos:int -> dlen:int -> zflush -> zresult = "zlib_inflate_bytecode" "zlib_inflate"
+external zlib_inflate_end : zstream -> unit = "zlib_inflate_end"
+
+external _executable_path : string -> string = "executable_path"
+external get_full_path : string -> string = "get_full_path"
+external get_real_path : string -> string = "get_real_path"
+
+external zlib_deflate_bound : zstream -> int -> int = "zlib_deflate_bound"
+
+external zlib_crc32 : bytes -> int -> int32 = "zlib_crc32"
+
+external time : unit -> float = "sys_time"
+
+external getch : bool -> int = "sys_getch"
+
+external filetime : string -> float = "sys_filetime"
+
+(* support for backward compatibility *)
+let zlib_deflate_init lvl = zlib_deflate_init2 lvl 15
+let zlib_inflate_init() = zlib_inflate_init2 15
+
+let executable_path() =
+	let p = _executable_path Sys.argv.(0) in
+	let p1 = (try String.rindex p '/' with Not_found -> String.length p + 1) in
+	let p2 = (try String.rindex p '\\' with Not_found -> String.length p + 1) in
+	match min p1 p2 with
+	| x when x = String.length p + 1 -> ""
+	| pos ->
+		String.sub p 0 pos ^ "/"
+
+let zlib_op op z str =
+	let bufsize = 1 lsl 14 in
+	let tmp = Bytes.create bufsize in
+	let total = ref 0 in
+	let rec loop pos len acc =
+		let r = op z ~src:str ~spos:pos ~slen:len ~dst:tmp ~dpos:0 ~dlen:bufsize (if len = 0 then Z_FINISH else Z_SYNC_FLUSH) in
+		total := !total + r.z_wrote;
+		let acc = Bytes.sub tmp 0 r.z_wrote :: acc in
+		if r.z_finish then
+			acc
+		else
+			loop (pos + r.z_read) (len - r.z_read) acc
+	in
+	let strings = loop 0 (String.length str) [] in
+	let big = Bytes.create !total in
+	ignore(List.fold_left (fun p s ->
+		let l = Bytes.length s in
+		let p = p - l in
+		Bytes.unsafe_blit s 0 big p l;
+		p
+	) !total strings);
+	Bytes.unsafe_to_string big
+
+let zip str =
+	let z = zlib_deflate_init 9 in
+	let s = zlib_op zlib_deflate z str in
+	zlib_deflate_end z;
+	s
+
+let unzip str =
+	let z = zlib_inflate_init()  in
+	let s = zlib_op zlib_inflate z str in
+	zlib_inflate_end z;
+	s
+
+let input_zip ?(bufsize=65536) ch =
+	let tmp_out = Bytes.create bufsize in
+	let tmp_in = Bytes.create bufsize in
+	let tmp_buf = Buffer.create bufsize in
+	let buf = ref "" in
+	let p = ref 0 in
+	let z = zlib_inflate_init() in
+	let rec fill_buffer() =
+		let rec loop pos len =
+			if len > 0 || pos = 0 then begin
+				let r = zlib_inflate z (Bytes.unsafe_to_string tmp_in) pos len tmp_out 0 bufsize (if pos = 0 && len = 0 then Z_FINISH else Z_SYNC_FLUSH) in
+				Buffer.add_subbytes tmp_buf tmp_out 0 r.z_wrote;
+				loop (pos + r.z_read) (len - r.z_read);
+			end
+		in
+		loop 0 (IO.input ch tmp_in 0 bufsize);
+		p := 0;
+		buf := Buffer.contents tmp_buf;
+		Buffer.clear tmp_buf;
+	in
+	let read() =
+		if !p = String.length !buf then fill_buffer();
+		let c = String.unsafe_get !buf !p in
+		incr p;
+		c
+	in
+	let rec input str pos len =
+		let b = String.length !buf - !p in
+		if b >= len then begin
+			String.blit !buf !p str pos len;
+			p := !p + len;
+			len;
+		end else begin
+			String.blit !buf !p str pos b;
+			fill_buffer();
+			if !p = String.length !buf then
+				b
+			else
+				b + input str (pos + b) (len - b)
+		end;
+	in
+	let close() =
+		zlib_inflate_end z
+	in
+	IO.create_in ~read ~input ~close
+
+let output_zip ?(bufsize=65536) ?(level=9) ch =
+	let z = zlib_deflate_init level in
+	let out = Bytes.create bufsize in
+	let tmp_out = Bytes.create bufsize in
+	let p = ref 0 in
+	let rec flush finish =
+		let r = zlib_deflate z (Bytes.unsafe_to_string out) 0 !p tmp_out 0 bufsize (if finish then Z_FINISH else Z_SYNC_FLUSH) in
+		ignore(IO.really_output ch tmp_out 0 r.z_wrote);
+		let remain = !p - r.z_read in
+		Bytes.blit out r.z_read out 0 remain;
+		p := remain;
+		if finish && not r.z_finish then flush true
+	in
+	let write c =
+		if !p = bufsize then flush false;
+		Bytes.unsafe_set out !p c;
+		incr p
+	in
+	let rec output str pos len =
+		let b = bufsize - !p in
+		if len <= b then begin
+			Bytes.blit str pos out !p len;
+			p := !p + len;
+			len
+		end else begin
+			Bytes.blit str pos out !p b;
+			p := !p + b;
+			flush false;
+			b + output str (pos + b) (len - b);
+		end;
+	in
+	let close() =
+		flush true;
+		zlib_deflate_end z
+	in
+	IO.create_out ~write ~output ~flush:(fun() -> flush false; IO.flush ch) ~close
+

libs/extc/extc_stubs.c

@@ -0,0 +1,575 @@
+/*
+ *  Extc : C common OCaml bindings
+ *  Copyright (c)2004-2017 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ */
+
+#include <assert.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/custom.h>
+#include <caml/mlvalues.h>
+#include <caml/fail.h>
+#include <zlib.h>
+#ifdef _WIN32
+#	include <windows.h>
+#	include <conio.h>
+#else
+#	include <dlfcn.h>
+#	include <limits.h>
+#	include <unistd.h>
+#	include <string.h>
+#	include <termios.h>
+#	include <stdio.h>
+#	include <time.h>
+#	include <sys/time.h>
+#	include <sys/times.h>
+#	include <sys/stat.h>
+#	include <caml/memory.h>
+#endif
+#ifdef __APPLE__
+#	include <sys/param.h>
+#	include <sys/syslimits.h>
+#	include <mach-o/dyld.h>
+#include <mach/mach.h>
+#include <mach/mach_time.h>
+#endif
+#ifdef __FreeBSD__
+#	include <sys/param.h>
+#	include <sys/sysctl.h>
+#	include <sys/user.h>
+#endif
+
+#ifndef CLK_TCK
+#	define CLK_TCK	100
+#endif
+
+/**
+ * Converts an OCaml value to a C pointer for a z_stream.
+ *
+ * @param v {value} An OCaml value
+ * @return {z_streamp} A pointer for a z_stream
+ */
+#define ZStreamP_val(v) (*((z_streamp *) Data_custom_val(v)))
+
+/**
+ * Converts an OCaml `Extc.zflush` value to an allowed flush value for _zlib_.
+ *
+ * It may raise the following OCaml exception:
+ * - Failure: Unknown zflush value.
+ *
+ * Make sure to update this function when refactoring OCaml's `Extc.zflush` type. The integer value
+ * of OCaml's `Extc.zflush` is the 0-based index of the position of the constructor in the type
+ * definition.
+ *
+ * See:
+ * https://github.com/HaxeFoundation/haxe-debian/blob/31cb4aaab9f6770d058883a1c5b97e36c8ec5d71/libs/extc/extc.ml#L22
+ * https://github.com/madler/zlib/blob/cacf7f1d4e3d44d871b605da3b647f07d718623f/zlib.h#L168
+ *
+ * @param zflush_val {value} OCaml `Extc.zflush`
+ * @return {int} C int representing an allowed flush value for _zlib_
+ */
+int Zflush_val(value zflush_val) {
+	switch (Int_val(zflush_val)) {
+		case 0: return Z_NO_FLUSH;
+		case 1: return Z_PARTIAL_FLUSH;
+		case 2: return Z_SYNC_FLUSH;
+		case 3: return Z_FULL_FLUSH;
+		case 4: return Z_FINISH;
+		// TODO: support Z_BLOCK and Z_TREE
+		// TODO: append the received value
+		default: failwith("Error in `Zflush_val` (extc_stubs.c): Unknown zflush value");
+	}
+	assert(0);
+}
+
+/**
+ * Converts an allowed flush value for _zlib_ to an OCaml `Extc.zflush` value.
+ *
+ * Make sure to update this function when refactoring OCaml's `Extc.zflush` type. The integer value
+ * of OCaml's `Extc.zflush` is the 0-based index of the position of the constructor in the type
+ * definition.
+ *
+ * See:
+ * https://github.com/madler/zlib/blob/cacf7f1d4e3d44d871b605da3b647f07d718623f/zlib.h#L168
+ * https://github.com/HaxeFoundation/haxe-debian/blob/31cb4aaab9f6770d058883a1c5b97e36c8ec5d71/libs/extc/extc.ml#L22
+ *
+ * @param {int} C int representing an allowed flush value for _zlib_
+ * @return {value} OCaml `Extc.zflush`
+ */
+value val_Zflush(int zflush) {
+	switch (zflush) {
+		case Z_NO_FLUSH: return Val_int(0);
+		case Z_PARTIAL_FLUSH: return Val_int(1);
+		case Z_SYNC_FLUSH: return Val_int(2);
+		case Z_FULL_FLUSH: return Val_int(3);
+		case Z_FINISH: return Val_int(4);
+		// TODO: support Z_BLOCK and Z_TREE
+	}
+	assert(0);
+}
+
+/**
+ * Free the memory of the pointer contained in the supplied OCaml value `caml_z_stream_pointer`.
+ *
+ * @param z_streamp_val {value} An OCaml value containing a z_stream pointer to the memory to free.
+ */
+void zlib_free_stream(value z_streamp_val) {
+	caml_stat_free(ZStreamP_val(z_streamp_val));
+	ZStreamP_val(z_streamp_val) = NULL;
+}
+
+/**
+ * Define the custom operations for a z_stream. This ensures that the memory owned
+ * by the z_stream pointer is freed.
+ *
+ * See:
+ * https://github.com/ocaml/ocaml/blob/70d880a41a82aae1ebd428fd38100e8467f8535a/byterun/caml/custom.h#L25
+ */
+static struct custom_operations zlib_stream_ops = {
+	// identifier
+	"z_stream_ops",
+	// finalize
+	&zlib_free_stream,
+	// compare
+	NULL,
+	// hash
+	NULL,
+	// serialize
+	NULL,
+	// compare_ext
+	NULL
+};
+
+/**
+ * Create an OCaml value containing a new z_stream pointer.
+ *
+ * This function may raise the following OCaml exception:
+ * - Out_of_memory exception
+ *
+ * @return {value} An OCaml value containing a new z_stream pointer.
+ */
+value zlib_new_stream() {
+    value z_streamp_val = caml_alloc_custom(&zlib_stream_ops, sizeof(z_streamp), 0, 1);
+    ZStreamP_val(z_streamp_val) = caml_stat_alloc(sizeof(z_stream));
+    ZStreamP_val(z_streamp_val)->zalloc = NULL;
+    ZStreamP_val(z_streamp_val)->zfree = NULL;
+    ZStreamP_val(z_streamp_val)->opaque = NULL;
+    ZStreamP_val(z_streamp_val)->next_in = NULL;
+    ZStreamP_val(z_streamp_val)->next_out = NULL;
+    return z_streamp_val;
+}
+
+/**
+ * OCaml binding for _zlib_'s `deflateInit2` function.
+ *
+ * This creates a new stream and initializes it for deflate.
+ *
+ * This function may raise the following OCaml exceptions:
+ * - Out_of_memory exception
+ * - Failure exception: Invalid parameters
+ * - Failure exception: Invalid version
+ * - Failure exception: Unknown zlib return code
+ *
+ * See:
+ * https://github.com/madler/zlib/blob/cacf7f1d4e3d44d871b605da3b647f07d718623f/zlib.h#L538
+ *
+ * @param levelVal {value} OCaml `int`: the compression level, must be in the range 0..9.
+ *     0 gives no compression at all, 1 the best speed, 9 the best compression.
+ * @param windowBitsVal {value} OCaml `int`: base two logarithm of the window size (size of the
+ *     history buffer) used by _zlib_. It should be in the range 9..15 for this version of _zlib_.
+ *     It can also be in the range -15..-8 (the absolute value is used) for raw deflate.
+ *     Finally, it can be greater than 15 for gzip encoding. See _zlib_'s documentation for
+ *     `deflateInit2` for the exact documentation.
+ * @return {value} An OCaml value representing the new stream, initialized for deflate.
+ */
+CAMLprim value zlib_deflate_init2(value level_val, value window_bits_val) {
+	int level = Int_val(level_val);
+	int window_bits = Int_val(window_bits_val);
+	value z_streamp_val = zlib_new_stream();
+	z_streamp stream = ZStreamP_val(z_streamp_val);
+
+	int deflate_init2_result = deflateInit2(
+		stream,
+		level,
+		Z_DEFLATED, // method
+		window_bits,
+		8, // memLevel
+		Z_DEFAULT_STRATEGY // strategy
+	);
+
+	if (deflate_init2_result == Z_OK) {
+		return z_streamp_val;
+	}
+
+	switch (deflate_init2_result) {
+		case Z_MEM_ERROR:
+			caml_raise_out_of_memory();
+			break;
+		case Z_STREAM_ERROR:
+			// TODO: use stream->msg to get _zlib_'s text message
+			failwith("Error in `zlib_deflate_init2` (extc_stubs.c): call to `deflateInit2` failed: Z_STREAM_ERROR");
+			break;
+		case Z_VERSION_ERROR:
+			// TODO: use stream->msg to get _zlib_'s text message
+			failwith("Error in `zlib_deflate_init2` (extc_stubs.c): call to `deflateInit2` failed: Z_VERSION_ERROR");
+			break;
+		default:
+			failwith("Error in `zlib_deflate_init2` (extc_stubs.c): unknown return code from `deflateInit2`");
+	}
+	assert(0);
+}
+
+/**
+ * OCaml binding for _zlib_'s `deflate` function.
+ *
+ * Compresses as much data as possible, and stops when the input buffer becomes empty or the output
+ * buffer becomes full.
+ *
+ * This function may raise the following OCaml exceptions:
+ * - Out_of_memory exception
+ * - Failure exception: Invalid parameters
+ * - Failure exception: Invalid version
+ * - Failure exception: Unknown zlib return code
+ *
+ * See:
+ * https://github.com/madler/zlib/blob/cacf7f1d4e3d44d871b605da3b647f07d718623f/zlib.h#L250
+ *
+ * @param stream_val {value} OCaml `Extc.zstream`: value containing a z_stream pointer to a deflate
+ *     stream.
+ * @param src {value} OCaml `bytes`: Source buffer
+ * @param spos {value} OCaml `int`: Index of the inclusive start offset of the source.
+ * @param slen {value} OCaml `int`: Length of the data to read from the source buffer, from spos.
+ * @param dst {value} OCaml `bytes`: Source buffer
+ * @param dpos {value} OCaml `int`: Index of the inclusive start offset of the source.
+ * @param dlen {value} OCaml `int`: Length of the data to read from the source buffer, from spos.
+ * @param flush_val {value} OCaml `Extc.zflush`: Controls the flush logic. See _zlib_'s
+ *     documentation.
+ * @return {value} OCaml `Extc.reslut`.
+ */
+CAMLprim value zlib_deflate(value stream_val, value src, value spos, value slen, value dst, value dpos, value dlen, value flush_val) {
+	z_streamp stream = ZStreamP_val(stream_val);
+	int flush = Zflush_val(flush_val);
+
+	stream->next_in = (Bytef*)(String_val(src) + Int_val(spos));
+	stream->next_out = (Bytef*)(String_val(dst) + Int_val(dpos));
+	stream->avail_in = Int_val(slen);
+	stream->avail_out = Int_val(dlen);
+
+	int deflate_result = deflate(stream, flush);
+
+	if (deflate_result == Z_OK || deflate_result == Z_STREAM_END) {
+		stream->next_in = NULL;
+		stream->next_out = NULL;
+		value zresult = alloc_small(3, 0);
+		// z_finish
+		Field(zresult, 0) = Val_bool(deflate_result == Z_STREAM_END);
+		// z_read
+		Field(zresult, 1) = Val_int(Int_val(slen) - stream->avail_in);
+		// z_wrote
+		Field(zresult, 2) = Val_int(Int_val(dlen) - stream->avail_out);
+
+		return zresult;
+	}
+	switch (deflate_result) {
+		case Z_MEM_ERROR:
+			caml_raise_out_of_memory();
+			break;
+		case Z_STREAM_ERROR:
+			// TODO: use stream->msg to get _zlib_'s text message
+			failwith("Error in `zlib_deflate` (extc_stubs.c): call to `deflate` failed: Z_STREAM_ERROR");
+			break;
+		case Z_BUF_ERROR:
+			// TODO: use stream->msg to get _zlib_'s text message
+			failwith("Error in `zlib_deflate` (extc_stubs.c): call to `deflate` failed: Z_BUF_ERROR");
+			break;
+		default:
+			failwith("Error in `zlib_deflate` (extc_stubs.c): unknown return code from `deflate`");
+	}
+	assert(0);
+}
+
+CAMLprim value zlib_deflate_bytecode(value *arg, int nargs) {
+	return zlib_deflate(arg[0], arg[1], arg[2], arg[3], arg[4], arg[5], arg[6], arg[7]);
+}
+
+CAMLprim value zlib_deflate_end(value zv) {
+	if( deflateEnd(ZStreamP_val(zv)) != 0 )
+		failwith("zlib_deflate_end");
+	return Val_unit;
+}
+
+CAMLprim value zlib_inflate_init(value wbits) {
+	value z = zlib_new_stream();
+	if( inflateInit2(ZStreamP_val(z),Int_val(wbits)) != Z_OK )
+		failwith("zlib_inflate_init");
+	return z;
+}
+
+CAMLprim value zlib_inflate( value zv, value src, value spos, value slen, value dst, value dpos, value dlen, value flush ) {
+	z_streamp z = ZStreamP_val(zv);
+	value res;
+	int r;
+
+	z->next_in = (Bytef*)(String_val(src) + Int_val(spos));
+	z->next_out = (Bytef*)(String_val(dst) + Int_val(dpos));
+	z->avail_in = Int_val(slen);
+	z->avail_out = Int_val(dlen);
+	if( (r = inflate(z,Int_val(flush))) < 0 )
+		failwith("zlib_inflate");
+
+	z->next_in = NULL;
+	z->next_out = NULL;
+
+	res = alloc_small(3, 0);
+	Field(res, 0) = Val_bool(r == Z_STREAM_END);
+	Field(res, 1) = Val_int(Int_val(slen) - z->avail_in);
+	Field(res, 2) = Val_int(Int_val(dlen) - z->avail_out);
+	return res;
+}
+
+CAMLprim value zlib_inflate_bytecode(value * arg, int nargs) {
+	return zlib_inflate(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],arg[7]);
+}
+
+CAMLprim value zlib_inflate_end(value zv) {
+	if( inflateEnd(ZStreamP_val(zv)) != 0 )
+		failwith("zlib_inflate_end");
+	return Val_unit;
+}
+
+CAMLprim value zlib_deflate_bound(value zv,value len) {
+	return Val_int(deflateBound(ZStreamP_val(zv),Int_val(len)));
+}
+
+CAMLprim value zlib_crc32( value src, value len ) {
+	CAMLparam2(src,len);
+	CAMLlocal1(result);
+	uLong crc = crc32(0L, (Bytef*)(String_val(src)), Int_val(len));
+	result = caml_copy_int32(crc);
+	CAMLreturn(result);
+}
+
+CAMLprim value executable_path(value u) {
+#ifdef _WIN32
+	char path[MAX_PATH];
+	if( GetModuleFileName(NULL,path,MAX_PATH) == 0 )
+		failwith("executable_path");
+	return caml_copy_string(path);
+#elif __APPLE__
+	char path[MAXPATHLEN+1];
+	uint32_t path_len = MAXPATHLEN;
+	if ( _NSGetExecutablePath(path, &path_len) )
+		failwith("executable_path");
+	return caml_copy_string(path);
+#elif __FreeBSD__
+	char path[PATH_MAX];
+	int error, name[4];
+	size_t len;
+	name[0] = CTL_KERN;
+	name[1] = KERN_PROC;
+	name[2] = KERN_PROC_PATHNAME;
+	name[3] = (int)getpid();
+	len = sizeof(path);
+	error = sysctl(name, 4, path, &len, NULL, 0);
+	if( error < 0 )
+		failwith("executable_path");
+	return caml_copy_string(path);
+#else
+	char path[PATH_MAX];
+	int length = readlink("/proc/self/exe", path, sizeof(path));
+	if( length < 0 || length >= PATH_MAX ) {
+		const char *p = getenv("_");
+		if( p != NULL )
+			return caml_copy_string(p);
+		else
+			failwith("executable_path");
+	}
+	path[length] = '\0';
+	return caml_copy_string(path);
+#endif
+}
+
+CAMLprim value get_full_path( value f ) {
+#ifdef _WIN32
+	char path[MAX_PATH];
+	if( GetFullPathName(String_val(f),MAX_PATH,path,NULL) == 0 )
+		failwith("get_full_path");
+	return caml_copy_string(path);
+#else
+	char path[4096];
+	if( realpath(String_val(f),path) == NULL )
+		failwith("get_full_path");
+	return caml_copy_string(path);
+#endif
+}
+
+CAMLprim value get_real_path( value path ) {
+#ifdef _WIN32
+	const char sep = '\\';
+	size_t len, i, last;
+	WIN32_FIND_DATA data;
+	HANDLE handle;
+	char out[MAX_PATH];
+
+	// this will ensure the full class path with proper casing
+	if( GetFullPathName(String_val(path),MAX_PATH,out,NULL) == 0 )
+		failwith("get_real_path");
+
+	len = strlen(out);
+	i = 0;
+
+	if (len >= 2 && out[1] == ':') {
+		// convert drive letter to uppercase
+		if (out[0] >= 'a' && out[0] <= 'z')
+			out[0] += 'A' - 'a';
+		if (len >= 3 && out[2] == sep)
+			i = 3;
+		else
+			i = 2;
+	}
+
+	last = i;
+
+	while (i < len) {
+		// skip until separator
+		while (i < len && out[i] != sep)
+			i++;
+
+		// temporarily strip string to last found component
+		out[i] = 0;
+
+		// get actual file/dir name with proper case
+		if ((handle = FindFirstFile(out, &data)) != INVALID_HANDLE_VALUE) {
+			int klen = strlen(data.cFileName);
+			// a ~ was expanded !
+			if( klen != i - last ) {
+				int d = klen - (i - last);
+				memmove(out + i + d, out + i, len - i + 1);
+				len += d;
+				i += d;
+			}
+			// replace the component with proper case
+			memcpy(out + last, data.cFileName, klen + 1);
+			FindClose(handle);
+		}
+
+		// if we're not at the end, restore the path
+		if (i < len)
+			out[i] = sep;
+
+		// advance
+		i++;
+		last = i;
+	}
+
+	return caml_copy_string(out);
+#else
+	return path;
+#endif
+}
+
+#ifndef _WIN32
+#define TimeSpecToSeconds(ts) (double)ts.tv_sec + (double)ts.tv_nsec / 1000000000.0
+#endif
+
+CAMLprim value sys_time() {
+#ifdef _WIN32
+#define EPOCH_DIFF	(134774*24*60*60.0)
+	static LARGE_INTEGER freq;
+	static int freq_init = -1;
+	LARGE_INTEGER counter;
+	if( freq_init == -1 )
+		freq_init = QueryPerformanceFrequency(&freq);
+	if( !freq_init || !QueryPerformanceCounter(&counter) ) {
+		SYSTEMTIME t;
+		FILETIME ft;
+		ULARGE_INTEGER ui;
+		GetSystemTime(&t);
+		if( !SystemTimeToFileTime(&t,&ft) )
+			failwith("sys_cpu_time");
+		ui.LowPart = ft.dwLowDateTime;
+		ui.HighPart = ft.dwHighDateTime;
+		return caml_copy_double( ((double)ui.QuadPart) / 10000000.0 - EPOCH_DIFF );
+	}
+	return caml_copy_double( ((double)counter.QuadPart) / ((double)freq.QuadPart) );
+#elif __APPLE__
+
+	uint64_t time;
+	uint64_t elapsedNano;
+	static mach_timebase_info_data_t sTimebaseInfo;
+
+	time = mach_absolute_time();
+
+	if ( sTimebaseInfo.denom == 0 ) {
+		(void) mach_timebase_info(&sTimebaseInfo);
+	}
+
+	elapsedNano = time * sTimebaseInfo.numer / sTimebaseInfo.denom;
+
+	return caml_copy_double(time / 1000000000.0);
+#elif defined CLOCK_MONOTONIC_RAW
+	struct timespec t;
+	clock_gettime(CLOCK_MONOTONIC_RAW, &t);
+	return caml_copy_double(TimeSpecToSeconds(t));
+#else
+	struct timespec t;
+	clock_gettime(CLOCK_MONOTONIC, &t);
+	return caml_copy_double(TimeSpecToSeconds(t));
+#endif
+}
+
+CAMLprim value sys_getch( value b ) {
+#	ifdef _WIN32
+	return Val_int( Bool_val(b)?getche():getch() );
+#	else
+	// took some time to figure out how to do that
+	// without relying on ncurses, which clear the
+	// terminal on initscr()
+	int c;
+	struct termios term, old;
+	tcgetattr(fileno(stdin), &old);
+	term = old;
+	cfmakeraw(&term);
+	tcsetattr(fileno(stdin), 0, &term);
+	c = getchar();
+	tcsetattr(fileno(stdin), 0, &old);
+	if( Bool_val(b) ) fputc(c,stdout);
+	return Val_int(c);
+#	endif
+}
+
+CAMLprim value sys_filetime( value file ) {
+#	ifdef _WIN32
+	FILETIME fp;
+	ULARGE_INTEGER ui;
+	HANDLE h = CreateFile(String_val(file),FILE_READ_ATTRIBUTES,FILE_SHARE_DELETE | FILE_SHARE_READ | FILE_SHARE_WRITE,NULL,OPEN_EXISTING,FILE_FLAG_BACKUP_SEMANTICS,NULL);
+	if( h == INVALID_HANDLE_VALUE || !GetFileTime(h,NULL,NULL,&fp) ) {
+		CloseHandle(h);
+		return caml_copy_double(0.);
+	}
+	CloseHandle(h);
+	ui.LowPart = fp.dwLowDateTime;
+	ui.HighPart = fp.dwHighDateTime;
+	return caml_copy_double( ((double)ui.QuadPart) / 10000000.0 - EPOCH_DIFF );
+#	else
+	struct stat sbuf;
+	if( stat(String_val(file),&sbuf) < 0 )
+		return caml_copy_double(0.);
+	return caml_copy_double( sbuf.st_mtime );
+#	endif
+}

libs/extc/process.ml

@@ -0,0 +1,31 @@
+(*
+ *  Extc : C common OCaml bindings
+ *  Copyright (c)2004-2015 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+
+type process
+
+external run : string -> string array option -> process = "process_run"
+external read_stdout : process -> string -> int -> int -> int = "process_stdout_read"
+external read_stderr : process -> string -> int -> int -> int = "process_stderr_read"
+external write_stdin : process -> string -> int -> int -> int = "process_stdin_write"
+external close_stdin : process -> unit = "process_stdin_close"
+external exit : process -> int = "process_exit"
+external pid : process -> int = "process_pid"
+external close : process -> unit = "process_close"
+external kill : process -> unit = "process_kill"
+

libs/extc/process_stubs.c

@@ -0,0 +1,619 @@
+/*
+ * Copyright (C)2005-2015 Haxe Foundation
+ *
+ * Permission is hereby granted, free of charge, to any person obtaining a
+ * copy of this software and associated documentation files (the "Software"),
+ * to deal in the Software without restriction, including without limitation
+ * the rights to use, copy, modify, merge, publish, distribute, sublicense,
+ * and/or sell copies of the Software, and to permit persons to whom the
+ * Software is furnished to do so, subject to the following conditions:
+ *
+ * The above copyright notice and this permission notice shall be included in
+ * all copies or substantial portions of the Software.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+ * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+ * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+ * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+ * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+ * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+ * DEALINGS IN THE SOFTWARE.
+ */
+
+ // ported from NekoVM
+
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/mlvalues.h>
+#include <caml/fail.h>
+
+#ifdef _WIN32
+#	include <windows.h>
+#else
+#	include <sys/types.h>
+#	include <signal.h>
+#	include <unistd.h>
+#	include <errno.h>
+#	include <string.h>
+#	ifndef __APPLE__
+#		if defined(__FreeBSD__) || defined(__DragonFly__)
+#			include <sys/wait.h>
+#		else
+#			include <wait.h>
+#		endif
+#	endif
+#endif
+
+#ifdef _WIN32
+#	define POSIX_LABEL(name)
+#	define HANDLE_EINTR(label)
+#	define HANDLE_FINTR(f,label)
+#else
+#	include <errno.h>
+#	define POSIX_LABEL(name)	name:
+#	define HANDLE_EINTR(label)	if( errno == EINTR ) goto label
+#	define HANDLE_FINTR(f,label) if( ferror(f) && errno == EINTR ) goto label
+#endif
+
+// --- neko-to-caml api --
+#define val_check(v,t)
+#define val_check_kind(v,k)
+#define val_data(v) v
+#define val_array_size(v) Wosize_val(v)
+#define val_array_ptr(v) (&Field(v,0))
+#define val_string(v) String_val(v)
+#define val_strlen(v) caml_string_length(v)
+#define alloc_abstract(_,data) ((value)data)
+#define alloc_int(i) Val_int(i)
+#define val_gc(v,callb)
+#define val_null Val_int(0)
+#define val_some(v) Field(v,0)
+#define val_int(v) Int_val(v)
+#define DEFINE_KIND(_)
+#define neko_error() failwith(__FUNCTION__)
+
+static value alloc_private( int size ) {
+	return alloc((size + sizeof(value) - 1) / sizeof(value), Abstract_tag);
+}
+
+// --- buffer api
+#define EXTERN
+
+typedef struct _stringitem {
+	char *str;
+	int size;
+	int len;
+	struct _stringitem *next;
+} * stringitem;
+
+struct _buffer {
+	int totlen;
+	int blen;
+	stringitem data;
+};
+
+typedef struct _buffer *buffer;
+
+static void buffer_append_new( buffer b, const char *s, int len ) {
+	int size;
+	stringitem it;
+	while( b->totlen >= (b->blen << 2) )
+		b->blen <<= 1;
+	size = (len < b->blen)?b->blen:len;
+	it = (stringitem)malloc(sizeof(struct _stringitem));
+	it->str = (char*)malloc(size);
+	memcpy(it->str,s,len);
+	it->size = size;
+	it->len = len;
+	it->next = b->data;
+	b->data = it;
+}
+
+EXTERN void buffer_append_sub( buffer b, const char *s, int len ) {
+	stringitem it;
+	if( s == NULL || len <= 0 )
+		return;
+	b->totlen += len;
+	it = b->data;
+	if( it ) {
+		int free = it->size - it->len;
+		if( free >= len ) {
+			memcpy(it->str + it->len,s,len);
+			it->len += len;
+			return;
+		} else {
+			memcpy(it->str + it->len,s,free);
+			it->len += free;
+			s += free;
+			len -= free;
+		}
+	}
+	buffer_append_new(b,s,len);
+}
+
+EXTERN void buffer_append_str( buffer b, const char *s ) {
+	if( s == NULL )
+		return;
+	buffer_append_sub(b,s,strlen(s));
+}
+
+EXTERN buffer alloc_buffer( const char *init ) {
+	buffer b = (buffer)malloc(sizeof(struct _buffer));
+	b->totlen = 0;
+	b->blen = 16;
+	b->data = NULL;
+	if( init )
+		buffer_append_str(b,init);
+	return b;
+}
+
+EXTERN void buffer_append_char( buffer b, char c ) {
+	stringitem it;
+	b->totlen++;
+	it = b->data;
+	if( it && it->len != it->size ) {
+		it->str[it->len++] = c;
+		return;
+	}
+	buffer_append_new(b,&c,1);
+}
+
+EXTERN char *buffer_to_string( buffer b ) {
+	char *v = (char*)malloc(b->totlen + 1);
+	stringitem it = b->data;
+	char *s = v + b->totlen;
+	*s = 0;
+	while( it != NULL ) {
+		stringitem tmp;
+		s -= it->len;
+		memcpy(s,it->str,it->len);
+		tmp = it->next;
+		free(it->str);
+		free(it);
+		it = tmp;
+	}
+	free(b);
+	return v;
+}
+
+EXTERN int buffer_length( buffer b ) {
+	return b->totlen;
+}
+
+// ---------------
+
+#include <stdio.h>
+#include <stdlib.h>
+
+typedef struct {
+#ifdef _WIN32
+	HANDLE oread;
+	HANDLE eread;
+	HANDLE iwrite;
+	PROCESS_INFORMATION pinf;
+#else
+	int oread;
+	int eread;
+	int iwrite;
+	int pid;
+#endif
+} vprocess;
+
+DEFINE_KIND(k_process);
+
+#define val_process(v)	((vprocess*)val_data(v))
+
+/**
+	<doc>
+	<h1>Process</h1>
+	<p>
+	An API for starting and communication with sub processes.
+	</p>
+	</doc>
+**/
+#ifndef _WIN32
+static int do_close( int fd ) {
+	POSIX_LABEL(close_again);
+	if( close(fd) != 0 ) {
+		HANDLE_EINTR(close_again);
+		return 1;
+	}
+	return 0;
+}
+#endif
+
+static void free_process( value vp ) {
+	vprocess *p = val_process(vp);
+#	ifdef _WIN32
+	CloseHandle(p->eread);
+	CloseHandle(p->oread);
+	CloseHandle(p->iwrite);
+	CloseHandle(p->pinf.hProcess);
+	CloseHandle(p->pinf.hThread);
+#	else
+	do_close(p->eread);
+	do_close(p->oread);
+	do_close(p->iwrite);
+#	endif
+}
+
+/**
+	process_run : cmd:string -> args:string array option -> 'process
+	<doc>
+	Start a process using a command and the specified arguments.
+	When args is not null, cmd and args will be auto-quoted/escaped.
+	If no auto-quoting/escaping is desired, you should append necessary
+	arguments to cmd as if it is inputted to the shell directly, and pass
+	null as args.
+	</doc>
+**/
+CAMLprim value process_run( value cmd, value vargs ) {
+	CAMLparam2(cmd,vargs);
+	int i, isRaw;
+	vprocess *p;
+	val_check(cmd,string);
+	isRaw = vargs == val_null;
+	if (!isRaw) {
+		val_check(vargs,array);
+		vargs = val_some(vargs);
+	}
+#	ifdef _WIN32
+	{
+		SECURITY_ATTRIBUTES sattr;
+		STARTUPINFO sinf;
+		HANDLE proc = GetCurrentProcess();
+		HANDLE oread,eread,iwrite;
+		// creates commandline
+		buffer b = alloc_buffer(NULL);
+		char *sargs;
+		if (isRaw) {
+			char* cmdexe;
+			buffer_append_char(b,'"');
+			cmdexe = getenv("COMSPEC");
+			if (!cmdexe) cmdexe = "cmd.exe";
+			buffer_append_str(b,cmdexe);
+			buffer_append_char(b,'"');
+			buffer_append_str(b,"/C \"");
+			buffer_append_str(b,val_string(cmd));
+			buffer_append_char(b,'"');
+		} else {
+			buffer_append_char(b,'"');
+			buffer_append_str(b,val_string(cmd));
+			buffer_append_char(b,'"');
+			for(i=0;i<val_array_size(vargs);i++) {
+				value v = val_array_ptr(vargs)[i];
+				int j,len;
+				unsigned int bs_count = 0;
+				unsigned int k;
+				val_check(v,string);
+				len = val_strlen(v);
+				buffer_append_str(b," \"");
+				for(j=0;j<len;j++) {
+					char c = val_string(v)[j];
+					switch( c ) {
+					case '"':
+						// Double backslashes.
+						for (k=0;k<bs_count*2;k++) {
+							buffer_append_char(b,'\\');
+						}
+						bs_count = 0;
+						buffer_append_str(b, "\\\"");
+						break;
+					case '\\':
+						// Don't know if we need to double yet.
+						bs_count++;
+						break;
+					default:
+						// Normal char
+						for (k=0;k<bs_count;k++) {
+							buffer_append_char(b,'\\');
+						}
+						bs_count = 0;
+						buffer_append_char(b,c);
+						break;
+					}
+				}
+				// Add remaining backslashes, if any.
+				for (k=0;k<bs_count*2;k++) {
+					buffer_append_char(b,'\\');
+				}
+				buffer_append_char(b,'"');
+			}
+		}
+		sargs = buffer_to_string(b);
+		p = (vprocess*)alloc_private(sizeof(vprocess));
+		// startup process
+		sattr.nLength = sizeof(sattr);
+		sattr.bInheritHandle = TRUE;
+		sattr.lpSecurityDescriptor = NULL;
+		memset(&sinf,0,sizeof(sinf));
+		sinf.cb = sizeof(sinf);
+		sinf.dwFlags = STARTF_USESTDHANDLES | STARTF_USESHOWWINDOW;
+		sinf.wShowWindow = SW_HIDE;
+		CreatePipe(&oread,&sinf.hStdOutput,&sattr,0);
+		CreatePipe(&eread,&sinf.hStdError,&sattr,0);
+		CreatePipe(&sinf.hStdInput,&iwrite,&sattr,0);
+		DuplicateHandle(proc,oread,proc,&p->oread,0,FALSE,DUPLICATE_SAME_ACCESS);
+		DuplicateHandle(proc,eread,proc,&p->eread,0,FALSE,DUPLICATE_SAME_ACCESS);
+		DuplicateHandle(proc,iwrite,proc,&p->iwrite,0,FALSE,DUPLICATE_SAME_ACCESS);
+		CloseHandle(oread);
+		CloseHandle(eread);
+		CloseHandle(iwrite);
+
+		if( !CreateProcess(NULL,val_string(sargs),NULL,NULL,TRUE,0,NULL,NULL,&sinf,&p->pinf) ) {
+			CloseHandle(p->eread);
+			CloseHandle(p->oread);
+			CloseHandle(p->iwrite);
+			free(sargs);
+			neko_error();
+		}
+		free(sargs);
+		// close unused pipes
+		CloseHandle(sinf.hStdOutput);
+		CloseHandle(sinf.hStdError);
+		CloseHandle(sinf.hStdInput);
+	}
+#	else
+	char **argv;
+	if (isRaw) {
+		argv = (char**)alloc_private(sizeof(char*)*4);
+		argv[0] = "/bin/sh";
+		argv[1] = "-c";
+		argv[2] = val_string(cmd);
+		argv[3] = NULL;
+	} else {
+		argv = (char**)alloc_private(sizeof(char*)*(val_array_size(vargs)+2));
+		argv[0] = val_string(cmd);
+		for(i=0;i<val_array_size(vargs);i++) {
+			value v = val_array_ptr(vargs)[i];
+			val_check(v,string);
+			argv[i+1] = val_string(v);
+		}
+		argv[i+1] = NULL;
+	}
+	int input[2], output[2], error[2];
+	if( pipe(input) || pipe(output) || pipe(error) )
+		neko_error();
+	p = (vprocess*)alloc_private(sizeof(vprocess));
+	p->pid = fork();
+	if( p->pid == -1 ) {
+		do_close(input[0]);
+		do_close(input[1]);
+		do_close(output[0]);
+		do_close(output[1]);
+		do_close(error[0]);
+		do_close(error[1]);
+		neko_error();
+	}
+	// child
+	if( p->pid == 0 ) {
+		close(input[1]);
+		close(output[0]);
+		close(error[0]);
+		dup2(input[0],0);
+		dup2(output[1],1);
+		dup2(error[1],2);
+		execvp(argv[0],argv);
+		fprintf(stderr,"Command not found : %s\n",val_string(cmd));
+		exit(1);
+	}
+	// parent
+	do_close(input[0]);
+	do_close(output[1]);
+	do_close(error[1]);
+	p->iwrite = input[1];
+	p->oread = output[0];
+	p->eread = error[0];
+#	endif
+	{
+		CAMLlocal1(vp);
+		vp = alloc_abstract(k_process,p);
+		val_gc(vp,free_process);
+		CAMLreturn(vp);
+	}
+}
+
+#define CHECK_ARGS()	\
+	vprocess *p; \
+	val_check_kind(vp,k_process); \
+	val_check(str,string); \
+	val_check(pos,int); \
+	val_check(len,int); \
+	if( val_int(pos) < 0 || val_int(len) < 0 || val_int(pos) + val_int(len) > val_strlen(str) ) \
+		neko_error(); \
+	p = val_process(vp); \
+
+
+/**
+	process_stdout_read : 'process -> buf:string -> pos:int -> len:int -> int
+	<doc>
+	Read up to [len] bytes in [buf] starting at [pos] from the process stdout.
+	Returns the number of bytes read this way. Raise an exception if this
+	process stdout is closed and no more data is available for reading.
+	</doc>
+**/
+CAMLprim value process_stdout_read( value vp, value str, value pos, value len ) {
+	CHECK_ARGS();
+#	ifdef _WIN32
+	{
+		DWORD nbytes;
+		if( !ReadFile(p->oread,val_string(str)+val_int(pos),val_int(len),&nbytes,NULL) )
+			neko_error();
+		return alloc_int(nbytes);
+	}
+#	else
+	int nbytes;
+	POSIX_LABEL(stdout_read_again);
+	nbytes = read(p->oread,val_string(str)+val_int(pos),val_int(len));
+	if( nbytes < 0 ) {
+		HANDLE_EINTR(stdout_read_again);
+		neko_error();
+	}
+	if( nbytes == 0 )
+		neko_error();
+	return alloc_int(nbytes);
+#	endif
+}
+
+/**
+	process_stderr_read : 'process -> buf:string -> pos:int -> len:int -> int
+	<doc>
+	Read up to [len] bytes in [buf] starting at [pos] from the process stderr.
+	Returns the number of bytes read this way. Raise an exception if this
+	process stderr is closed and no more data is available for reading.
+	</doc>
+**/
+CAMLprim value process_stderr_read( value vp, value str, value pos, value len ) {
+	CHECK_ARGS();
+#	ifdef _WIN32
+	{
+		DWORD nbytes;
+		if( !ReadFile(p->eread,val_string(str)+val_int(pos),val_int(len),&nbytes,NULL) )
+			neko_error();
+		return alloc_int(nbytes);
+	}
+#	else
+	int nbytes;
+	POSIX_LABEL(stderr_read_again);
+	nbytes = read(p->eread,val_string(str)+val_int(pos),val_int(len));
+	if( nbytes < 0 ) {
+		HANDLE_EINTR(stderr_read_again);
+		neko_error();
+	}
+	if( nbytes == 0 )
+		neko_error();
+	return alloc_int(nbytes);
+#	endif
+}
+
+/**
+	process_stdin_write : 'process -> buf:string -> pos:int -> len:int -> int
+	<doc>
+	Write up to [len] bytes from [buf] starting at [pos] to the process stdin.
+	Returns the number of bytes writen this way. Raise an exception if this
+	process stdin is closed.
+	</doc>
+**/
+CAMLprim value process_stdin_write( value vp, value str, value pos, value len ) {
+	CHECK_ARGS();
+#	ifdef _WIN32
+	{
+		DWORD nbytes;
+		if( !WriteFile(p->iwrite,val_string(str)+val_int(pos),val_int(len),&nbytes,NULL) )
+			neko_error();
+		return alloc_int(nbytes);
+	}
+#	else
+	int nbytes;
+	POSIX_LABEL(stdin_write_again);
+	nbytes = write(p->iwrite,val_string(str)+val_int(pos),val_int(len));
+	if( nbytes == -1 ) {
+		HANDLE_EINTR(stdin_write_again);
+		neko_error();
+	}
+	return alloc_int(nbytes);
+#	endif
+}
+
+/**
+	process_stdin_close : 'process -> void
+	<doc>
+	Close the process standard input.
+	</doc>
+**/
+CAMLprim value process_stdin_close( value vp ) {
+	vprocess *p;
+	val_check_kind(vp,k_process);
+	p = val_process(vp);
+#	ifdef _WIN32
+	if( !CloseHandle(p->iwrite) )
+		neko_error();
+#	else
+	if( do_close(p->iwrite) )
+		neko_error();
+	p->iwrite = -1;
+#	endif
+	return val_null;
+}
+
+/**
+	process_exit : 'process -> int
+	<doc>
+	Wait until the process terminate, then returns its exit code.
+	</doc>
+**/
+CAMLprim value process_exit( value vp ) {
+	vprocess *p;
+	val_check_kind(vp,k_process);
+	p = val_process(vp);
+#	ifdef _WIN32
+	{
+		DWORD rval;
+		WaitForSingleObject(p->pinf.hProcess,INFINITE);
+		if( !GetExitCodeProcess(p->pinf.hProcess,&rval) )
+			neko_error();
+		return alloc_int(rval);
+	}
+#	else
+	int rval;
+	while( waitpid(p->pid,&rval,0) != p->pid ) {
+		if( errno == EINTR )
+			continue;
+		neko_error();
+	}
+	if( !WIFEXITED(rval) )
+		neko_error();
+	return alloc_int(WEXITSTATUS(rval));
+#	endif
+}
+
+/**
+	process_pid : 'process -> int
+	<doc>
+	Returns the process id.
+	</doc>
+**/
+CAMLprim value process_pid( value vp ) {
+	vprocess *p;
+	val_check_kind(vp,k_process);
+	p = val_process(vp);
+#	ifdef _WIN32
+	return alloc_int(p->pinf.dwProcessId);
+#	else
+	return alloc_int(p->pid);
+#	endif
+}
+
+/**
+	process_close : 'process -> void
+	<doc>
+	Close the process I/O.
+	</doc>
+**/
+CAMLprim value process_close( value vp ) {
+	val_check_kind(vp,k_process);
+	free_process(vp);
+	//val_kind(vp) = NULL;
+	//val_gc(vp,NULL);
+	return val_null;
+}
+
+/**
+	process_kill : 'process -> void
+	<doc>
+	Terminates a running process.
+	</doc>
+**/
+CAMLprim value process_kill( value vp ) {
+	val_check_kind(vp,k_process);
+#	ifdef _WIN32
+	TerminateProcess(val_process(vp)->pinf.hProcess,-1);
+#	else
+	kill(val_process(vp)->pid,9);
+#	endif
+	return val_null;
+}
+
+
+/* ************************************************************************ */

libs/extc/test.ml

@@ -0,0 +1,51 @@
+(*
+ *  Extc : C common OCaml bindings
+ *  Copyright (c)2004 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+
+if Array.length Sys.argv > 1 then begin
+	print_string Sys.argv.(1);
+	flush stdout;
+	prerr_string "ERROR";
+	flush stderr;
+	let input = Std.input_all stdin in
+	print_string input;
+	exit 66;
+end;
+ 
+prerr_endline "Start";
+
+prerr_endline (Extc.executable_path());
+let contents = Std.input_file "test.ml" in
+let s = Extc.unzip (Extc.zip contents) in
+if s <> contents then failwith "zip + unzip failed";
+
+let p = Process.run "test" [|"Hello"|] in
+let tmp = String.create 100 in
+let out = String.sub tmp 0 (Process.read_stdout p tmp 0 100) in
+if out <> "Hello" then failwith ("OUT=" ^ out ^ "#");
+let err = String.sub tmp 0 (Process.read_stderr p tmp 0 100) in
+if err <> "ERROR" then failwith ("ERR= " ^ err ^ "#");
+ignore(Process.write_stdin p "INPUT" 0 5);
+Process.close_stdin p;
+let out = String.sub tmp 0 (Process.read_stdout p tmp 0 100) in
+if out <> "INPUT" then failwith ("IN-OUT=" ^ out ^ "#");
+let code = Process.exit p in
+if code <> 66 then failwith ("EXIT=" ^ string_of_int code);
+Process.close p;
+
+prerr_endline "End";

libs/extlib-leftovers/Makefile

@@ -0,0 +1,35 @@
+# Makefile contributed by Alain Frisch
+OCAMLOPT=ocamlopt
+OCAMLC=ocamlc
+
+MODULES = \
+ multiArray rbuffer uCharExt uTF8
+
+# the list is topologically sorted
+
+MLI = $(MODULES:=.mli)
+SRC = $(MLI) $(MODULES:=.ml)
+
+all: bytecode native
+
+opt: native
+
+bytecode: extlib-leftovers.cma
+
+native: extlib-leftovers.cmxa
+
+extlib-leftovers.cma: $(SRC)
+	$(OCAMLC) -safe-string -a -o extlib-leftovers.cma $(SRC)
+
+extlib-leftovers.cmxa: $(SRC)
+	$(OCAMLOPT) -safe-string -g -a -o extlib-leftovers.cmxa $(SRC)
+
+clean:
+	rm -f $(wildcard *.cmo) $(wildcard *.cmx) $(wildcard *.o) $(wildcard *.cmi) $(wildcard *.cma) $(wildcard *.cmxa) $(wildcard *.a) $(wildcard *.lib) $(wildcard *.obj)
+	rm -Rf doc
+
+.PHONY: all opt bytecode native doc copy install uninstall clean
+
+Makefile: ;
+
+$(SRC): ;

libs/extlib-leftovers/dune

@@ -0,0 +1,7 @@
+(include_subdirs no)
+
+(library
+	(name extlib_leftovers)
+	(libraries extlib)
+	(wrapped false)
+)

libs/extlib-leftovers/multiArray.ml

@@ -0,0 +1,284 @@
+(*
+ * MultiArray - Resizeable Big Ocaml arrays
+ * Copyright (C) 2012 Nicolas Cannasse
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+
+type 'a intern
+
+external ilen : 'a intern -> int = "%obj_size"
+let idup (x : 'a intern) = if ilen x = 0 then x else (Obj.magic (Obj.dup (Obj.repr x)) : 'a intern)
+let imake tag len = (Obj.magic (Obj.new_block tag len) : 'a intern)
+external iget : 'a intern -> int -> 'a = "%obj_field"
+external iset : 'a intern -> int -> 'a -> unit = "%obj_set_field"
+
+type 'a t = {
+	mutable arr : 'a intern intern;
+	mutable len : int;
+	mutable darr : 'a intern option;
+}
+
+exception Invalid_arg of int * string * string
+
+let invalid_arg n f p = raise (Invalid_arg (n,f,p))
+
+let length d = d.len
+
+(* create 1K chunks, which allows up to 4GB elements *)
+
+let nbits = 10
+let size = 1 lsl nbits
+let mask = size - 1
+
+let create() =
+	{
+		len = 0;
+		arr = imake 0 0;
+		darr = Some (imake 0 0);
+	}
+
+let init len f =
+	if len > Sys.max_array_length then begin
+		let count = (len + size - 1) lsr nbits in
+		let d = {
+			len = len;
+			arr = imake 0 count;
+			darr = None;
+		} in
+		let max = count - 1 in
+		for i = 0 to max do
+			let arr = imake 0 size in
+			iset d.arr i arr;
+			for j = 0 to (if i = max then len land mask else size) - 1 do
+				iset arr j (f ((i lsl nbits) + j))
+			done;
+		done;
+		d
+	end else begin
+		let arr = imake 0 len in
+		for i = 0 to len - 1 do
+			iset arr i (f i)
+		done;
+		{
+			len = len;
+			arr = imake 0 0;
+			darr = Some arr;
+		}		
+	end
+
+let make len e =
+	if len > Sys.max_array_length then begin
+		let count = (len + size - 1) lsr nbits in
+		let d = {
+			len = len;
+			arr = imake 0 count;
+			darr = None;
+		} in
+		let max = count - 1 in
+		for i = 0 to max do
+			let arr = imake 0 size in
+			iset d.arr i arr;
+			for j = 0 to (if i = max then len land mask else size) - 1 do
+				iset arr j e
+			done;
+		done;
+		d
+	end else begin
+		let arr = imake 0 len in
+		for i = 0 to len - 1 do
+			iset arr i e
+		done;
+		{
+			len = len;
+			arr = imake 0 0;
+			darr = Some arr;
+		}
+	end
+
+let empty d =
+	d.len = 0
+
+let get d idx =
+	if idx < 0 || idx >= d.len then invalid_arg idx "get" "index";
+	match d.darr with
+	| None -> iget (iget d.arr (idx lsr nbits)) (idx land mask)
+	| Some arr -> iget arr idx
+
+let set d idx v =
+	if idx < 0 || idx >= d.len then invalid_arg idx "set" "index";
+	match d.darr with
+	| None -> iset (iget d.arr (idx lsr nbits)) (idx land mask) v
+	| Some arr -> iset arr idx v
+
+let rec add d v =
+	(match d.darr with
+	| None ->
+		let asize = ilen d.arr in
+		if d.len >= asize lsl nbits then begin
+			let narr = imake 0 (asize + 1) in
+			for i = 0 to asize-1 do
+				iset narr i (iget d.arr i);
+			done;
+			iset narr asize (imake 0 size);
+			d.arr <- narr;
+		end;
+		iset (iget d.arr (d.len lsr nbits)) (d.len land mask) v;
+	| Some arr ->
+		if d.len < ilen arr then begin
+			(* set *)
+			iset arr d.len v;			
+		end else if d.len lsl 1 >= Sys.max_array_length then begin
+			(* promote *)
+			let count = (d.len + size) lsr nbits in
+			d.darr <- None;
+			d.arr <- imake 0 count;
+			let max = count - 1 in
+			for i = 0 to max do
+				let arr2 = imake 0 size in
+				iset d.arr i arr2;
+				for j = 0 to (if i = max then d.len land mask else size) - 1 do
+					iset arr2 j (iget arr ((i lsl nbits) + j))
+				done;
+			done;
+			iset (iget d.arr (d.len lsr nbits)) (d.len land mask) v;
+		end else begin
+			(* resize *)
+			let arr2 = imake 0 (if d.len = 0 then 1 else d.len lsl 1) in
+			for i = 0 to d.len - 1 do
+				iset arr2 i (iget arr i)
+			done;
+			iset arr2 d.len v;
+			d.darr <- Some arr2;
+		end);
+	d.len <- d.len + 1
+
+let clear d =
+	d.len <- 0;
+	d.arr <- imake 0 0;
+	d.darr <- Some (imake 0 0)
+
+let of_array src =
+	let c = create() in
+	Array.iteri (fun i v -> add c v) src;
+	c
+
+let of_list src =
+	let c = create() in
+	List.iter (add c) src;
+	c
+	
+let iter f d = match d.darr with
+	| None ->
+	 	let max = ilen d.arr - 1 in
+		for i = 0 to max do
+			let arr = iget d.arr i in
+			for j = 0 to (if i = max then (d.len land mask) else size) - 1 do
+				f (iget arr j)
+			done;
+		done
+	| Some arr ->
+		for i = 0 to d.len - 1 do
+			f (iget arr i)
+		done
+
+let iteri f d = match d.darr with
+	| None ->
+		let max = ilen d.arr - 1 in
+		for i = 0 to max do
+			let arr = iget d.arr i in
+			for j = 0 to (if i = max then (d.len land mask) else size) - 1 do
+				f ((i lsl nbits) + j) (iget arr j)
+			done;
+		done
+	| Some arr ->
+		for i = 0 to d.len - 1 do
+			f i (iget arr i)
+		done
+
+let map f d = match d.darr with
+	| None ->
+		let max = ilen d.arr - 1 in
+		let d2 = {
+			len = d.len;
+			arr = imake 0 (max + 1);
+			darr = None;
+		} in
+		for i = 0 to max do
+			let arr = iget d.arr i in
+			let narr = imake 0 size in
+			iset d2.arr i narr;
+			for j = 0 to (if i = max then (d.len land mask) else size) - 1 do
+				iset narr j (f (iget arr j))
+			done;
+		done;
+		d2
+	| Some arr ->
+		let arr2 = imake 0 d.len in
+		for i = 0 to d.len - 1 do
+			iset arr2 i (f (iget arr i))
+		done;
+		{
+			len = d.len;
+			arr = imake 0 0;
+			darr = Some (arr2);
+		}
+
+let mapi f d = match d.darr with
+	| None ->
+		let max = ilen d.arr - 1 in
+		let d2 = {
+			len = d.len;
+			arr = imake 0 (max + 1);
+			darr = None;
+		} in
+		for i = 0 to max do
+			let arr = iget d.arr i in
+			let narr = imake 0 size in
+			iset d2.arr i narr;
+			for j = 0 to (if i = max then (d.len land mask) else size) - 1 do
+				iset narr j (f ((i lsl nbits) + j) (iget arr j))
+			done;
+		done;
+		d2
+	| Some arr ->
+		let arr2 = imake 0 d.len in
+		for i = 0 to d.len - 1 do
+			iset arr2 i (f i (iget arr i))
+		done;
+		{
+			len = d.len;
+			arr = imake 0 0;
+			darr = Some (arr2);
+		}
+
+let fold_left f acc d = match d.darr with
+	| None ->
+		let acc = ref acc in
+		let max = ilen d.arr - 1 in
+		for i = 0 to max do
+			let arr = iget d.arr i in
+			for j = 0 to (if i = max then (d.len land mask) else size) - 1 do
+				acc := f !acc (iget arr j)
+			done;
+		done;
+		!acc
+	| Some arr ->
+		let acc = ref acc in
+		for i = 0 to d.len - 1 do
+			acc := f !acc (iget arr i)
+		done;
+		!acc

libs/extlib-leftovers/multiArray.mli

@@ -0,0 +1,115 @@
+(*
+ * MultiArray - Resizeable Ocaml big arrays
+ * Copyright (C) 201 Nicolas Cannasse
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+
+(** Dynamic Big arrays.
+
+   A dynamic array is equivalent to a OCaml array that will resize itself
+   when elements are added or removed. MultiArray is different from DynArray
+   since it allows more than 4 Millions elements on 32 bits systems.
+
+   A MultiArray of size <= Sys.max_array_length will use a single indirection
+   internal representation. If the size exceeds Sys.max_array_length, e.g. by
+   adding an additional element, the internal representation is promoted to use
+   double indirection. This allows for bigger arrays, but it also slower.
+*)
+
+type 'a t
+
+exception Invalid_arg of int * string * string
+(** When an operation on an array fails, [Invalid_arg] is raised. The
+	integer is the value that made the operation fail, the first string
+	contains the function name that has been called and the second string
+	contains the parameter name that made the operation fail.
+*)
+
+(** {6 MultiArray creation} *)
+
+val create : unit -> 'a t
+(** [create()] returns a new empty dynamic array. *)
+
+val make : int -> 'a -> 'a t
+(** [make count value] returns an array with some memory already allocated and
+	[count] elements initialized to [value]. *)
+
+val init : int -> (int -> 'a) -> 'a t
+(** [init n f] returns an array of [n] elements filled with values
+	returned by [f 0 , f 1, ... f (n-1)]. *)
+
+(** {6 MultiArray manipulation functions} *)
+
+val empty : 'a t -> bool
+(** Return true if the number of elements in the array is 0. *)
+
+val length : 'a t -> int
+(** Return the number of elements in the array. *)
+
+val get : 'a t -> int -> 'a
+(** [get darr idx] gets the element in [darr] at index [idx]. If [darr] has
+	[len] elements in it, then the valid indexes range from [0] to [len-1]. *)
+
+val set : 'a t -> int -> 'a -> unit
+(** [set darr idx v] sets the element of [darr] at index [idx] to value
+	[v].  The previous value is overwritten. *)
+
+val add : 'a t -> 'a -> unit
+(** [add darr v] appends [v] onto [darr].  [v] becomes the new
+	last element of [darr]. If required, the size of the internal representation
+	is doubled. If this would exceed Sys.max_array_length, the internal
+	representation is automatically changed to double indirection and the
+	current contents are copied over. *)
+
+val clear : 'a t -> unit
+(** remove all elements from the array and resize it to 0. *)
+
+(** {6 MultiArray copy and conversion} *)
+
+val of_array : 'a array -> 'a t
+(** [of_array arr] returns an array with the elements of [arr] in it
+	in order. *)
+
+val of_list : 'a list -> 'a t
+(** [of_list lst] returns a dynamic array with the elements of [lst] in
+	it in order. *)
+
+(** {6 MultiArray functional support} *)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** [iter f darr] calls the function [f] on every element of [darr].  It
+	is equivalent to [for i = 0 to length darr - 1 do f (get darr i) done;] *)
+
+val iteri : (int -> 'a -> unit) -> 'a t -> unit
+(** [iter f darr] calls the function [f] on every element of [darr].  It
+	is equivalent to [for i = 0 to length darr - 1 do f i (get darr i) done;]
+	*)
+
+val map : ('a -> 'b) -> 'a t -> 'b t
+(** [map f darr] applies the function [f] to every element of [darr]
+	and creates a dynamic array from the results - similar to [List.map] or
+	[Array.map]. *)
+
+val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t
+(** [mapi f darr] applies the function [f] to every element of [darr]
+	and creates a dynamic array from the results - similar to [List.mapi] or
+	[Array.mapi]. *)
+
+val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
+(** [fold_left f x darr] computes
+	[f ( ... ( f ( f (get darr 0) x) (get darr 1) ) ... ) (get darr n-1)],
+	similar to [Array.fold_left] or [List.fold_left]. *)

libs/extlib-leftovers/rbuffer.ml

@@ -0,0 +1,219 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Copyright (C) Jean-Christophe Filliatre                               *)
+(*                                                                        *)
+(*  This software is free software; you can redistribute it and/or        *)
+(*  modify it under the terms of the GNU Library General Public           *)
+(*  License version 2.1, with the special exception on linking            *)
+(*  described in file LICENSE.                                            *)
+(*                                                                        *)
+(*  This software 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.                  *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Ropes-based implementation of Buffer *)
+
+type rope =
+  | Str of string
+  | App of rope * rope * int (* total length *)
+
+let rope_empty = Str ""
+
+let rope_length = function
+  | Str s -> String.length s
+  | App (_, _, n) -> n
+
+let rec rope_nth i = function
+  | Str s ->
+      String.unsafe_get s i
+  | App (l, r, _) ->
+      let ll = rope_length l in
+      if i < ll then rope_nth i l else rope_nth (i - ll) r
+
+type t = {
+  mutable rope : rope;     (* the left part is a rope *)
+  mutable buffer : bytes; (* the right part is a buffer... *)
+  mutable position : int;  (* ...with [position] bytes used *)
+}
+
+let create n =
+  let n = if n < 1 then 1 else n in
+  let n = if n > Sys.max_string_length then Sys.max_string_length else n in
+  let s = Bytes.create n in
+  { rope = rope_empty; buffer = s; position = 0; }
+
+let reset b =
+  b.rope <- rope_empty;
+  b.position <- 0
+
+let clear = reset
+
+let length b =
+  rope_length b.rope + b.position
+
+(* [blit s i r] blits the contents of rope [r] in string [s] at index [i] *)
+let rec blit_rope s i = function
+  | Str str ->
+      String.blit str 0 s i (String.length str)
+  | App (l, r, _) ->
+      let ll = rope_length l in
+      blit_rope s i l;
+      blit_rope s (i + ll) r
+
+(* rename contents to unsafe_contents to avoid accidental usage *)
+let unsafe_contents b =
+  let r = rope_length b.rope in
+  let n = b.position in
+  let len = r + n in
+  if len > Sys.max_string_length then invalid_arg "Rbuffer.contents";
+  let s = Bytes.create len in
+  blit_rope s 0 b.rope;
+  Bytes.blit b.buffer 0 s r n;
+  Bytes.unsafe_to_string s
+
+(* [blit_subrope s i ofs len] blits the subrope [r[ofs..ofs+len-1]] in string
+   [s] at index [i] *)
+let rec blit_subrope s i ofs len = function
+  | Str str ->
+      assert (ofs >= 0 && ofs + len <= String.length str);
+      String.blit str ofs s i len
+  | App (l, r, _) ->
+      let ll = rope_length l in
+      if ofs + len <= ll then
+	blit_subrope s i ofs len l
+      else if ofs >= ll then
+	blit_subrope s i (ofs - ll) len r
+      else begin
+	let lenl = ll - ofs in
+	blit_subrope s i ofs lenl l;
+	blit_subrope s (i + lenl) 0 (len - lenl) r
+      end
+
+let sub b ofs len =
+  let r = rope_length b.rope in
+  if len > Sys.max_string_length ||
+     ofs < 0 || len < 0 || ofs > r + b.position - len
+  then invalid_arg "Buffer.sub";
+  let s = Bytes.create len in
+  if ofs + len <= r then
+    blit_subrope s 0 ofs len b.rope
+  else if ofs >= r then
+    Bytes.blit b.buffer (ofs - r) s 0 len
+  else begin
+    blit_subrope s 0 ofs (r - ofs) b.rope;
+    Bytes.blit b.buffer 0 s (r - ofs) (ofs + len - r)
+  end;
+  Bytes.unsafe_to_string s
+
+let nth b i =
+  let r = rope_length b.rope in
+  if i < 0 || i >= r + b.position then invalid_arg "Buffer.nth";
+  if i < r then rope_nth i b.rope else Bytes.unsafe_get b.buffer (i - r)
+
+(* moves the data in [b.buffer], if any, to the rope; ensures [b.position=0] *)
+let move_buffer_to_rope b =
+  let pos = b.position in
+  if pos > 0 then begin
+    let n = Bytes.length b.buffer in
+    if pos = n then begin
+      (* whole buffer goes to the rope; faster to allocate a new buffer *)
+      b.rope <- App (b.rope, Str (Bytes.unsafe_to_string b.buffer), rope_length b.rope + pos);
+      b.buffer <- Bytes.create n
+    end else begin
+      (* part of the buffer goes to the rope; easier to copy it *)
+      b.rope <- App (b.rope, Str (Bytes.sub_string b.buffer 0 pos),
+		     rope_length b.rope + pos)
+    end;
+    b.position <- 0
+  end
+
+let add_char b c =
+  if b.position = Bytes.length b.buffer then move_buffer_to_rope b;
+  let pos = b.position in
+  Bytes.set b.buffer pos c;
+  b.position <- pos + 1
+
+(* allocates space for [len] bytes and returns the corresponding place
+   (as a string and an offset within that string) *)
+let alloc b len =
+  let n = Bytes.length b.buffer in
+  let pos = b.position in
+  let len' = pos + len in
+  if len' <= n then begin
+    (* fits in the buffer *)
+    b.position <- len';
+    b.buffer, pos
+  end else if len' <= Sys.max_string_length then begin
+    (* buffer and len fit in a new string, allocated in the rope *)
+    let str = Bytes.create len' in
+    Bytes.blit b.buffer 0 str 0 pos;
+    b.rope <- App (b.rope, Str (Bytes.unsafe_to_string str), rope_length b.rope + len');
+    b.position <- 0;
+    str, pos
+  end else begin
+    (* buffer and len require two strings, allocated in the rope *)
+    let str = Bytes.create len in
+    b.rope <- App (b.rope,
+		   App (Str (Bytes.sub_string b.buffer 0 pos), Str (Bytes.unsafe_to_string str), len'),
+		   rope_length b.rope + len');
+    b.position <- 0;
+    str, 0
+  end
+
+let safe_add_substring b s offset len =
+  let str, pos = alloc b len in
+  String.blit s offset str pos len
+
+let add_substring b s offset len =
+  if offset < 0 || len < 0 || offset > String.length s - len
+  then invalid_arg "Buffer.add_substring";
+  safe_add_substring b s offset len
+
+let add_string b s =
+  safe_add_substring b s 0 (String.length s)
+
+let add_buffer b b2 =
+  if b.position > 0 then move_buffer_to_rope b;
+  (* now we have b.position = 0 *)
+  b.rope <- App (b.rope, b2.rope, rope_length b.rope + rope_length b2.rope);
+  add_substring b (Bytes.unsafe_to_string b2.buffer) 0 b2.position
+
+let rec add_channel b ic len =
+  if len <= Sys.max_string_length then begin
+    let str, pos = alloc b len in
+    really_input ic str pos len
+  end else begin
+    let str, pos = alloc b Sys.max_string_length in
+    really_input ic str pos Sys.max_string_length;
+    add_channel b ic (len - Sys.max_string_length)
+  end
+
+let output_buffer oc b =
+  let rec loop wl = match wl with
+    | Str s :: wl ->
+      output oc (Bytes.of_string s) 0 (String.length s);
+      loop wl
+    | App( l, r, _) :: wl ->
+      loop (l :: r :: wl)
+    | [] ->
+      ()
+  in
+  loop [b.rope];
+  output oc b.buffer 0 b.position
+
+open Format
+
+let print fmt b =
+  let rec loop wl = match wl with
+    | Str s :: wl ->
+      pp_print_string fmt s;
+      loop wl
+    | App( l, r, _) :: wl ->
+      loop (l :: r :: wl)
+    | [] ->
+      ()
+  in
+  loop [b.rope];
+  pp_print_string fmt (Bytes.sub_string b.buffer 0 b.position)

libs/extlib-leftovers/rbuffer.mli

@@ -0,0 +1,39 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Copyright (C) Jean-Christophe Filliatre                               *)
+(*                                                                        *)
+(*  This software is free software; you can redistribute it and/or        *)
+(*  modify it under the terms of the GNU Library General Public           *)
+(*  License version 2.1, with the special exception on linking            *)
+(*  described in file LICENSE.                                            *)
+(*                                                                        *)
+(*  This software 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.                  *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Ropes-based implementation of Buffer *)
+
+type t
+
+val create : int -> t
+val reset : t -> unit
+val clear : t -> unit
+val length : t -> int
+
+val unsafe_contents : t -> string
+
+val sub : t -> int -> int -> string
+val nth : t -> int -> char
+
+
+val add_char : t -> char -> unit
+
+val add_substring : t -> string -> int -> int -> unit
+val add_string : t -> string -> unit
+val add_buffer : t -> t -> unit
+
+val add_channel : t -> in_channel -> int -> unit
+
+val output_buffer : out_channel -> t -> unit

libs/extlib-leftovers/uCharExt.ml

@@ -0,0 +1,48 @@
+(* 
+ * UChar - Unicode (ISO-UCS) characters
+ * Copyright (C) 2002, 2003 Yamagata Yoriyuki
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+
+type t = int
+
+exception Out_of_range
+
+external unsafe_chr_of_uint : int -> t = "%identity"
+external uint_code : t -> int = "%identity"
+
+let char_of c = 
+  if c >= 0 && c < 0x100 then Char.chr c else raise Out_of_range
+
+let of_char = Char.code
+
+let code c = if c >= 0 then c else raise Out_of_range
+
+let chr n =
+  if n >= 0 && n lsr 31 = 0 then n else invalid_arg "UChar.chr"
+
+let chr_of_uint n = if n lsr 31 = 0 then n else invalid_arg "UChar.uint_chr"
+  
+let eq (u1 : t) (u2 : t) = u1 = u2
+let compare u1 u2 =
+  let sgn = (u1 lsr 16) - (u2 lsr 16) in
+  if sgn = 0 then (u1 land 0xFFFF) -  (u2 land 0xFFFF) else sgn
+
+type uchar = t
+
+let int_of_uchar u = uint_code u
+let uchar_of_int n = chr_of_uint n

libs/extlib-leftovers/uCharExt.mli

@@ -0,0 +1,79 @@
+(* 
+ * UChar - Unicode (ISO-UCS) characters
+ * Copyright (C) 2002, 2003 Yamagata Yoriyuki
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+
+(** Unicode (ISO-UCS) characters.
+
+   This module implements Unicode (actually ISO-UCS) characters.  All
+   31-bit code points are allowed.
+*)
+
+(** Unicode characters. All 31-bit code points are allowed.*) 
+type t
+
+exception Out_of_range
+
+(** [char_of u] returns the Latin-1 representation of [u].
+   If [u] can not be represented by Latin-1, raises Out_of_range *)
+val char_of : t -> char
+
+(** [of_char c] returns the Unicode character of the Latin-1 character [c] *)
+val of_char : char -> t
+
+(** [code u] returns the Unicode code number of [u].
+   If the value can not be represented by a positive integer,
+   raise Out_of_range *)
+val code : t -> int
+
+(** [code n] returns the Unicode character with the code number [n]. 
+   If n >= 2^32 or n < 0, raises [invalid_arg] *)
+val chr : int -> t
+
+(** [uint_code u] returns the Unicode code number of [u].
+   The returned int is unsigned, that is, on 32-bit platforms,
+   the sign bit is used for storing the 31-th bit of the code number. *)
+external uint_code : t -> int = "%identity"
+
+(** [chr_of_uint n] returns the Unicode character of the code number [n].
+   [n] is interpreted as unsigned, that is, on 32-bit platforms,
+   the sign bit is treated as the 31-th bit of the code number.
+   If n exceeds 31-bit values, then raise [Invalid_arg]. *)
+val chr_of_uint : int -> t
+
+(** Unsafe version of {!UChar.chr_of_uint}.
+   No check of its argument is performed. *)
+external unsafe_chr_of_uint : int -> t = "%identity"
+
+(** Equality by code point comparison *)
+val eq : t -> t -> bool
+
+(** [compare u1 u2] returns, 
+   a value > 0 if [u1] has a larger Unicode code number than [u2], 
+   0 if [u1] and [u2] are the same Unicode character,
+   a value < 0 if [u1] has a smaller Unicode code number than [u2]. *)
+val compare : t -> t -> int
+
+(** Aliases of [type t] *)
+type uchar = t
+
+(** Alias of [uint_code] *)
+val int_of_uchar : uchar -> int
+
+(** Alias of [chr_of_uint] *)
+val uchar_of_int : int -> uchar

libs/extlib-leftovers/uTF8.ml

@@ -0,0 +1,220 @@
+(*
+ * UTF-8 - UTF-8 encoded Unicode string
+ * Copyright 2002, 2003 (C) Yamagata Yoriyuki.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+
+open UCharExt
+
+type t = string
+type index = int
+
+let look s i =
+  let n' =
+    let n = Char.code s.[i] in
+    if n < 0x80 then n else
+    if n <= 0xdf then
+      (n - 0xc0) lsl 6 lor (0x7f land (Char.code s.[i + 1]))
+    else if n <= 0xef then
+      let n' = n - 0xe0 in
+      let m0 = Char.code s.[i + 2] in
+      let m = Char.code (String.unsafe_get s (i + 1)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      n' lsl 6 lor (0x7f land m0)
+    else if n <= 0xf7 then
+      let n' = n - 0xf0 in
+      let m0 = Char.code s.[i + 3] in
+      let m = Char.code (String.unsafe_get s (i + 1)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      let m = Char.code (String.unsafe_get s (i + 2)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      n' lsl 6 lor (0x7f land m0)
+    else if n <= 0xfb then
+      let n' = n - 0xf8 in
+      let m0 = Char.code s.[i + 4] in
+      let m = Char.code (String.unsafe_get s (i + 1)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      let m = Char.code (String.unsafe_get s (i + 2)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      let m = Char.code (String.unsafe_get s (i + 3)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      n' lsl 6 lor (0x7f land m0)
+    else if n <= 0xfd then
+      let n' = n - 0xfc in
+      let m0 = Char.code s.[i + 5] in
+      let m = Char.code (String.unsafe_get s (i + 1)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      let m = Char.code (String.unsafe_get s (i + 2)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      let m = Char.code (String.unsafe_get s (i + 3)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      let m = Char.code (String.unsafe_get s (i + 4)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      n' lsl 6 lor (0x7f land m0)
+    else invalid_arg "UTF8.look"
+  in
+  Obj.magic n'
+
+let rec search_head s i =
+  if i >= String.length s then i else
+  let n = Char.code (String.unsafe_get s i) in
+  if n < 0x80 || n >= 0xc2 then i else
+  search_head s (i + 1)
+
+let next s i =
+  let n = Char.code s.[i] in
+  if n < 0x80 then i + 1 else
+  if n < 0xc0 then search_head s (i + 1) else
+  if n <= 0xdf then i + 2
+  else if n <= 0xef then i + 3
+  else if n <= 0xf7 then i + 4
+  else if n <= 0xfb then i + 5
+  else if n <= 0xfd then i + 6
+  else invalid_arg "UTF8.next"
+
+let rec search_head_backward s i =
+  if i < 0 then -1 else
+  let n = Char.code s.[i] in
+  if n < 0x80 || n >= 0xc2 then i else
+  search_head_backward s (i - 1)
+
+let prev s i = search_head_backward s (i - 1)
+
+let move s i n =
+  if n >= 0 then
+    let rec loop i n = if n <= 0 then i else loop (next s i) (n - 1) in
+    loop i n
+  else
+    let rec loop i n = if n >= 0 then i else loop (prev s i) (n + 1) in
+    loop i n
+
+let rec nth_aux s i n =
+  if n = 0 then i else
+  nth_aux s (next s i) (n - 1)
+
+let nth s n = nth_aux s 0 n
+
+let last s = search_head_backward s (String.length s - 1)
+
+let out_of_range s i = i < 0 || i >= String.length s
+
+let compare_index _ i j = i - j
+
+let get s n = look s (nth s n)
+
+let add_uchar buf u =
+  let masq = 0b111111 in
+  let k = int_of_uchar u in
+  if k < 0 || k >= 0x4000000 then begin
+    Buffer.add_char buf (Char.chr (0xfc + (k lsr 30)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 24) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 18) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 12) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq)));
+  end else if k <= 0x7f then
+    Buffer.add_char buf (Char.unsafe_chr k)
+  else if k <= 0x7ff then begin
+    Buffer.add_char buf (Char.unsafe_chr (0xc0 lor (k lsr 6)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq)))
+  end else if k <= 0xffff then begin
+    Buffer.add_char buf (Char.unsafe_chr (0xe0 lor (k lsr 12)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq)));
+  end else if k <= 0x1fffff then begin
+    Buffer.add_char buf (Char.unsafe_chr (0xf0 + (k lsr 18)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 12) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq)));
+  end else begin
+    Buffer.add_char buf (Char.unsafe_chr (0xf8 + (k lsr 24)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 18) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 12) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq)));
+  end
+
+let init len f =
+  let buf = Buffer.create len in
+  for c = 0 to len - 1 do add_uchar buf (f c) done;
+  Buffer.contents buf
+
+let rec length_aux s c i =
+  if i >= String.length s then c else
+  let n = Char.code (String.unsafe_get s i) in
+  let k =
+    if n < 0x80 then 1 else
+    if n < 0xc0 then invalid_arg "UTF8.length" else
+    if n < 0xe0 then 2 else
+    if n < 0xf0 then 3 else
+    if n < 0xf8 then 4 else
+    if n < 0xfc then 5 else
+    if n < 0xfe then 6 else
+    invalid_arg "UTF8.length" in
+  length_aux s (c + 1) (i + k)
+
+let length s = length_aux s 0 0
+
+let rec iter_aux proc s i =
+  if i >= String.length s then () else
+  let u = look s i in
+  proc u;
+  iter_aux proc s (next s i)
+
+let iter proc s = iter_aux proc s 0
+
+let compare s1 s2 = Pervasives.compare s1 s2
+
+exception Malformed_code
+
+let validate s =
+  let rec trail c i a =
+    if c = 0 then a else
+    if i >= String.length s then raise Malformed_code else
+    let n = Char.code (String.unsafe_get s i) in
+    if n < 0x80 || n >= 0xc0 then raise Malformed_code else
+    trail (c - 1) (i + 1) (a lsl 6 lor (n - 0x80)) in
+  let rec main i =
+    if i >= String.length s then () else
+    let n = Char.code (String.unsafe_get s i) in
+    if n < 0x80 then main (i + 1) else
+    if n < 0xc2 then raise Malformed_code else
+    if n <= 0xdf then
+      if trail 1 (i + 1) (n - 0xc0) < 0x80 then raise Malformed_code else
+      main (i + 2)
+    else if n <= 0xef then
+      if trail 2 (i + 1) (n - 0xe0) < 0x800 then raise Malformed_code else
+      main (i + 3)
+    else if n <= 0xf7 then
+      if trail 3 (i + 1) (n - 0xf0) < 0x10000 then raise Malformed_code else
+      main (i + 4)
+    else if n <= 0xfb then
+      if trail 4 (i + 1) (n - 0xf8) < 0x200000 then raise Malformed_code else
+      main (i + 5)
+    else if n <= 0xfd then
+      let n = trail 5 (i + 1) (n - 0xfc) in
+      if n lsr 16 < 0x400 then raise Malformed_code else
+      main (i + 6)
+    else raise Malformed_code in
+  main 0
+
+module Buf =
+  struct
+    include Buffer
+    type buf = t
+    let add_char = add_uchar
+  end

libs/extlib-leftovers/uTF8.mli

@@ -0,0 +1,146 @@
+(*
+ * UTF-8 - UTF-8 encoded Unicode string
+ * Copyright 2002, 2003 (C) Yamagata Yoriyuki.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+
+(** UTF-8 encoded Unicode strings.
+
+   The Module for UTF-8 encoded Unicode strings.
+*)
+
+open UCharExt
+
+(** UTF-8 encoded Unicode strings. the type is normal string. *)
+type t = string
+
+exception Malformed_code
+
+(** [validate s]
+   Succeeds if s is valid UTF-8, otherwise raises Malformed_code.
+   Other functions assume strings are valid UTF-8, so it is prudent
+   to test their validity for strings from untrusted origins. *)
+val validate : t -> unit
+
+(* All functions below assume string are valid UTF-8.  If not,
+ * the result is unspecified. *)
+
+(** [get s n] returns [n]-th Unicode character of [s].
+   The call requires O(n)-time. *)
+val get : t -> int -> uchar
+
+(** [init len f]
+   returns a new string which contains [len] Unicode characters.
+   The i-th Unicode character is initialized by [f i] *)
+val init : int -> (int -> uchar) -> t
+
+(** [length s] returns the number of Unicode characters contained in s *)
+val length : t -> int
+
+(** Positions in the string represented by the number of bytes from the head.
+   The location of the first character is [0] *)
+type index = int
+
+(** [nth s n] returns the position of the [n]-th Unicode character.
+   The call requires O(n)-time *)
+val nth : t -> int -> index
+
+(** The position of the head of the last Unicode character. *)
+val last : t -> index
+
+(** [look s i]
+   returns the Unicode character of the location [i] in the string [s]. *)
+val look : t -> index -> uchar
+
+(** [out_of_range s i]
+   tests whether [i] is a position inside of [s]. *)
+val out_of_range : t -> index -> bool
+
+(** [compare_index s i1 i2] returns
+   a value < 0 if [i1] is the position located before [i2],
+   0 if [i1] and [i2] points the same location,
+   a value > 0 if [i1] is the position located after [i2]. *)
+val compare_index : t -> index -> index -> int
+
+(** [next s i]
+   returns the position of the head of the Unicode character
+   located immediately after [i].
+   If [i] is inside of [s], the function always successes.
+   If [i] is inside of [s] and there is no Unicode character after [i],
+   the position outside [s] is returned.
+   If [i] is not inside of [s], the behaviour is unspecified. *)
+val next : t -> index -> index
+
+(** [prev s i]
+   returns the position of the head of the Unicode character
+   located immediately before [i].
+   If [i] is inside of [s], the function always successes.
+   If [i] is inside of [s] and there is no Unicode character before [i],
+   the position outside [s] is returned.
+   If [i] is not inside of [s], the behaviour is unspecified. *)
+val prev : t -> index -> index
+
+(** [move s i n]
+   returns [n]-th Unicode character after [i] if n >= 0,
+   [n]-th Unicode character before [i] if n < 0.
+   If there is no such character, the result is unspecified. *)
+val move : t -> index -> int -> index
+
+(** [iter f s]
+   applies [f] to all Unicode characters in [s].
+   The order of application is same to the order
+   of the Unicode characters in [s]. *)
+val iter : (uchar -> unit) -> t -> unit
+
+(** Code point comparison by the lexicographic order.
+   [compare s1 s2] returns
+   a positive integer if [s1] > [s2],
+   0 if [s1] = [s2],
+   a negative integer if [s1] < [s2]. *)
+val compare : t -> t -> int
+
+val add_uchar : Buffer.t -> uchar -> unit
+
+(** Buffer module for UTF-8 strings *)
+module Buf : sig
+  (** Buffers for UTF-8 strings. *)
+  type buf
+
+  (** [create n] creates a buffer with the initial size [n]-bytes. *)
+  val create : int -> buf
+
+  (* The rest of functions is similar to the ones of Buffer in stdlib. *)
+  (** [contents buf] returns the contents of the buffer. *)
+  val contents : buf -> t
+
+  (** Empty the buffer,
+     but retains the internal storage which was holding the contents *)
+  val clear : buf -> unit
+
+  (** Empty the buffer and de-allocate the internal storage. *)
+  val reset : buf -> unit
+
+  (** Add one Unicode character to the buffer. *)
+  val add_char : buf -> uchar -> unit
+
+  (** Add the UTF-8 string to the buffer. *)
+  val add_string : buf -> t -> unit
+
+  (** [add_buffer b1 b2] adds the contents of [b2] to [b1].
+     The contents of [b2] is not changed. *)
+  val add_buffer : buf -> buf -> unit
+end

libs/ilib/Makefile

@@ -0,0 +1,26 @@
+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): ;

libs/ilib/dump.ml

@@ -0,0 +1,38 @@
+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 <exe-path>"
+	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()

libs/ilib/dune

@@ -0,0 +1,9 @@
+(include_subdirs no)
+
+(library
+	(name ilib)
+	(modules_without_implementation ilData ilMeta)
+	(modules (:standard \ dump))
+	(libraries extlib)
+	(wrapped false)
+)

libs/ilib/ilData.mli

@@ -0,0 +1,115 @@
+(*
+ *  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;
+}

libs/ilib/ilMeta.mli

@@ -0,0 +1,1204 @@
+(*
+ *  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 <underlying type><rank><num_sizes><size1>...<sizeN>
+			          <num_lower_bounds><lower_bound1>...<lower_boundM> *)
+			(* <rank> is the number of dimensions (K>0) *)
+			(* <num_sizes> num of specified sizes for dimensions (N <= K) *)
+			(* <num_lower_bounds> num of lower bounds (M <= K) *)
+			(* all int values are compressed *)
+	| SGenericInst of ilsig * (ilsig list) (* 0x15 *)
+		(* A generic type instantiation. encoded like: *)
+			(* SGenericInst <type> <type-arg-count> <type1>...<typeN> *)
+	| 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 <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 <variant-type> *)
+	| NFixedArray of int * variantsig (* 0x1E *)
+		(* fixed-size array, of size <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 (<class_str>, <cookie_str>) *)
+	| NError (* 0x2D *)
+		(* maps in32 to VT_HRESULT *)
+  | NCustom of int
+
+and variantsig =
+	| VT_EMPTY (* 0x00 *)
+		(* No <empty> *)
+	| 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 <v_type> vector *) *)
+	(* | VT_ARRAY of variantsig (* 0x2000 *) *)
+	(* 	(* Yes <v_type> [ ] *) *)
+	(* | VT_BYREF of variantsig (* 0x4000 *) *)
+	(* 	(* Yes <v_type> & *) *)

libs/ilib/ilMetaDebug.ml

@@ -0,0 +1,24 @@
+(*
+ *  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

libs/ilib/ilMetaReader.ml

@@ -0,0 +1,2403 @@
+(*
+ *  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 = "<not initialized>"
+
+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 ->
+			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;
+	}
+

libs/ilib/ilMetaTools.ml

@@ -0,0 +1,472 @@
+(*
+ *  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;
+	}

libs/ilib/ilMetaWriter.ml

@@ -0,0 +1,78 @@
+(*
+ *  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

libs/ilib/peData.ml

@@ -0,0 +1,546 @@
+(*
+ *  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 *)
+
+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 *)
+}

libs/ilib/peDataDebug.ml

@@ -0,0 +1,184 @@
+(*
+ *  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"
+
+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))

libs/ilib/peReader.ml

@@ -0,0 +1,493 @@
+(*
+ *  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 : Pervasives.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 =
+	Pervasives.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 *)
+	| _ -> 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);
+	}

libs/ilib/peWriter.ml

@@ -0,0 +1,158 @@
+(*
+ *  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 *)
+
+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

libs/javalib/Makefile

@@ -0,0 +1,22 @@
+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): ;

libs/javalib/dune

@@ -0,0 +1,7 @@
+(include_subdirs no)
+
+(library
+	(name javalib)
+	(libraries extlib)
+	(wrapped false)
+)

libs/javalib/jData.ml

@@ -0,0 +1,250 @@
+(*
+ *  This file is part of JavaLib
+ *  Copyright (c)2004-2012 Nicolas Cannasse and Caue Waneck
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 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 <init> *)
+  | 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 "<init>" and "<clinit>" values *)
+  | ConstMethod of (jpath * unqualified_name * jmethod_signature) (* tag = 10 *)
+  (** interface method reference *)
+  | ConstInterfaceMethod of (jpath * unqualified_name * jmethod_signature) (* tag = 11 *)
+  (** constant values *)
+  | ConstString of string  (* tag = 8 *)
+  | ConstInt of int32 (* tag = 3 *)
+  | ConstFloat of float (* tag = 4 *)
+  | ConstLong of int64 (* tag = 5 *)
+  | ConstDouble of float (* tag = 6 *)
+  (** name and type: used to represent a field or method, without indicating which class it belongs to *)
+  | ConstNameAndType of unqualified_name * jsignature
+  (** UTF8 encoded strings. Note that when reading/writing, take into account Utf8 modifications of java *)
+  (* (http://docs.oracle.com/javase/specs/jvms/se7/html/jvms-4.html#jvms-4.4.7) *)
+  | ConstUtf8 of string
+  (** invokeDynamic-specific *)
+  | ConstMethodHandle of (reference_type * jconstant) (* tag = 15 *)
+  | ConstMethodType of jmethod_signature (* tag = 16 *)
+  | ConstInvokeDynamic of (bootstrap_method * unqualified_name * jsignature) (* tag = 18 *)
+  | ConstUnusable
+
+type jcode = unit (* TODO *)
+
+type jaccess_flag =
+  | JPublic (* 0x0001 *)
+  | JPrivate (* 0x0002 *)
+  | JProtected (* 0x0004 *)
+  | JStatic (* 0x0008 *)
+  | JFinal (* 0x0010 *)
+  | JSynchronized (* 0x0020 *)
+  | JVolatile (* 0x0040 *)
+  | JTransient (* 0x0080 *)
+  (** added if created by the compiler *)
+  | JSynthetic (* 0x1000 *)
+  | JEnum (* 0x4000 *)
+  | JUnusable (* should not be present *)
+  (** class flags *)
+  | JSuper (* 0x0020 *)
+  | JInterface (* 0x0200 *)
+  | JAbstract (* 0x0400 *)
+  | JAnnotation (* 0x2000 *)
+  (** method flags *)
+  | JBridge (* 0x0040 *)
+  | JVarArgs (* 0x0080 *)
+  | JNative (* 0x0100 *)
+  | JStrict (* 0x0800 *)
+
+type jaccess = jaccess_flag list
+
+(* type parameter name, extends signature, implements signatures *)
+type jtypes = (string * jsignature option * jsignature list) list
+
+type jannotation = {
+  ann_type : jsignature;
+  ann_elements : (string * jannotation_value) list;
+}
+
+and jannotation_value =
+  | ValConst of 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 jattribute =
+  | AttrDeprecated
+  | AttrVisibleAnnotations of jannotation list
+  | AttrInvisibleAnnotations of jannotation list
+  | AttrUnknown of string * string
+
+type jfield_kind =
+  | JKField
+  | JKMethod
+
+type jfield = {
+  jf_name : string;
+  jf_kind : jfield_kind;
+  (* signature, as used by the vm *)
+  jf_vmsignature : jsignature;
+  (* actual signature, as used in java code *)
+  jf_signature : jsignature;
+  jf_throws : jsignature list;
+  jf_types : jtypes;
+  jf_flags : jaccess;
+  jf_attributes : jattribute list;
+  jf_constant : jconstant option;
+  jf_code : jcode option;
+}
+
+type jclass = {
+  cversion : jversion;
+  cpath : jpath;
+  csuper : jsignature;
+  cflags : jaccess;
+  cinterfaces : jsignature list;
+  cfields : jfield list;
+  cmethods : jfield list;
+  cattributes : jattribute list;
+
+  cinner_types : (jpath * jpath option * string option * jaccess) list;
+  ctypes : jtypes;
+}
+
+(* reading/writing *)
+type utf8ref = int
+type classref = int
+type nametyperef = int
+type dynref = int
+type bootstrapref = int
+
+type jconstant_raw =
+  | KClass of utf8ref (* 7 *)
+  | KFieldRef of (classref * nametyperef) (* 9 *)
+  | KMethodRef of (classref * nametyperef) (* 10 *)
+  | KInterfaceMethodRef of (classref * nametyperef) (* 11 *)
+  | KString of utf8ref (* 8 *)
+  | KInt of int32 (* 3 *)
+  | KFloat of float (* 4 *)
+  | KLong of int64 (* 5 *)
+  | KDouble of float (* 6 *)
+  | KNameAndType of (utf8ref * utf8ref) (* 12 *)
+  | KUtf8String of string (* 1 *)
+  | KMethodHandle of (reference_type * dynref) (* 15 *)
+  | KMethodType of utf8ref (* 16 *)
+  | KInvokeDynamic of (bootstrapref * nametyperef) (* 18 *)
+  | KUnusable
+
+(* jData debugging *)
+let is_override_attrib = (function
+    (* TODO: pass anotations as @:meta *)
+    | AttrVisibleAnnotations ann ->
+      List.exists (function
+        | { ann_type = TObject( (["java";"lang"], "Override"), [] ) } ->
+            true
+        | _ -> false
+      ) ann
+    | _ -> false
+  )
+
+let is_override field =
+  List.exists is_override_attrib field.jf_attributes
+
+let path_s = function
+  | (pack,name) -> String.concat "." (pack @ [name])
+
+let rec s_sig = function
+  | TByte (* B *) -> "byte"
+  | TChar (* C *) -> "char"
+  | TDouble (* D *) -> "double"
+  | TFloat (* F *) -> "float"
+  | TInt (* I *) -> "int"
+  | TLong (* J *) -> "long"
+  | TShort (* S *) -> "short"
+  | TBool (* Z *) -> "bool"
+  | TObject(path,args) -> path_s  path ^ s_args args
+  | TObjectInner (sl, sjargl) -> String.concat "." sl ^ "." ^ (String.concat "." (List.map (fun (s,arg) -> s ^ s_args arg) sjargl))
+  | TArray (s,i) -> s_sig s ^ "[" ^ (match i with | None -> "" | Some i -> string_of_int i) ^ "]"
+  | TMethod (sigs, sopt) -> (match sopt with | None -> "" | Some s -> s_sig s ^ " ") ^ "(" ^ String.concat ", " (List.map s_sig sigs) ^ ")"
+  | TTypeParameter s -> s
+
+and s_args = function
+  | [] -> ""
+  | args -> "<" ^ String.concat ", " (List.map (fun t ->
+      match t with
+      | TAny -> "*"
+      | TType (wc, s) ->
+        (match wc with
+          | WNone -> ""
+          | WExtends -> "+"
+          | WSuper -> "-") ^
+        (s_sig s))
+    args) ^ ">"
+
+let s_field f = (if is_override f then "override " else "") ^ s_sig f.jf_signature ^ " " ^ f.jf_name
+
+let s_fields fs = "{ \n\t" ^ String.concat "\n\t" (List.map s_field fs) ^ "\n}"
+

libs/javalib/jReader.ml

@@ -0,0 +1,597 @@
+(*
+ *  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())
+  | 18 ->
+    let bootstrapref = read_ui16 ch in (* not index *)
+    let nametyperef = index() in
+    KInvokeDynamic (bootstrapref, nametyperef)
+  | n ->
+    error()
+
+let expand_path s =
+  let rec loop remaining acc =
+    match remaining with
+    | name :: [] -> List.rev acc, name
+    | v :: tl -> loop tl (v :: acc)
+    | _ -> assert false
+  in
+  loop (String.nsplit s "/") []
+
+let rec parse_type_parameter_part s =
+  match s.[0] with
+  | '*' -> TAny, 1
+  | c ->
+    let wildcard, i = match c with
+      | '+' -> WExtends, 1
+      | '-' -> WSuper, 1
+      | _ -> WNone, 0
+    in
+    let jsig, l = parse_signature_part (String.sub s i (String.length s - 1)) in
+    (TType (wildcard, jsig), l + i)
+
+and parse_signature_part s =
+  let len = String.length s in
+  if len = 0 then raise Exit;
+  match s.[0] with
+  | 'B' -> TByte, 1
+  | 'C' -> TChar, 1
+  | 'D' -> TDouble, 1
+  | 'F' -> TFloat, 1
+  | 'I' -> TInt, 1
+  | 'J' -> TLong, 1
+  | 'S' -> TShort, 1
+  | 'Z' -> TBool, 1
+  | 'L' ->
+    (try
+      let orig_s = s in
+      let rec loop start i acc =
+        match s.[i] with
+        | '/' -> loop (i + 1) (i + 1) (String.sub s start (i - start) :: acc)
+        | ';' | '.' -> List.rev acc, (String.sub s start (i - start)), [], (i)
+        | '<' ->
+          let name = String.sub s start (i - start) in
+          let rec loop_params i acc =
+            let s = String.sub s i (len - i) in
+            match s.[0] with
+            | '>' -> List.rev acc, i + 1
+            | _ ->
+              let tp, l = parse_type_parameter_part s in
+              loop_params (l + i) (tp :: acc)
+          in
+          let params, _end = loop_params (i + 1) [] in
+          List.rev acc, name, params, (_end)
+        | _ -> loop start (i+1) acc
+      in
+      let pack, name, params, _end = loop 1 1 [] in
+      let rec loop_inner i acc =
+        match s.[i] with
+        | '.' ->
+          let pack, name, params, _end = loop (i+1) (i+1) [] in
+          if pack <> [] then error ("Inner types must not define packages. For '" ^ orig_s ^ "'.");
+          loop_inner _end ( (name,params) :: acc )
+        | ';' -> List.rev acc, i + 1
+        | c -> error ("End of complex type signature expected after type parameter. Got '" ^ Char.escaped c ^ "' for '" ^ orig_s ^ "'." );
+      in
+      let inners, _end = loop_inner _end [] in
+      match inners with
+      | [] -> TObject((pack,name), params), _end
+      | _ -> TObjectInner( pack, (name,params) :: inners ), _end
+    with
+      Invalid_string -> raise Exit)
+  | '[' ->
+    let p = ref 1 in
+    while !p < String.length s && s.[!p] >= '0' && s.[!p] <= '9' do
+      incr p;
+    done;
+    let size = (if !p > 1 then Some (int_of_string (String.sub s 1 (!p - 1))) else None) in
+    let s , l = parse_signature_part (String.sub s !p (String.length s - !p)) in
+    TArray (s,size) , l + !p
+  | '(' ->
+    let p = ref 1 in
+    let args = ref [] in
+    while !p < String.length s && s.[!p] <> ')' do
+      let a , l = parse_signature_part (String.sub s !p (String.length s - !p)) in
+      args := a :: !args;
+      p := !p + l;
+    done;
+    incr p;
+    if !p >= String.length s then raise Exit;
+    let ret , l = (match s.[!p] with 'V' -> None , 1 | _ ->
+      let s, l = parse_signature_part (String.sub s !p (String.length s - !p)) in
+      Some s, l
+    ) in
+    TMethod (List.rev !args,ret) , !p + l
+  | 'T' ->
+    (try
+      let s1 , _ = String.split s ";" in
+      let len = String.length s1 in
+      TTypeParameter (String.sub s1 1 (len - 1)) , len + 1
+    with
+      Invalid_string -> raise Exit)
+  | _ ->
+    raise Exit
+
+let parse_signature s =
+  try
+    let sign , l = parse_signature_part s in
+    if String.length s <> l then raise Exit;
+    sign
+  with
+    Exit -> error ("Invalid signature '" ^ s ^ "'")
+
+let parse_method_signature s =
+  match parse_signature s with
+  | (TMethod m) -> m
+  | _ -> error ("Unexpected signature '" ^ s ^ "'. Expecting method")
+
+let parse_formal_type_params s =
+  match s.[0] with
+  | '<' ->
+    let rec read_id i =
+      match s.[i] with
+      | ':' | '>' -> i
+      | _ -> read_id (i + 1)
+    in
+    let len = String.length s in
+    let rec parse_params idx acc =
+      let idi = read_id (idx + 1) in
+      let id = String.sub s (idx + 1) (idi - idx - 1) in
+      (* next must be a : *)
+      (match s.[idi] with | ':' -> () | _ -> error ("Invalid formal type signature character: " ^ Char.escaped s.[idi] ^ " ; from " ^ s));
+      let ext, l = match s.[idi + 1] with
+        | ':' | '>' -> None, idi + 1
+        | _ ->
+          let sgn, l = parse_signature_part (String.sub s (idi + 1) (len - idi - 1)) in
+          Some sgn, l + idi + 1
+      in
+      let rec loop idx acc =
+        match s.[idx] with
+        | ':' ->
+          let ifacesig, ifacei = parse_signature_part (String.sub s (idx + 1) (len - idx - 1)) in
+          loop (idx + ifacei + 1) (ifacesig :: acc)
+        | _ -> acc, idx
+      in
+      let ifaces, idx = loop l [] in
+      let acc = (id, ext, ifaces) :: acc in
+      if s.[idx] = '>' then List.rev acc, idx + 1 else parse_params (idx - 1) acc
+    in
+    parse_params 0 []
+  | _ -> [], 0
+
+let parse_throws s =
+  let len = String.length s in
+  let rec loop idx acc =
+    if idx > len then raise Exit
+    else if idx = len then acc, idx
+    else match s.[idx] with
+    | '^' ->
+      let tsig, l = parse_signature_part (String.sub s (idx+1) (len - idx - 1)) in
+      loop (idx + l + 1) (tsig :: acc)
+    | _ -> acc, idx
+  in
+  loop 0 []
+
+let parse_complete_method_signature s =
+  try
+    let len = String.length s in
+    let tparams, i = parse_formal_type_params s in
+    let sign, l = parse_signature_part (String.sub s i (len - i)) in
+    let throws, l2 = parse_throws (String.sub s (i+l) (len - i - l)) in
+    if (i + l + l2) <> len then raise Exit;
+
+    match sign with
+    | TMethod msig -> tparams, msig, throws
+    | _ -> raise Exit
+  with
+    Exit -> error ("Invalid method extended signature '" ^ s ^ "'")
+
+
+let rec expand_constant consts i =
+  let unexpected i = error (string_of_int i ^ ": Unexpected constant type") in
+  let expand_path n = match Array.get consts n with
+    | KUtf8String s -> expand_path s
+    | _ -> unexpected n
+  in
+  let expand_cls n = match expand_constant consts n with
+    | ConstClass p -> p
+    | _ -> unexpected n
+  in
+  let expand_nametype n = match expand_constant consts n with
+    | ConstNameAndType (s,jsig) -> s, jsig
+    | _ -> unexpected n
+  in
+  let expand_string n = match Array.get consts n with
+    | KUtf8String s -> s
+    | _ -> unexpected n
+  in
+  let expand_nametype_m n = match expand_nametype n with
+    | (n, TMethod m) -> n, m
+    | _ -> unexpected n
+  in
+  let expand ncls nt = match expand_cls ncls, expand_nametype nt with
+    | path, (n, m) -> path, n, m
+  in
+  let expand_m ncls nt = match expand_cls ncls, expand_nametype_m nt with
+    | path, (n, m) -> path, n, m
+  in
+
+  match Array.get consts i with
+  | KClass utf8ref ->
+    ConstClass (expand_path utf8ref)
+  | KFieldRef (classref, nametyperef) ->
+    ConstField (expand classref nametyperef)
+  | KMethodRef (classref, nametyperef) ->
+    ConstMethod (expand_m classref nametyperef)
+  | KInterfaceMethodRef (classref, nametyperef) ->
+    ConstInterfaceMethod (expand_m classref nametyperef)
+  | KString utf8ref ->
+    ConstString (expand_string utf8ref)
+  | KInt i32 ->
+    ConstInt i32
+  | KFloat f ->
+    ConstFloat f
+  | KLong i64 ->
+    ConstLong i64
+  | KDouble d ->
+    ConstDouble d
+  | KNameAndType (n, t) ->
+    ConstNameAndType(expand_string n, parse_signature (expand_string t))
+  | KUtf8String s ->
+    ConstUtf8 s (* TODO: expand UTF8 characters *)
+  | KMethodHandle (reference_type, dynref) ->
+    ConstMethodHandle (reference_type, expand_constant consts dynref)
+  | KMethodType utf8ref ->
+    ConstMethodType (parse_method_signature (expand_string utf8ref))
+  | KInvokeDynamic (bootstrapref, nametyperef) ->
+    let n, t = expand_nametype nametyperef in
+    ConstInvokeDynamic(bootstrapref, n, t)
+  | KUnusable ->
+    ConstUnusable
+
+let parse_access_flags ch all_flags =
+  let fl = read_ui16 ch in
+  let flags = ref [] in
+  let fbit = ref 0 in
+  List.iter (fun f ->
+    if fl land (1 lsl !fbit) <> 0 then begin
+      flags := f :: !flags;
+      if f = JUnusable then error ("Unusable flag: " ^ string_of_int fl)
+    end;
+    incr fbit
+  ) all_flags;
+  (*if fl land (0x4000 - (1 lsl !fbit)) <> 0 then error ("Invalid access flags " ^ string_of_int fl);*)
+  !flags
+
+let get_constant c n =
+  if n < 1 || n >= Array.length c then error ("Invalid constant index " ^ string_of_int n);
+  match c.(n) with
+  | ConstUnusable -> error "Unusable constant index";
+  | x -> x
+
+let get_class consts ch =
+  match get_constant consts (read_ui16 ch) with
+  | ConstClass n -> n
+  | _ -> error "Invalid class index"
+
+let get_string consts ch =
+  let i = read_ui16 ch in
+  match get_constant consts i with
+  | ConstUtf8 s -> s
+  | _ -> error ("Invalid string index " ^ string_of_int i)
+
+let rec parse_element_value consts ch =
+  let tag = IO.read_byte ch in
+  match Char.chr tag with
+  | 'B' | 'C' | 'D' | '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)
+  | "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" -> (* TODO *)
+      do_default()
+    | JKMethod, "Exceptions" ->
+      let num = read_ui16 ch in
+      throws := List.init num (fun _ -> TObject(get_class consts ch,[]));
+      None
+    | JKMethod, "Signature" ->
+      let s = get_string consts ch in
+      let tp, sgn, thr = parse_complete_method_signature s in
+      if thr <> [] then throws := thr;
+      types := tp;
+      jsig := TMethod(sgn);
+      None
+    | _ -> do_default()
+  ) consts ch attrib_count in
+  {
+    jf_name = name;
+    jf_kind = kind;
+    (* signature, as used by the vm *)
+    jf_vmsignature = sign;
+    (* actual signature, as used in java code *)
+    jf_signature = !jsig;
+    jf_throws = !throws;
+    jf_types = !types;
+    jf_flags = !acc;
+    jf_attributes = attribs;
+    jf_constant = !constant;
+    jf_code = !code;
+  }
+
+let parse_class ch =
+  if read_real_i32 ch <> 0xCAFEBABEl then error "Invalid header";
+  let minorv = read_ui16 ch in
+  let majorv = read_ui16 ch in
+  let constant_count = read_ui16 ch in
+  let const_big = ref true in
+  let consts = Array.init constant_count (fun idx ->
+    if !const_big then begin
+      const_big := false;
+      KUnusable
+    end else
+      let c = parse_constant constant_count idx ch in
+      (match c with KLong _ | KDouble _ -> const_big := true | _ -> ());
+      c
+  ) in
+  let consts = Array.mapi (fun i _ -> expand_constant consts i) consts in
+  let flags = parse_access_flags ch [JPublic; JUnusable; JUnusable; JUnusable; JFinal; JSuper; JUnusable; JUnusable; JUnusable; JInterface; JAbstract; JUnusable; JSynthetic; JAnnotation; JEnum] in
+  let this = get_class consts ch in
+  let super_idx = read_ui16 ch in
+  let super = match super_idx with
+    | 0 -> TObject((["java";"lang"], "Object"), []);
+    | idx -> match get_constant consts idx with
+      | ConstClass path -> TObject(path,[])
+      | _ -> error "Invalid super index"
+  in
+  let interfaces = List.init (read_ui16 ch) (fun _ -> TObject (get_class consts ch, [])) in
+  let fields = List.init (read_ui16 ch) (fun _ -> parse_field JKField consts ch) in
+  let methods = List.init (read_ui16 ch) (fun _ -> parse_field JKMethod consts ch) in
+
+  let inner = ref [] in
+  let types = ref [] in
+  let super = ref super in
+  let interfaces = ref interfaces in
+
+  let attribs = read_ui16 ch in
+  let attribs = parse_attributes ~on_special:(fun _ _ aname alen do_default ->
+    match aname with
+    | "InnerClasses" ->
+      let count = read_ui16 ch in
+      let classes = List.init count (fun _ ->
+        let inner_ci = get_class consts ch in
+        let outeri = read_ui16 ch in
+        let outer_ci = match outeri with
+          | 0 -> None
+          | _ -> match get_constant consts outeri with
+          | ConstClass n -> Some n
+          | _ -> error "Invalid class index"
+        in
+
+        let inner_namei = read_ui16 ch in
+        let inner_name = match inner_namei with
+          | 0 -> None
+          | _ -> match get_constant consts inner_namei with
+          | ConstUtf8 s -> Some s
+          | _ -> error ("Invalid string index " ^ string_of_int inner_namei)
+        in
+        let flags = parse_access_flags ch [JPublic; JPrivate; JProtected; JStatic; JFinal; JUnusable; JUnusable; JUnusable; JUnusable; JInterface; JAbstract; JSynthetic; JAnnotation; JEnum] in
+        inner_ci, outer_ci, inner_name, flags
+      ) in
+      inner := classes;
+      None
+    | "Signature" ->
+      let s = get_string consts ch in
+      let formal, idx = parse_formal_type_params s in
+      types := formal;
+      let s = String.sub s idx (String.length s - idx) in
+      let len = String.length s in
+      let sup, idx = parse_signature_part s in
+      let rec loop idx acc =
+        if idx = len then
+          acc
+        else begin
+          let s = String.sub s idx (len - idx) in
+          let iface, i2 = parse_signature_part s in
+          loop (idx + i2) (iface :: acc)
+        end
+      in
+      interfaces := loop idx [];
+      super := sup;
+      None
+    | _ -> do_default()
+  ) consts ch attribs in
+  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;
+  }
+

libs/javalib/jWriter.ml

@@ -0,0 +1,289 @@
+(*
+ *  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 "<init>" and "<clinit>" 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))))
+    | ConstInvokeDynamic (bootstrap_method, unqualified_name, jsignature) (* tag = 18 *) ->
+        write_byte ctx.cpool 18;
+        write_ui16 ctx.cpool bootstrap_method;
+        write_ui16 ctx.cpool (const ctx (ConstNameAndType(unqualified_name, jsignature)))
+    | ConstUnusable -> assert false);
+    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
+;;
+

libs/json/dune

@@ -0,0 +1,6 @@
+(include_subdirs no)
+
+(library
+	(name json)
+	(preprocess (pps sedlex.ppx))
+)

src/core/json.ml → libs/json/json.ml

@@ -1,6 +1,6 @@
 (*
 	The Haxe Compiler
-	Copyright (C) 2005-2017  Haxe Foundation
+	Copyright (C) 2005-2019  Haxe Foundation
 
 	This program is free software; you can redistribute it and/or
 	modify it under the terms of the GNU General Public License
@@ -103,6 +103,11 @@ and write_object w o =
 	write_iter write_el (fun() -> write_sep w) o;
 	w "}"
 
+let string_of_json json =
+	let b = Buffer.create 0 in
+	write_json (Buffer.add_string b) json;
+	Buffer.contents b;
+
 module Reader = struct
 	(*
 		The following code is basically stripped down yojson (https://github.com/mjambon/yojson),
@@ -310,7 +315,7 @@ module Reader = struct
 	and finish_escaped_char buf lexbuf =
 		match%sedlex lexbuf with
 		| '"' | '\\' | '/' ->
-			Buffer.add_char buf (char_of_int (Sedlexing.lexeme_char lexbuf 0))
+			Buffer.add_char buf (Uchar.to_char (Sedlexing.lexeme_char lexbuf 0))
 		| 'b' ->
 			Buffer.add_char buf '\b'
 		| 'f' ->
@@ -324,7 +329,7 @@ module Reader = struct
 		| 'u', hex, hex, hex, hex ->
 			let a,b,c,d =
 				match Sedlexing.lexeme lexbuf with
-				| [|_; a; b; c; d|] -> a, b, c, d
+				| [|_; a; b; c; d|] -> Uchar.to_int a, Uchar.to_int b, Uchar.to_int c, Uchar.to_int d
 				| _ -> assert false
 			in
 			let x =
@@ -342,7 +347,7 @@ module Reader = struct
 		| "\\u", hex, hex, hex, hex ->
 			let a,b,c,d =
 				match Sedlexing.lexeme lexbuf with
-				| [|_;_ ; a; b; c; d|] -> a, b, c, d
+				| [|_;_ ; a; b; c; d|] -> Uchar.to_int a, Uchar.to_int b, Uchar.to_int c, Uchar.to_int d
 				| _ -> assert false
 			in
 			let y =

libs/mbedtls/dune

@@ -0,0 +1,9 @@
+(include_subdirs no)
+
+(library
+	(name mbedtls)
+	(c_names
+		mbedtls_stubs
+	)
+	(wrapped false)
+)

libs/mbedtls/mbedtls.ml

@@ -0,0 +1,69 @@
+type mbedtls_ctr_drbg_context
+type mbedtls_entropy_context
+type mbedtls_ssl_config
+type mbedtls_ssl_context
+type mbedtls_x509_crt
+type mbedtls_pk_context
+
+type mbedtls_result = int
+
+type t_mbedtls_entropy_func = mbedtls_entropy_context -> bytes -> int -> mbedtls_result
+
+external mbedtls_strerror : int -> string = "ml_mbedtls_strerror"
+
+external mbedtls_ctr_drbg_init : unit -> mbedtls_ctr_drbg_context = "ml_mbedtls_ctr_drbg_init"
+external mbedtls_ctr_drbg_random : mbedtls_ctr_drbg_context -> bytes -> int -> mbedtls_result = "ml_mbedtls_ctr_drbg_random"
+external mbedtls_ctr_drbg_seed :
+	mbedtls_ctr_drbg_context ->
+	'a ->
+	string option ->
+	mbedtls_result = "ml_mbedtls_ctr_drbg_seed"
+
+external mbedtls_entropy_func : mbedtls_entropy_context -> bytes -> int -> mbedtls_result = "ml_mbedtls_entropy_func"
+external mbedtls_entropy_init : unit -> mbedtls_entropy_context = "ml_mbedtls_entropy_init"
+
+external mbedtls_ssl_conf_ca_chain : mbedtls_ssl_config -> mbedtls_x509_crt -> unit = "ml_mbedtls_ssl_conf_ca_chain"
+external mbedtls_ssl_config_authmode : mbedtls_ssl_config -> int -> unit = "ml_mbedtls_ssl_conf_authmode"
+external mbedtls_ssl_config_defaults : mbedtls_ssl_config -> int -> int -> int -> mbedtls_result = "ml_mbedtls_ssl_config_defaults"
+external mbedtls_ssl_config_init : unit -> mbedtls_ssl_config = "ml_mbedtls_ssl_config_init"
+external mbedtls_ssl_config_rng : mbedtls_ssl_config -> 'a -> unit = "ml_mbedtls_ssl_conf_rng"
+
+external mbedtls_ssl_init : unit -> mbedtls_ssl_context = "ml_mbedtls_ssl_init"
+external mbedtls_ssl_get_peer_cert : mbedtls_ssl_context -> mbedtls_x509_crt option = "ml_mbedtls_ssl_get_peer_cert"
+external mbedtls_ssl_handshake : mbedtls_ssl_context -> mbedtls_result = "ml_mbedtls_ssl_handshake"
+external mbedtls_ssl_read : mbedtls_ssl_context -> bytes -> int -> int -> mbedtls_result = "ml_mbedtls_ssl_read"
+external mbedtls_ssl_set_bio :
+	mbedtls_ssl_context ->
+	'a ->
+	('a -> bytes -> mbedtls_result) ->
+	('a -> bytes -> mbedtls_result) ->
+	unit = "ml_mbedtls_ssl_set_bio"
+external mbedtls_ssl_set_hostname : mbedtls_ssl_context -> string -> mbedtls_result = "ml_mbedtls_ssl_set_hostname"
+external mbedtls_ssl_setup : mbedtls_ssl_context -> mbedtls_ssl_config -> mbedtls_result = "ml_mbedtls_ssl_setup"
+external mbedtls_ssl_write : mbedtls_ssl_context -> bytes -> int -> int -> mbedtls_result = "ml_mbedtls_ssl_write"
+
+external mbedtls_pk_init : unit -> mbedtls_pk_context = "ml_mbedtls_pk_init"
+external mbedtls_pk_parse_key : mbedtls_pk_context -> bytes -> string option -> mbedtls_result = "ml_mbedtls_pk_parse_key"
+external mbedtls_pk_parse_keyfile : mbedtls_pk_context -> string -> string option -> mbedtls_result = "ml_mbedtls_pk_parse_keyfile"
+external mbedtls_pk_parse_public_keyfile : mbedtls_pk_context -> string -> mbedtls_result = "ml_mbedtls_pk_parse_public_keyfile"
+external mbedtls_pk_parse_public_key : mbedtls_pk_context -> bytes -> mbedtls_result = "ml_mbedtls_pk_parse_public_key"
+
+external mbedtls_x509_crt_init : unit -> mbedtls_x509_crt = "ml_mbedtls_x509_crt_init"
+external mbedtls_x509_next : mbedtls_x509_crt -> mbedtls_x509_crt option = "ml_mbedtls_x509_next"
+external mbedtls_x509_crt_parse : mbedtls_x509_crt -> bytes -> mbedtls_result = "ml_mbedtls_x509_crt_parse"
+external mbedtls_x509_crt_parse_file : mbedtls_x509_crt -> string -> mbedtls_result = "ml_mbedtls_x509_crt_parse_file"
+external mbedtls_x509_crt_parse_path : mbedtls_x509_crt -> string -> mbedtls_result = "ml_mbedtls_x509_crt_parse_path"
+
+external hx_cert_get_alt_names : mbedtls_x509_crt -> string array = "hx_cert_get_alt_names"
+external hx_cert_get_issuer : mbedtls_x509_crt -> string -> string option = "hx_cert_get_issuer"
+external hx_cert_get_notafter : mbedtls_x509_crt -> float = "hx_cert_get_notafter"
+external hx_cert_get_notbefore : mbedtls_x509_crt -> float = "hx_cert_get_notbefore"
+external hx_cert_get_subject : mbedtls_x509_crt -> string -> string option = "hx_cert_get_subject"
+
+(* glue *)
+
+external hx_cert_load_defaults : mbedtls_x509_crt -> int = "hx_cert_load_defaults"
+external hx_get_ssl_authmode_flags : unit -> (string * int) array = "hx_get_ssl_authmode_flags"
+external hx_get_ssl_endpoint_flags : unit -> (string * int) array = "hx_get_ssl_endpoint_flags"
+external hx_get_ssl_preset_flags : unit -> (string * int) array = "hx_get_ssl_preset_flags"
+external hx_get_ssl_transport_flags : unit -> (string * int) array = "hx_get_ssl_transport_flags"

libs/mbedtls/mbedtls_stubs.c

@@ -0,0 +1,598 @@
+#include <ctype.h>
+#include <string.h>
+#include <stdio.h>
+
+#ifdef _WIN32
+#include <windows.h>
+#include <wincrypt.h>
+#endif
+
+#ifdef __APPLE__
+#include <Security/Security.h>
+#endif
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+#include <caml/custom.h>
+
+#include "mbedtls/debug.h"
+#include "mbedtls/error.h"
+#include "mbedtls/config.h"
+#include "mbedtls/ssl.h"
+#include "mbedtls/entropy.h"
+#include "mbedtls/ctr_drbg.h"
+#include "mbedtls/certs.h"
+#include "mbedtls/oid.h"
+
+#define PVoid_val(v) (*((void**) Data_custom_val(v)))
+
+void debug(void* ctx, int debug_level, const char* file_name, int line, const char* message) {
+	printf("%s:%i: %s", file_name, line, message);
+}
+
+#define Val_none Val_int(0)
+
+static value Val_some(value v) {
+    CAMLparam1(v);
+    CAMLlocal1(some);
+    some = caml_alloc(1, 0);
+    Store_field(some, 0, v);
+    CAMLreturn(some);
+}
+
+CAMLprim value ml_mbedtls_strerror(value code) {
+	CAMLparam1(code);
+	CAMLlocal1(r);
+	char buf[128];
+	mbedtls_strerror(Int_val(code), buf, sizeof(buf));
+	r = caml_copy_string(buf);
+	CAMLreturn(r);
+}
+
+// CtrDrbg
+
+#define CtrDrbg_val(v) (*((mbedtls_ctr_drbg_context**) Data_custom_val(v)))
+
+static void ml_mbedtls_ctr_drbg_finalize(value v) {
+	mbedtls_ctr_drbg_context* ctr_drbg = CtrDrbg_val(v);
+	if (ctr_drbg != NULL) {
+		mbedtls_ctr_drbg_free(ctr_drbg);
+	}
+}
+
+static struct custom_operations ctr_drbg_ops = {
+	.identifier  = "ml_ctr_drbg",
+	.finalize    = ml_mbedtls_ctr_drbg_finalize,
+	.compare     = custom_compare_default,
+	.hash        = custom_hash_default,
+	.serialize   = custom_serialize_default,
+	.deserialize = custom_deserialize_default,
+};
+
+CAMLprim value ml_mbedtls_ctr_drbg_init(void) {
+	CAMLparam0();
+	CAMLlocal1(obj);
+	obj = caml_alloc_custom(&ctr_drbg_ops, sizeof(mbedtls_ctr_drbg_context*), 0, 1);
+	mbedtls_ctr_drbg_context* ctr_drbg = malloc(sizeof(mbedtls_ctr_drbg_context));
+	mbedtls_ctr_drbg_init(ctr_drbg);
+	CtrDrbg_val(obj) = ctr_drbg;
+	CAMLreturn(obj);
+}
+
+CAMLprim value ml_mbedtls_ctr_drbg_random(value p_rng, value output, value output_len) {
+	CAMLparam3(p_rng, output, output_len);
+	CAMLreturn(Val_int(mbedtls_ctr_drbg_random(CtrDrbg_val(p_rng), String_val(output), Int_val(output_len))));
+}
+
+CAMLprim value ml_mbedtls_ctr_drbg_seed(value ctx, value p_entropy, value custom) {
+	CAMLparam2(ctx, custom);
+	CAMLreturn(Val_int(mbedtls_ctr_drbg_seed(CtrDrbg_val(ctx), mbedtls_entropy_func, PVoid_val(p_entropy), NULL, 0)));
+}
+
+// Entropy
+
+#define Entropy_val(v) (*((mbedtls_entropy_context**) Data_custom_val(v)))
+
+static void ml_mbedtls_entropy_finalize(value v) {
+	mbedtls_entropy_context* entropy = Entropy_val(v);
+	if (entropy != NULL) {
+		mbedtls_entropy_free(entropy);
+	}
+}
+
+static struct custom_operations entropy_ops = {
+	.identifier  = "ml_entropy",
+	.finalize    = ml_mbedtls_entropy_finalize,
+	.compare     = custom_compare_default,
+	.hash        = custom_hash_default,
+	.serialize   = custom_serialize_default,
+	.deserialize = custom_deserialize_default,
+};
+
+CAMLprim value ml_mbedtls_entropy_init(void) {
+	CAMLparam0();
+	CAMLlocal1(obj);
+	obj = caml_alloc_custom(&entropy_ops, sizeof(mbedtls_entropy_context*), 0, 1);
+	mbedtls_entropy_context* entropy = malloc(sizeof(mbedtls_entropy_context));
+	mbedtls_entropy_init(entropy);
+	Entropy_val(obj) = entropy;
+	CAMLreturn(obj);
+}
+
+CAMLprim value ml_mbedtls_entropy_func(value data, value output, value len) {
+	CAMLparam3(data, output, len);
+	CAMLreturn(Val_int(mbedtls_entropy_func(PVoid_val(data), String_val(output), Int_val(len))));
+}
+
+// Certificate
+
+#define X509Crt_val(v) (*((mbedtls_x509_crt**) Data_custom_val(v)))
+
+static void ml_mbedtls_x509_crt_finalize(value v) {
+	mbedtls_x509_crt* x509_crt = X509Crt_val(v);
+	if (x509_crt != NULL) {
+		mbedtls_x509_crt_free(x509_crt);
+	}
+}
+
+static struct custom_operations x509_crt_ops = {
+	.identifier  = "ml_x509_crt",
+	.finalize    = ml_mbedtls_x509_crt_finalize,
+	.compare     = custom_compare_default,
+	.hash        = custom_hash_default,
+	.serialize   = custom_serialize_default,
+	.deserialize = custom_deserialize_default,
+};
+
+CAMLprim value ml_mbedtls_x509_crt_init(void) {
+	CAMLparam0();
+	CAMLlocal1(obj);
+	obj = caml_alloc_custom(&x509_crt_ops, sizeof(mbedtls_x509_crt*), 0, 1);
+	mbedtls_x509_crt* x509_crt = malloc(sizeof(mbedtls_x509_crt));
+	mbedtls_x509_crt_init(x509_crt);
+	X509Crt_val(obj) = x509_crt;
+	CAMLreturn(obj);
+}
+
+CAMLprim value ml_mbedtls_x509_next(value chain) {
+	CAMLparam1(chain);
+	CAMLlocal2(r, obj);
+	mbedtls_x509_crt* cert = X509Crt_val(chain);
+	if (cert->next == NULL) {
+		CAMLreturn(Val_none);
+	}
+	obj = caml_alloc_custom(&x509_crt_ops, sizeof(mbedtls_x509_crt*), 0, 1);
+	X509Crt_val(obj) = cert->next;
+	CAMLreturn(Val_some(obj));
+}
+
+CAMLprim value ml_mbedtls_x509_crt_parse(value chain, value bytes) {
+	CAMLparam2(chain, bytes);
+	const char* buf = String_val(bytes);
+	int len = caml_string_length(bytes);
+	CAMLreturn(Val_int(mbedtls_x509_crt_parse(X509Crt_val(chain), buf, len + 1)));
+}
+
+CAMLprim value ml_mbedtls_x509_crt_parse_file(value chain, value path) {
+	CAMLparam2(chain, path);
+	CAMLreturn(Val_int(mbedtls_x509_crt_parse_file(X509Crt_val(chain), String_val(path))));
+}
+
+CAMLprim value ml_mbedtls_x509_crt_parse_path(value chain, value path) {
+	CAMLparam2(chain, path);
+	CAMLreturn(Val_int(mbedtls_x509_crt_parse_path(X509Crt_val(chain), String_val(path))));
+}
+
+// Certificate Haxe API
+
+value caml_string_of_asn1_buf(mbedtls_asn1_buf* dat) {
+	CAMLparam0();
+	CAMLlocal1(s);
+	s = caml_alloc_string(dat->len);
+	memcpy(String_val(s), dat->p, dat->len);
+	CAMLreturn(s);
+}
+
+CAMLprim value hx_cert_get_alt_names(value chain) {
+	CAMLparam1(chain);
+	CAMLlocal1(obj);
+	mbedtls_x509_crt* cert = X509Crt_val(chain);
+	if (cert->ext_types & MBEDTLS_X509_EXT_SUBJECT_ALT_NAME == 0 || &cert->subject_alt_names == NULL) {
+		obj = Atom(0);
+	} else {
+		mbedtls_asn1_sequence* cur = &cert->subject_alt_names;
+		int i = 0;
+		while (cur != NULL) {
+			++i;
+			cur = cur->next;
+		}
+		obj = caml_alloc(i, 0);
+		cur = &cert->subject_alt_names;
+		i = 0;
+		while (cur != NULL) {
+			Store_field(obj, i, caml_string_of_asn1_buf(&cur->buf));
+			++i;
+			cur = cur->next;
+		}
+	}
+	CAMLreturn(obj);
+}
+
+CAMLprim value hx_cert_get_subject(value chain, value objname) {
+	CAMLparam2(chain, objname);
+	mbedtls_x509_name *obj;
+	mbedtls_x509_crt* cert = X509Crt_val(chain);
+	const char *oname, *rname;
+	obj = &cert->subject;
+	rname = String_val(objname);
+	while (obj != NULL) {
+		int r = mbedtls_oid_get_attr_short_name(&obj->oid, &oname);
+		if (r == 0 && strcmp(oname, rname) == 0) {
+			CAMLreturn(Val_some(caml_string_of_asn1_buf(&obj->val)));
+		}
+		obj = obj->next;
+	}
+	CAMLreturn(Val_none);
+}
+
+CAMLprim value hx_cert_get_issuer(value chain, value objname) {
+	CAMLparam2(chain, objname);
+	mbedtls_x509_name *obj;
+	mbedtls_x509_crt* cert = X509Crt_val(chain);
+	int r;
+	const char *oname, *rname;
+	obj = &cert->issuer;
+	rname = String_val(objname);
+	while (obj != NULL) {
+		r = mbedtls_oid_get_attr_short_name(&obj->oid, &oname);
+		if (r == 0 && strcmp(oname, rname) == 0) {
+			CAMLreturn(Val_some(caml_string_of_asn1_buf(&obj->val)));
+		}
+		obj = obj->next;
+	}
+	CAMLreturn(Val_none);
+}
+
+time_t time_to_time_t(mbedtls_x509_time* t) {
+	struct tm info;
+	info.tm_year = t->year - 1900;
+	info.tm_mon = t->mon - 1;
+	info.tm_mday = t->day;
+	info.tm_hour = t->hour;
+	info.tm_min = t->min;
+	info.tm_sec = t->sec;
+	return mktime(&info);
+}
+
+CAMLprim value hx_cert_get_notafter(value chain) {
+	CAMLparam1(chain);
+	mbedtls_x509_crt* cert = X509Crt_val(chain);
+	mbedtls_x509_time *t = &cert->valid_to;
+	time_t time = time_to_time_t(t);
+	CAMLreturn(caml_copy_double((double)time));
+}
+
+CAMLprim value hx_cert_get_notbefore(value chain) {
+	CAMLparam1(chain);
+	mbedtls_x509_crt* cert = X509Crt_val(chain);
+	mbedtls_x509_time *t = &cert->valid_from;
+	time_t time = time_to_time_t(t);
+	CAMLreturn(caml_copy_double((double)time));
+}
+
+// Config
+
+#define Config_val(v) (*((mbedtls_ssl_config**) Data_custom_val(v)))
+
+static void ml_mbedtls_ssl_config_finalize(value v) {
+	mbedtls_ssl_config* ssl_config = Config_val(v);
+	if (ssl_config != NULL) {
+		mbedtls_ssl_config_free(ssl_config);
+	}
+}
+
+static struct custom_operations ssl_config_ops = {
+	.identifier  = "ml_ssl_config",
+	.finalize    = ml_mbedtls_ssl_config_finalize,
+	.compare     = custom_compare_default,
+	.hash        = custom_hash_default,
+	.serialize   = custom_serialize_default,
+	.deserialize = custom_deserialize_default,
+};
+
+CAMLprim value ml_mbedtls_ssl_config_init(void) {
+	CAMLparam0();
+	CAMLlocal1(obj);
+	obj = caml_alloc_custom(&ssl_config_ops, sizeof(mbedtls_ssl_config*), 0, 1);
+	mbedtls_ssl_config* ssl_config = malloc(sizeof(mbedtls_ssl_config));
+	mbedtls_ssl_config_init(ssl_config);
+	Config_val(obj) = ssl_config;
+	CAMLreturn(obj);
+}
+
+CAMLprim value ml_mbedtls_ssl_conf_authmode(value conf, value authmode) {
+	CAMLparam2(conf, authmode);
+	mbedtls_ssl_conf_authmode(Config_val(conf), Int_val(authmode));
+	CAMLreturn(Val_unit);
+}
+
+CAMLprim value ml_mbedtls_ssl_conf_ca_chain(value conf, value ca_chain) {
+	CAMLparam2(conf, ca_chain);
+	mbedtls_ssl_conf_ca_chain(Config_val(conf), X509Crt_val(ca_chain), NULL);
+	CAMLreturn(Val_unit);
+}
+
+CAMLprim value ml_mbedtls_ssl_config_defaults(value conf, value endpoint, value transport, value preset) {
+	CAMLparam4(conf, endpoint, transport, preset);
+	CAMLreturn(Val_int(mbedtls_ssl_config_defaults(Config_val(conf), Int_val(endpoint), Int_val(transport), Int_val(preset))));
+}
+
+CAMLprim value ml_mbedtls_ssl_conf_rng(value conf, value p_rng) {
+	CAMLparam2(conf, p_rng);
+	mbedtls_ssl_conf_rng(Config_val(conf), mbedtls_ctr_drbg_random, PVoid_val(p_rng));
+	CAMLreturn(Val_unit);
+}
+
+// Pk
+
+#define PkContext_val(v) (*((mbedtls_pk_context**) Data_custom_val(v)))
+
+static void ml_mbedtls_pk_context_finalize(value v) {
+	mbedtls_pk_context* pk_context = PkContext_val(v);
+	if (pk_context != NULL) {
+		mbedtls_pk_free(pk_context);
+	}
+}
+
+static struct custom_operations pk_context_ops = {
+	.identifier  = "ml_pk_context",
+	.finalize    = ml_mbedtls_pk_context_finalize,
+	.compare     = custom_compare_default,
+	.hash        = custom_hash_default,
+	.serialize   = custom_serialize_default,
+	.deserialize = custom_deserialize_default,
+};
+
+CAMLprim value ml_mbedtls_pk_init(void) {
+	CAMLparam0();
+	CAMLlocal1(obj);
+	obj = caml_alloc_custom(&pk_context_ops, sizeof(mbedtls_pk_context*), 0, 1);
+	mbedtls_pk_context* pk_context = malloc(sizeof(mbedtls_pk_context));
+	mbedtls_pk_init(pk_context);
+	PkContext_val(obj) = pk_context;
+	CAMLreturn(obj);
+}
+
+CAMLprim value ml_mbedtls_pk_parse_key(value ctx, value key, value password) {
+	CAMLparam3(ctx, key, password);
+	const char* pwd = NULL;
+	size_t pwdlen = 0;
+	if (password != Val_none) {
+		pwd = String_val(Field(password, 0));
+		pwdlen = caml_string_length(Field(password, 0));
+	}
+	CAMLreturn(mbedtls_pk_parse_key(PkContext_val(ctx), String_val(key), caml_string_length(key) + 1, pwd, pwdlen));
+}
+
+CAMLprim value ml_mbedtls_pk_parse_keyfile(value ctx, value path, value password) {
+	CAMLparam3(ctx, path, password);
+	const char* pwd = NULL;
+	if (password != Val_none) {
+		pwd = String_val(Field(password, 0));
+	}
+	CAMLreturn(mbedtls_pk_parse_keyfile(PkContext_val(ctx), String_val(path), pwd));
+}
+
+CAMLprim value ml_mbedtls_pk_parse_public_key(value ctx, value key) {
+	CAMLparam2(ctx, key);
+	CAMLreturn(mbedtls_pk_parse_public_key(PkContext_val(ctx), String_val(key), caml_string_length(key) + 1));
+}
+
+CAMLprim value ml_mbedtls_pk_parse_public_keyfile(value ctx, value path) {
+	CAMLparam2(ctx, path);
+	CAMLreturn(mbedtls_pk_parse_public_keyfile(PkContext_val(ctx), String_val(path)));
+}
+
+// Ssl
+
+#define SslContext_val(v) (*((mbedtls_ssl_context**) Data_custom_val(v)))
+
+static void ml_mbedtls_ssl_context_finalize(value v) {
+	mbedtls_ssl_context* ssl_context = SslContext_val(v);
+	if (ssl_context != NULL) {
+		mbedtls_ssl_free(ssl_context);
+	}
+}
+
+static struct custom_operations ssl_context_ops = {
+	.identifier  = "ml_ssl_context",
+	.finalize    = ml_mbedtls_ssl_context_finalize,
+	.compare     = custom_compare_default,
+	.hash        = custom_hash_default,
+	.serialize   = custom_serialize_default,
+	.deserialize = custom_deserialize_default,
+};
+
+CAMLprim value ml_mbedtls_ssl_init(void) {
+	CAMLparam0();
+	CAMLlocal1(obj);
+	obj = caml_alloc_custom(&ssl_context_ops, sizeof(mbedtls_ssl_context*), 0, 1);
+	mbedtls_ssl_context* ssl_context = malloc(sizeof(mbedtls_ssl_context));
+	mbedtls_ssl_init(ssl_context);
+	SslContext_val(obj) = ssl_context;
+	CAMLreturn(obj);
+}
+
+CAMLprim value ml_mbedtls_ssl_get_peer_cert(value ssl) {
+	CAMLparam1(ssl);
+	CAMLlocal1(obj);
+	mbedtls_ssl_context* ssl_context = SslContext_val(ssl);
+	mbedtls_x509_crt* crt = (mbedtls_x509_crt*)mbedtls_ssl_get_peer_cert(ssl_context);
+	if (crt == NULL) {
+		CAMLreturn(Val_none);
+	}
+	obj = caml_alloc_custom(&x509_crt_ops, sizeof(mbedtls_x509_crt*), 0, 1);
+	X509Crt_val(obj) = crt;
+	CAMLreturn(Val_some(obj));
+}
+
+CAMLprim value ml_mbedtls_ssl_handshake(value ssl) {
+	CAMLparam1(ssl);
+	CAMLreturn(Val_int(mbedtls_ssl_handshake(SslContext_val(ssl))));
+}
+
+CAMLprim value ml_mbedtls_ssl_read(value ssl, value buf, value pos, value len) {
+	CAMLparam4(ssl, buf, pos, len);
+	CAMLreturn(Val_int(mbedtls_ssl_read(SslContext_val(ssl), String_val(buf) + Int_val(pos), Int_val(len))));
+}
+
+static int bio_write_cb(void* ctx, const unsigned char* buf, size_t len) {
+	CAMLparam0();
+	CAMLlocal3(r, s, vctx);
+	vctx = (value)ctx;
+	s = caml_alloc_string(len);
+	memcpy(String_val(s), buf, len);
+	r = caml_callback2(Field(vctx, 1), Field(vctx, 0), s);
+	CAMLreturn(Int_val(r));
+}
+
+static int bio_read_cb(void* ctx, unsigned char* buf, size_t len) {
+	CAMLparam0();
+	CAMLlocal3(r, s, vctx);
+	vctx = (value)ctx;
+	s = caml_alloc_string(len);
+	r = caml_callback2(Field(vctx, 2), Field(vctx, 0), s);
+	memcpy(buf, String_val(s), len);
+	CAMLreturn(Int_val(r));
+}
+
+CAMLprim value ml_mbedtls_ssl_set_bio(value ssl, value p_bio, value f_send, value f_recv) {
+	CAMLparam4(ssl, p_bio, f_send, f_recv);
+	CAMLlocal1(ctx);
+	ctx = caml_alloc(3, 0);
+	Store_field(ctx, 0, p_bio);
+	Store_field(ctx, 1, f_send);
+	Store_field(ctx, 2, f_recv);
+	mbedtls_ssl_set_bio(SslContext_val(ssl), (void*)ctx, bio_write_cb, bio_read_cb, NULL);
+	CAMLreturn(Val_unit);
+}
+
+CAMLprim value ml_mbedtls_ssl_set_hostname(value ssl, value hostname) {
+	CAMLparam2(ssl, hostname);
+	CAMLreturn(Val_int(mbedtls_ssl_set_hostname(SslContext_val(ssl), String_val(hostname))));
+}
+
+CAMLprim value ml_mbedtls_ssl_setup(value ssl, value conf) {
+	CAMLparam2(ssl, conf);
+	CAMLreturn(Val_int(mbedtls_ssl_setup(SslContext_val(ssl), Config_val(conf))));
+}
+
+CAMLprim value ml_mbedtls_ssl_write(value ssl, value buf, value pos, value len) {
+	CAMLparam4(ssl, buf, pos, len);
+	CAMLreturn(Val_int(mbedtls_ssl_write(SslContext_val(ssl), String_val(buf) + Int_val(pos), Int_val(len))));
+}
+
+// glue
+
+CAMLprim value hx_cert_load_defaults(value certificate) {
+	CAMLparam1(certificate);
+	int r = 1;
+
+	mbedtls_x509_crt *chain = X509Crt_val(certificate);
+
+	#ifdef _WIN32
+	HCERTSTORE store;
+	PCCERT_CONTEXT cert;
+
+	if (store = CertOpenSystemStore(0, "Root")) {
+		cert = NULL;
+		while (cert = CertEnumCertificatesInStore(store, cert)) {
+			r = mbedtls_x509_crt_parse_der(chain, (unsigned char *)cert->pbCertEncoded, cert->cbCertEncoded);
+			if (r != 0) {
+				CAMLreturn(Val_int(r));
+			}
+		}
+		CertCloseStore(store, 0);
+	}
+	#endif
+
+	#ifdef __APPLE__
+	CFMutableDictionaryRef search;
+	CFArrayRef result;
+	SecKeychainRef keychain;
+	SecCertificateRef item;
+	CFDataRef dat;
+	// Load keychain
+	if (SecKeychainOpen("/System/Library/Keychains/SystemRootCertificates.keychain", &keychain) == errSecSuccess) {
+		// Search for certificates
+		search = CFDictionaryCreateMutable(NULL, 0, NULL, NULL);
+		CFDictionarySetValue(search, kSecClass, kSecClassCertificate);
+		CFDictionarySetValue(search, kSecMatchLimit, kSecMatchLimitAll);
+		CFDictionarySetValue(search, kSecReturnRef, kCFBooleanTrue);
+		CFDictionarySetValue(search, kSecMatchSearchList, CFArrayCreate(NULL, (const void **)&keychain, 1, NULL));
+		if (SecItemCopyMatching(search, (CFTypeRef *)&result) == errSecSuccess) {
+			CFIndex n = CFArrayGetCount(result);
+			for (CFIndex i = 0; i < n; i++) {
+				item = (SecCertificateRef)CFArrayGetValueAtIndex(result, i);
+
+				// Get certificate in DER format
+				dat = SecCertificateCopyData(item);
+				if (dat) {
+					r = mbedtls_x509_crt_parse_der(chain, (unsigned char *)CFDataGetBytePtr(dat), CFDataGetLength(dat));
+					CFRelease(dat);
+					if (r != 0) {
+						CAMLreturn(Val_int(r));
+					}
+				}
+			}
+		}
+		CFRelease(keychain);
+	}
+	#endif
+
+	CAMLreturn(Val_int(r));
+}
+
+static value build_fields(int num_fields, const char* names[], int values[]) {
+	CAMLparam0();
+	CAMLlocal2(ret, tuple);
+	ret = caml_alloc(num_fields, 0);
+	for (int i = 0; i < num_fields; ++i) {
+		tuple = caml_alloc_tuple(2);
+		Store_field(tuple, 0, caml_copy_string(names[i]));
+		Store_field(tuple, 1, Val_int(values[i]));
+		Store_field(ret, i, tuple);
+	}
+	CAMLreturn(ret);
+}
+
+CAMLprim value hx_get_ssl_authmode_flags(value unit) {
+	CAMLparam1(unit);
+	const char* names[] = {"SSL_VERIFY_NONE", "SSL_VERIFY_OPTIONAL", "SSL_VERIFY_REQUIRED"};
+	int values[] = {MBEDTLS_SSL_VERIFY_NONE, MBEDTLS_SSL_VERIFY_OPTIONAL, MBEDTLS_SSL_VERIFY_REQUIRED};
+	CAMLreturn(build_fields(sizeof(values) / sizeof(values[0]), names, values));
+}
+
+CAMLprim value hx_get_ssl_endpoint_flags(value unit) {
+	CAMLparam1(unit);
+	const char* names[] = {"SSL_IS_CLIENT", "SSL_IS_SERVER"};
+	int values[] = {MBEDTLS_SSL_IS_CLIENT, MBEDTLS_SSL_IS_SERVER};
+	CAMLreturn(build_fields(sizeof(values) / sizeof(values[0]), names, values));
+}
+
+CAMLprim value hx_get_ssl_preset_flags(value unit) {
+	CAMLparam1(unit);
+	const char* names[] = {"SSL_PRESET_DEFAULT", "SSL_PRESET_SUITEB"};
+	int values[] = {MBEDTLS_SSL_PRESET_DEFAULT, MBEDTLS_SSL_PRESET_SUITEB};
+	CAMLreturn(build_fields(sizeof(values) / sizeof(values[0]), names, values));
+}
+
+CAMLprim value hx_get_ssl_transport_flags(value unit) {
+	CAMLparam1(unit);
+	const char* names[] = {"SSL_TRANSPORT_STREAM", "SSL_TRANSPORT_DATAGRAM"};
+	int values[] = {MBEDTLS_SSL_TRANSPORT_STREAM, MBEDTLS_SSL_TRANSPORT_DATAGRAM};
+	CAMLreturn(build_fields(sizeof(values) / sizeof(values[0]), names, values));
+}

libs/neko/Makefile

@@ -0,0 +1,23 @@
+OCAMLOPT=ocamlopt
+OCAMLC=ocamlc
+SRC=nast.ml nxml.ml binast.ml nbytecode.ml ncompile.ml
+
+all: bytecode native
+
+native: neko.cmxa
+
+bytecode: neko.cma
+
+neko.cmxa: $(SRC)
+	ocamlfind $(OCAMLOPT) -package extlib -safe-string -a -o neko.cmxa $(SRC)
+
+neko.cma: $(SRC)
+	ocamlfind $(OCAMLC) -package extlib -safe-string -a -o neko.cma $(SRC)
+
+clean:
+	rm -rf neko.cmxa neko.cma neko.lib neko.a $(wildcard *.cmx) $(wildcard *.obj) $(wildcard *.o) $(wildcard *.cmi) $(wildcard *.cmo)
+
+.PHONY: all bytecode native clean
+
+Makefile: ;
+$(SRC): ;

libs/neko/binast.ml

@@ -0,0 +1,269 @@
+(*
+ *  Neko Binary AST for OCaml
+ *  Copyright (c)2005-2007 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+open Nast
+
+type context = {
+	ch : unit IO.output;
+	mutable curfile : string;
+	mutable curline : int;
+	mutable scount : int;
+	strings : (string,int) Hashtbl.t;
+}
+
+let b ctx n =
+	IO.write_byte ctx.ch n
+
+let write_ui24 ctx n =
+	IO.write_byte ctx.ch n;
+	IO.write_byte ctx.ch (n lsr 8);
+	IO.write_byte ctx.ch (n lsr 16)
+
+let write_string ctx s =
+	try
+		let x = ctx.scount - Hashtbl.find ctx.strings s in
+		if x > 0xFF then raise Not_found;
+		b ctx x;
+	with
+		Not_found ->
+			Hashtbl.replace ctx.strings s ctx.scount;
+			ctx.scount <- ctx.scount + 1;
+			b ctx 0;
+			IO.write_ui16 ctx.ch (String.length s);
+			IO.nwrite_string ctx.ch s
+
+let write_constant ctx = function
+	| True -> b ctx 0
+	| False -> b ctx 1
+	| Null -> b ctx 2
+	| This -> b ctx 3
+	| Int n ->
+		if n >= 0 && n <= 0xFF then begin
+			b ctx 4;
+			b ctx n;
+		end else begin
+			b ctx 5;
+			IO.write_i32 ctx.ch n;
+		end
+	| Float s ->
+		b ctx 6;
+		write_string ctx s
+	| String s ->
+		b ctx 7;
+		write_string ctx s
+	| Builtin s ->
+		b ctx 8;
+		write_string ctx s
+	| Ident s ->
+		b ctx 9;
+		write_string ctx s
+	| Int32 n ->
+		b ctx 5; (* same as Int *)
+		IO.write_real_i32 ctx.ch n
+
+let write_op ctx op =
+	b ctx (match op with
+	| "+" -> 0
+	| "-" -> 1
+	| "/" -> 2
+	| "*" -> 3
+	| "%" -> 4
+	| "<<" -> 5
+	| ">>" -> 6
+	| ">>>" -> 7
+	| "|" -> 8
+	| "&" -> 9
+	| "^" -> 10
+	| "==" -> 11
+	| "!=" -> 12
+	| ">" -> 13
+	| ">=" -> 14
+	| "<" -> 15
+	| "<=" -> 16
+	| "=" -> 17
+	| "&&" -> 18
+	| "||" -> 19
+	| "++=" -> 20
+	| "--=" -> 21
+	| "+=" -> 22
+	| "-=" -> 23
+	| "/=" -> 24
+	| "*=" -> 25
+	| "%=" -> 26
+	| "<<=" -> 27
+	| ">>=" -> 28
+	| ">>>=" -> 29
+	| "|=" -> 30
+	| "&=" -> 31
+	| "^=" -> 32
+	| op -> failwith ("Invalid neko ast op " ^ op))
+
+let rec write_expr_opt ctx = function
+	| None ->
+		b ctx 0;
+	| Some e ->
+		b ctx 1;
+		write_expr ctx e
+
+and write_expr ctx (e,p) =
+	if p.psource <> ctx.curfile then begin
+		b ctx 0;
+		write_string ctx p.psource;
+		write_ui24 ctx p.pline;
+		ctx.curfile <- p.psource;
+		ctx.curline <- p.pline;
+	end else if p.pline <> ctx.curline then begin
+		b ctx 1;
+		write_ui24 ctx p.pline;
+		ctx.curline <- p.pline;
+	end;
+	match e with
+	| EConst c ->
+		b ctx 2;
+		write_constant ctx c
+	| EBlock el ->
+		let n = List.length el in
+		if n <= 0xFF then begin
+			b ctx 3;
+			b ctx n;
+		end else begin
+			b ctx 4;
+			write_ui24 ctx n;
+		end;
+		List.iter (write_expr ctx) el
+	| EParenthesis e ->
+		b ctx 5;
+		write_expr ctx e;
+	| EField (e,f) ->
+		b ctx 6;
+		write_expr ctx e;
+		write_string ctx f;
+	| ECall (e,el) ->
+		let n = List.length el in
+		if n <= 0xFF then begin
+			b ctx 7;
+			write_expr ctx e;
+			b ctx n;
+		end else begin
+			b ctx 28;
+			write_expr ctx e;
+			write_ui24 ctx n;
+		end;
+		List.iter (write_expr ctx) el;
+	| EArray (e1,e2) ->
+		b ctx 8;
+		write_expr ctx e1;
+		write_expr ctx e2;
+	| EVars vl ->
+		b ctx 9;
+		b ctx (List.length vl);
+		List.iter (fun (v,e) ->
+			write_string ctx v;
+			write_expr_opt ctx e;
+		) vl;
+	| EWhile (e1,e2,NormalWhile) ->
+		b ctx 10;
+		write_expr ctx e1;
+		write_expr ctx e2;
+	| EWhile (e1,e2,DoWhile) ->
+		b ctx 11;
+		write_expr ctx e1;
+		write_expr ctx e2;
+	| EIf (e1,e2,eo) ->
+		b ctx 12;
+		write_expr ctx e1;
+		write_expr ctx e2;
+		write_expr_opt ctx eo;
+	| ETry (e1,v,e2) ->
+		b ctx 13;
+		write_expr ctx e1;
+		write_string ctx v;
+		write_expr ctx e2;
+	| EFunction (pl,e) ->
+		b ctx 14;
+		b ctx (List.length pl);
+		List.iter (write_string ctx) pl;
+		write_expr ctx e;
+	| EBinop (op,e1,e2) ->
+		b ctx 15;
+		write_op ctx op;
+		write_expr ctx e1;
+		write_expr ctx e2;
+	| EReturn None ->
+		b ctx 16;
+	| EReturn (Some e) ->
+		b ctx 17;
+		write_expr ctx e;
+	| EBreak None ->
+		b ctx 18;
+	| EBreak (Some e) ->
+		b ctx 19;
+		write_expr ctx e;
+	| EContinue ->
+		b ctx 20;
+	| ENext (e1,e2) ->
+		b ctx 21;
+		write_expr ctx e1;
+		write_expr ctx e2;
+	| EObject fl ->
+		let n = List.length fl in
+		if n <= 0xFF then begin
+			b ctx 22;
+			b ctx n;
+		end else begin
+			b ctx 23;
+			write_ui24 ctx n;
+		end;
+		List.iter (fun (f,e) ->
+			write_string ctx f;
+			write_expr ctx e;
+		) fl;
+	| ELabel l ->
+		b ctx 24;
+		write_string ctx l;
+	| ESwitch (e,cases,eo) ->
+		let n = List.length cases in
+		if n <= 0xFF then begin
+			b ctx 25;
+			b ctx n;
+		end else begin
+			b ctx 26;
+			write_ui24 ctx n;
+		end;
+		write_expr ctx e;
+		List.iter (fun (e1,e2) ->
+			write_expr ctx e1;
+			write_expr ctx e2;
+		) cases;
+		write_expr_opt ctx eo;
+	| ENeko s ->
+		b ctx 27;
+		write_ui24 ctx (String.length s);
+		IO.nwrite_string ctx.ch s
+
+let write ch e =
+	let ctx = {
+		ch = ch;
+		curfile = "";
+		curline = -1;
+		scount = 0;
+		strings = Hashtbl.create 0;
+	} in
+	IO.nwrite_string ctx.ch "NBA\001";
+	write_expr ctx e
+

libs/neko/dune

@@ -0,0 +1,7 @@
+(include_subdirs no)
+
+(library
+	(name neko)
+	(libraries extlib)
+	(wrapped false)
+)

libs/neko/nast.ml

@@ -0,0 +1,154 @@
+(*
+ *  Neko AST for OCaml
+ *  Copyright (c)2005 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+
+type pos = {
+	psource : string;
+	pline : int;
+}
+
+type constant =
+	| True
+	| False
+	| Null
+	| This
+	| Int of int
+	| Float of string
+	| String of string
+	| Builtin of string
+	| Ident of string
+	| Int32 of int32
+
+type while_flag =
+	| NormalWhile
+	| DoWhile
+
+type expr_decl =
+	| EConst of constant
+	| EBlock of expr list
+	| EParenthesis of expr
+	| EField of expr * string
+	| ECall of expr * expr list
+	| EArray of expr * expr	
+	| EVars of (string * expr option) list
+	| EWhile of expr * expr * while_flag
+	| EIf of expr * expr * expr option
+	| ETry of expr * string * expr
+	| EFunction of string list * expr
+	| EBinop of string * expr * expr
+	| EReturn of expr option
+	| EBreak of expr option
+	| EContinue
+	| ENext of expr * expr
+	| EObject of (string * expr) list
+	| ELabel of string
+	| ESwitch of expr * (expr * expr) list * expr option
+	| ENeko of string
+
+and expr = expr_decl * pos
+
+let pos = snd
+
+let null_pos = { pline = 0; psource = "<null pos>" }
+
+let mk_call v args p = ECall (v,args) , p
+let mk_call0 v p = ECall (v,[]) , p
+let mk_call1 v a p = ECall (v,[a]) , p
+let mk_ident i p = EConst (Ident i) , p
+let mk_builtin b p = EConst (Builtin b) , p
+let mk_int i p = EConst (Int i) , p
+let mk_string s p = EConst (String s) , p
+let mk_binop op e1 e2 p = EBinop (op,e1,e2) , p
+
+let map f (e,p) =
+	(match e with
+	| EBlock el -> EBlock (List.map f el)
+	| EParenthesis e -> EParenthesis (f e)
+	| EField (e,s) -> EField (f e, s)
+	| ECall (e,el) -> ECall (f e, List.map f el)
+	| EArray (e1,e2) -> EArray (f e1, f e2)
+	| EVars vl -> EVars (List.map (fun (v,e) -> v , match e with None -> None | Some e -> Some (f e)) vl)
+	| EWhile (e1,e2,flag) -> EWhile (f e1, f e2, flag)
+	| EIf (e,e1,e2) -> EIf (f e, f e1, match e2 with None -> None | Some e -> Some (f e))
+	| ETry (e,ident,e2) -> ETry (f e, ident, f e2)
+	| EFunction (params,e) -> EFunction (params, f e)
+	| EBinop (op,e1,e2) -> EBinop (op, f e1, f e2)
+	| EReturn (Some e) -> EReturn (Some (f e))
+	| EBreak (Some e) -> EBreak (Some (f e))
+	| ENext (e1,e2) -> ENext (f e1,f e2)
+	| EObject fl -> EObject (List.map (fun (s,e) -> s , f e) fl)
+	| ESwitch (e,cases,def) -> ESwitch (f e,List.map (fun(e1,e2) -> f e1, f e2) cases,match def with None -> None | Some e -> Some (f e))
+	| EReturn None
+	| EBreak None
+	| EContinue
+	| ENeko _
+	| ELabel _
+	| EConst _ as x -> x) , p
+
+let iter f (e,p) =
+	match e with
+	| EBlock el -> List.iter f el
+	| EParenthesis e -> f e
+	| EField (e,s) -> f e
+	| ECall (e,el) -> f e; List.iter f el
+	| EArray (e1,e2) -> f e1; f e2
+	| EVars vl -> List.iter (fun (_,e) -> match e with None -> () | Some e -> f e) vl
+	| EWhile (e1,e2,_) -> f e1; f e2
+	| EIf (e,e1,e2) -> f e; f e1; (match e2 with None -> () | Some e -> f e)
+	| ETry (e1,_,e2) -> f e1; f e2
+	| EFunction (_,e) -> f e
+	| EBinop (_,e1,e2) -> f e1; f e2
+	| EReturn (Some e) -> f e
+	| EBreak (Some e) -> f e
+	| ENext (e1,e2) -> f e1; f e2
+	| EObject fl -> List.iter (fun (_,e) -> f e) fl
+	| ESwitch (e,cases,def) -> f e; List.iter (fun(e1,e2) -> f e1; f e2) cases; (match def with None -> () | Some e -> f e) 
+	| EReturn None
+	| EBreak None
+	| EContinue
+	| ENeko _
+	| ELabel _
+	| EConst _ -> ()
+
+let is_printable c = c >= '\032' && c <= '\126'
+
+let escape s =
+	let b = Buffer.create (String.length s) in
+	for i = 0 to (String.length s) - 1 do
+		match s.[i] with
+		| '\n' -> Buffer.add_string b "\\n"
+		| '\t' -> Buffer.add_string b "\\t"
+		| '\r' -> Buffer.add_string b "\\r"
+		| '\\' -> Buffer.add_string b "\\\\"
+		| c when c == '"' || not (is_printable c) -> Buffer.add_string b (Printf.sprintf "\\%.3d" (int_of_char c))
+		| c -> Buffer.add_char b c
+	done;
+	Buffer.contents b
+
+let s_constant = function
+	| True -> "true"
+	| False -> "false"
+	| Null -> "null"
+	| This -> "this"
+	| Int i -> string_of_int i
+	| Float s -> s
+	| String s -> "\"" ^ escape s ^ "\""
+	| Builtin s -> "$" ^ s
+	| Ident s -> s
+	| Int32 i -> Int32.to_string i
+

libs/neko/nbytecode.ml

@@ -0,0 +1,377 @@
+(*
+ *  Neko Compiler
+ *  Copyright (c)2005 Motion-Twin
+ *
+ *  This library is free software; you can redistribute it and/lor
+ *  modify it under the terms of the GNU Lesser General Public
+ *  License as published by the Free Software Foundation; either
+ *  version 2.1 of the License, lor (at your option) any later version.
+ *
+ *  This library is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY lor FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ *  Lesser General Public License lor the LICENSE file for more details.
+ *)
+
+type opcode =
+	(* getters *)
+	| AccNull
+	| AccTrue
+	| AccFalse
+	| AccThis
+	| AccInt of int
+	| AccStack of int
+	| AccGlobal of int
+	| AccEnv of int
+	| AccField of string
+	| AccArray
+	| AccIndex of int
+	| AccBuiltin of string
+	(* setters *)
+	| SetStack of int
+	| SetGlobal of int
+	| SetEnv of int
+	| SetField of string
+	| SetArray
+	| SetIndex of int
+	| SetThis
+	(* stack ops *)
+	| Push
+	| Pop of int
+	| Call of int
+	| ObjCall of int
+	| Jump of int
+	| JumpIf of int
+	| JumpIfNot of int
+	| Trap of int
+	| EndTrap
+	| Ret of int
+	| MakeEnv of int
+	| MakeArray of int
+	(* value ops *)
+	| Bool
+	| IsNull
+	| IsNotNull
+	| Add
+	| Sub
+	| Mult
+	| Div
+	| Mod
+	| Shl
+	| Shr
+	| UShr
+	| Or
+	| And
+	| Xor
+	| Eq
+	| Neq
+	| Gt
+	| Gte
+	| Lt
+	| Lte
+	| Not
+	(* extra ops *)
+	| TypeOf
+	| Compare
+	| Hash
+	| New
+	| JumpTable of int
+	| Apply of int
+	| AccStack0
+	| AccStack1
+	| AccIndex0
+	| AccIndex1
+	| PhysCompare
+	| TailCall of int * int
+	| Loop
+	(* ocaml-specific *)
+	| AccInt32 of int32
+
+type global =
+	| GlobalVar of string
+	| GlobalFunction of int * int
+	| GlobalString of string
+	| GlobalFloat of string
+	| GlobalDebug of string array * ((int * int) array)
+	| GlobalVersion of int
+
+exception Invalid_file
+
+let error msg = failwith msg
+
+let trap_stack_delta = 6
+
+let hash_field f =
+	let h = ref 0 in
+	for i = 0 to String.length f - 1 do
+		h := !h * 223 + int_of_char (String.unsafe_get f i);
+	done;
+	if Sys.word_size = 64 then Int32.to_int (Int32.shift_right (Int32.shift_left (Int32.of_int !h) 1) 1) else !h
+
+
+let op_param x =
+	match x with
+	| AccInt _
+	| AccInt32 _
+	| AccStack _
+	| AccGlobal _
+	| AccEnv _
+	| AccField _
+	| AccBuiltin _
+	| SetStack _
+	| SetGlobal _
+	| SetEnv _
+	| SetField _
+	| Pop _
+	| Call _
+	| ObjCall _
+	| Jump _
+	| JumpIf _
+	| JumpIfNot _
+	| JumpTable _
+	| Trap _
+	| MakeEnv _
+	| MakeArray _
+	| Ret _
+	| AccIndex _
+	| SetIndex _
+	| Apply _
+	| TailCall _
+		-> true
+	| AccNull
+	| AccTrue
+	| AccFalse
+	| AccThis
+	| AccArray
+	| SetArray
+	| SetThis
+	| Push
+	| EndTrap
+	| Bool
+	| Add
+	| Sub
+	| Mult
+	| Div
+	| Mod
+	| Shl
+	| Shr
+	| UShr
+	| Or
+	| And
+	| Xor
+	| Eq
+	| Neq
+	| Gt
+	| Gte
+	| Lt
+	| Lte
+	| IsNull
+	| IsNotNull
+	| Not
+	| TypeOf
+	| Compare
+	| Hash
+	| New
+	| AccStack0
+	| AccStack1
+	| AccIndex0
+	| AccIndex1
+	| PhysCompare
+	| Loop
+		-> false
+
+let code_tables ops =
+	let ids = Hashtbl.create 0 in
+	let fids = DynArray.create() in
+	Array.iter (fun x ->
+		match x with
+		| AccField s
+		| SetField s
+		| AccBuiltin s ->
+			let id = hash_field s in
+			(try
+				let f = Hashtbl.find ids id in
+				if f <> s then error("Field hashing conflict " ^ s ^ " and " ^ f);
+			with Not_found ->
+				Hashtbl.add ids id s;
+				DynArray.add fids s
+			)
+		| _ -> ()
+	) ops;
+	let p = ref 0 in
+	let pos = Array.make (Array.length(ops) + 1) 0 in
+	Array.iteri (fun i op ->
+		pos.(i) <- !p;
+		p := !p + (if op_param op then 2 else 1);
+	) ops;
+	pos.(Array.length ops) <- !p;
+	(DynArray.to_array fids , pos , !p)
+
+let write_debug_infos ch files inf =
+	let nfiles = Array.length files in
+	(*
+	// the encoding of nfiles was set to keep
+	// backward compatibility with 1.3 which
+	// only allowed up to 127 filenames
+	*)
+	let lot_of_files = ref false in
+	if nfiles < 0x80 then
+		IO.write_byte ch nfiles
+	else if nfiles < 0x8000 then begin
+		lot_of_files := true;
+		IO.write_byte ch ((nfiles lsr 8) lor 0x80);
+		IO.write_byte ch (nfiles land 0xFF);
+	end else
+		assert false;
+	Array.iter (fun s -> IO.write_string ch s) files;
+    IO.write_i32 ch (Array.length inf);
+	let curfile = ref 0 in
+	let curpos = ref 0 in
+	let rcount = ref 0 in
+	let rec flush_repeat p =
+		if !rcount > 0 then begin
+			if !rcount > 15 then begin
+				IO.write_byte ch ((15 lsl 2) lor 2);
+				rcount := !rcount - 15;
+				flush_repeat(p)
+			end else begin
+				let delta = p - !curpos in
+				let delta = (if delta > 0 && delta < 4 then delta else 0) in
+				IO.write_byte ch ((delta lsl 6) lor (!rcount lsl 2) lor 2);
+				rcount := 0;
+				curpos := !curpos + delta;
+			end
+		end
+	in
+	Array.iter (fun (f,p) ->
+		if f <> !curfile then begin
+			flush_repeat(p);
+			curfile := f;
+			if !lot_of_files then begin
+				IO.write_byte ch ((f lsr 7) lor 1);
+				IO.write_byte ch (f land 0xFF);
+			end else
+				IO.write_byte ch ((f lsl 1) lor 1);
+		end;
+		if p <> !curpos then flush_repeat(p);
+		if p = !curpos then
+			rcount := !rcount + 1
+		else
+			let delta = p - !curpos in
+			if delta > 0 && delta < 32 then
+				IO.write_byte ch ((delta lsl 3) lor 4)
+			else begin
+				IO.write_byte ch (p lsl 3);
+				IO.write_byte ch (p lsr 5);
+				IO.write_byte ch (p lsr 13);
+			end;
+			curpos := p;
+	) inf;
+	flush_repeat(!curpos)
+
+let write ch (globals,ops) =
+	IO.nwrite_string ch "NEKO";
+	let ids , pos , csize = code_tables ops in
+	IO.write_i32 ch (Array.length globals);
+	IO.write_i32 ch (Array.length ids);
+	IO.write_i32 ch csize;
+	Array.iter (fun x ->
+		match x with
+		| GlobalVar s -> IO.write_byte ch 1; IO.write_string ch s
+		| GlobalFunction (p,nargs) -> IO.write_byte ch 2; IO.write_i32 ch (pos.(p) lor (nargs lsl 24))
+		| GlobalString s -> IO.write_byte ch 3; IO.write_ui16 ch (String.length s); IO.nwrite_string ch s
+		| GlobalFloat s -> IO.write_byte ch 4; IO.write_string ch s
+		| GlobalDebug (files,inf) -> IO.write_byte ch 5; write_debug_infos ch files inf;
+		| GlobalVersion v -> IO.write_byte ch 6; IO.write_byte ch v
+	) globals;
+	Array.iter (fun s ->
+		IO.write_string ch s;
+	) ids;
+	Array.iteri (fun i op ->
+		let pop = ref None in
+		let opid = (match op with
+			| AccNull -> 0
+			| AccTrue -> 1
+			| AccFalse -> 2
+			| AccThis -> 3
+			| AccInt n -> pop := Some n; 4
+			| AccInt32 n ->
+				let opid = 4 in
+				IO.write_byte ch ((opid lsl 2) lor 3);
+				IO.write_real_i32 ch n;
+				-1
+			| AccStack n -> pop := Some (n - 2); 5
+			| AccGlobal n -> pop := Some n; 6
+			| AccEnv n -> pop := Some n; 7
+			| AccField s -> pop := Some (hash_field s); 8
+			| AccArray -> 9
+			| AccIndex n -> pop := Some (n - 2); 10
+			| AccBuiltin s -> pop := Some (hash_field s); 11
+			| SetStack n -> pop := Some n; 12
+			| SetGlobal n -> pop := Some n; 13
+			| SetEnv n -> pop := Some n; 14
+			| SetField s -> pop := Some (hash_field s); 15
+			| SetArray -> 16
+			| SetIndex n -> pop := Some n; 17
+			| SetThis -> 18
+			| Push -> 19
+			| Pop n -> pop := Some n; 20
+			| Call n -> pop := Some n; 21
+			| ObjCall n -> pop := Some n; 22
+			| Jump n -> pop := Some (pos.(i+n) - pos.(i)); 23
+			| JumpIf n -> pop := Some (pos.(i+n) - pos.(i)); 24
+			| JumpIfNot n -> pop := Some (pos.(i+n) - pos.(i)); 25
+			| Trap n -> pop := Some (pos.(i+n) - pos.(i)); 26
+			| EndTrap -> 27
+			| Ret n -> pop := Some n; 28
+			| MakeEnv n -> pop := Some n; 29
+			| MakeArray n -> pop := Some n; 30
+			| Bool -> 31
+			| IsNull -> 32
+			| IsNotNull -> 33
+			| Add -> 34
+			| Sub -> 35
+			| Mult -> 36
+			| Div -> 37
+			| Mod -> 38
+			| Shl -> 39
+			| Shr -> 40
+			| UShr -> 41
+			| Or -> 42
+			| And -> 43
+			| Xor -> 44
+			| Eq -> 45
+			| Neq -> 46
+			| Gt -> 47
+			| Gte -> 48
+			| Lt -> 49
+			| Lte -> 50
+			| Not -> 51
+			| TypeOf -> 52
+			| Compare -> 53
+			| Hash -> 54
+			| New -> 55
+			| JumpTable n -> pop := Some n; 56
+			| Apply n -> pop := Some n; 57
+			| AccStack0 -> 58
+			| AccStack1 -> 59
+			| AccIndex0 -> 60
+			| AccIndex1 -> 61
+			| PhysCompare -> 62
+			| TailCall (args,st) -> pop := Some (args lor (st lsl 3)); 63
+			| Loop -> pop := Some 64; 0
+		) in
+		match !pop with
+		| None ->
+			if opid >= 0 then IO.write_byte ch (opid lsl 2)
+		| Some n ->
+			if opid < 32 && (n = 0 || n = 1) then
+				IO.write_byte ch ((opid lsl 3) lor (n lsl 2) lor 1)
+			else if n >= 0 && n <= 0xFF then begin
+				IO.write_byte ch ((opid lsl 2) lor 2);
+				IO.write_byte ch n;
+			end else begin
+				IO.write_byte ch ((opid lsl 2) lor 3);
+				IO.write_i32 ch n;
+			end
+	) ops

libs/neko/ncompile.ml

@@ -0,0 +1,1055 @@
+(*
+ *  Neko Compiler
+ *  Copyright (c)2005 Motion-Twin
+ *
+ *  This library is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU Lesser General Public
+ *  License as published by the Free Software Foundation; either
+ *  version 2.1 of the License, or (at your option) any later version.
+ *
+ *  This library is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ *  Lesser General Public License or the LICENSE file for more details.
+ *)
+open Nast
+open Nbytecode
+
+type access =
+	| XEnv of int
+	| XStack of int
+	| XGlobal of int
+	| XField of string
+	| XIndex of int
+	| XArray
+	| XThis
+
+type label = {
+	lname : string;
+	ltraps : int list;
+	lstack : int;
+	mutable lpos : int option;
+	mutable lwait : (unit -> unit) list;
+}
+
+type globals = {
+	globals : (global,int) Hashtbl.t;
+	gobjects : (string list,int) Hashtbl.t;
+	mutable functions : (opcode DynArray.t * (int * int) DynArray.t * int * int) list;
+	mutable gtable : global DynArray.t;
+	labels : (string,label) Hashtbl.t;
+	hfiles : (string,int) Hashtbl.t;
+	files : string DynArray.t;
+}
+
+type context = {
+	g : globals;
+	version : int;
+	mutable ops : opcode DynArray.t;
+	mutable locals : (string,int) PMap.t;
+	mutable env : (string,int) PMap.t;
+	mutable nenv : int;
+	mutable stack : int;
+	mutable loop_limit : int;
+	mutable loop_traps : int;
+	mutable limit : int;
+	mutable traps : int list;
+	mutable breaks : ((unit -> unit) * pos) list;
+	mutable continues : ((unit -> unit) * pos) list;
+	mutable pos : (int * int) DynArray.t;
+	mutable curpos : (int * int);
+	mutable curfile : string;
+}
+
+type error_msg = string
+
+exception Error of error_msg * pos
+
+let error e p =
+	raise (Error(e,p))
+
+let error_msg s =
+	s
+
+let stack_delta o =
+	match o with
+	| AccNull
+	| AccTrue
+	| AccFalse
+	| AccThis
+	| AccInt _
+	| AccInt32 _
+	| AccStack _
+	| AccGlobal _
+	| AccEnv _
+	| AccField _
+	| AccBuiltin _
+	| AccIndex _
+	| JumpIf _
+	| JumpIfNot _
+	| Jump _
+	| JumpTable _
+	| Ret _
+	| SetGlobal _
+	| SetStack _
+	| SetEnv _
+	| SetThis
+	| Bool
+	| IsNull
+	| IsNotNull
+	| Not
+	| Hash
+	| TypeOf
+	| New
+	| AccStack0
+	| AccStack1
+	| AccIndex0
+	| AccIndex1
+	| Loop
+		-> 0
+	| Add
+	| Sub
+	| Mult
+	| Div
+	| Mod
+	| Shl
+	| Shr
+	| UShr
+	| Or
+	| And
+	| Xor
+	| Eq
+	| Neq
+	| Gt
+	| Gte
+	| Lt
+	| Lte
+	| PhysCompare
+		-> -1
+	| AccArray -> -1
+	| SetField _ | SetIndex _ | Compare -> -1
+	| SetArray -> -2
+	| Push -> 1
+	| Pop x -> -x
+	| Apply nargs | Call nargs | TailCall (nargs,_) -> -nargs
+	| ObjCall nargs -> -(nargs + 1)
+	| MakeEnv size | MakeArray size -> -size
+	| Trap _ -> trap_stack_delta
+	| EndTrap -> -trap_stack_delta
+
+let check_stack ctx stack p =
+	if ctx.stack <> stack then error "Stack alignment failure" p
+
+let pos ctx =
+	DynArray.length ctx.ops
+
+let real_null_pos =
+	{ pline = 0; psource = "<null>" }
+
+let set_pos ctx p =
+	if p.psource = ctx.curfile then begin
+		if p.pline <> snd ctx.curpos then ctx.curpos <- (fst ctx.curpos, p.pline);
+	end else if p = real_null_pos then
+		()
+	else
+		let fid = (try
+			Hashtbl.find ctx.g.hfiles p.psource
+		with Not_found ->
+			let fid = DynArray.length ctx.g.files in
+			DynArray.add ctx.g.files p.psource;
+			Hashtbl.add ctx.g.hfiles p.psource fid;
+			fid
+		) in
+		ctx.curfile <- p.psource;
+		ctx.curpos <- (fid,p.pline)
+
+let write ctx op =
+	ctx.stack <- ctx.stack + stack_delta op;
+	DynArray.add ctx.pos ctx.curpos;
+	if op_param op then DynArray.add ctx.pos ctx.curpos;
+	DynArray.add ctx.ops op
+
+let jmp ctx =
+	let p = pos ctx in
+	write ctx (Jump 0);
+	(fun() -> DynArray.set ctx.ops p (Jump(pos ctx - p)))
+
+let cjmp cond ctx =
+	let p = pos ctx in
+	write ctx (Jump 0);
+	(fun() -> DynArray.set ctx.ops p (if cond then JumpIf(pos ctx - p) else JumpIfNot(pos ctx - p)))
+
+let trap ctx =
+	let p = pos ctx in
+	write ctx (Trap 0);
+	(fun() -> DynArray.set ctx.ops p (Trap(pos ctx - p)))
+
+let goto ctx p =
+	write ctx (Jump(p - pos ctx))
+
+let global ctx g =
+	let ginf = ctx.g in
+	try
+		Hashtbl.find ginf.globals g
+	with Not_found ->
+		let gid = DynArray.length ginf.gtable in
+		Hashtbl.add ginf.globals g gid;
+		DynArray.add ginf.gtable g;
+		gid
+
+let save_breaks ctx =
+	let oldc = ctx.continues in
+	let oldb = ctx.breaks in
+	let oldl = ctx.loop_limit in
+	let oldt = ctx.loop_traps in
+	ctx.loop_traps <- List.length ctx.traps;
+	ctx.loop_limit <- ctx.stack;
+	ctx.breaks <- [];
+	ctx.continues <- [];
+	(ctx , oldc, oldb , oldl, oldt)
+
+let process_continues (ctx,oldc,_,_,_) =
+	List.iter (fun (f,_) -> f()) ctx.continues;
+	ctx.continues <- oldc
+
+let process_breaks (ctx,_,oldb,oldl, oldt) =
+	List.iter (fun (f,_) -> f()) ctx.breaks;
+	ctx.loop_limit <- oldl;
+	ctx.loop_traps <- oldt;
+	ctx.breaks <- oldb
+
+let check_breaks ctx =
+	List.iter (fun (_,p) -> error "Break outside a loop" p) ctx.breaks;
+	List.iter (fun (_,p) -> error "Continue outside a loop" p) ctx.continues
+
+let make_array p el =
+	(ECall ((EConst (Builtin "array"),p),el), p)
+
+let get_cases_ints(cases) =
+	let max = ref (-1) in
+	let l = List.map (fun (e,e2) ->
+		match e with
+		| (EConst (Int n),_) when n >= 0 ->
+			if n > !max then max := n;
+			(n,e2)
+		| _ -> raise Exit
+	) cases in
+	(* // only create jump table if small or >10% cases matched *)
+	let nmatches = List.length l in
+	if nmatches < 3 then raise Exit;
+	if !max >= 16 && (nmatches * 100) / (!max + 1) < 10 then raise Exit;
+	if !max > 512 then raise Exit;
+	(l,!max + 1)
+
+let rec scan_labels ctx supported in_block e =
+	match fst e with
+	| EFunction (args,e) ->
+		let nargs = List.length args in
+		let traps = ctx.traps in
+		ctx.traps <- [];
+		ctx.stack <- ctx.stack + nargs;
+		scan_labels ctx supported false e;
+		ctx.stack <- ctx.stack - nargs;
+		ctx.traps <- traps
+	| EBlock _ ->
+		let old = ctx.stack in
+		Nast.iter (scan_labels ctx supported true) e;
+		ctx.stack <- old
+	| EVars l ->
+		if not in_block then error "Variable declaration must be done inside a block" (snd e);
+		List.iter (fun (_,e) ->
+			(match e with
+			| None -> ()
+			| Some e -> scan_labels ctx supported false e);
+			ctx.stack <- ctx.stack + 1
+		) l
+	| ELabel l when not supported ->
+		error "Label is not supported in this part of the program" (snd e);
+	| ELabel l when Hashtbl.mem ctx.g.labels l ->
+		error ("Duplicate label " ^ l) (snd e)
+	| ELabel l ->
+		let label = {
+			lname = l;
+			ltraps = List.rev ctx.traps;
+			lstack = ctx.stack;
+			lpos = None;
+			lwait = [];
+		} in
+		Hashtbl.add ctx.g.labels l label
+	| ETry (e,_,e2) ->
+		ctx.stack <- ctx.stack + trap_stack_delta;
+		ctx.traps <- ctx.stack :: ctx.traps;
+		scan_labels ctx supported false e;
+		ctx.stack <- ctx.stack - trap_stack_delta;
+		ctx.traps <- (match ctx.traps with [] -> assert false | _ :: l -> l);
+		ctx.stack <- ctx.stack + 1;
+		scan_labels ctx supported false e2;
+		ctx.stack <- ctx.stack - 1;
+	| EBinop ("=",e1,e2) ->
+		let rec is_extended (e,_) =
+			match e with
+			| EParenthesis e -> is_extended e
+			| EArray _
+			| EField _ ->
+				true
+			| _ ->
+				false
+		in
+		let ext = is_extended e1 in
+		if ext then ctx.stack <- ctx.stack + 1;
+		scan_labels ctx supported false e2;
+		ctx.stack <- ctx.stack + 1;
+		scan_labels ctx supported false e1;
+		ctx.stack <- ctx.stack - (if ext then 2 else 1);
+	| ECall ((EConst (Builtin "array"),_),e :: el) ->
+		if ctx.version >= 2 then begin
+			scan_labels ctx supported false e;
+			List.iter (fun e ->
+				ctx.stack <- ctx.stack + 1;
+				scan_labels ctx supported false e;
+			) el;
+			ctx.stack <- ctx.stack - List.length el
+		end else begin
+			List.iter (fun e ->
+				scan_labels ctx supported false e;
+				ctx.stack <- ctx.stack + 1;
+			) el;
+			scan_labels ctx supported false e;
+			ctx.stack <- ctx.stack - List.length el
+		end
+	| ECall ((EConst (Builtin x),_),el) when x <> "apply" ->
+		Nast.iter (scan_labels ctx false false) e
+	| ECall ((EConst (Builtin "apply"),_),e :: el)
+	| ECall(e,el) ->
+		List.iter (fun e ->
+			scan_labels ctx supported false e;
+			ctx.stack <- ctx.stack + 1;
+		) el;
+		scan_labels ctx supported false e;
+		ctx.stack <- ctx.stack - List.length el
+	| EObject fl ->
+		ctx.stack <- ctx.stack + 2;
+		List.iter (fun (s,e) ->
+			scan_labels ctx supported false e
+		) fl;
+		ctx.stack <- ctx.stack - 2;
+	| ESwitch (ee,[(econd,exec)],eo) ->
+		let p = snd e in
+		scan_labels ctx supported false (EIf ((EBinop ("==",ee,econd),p),exec,eo),p)
+	| ESwitch (e,cases,eo) ->
+		scan_labels ctx supported false e;
+		let delta = (try ignore(get_cases_ints cases); 0 with Exit -> 1) in
+		ctx.stack <- ctx.stack + delta;
+		List.iter (fun (e1,e2) ->
+			ctx.stack <- ctx.stack + delta;
+			scan_labels ctx supported false e1;
+			ctx.stack <- ctx.stack - delta;
+			scan_labels ctx supported false e2;
+		) cases;
+		(match eo with
+		| None -> ()
+		| Some e -> scan_labels ctx supported false e);
+		ctx.stack <- ctx.stack - delta;
+	| ENext (e1,e2) ->
+		scan_labels ctx supported in_block e1;
+		scan_labels ctx supported in_block e2;
+	| EConst _
+	| EContinue
+	| EBreak _
+	| EReturn _
+	| EIf _
+	| EWhile _
+	| EParenthesis _ ->
+		Nast.iter (scan_labels ctx supported false) e
+	| EBinop (_,_,_)
+	| EArray _
+	| EField _
+		->
+		Nast.iter (scan_labels ctx false false) e
+	| ENeko _ ->
+		assert false
+
+let compile_constant ctx c p =
+	match c with
+	| True -> write ctx AccTrue
+	| False -> write ctx AccFalse
+	| Null -> write ctx AccNull
+	| This -> write ctx AccThis
+	| Int n -> write ctx (AccInt n)
+	| Int32 n -> write ctx (AccInt32 n)
+	| Float f -> write ctx (AccGlobal (global ctx (GlobalFloat f)))
+	| String s -> write ctx (AccGlobal (global ctx (GlobalString s)))
+	| Builtin s ->
+		(match s with
+		| "tnull" -> write ctx (AccInt 0)
+		| "tint" -> write ctx (AccInt 1)
+		| "tfloat" -> write ctx (AccInt 2)
+		| "tbool" -> write ctx (AccInt 3)
+		| "tstring" -> write ctx (AccInt 4)
+		| "tobject" -> write ctx (AccInt 5)
+		| "tarray" -> write ctx (AccInt 6)
+		| "tfunction" -> write ctx (AccInt 7)
+		| "tabstract" -> write ctx (AccInt 8)
+		| s ->
+			write ctx (AccBuiltin s))
+	| Ident s ->
+		try
+			let l = PMap.find s ctx.locals in
+			if l <= ctx.limit then
+				let e = (try
+					PMap.find s ctx.env
+				with Not_found ->
+					let e = ctx.nenv in
+					ctx.nenv <- ctx.nenv + 1;
+					ctx.env <- PMap.add s e ctx.env;
+					e
+				) in
+				write ctx (AccEnv e);
+			else
+				let p = ctx.stack - l in
+				write ctx (if p = 0 then AccStack0 else if p = 1 then AccStack1 else AccStack p);
+		with Not_found ->
+			let g = global ctx (GlobalVar s) in
+			write ctx (AccGlobal g)
+
+let rec compile_access ctx e =
+	match fst e with
+	| EConst (Ident s) ->
+		(try
+			let l = PMap.find s ctx.locals in
+			if l <= ctx.limit then
+				let e = (try
+					PMap.find s ctx.env
+				with Not_found ->
+					let e = ctx.nenv in
+					ctx.nenv <- ctx.nenv + 1;
+					ctx.env <- PMap.add s e ctx.env;
+					e
+				) in
+				XEnv e
+			else
+				XStack l
+		with Not_found ->
+			let g = global ctx (GlobalVar s) in
+			XGlobal g)
+	| EField (e,f) ->
+		compile ctx false e;
+		write ctx Push;
+		XField f
+	| EArray (e1,(EConst (Int n),_)) ->
+		compile ctx false e1;
+		write ctx Push;
+		XIndex n
+	| EArray (ea,ei) ->
+		compile ctx false ei;
+		write ctx Push;
+		compile ctx false ea;
+		write ctx Push;
+		XArray
+	| EConst This ->
+		XThis
+	| _ ->
+		error "Invalid access" (snd e)
+
+and compile_access_set ctx a =
+	match a with
+	| XEnv n -> write ctx (SetEnv n)
+	| XStack l -> write ctx (SetStack (ctx.stack - l))
+	| XGlobal g -> write ctx (SetGlobal g)
+	| XField f -> write ctx (SetField f)
+	| XIndex i -> write ctx (SetIndex i)
+	| XThis -> write ctx SetThis
+	| XArray -> write ctx SetArray
+
+and compile_access_get ctx a =
+	match a with
+	| XEnv n -> write ctx (AccEnv n)
+	| XStack l -> write ctx (AccStack (ctx.stack - l))
+	| XGlobal g -> write ctx (AccGlobal g)
+	| XField f -> write ctx (AccField f)
+	| XIndex i -> write ctx (AccIndex i)
+	| XThis -> write ctx AccThis
+	| XArray ->
+		write ctx Push;
+		write ctx (AccStack 2);
+		write ctx AccArray
+
+and write_op ctx op p =
+	match op with
+	| "+" -> write ctx Add
+	| "-" -> write ctx Sub
+	| "/" -> write ctx Div
+	| "*" -> write ctx Mult
+	| "%" -> write ctx Mod
+	| "<<" -> write ctx Shl
+	| ">>" -> write ctx Shr
+	| ">>>" -> write ctx UShr
+	| "|" -> write ctx Or
+	| "&" -> write ctx And
+	| "^" -> write ctx Xor
+	| "==" -> write ctx Eq
+	| "!=" -> write ctx Neq
+	| ">" -> write ctx Gt
+	| ">=" -> write ctx Gte
+	| "<" -> write ctx Lt
+	| "<=" -> write ctx Lte
+	| _ -> error "Unknown operation" p
+
+and compile_binop ctx tail op e1 e2 p =
+	match op with
+	| "=" ->
+		let a = compile_access ctx e1 in
+		compile ctx false e2;
+		compile_access_set ctx a
+	| "&&" ->
+		compile ctx false e1;
+		let jnext = cjmp false ctx in
+		compile ctx tail e2;
+		jnext()
+	| "||" ->
+		compile ctx false e1;
+		let jnext = cjmp true ctx in
+		compile ctx tail e2;
+		jnext()
+	| "++="
+	| "--=" ->
+		write ctx Push;
+		let base = ctx.stack in
+		let a = compile_access ctx e1 in
+		compile_access_get ctx a;
+		write ctx (SetStack(ctx.stack - base));
+		write ctx Push;
+		compile ctx false e2;
+		write_op ctx (String.sub op 0 (String.length op - 2)) p;
+		compile_access_set ctx a;
+		write ctx (AccStack 0);
+		write ctx (Pop 1);
+	| "+="
+	| "-="
+	| "/="
+	| "*="
+	| "%="
+	| "<<="
+	| ">>="
+	| ">>>="
+	| "|="
+	| "&="
+	| "^=" ->
+		let a = compile_access ctx e1 in
+		compile_access_get ctx a;
+		write ctx Push;
+		compile ctx false e2;
+		write_op ctx (String.sub op 0 (String.length op - 1)) p;
+		compile_access_set ctx a
+	| _ ->
+		match (op , e1 , e2) with
+		| ("==" , _ , (EConst Null,_)) ->
+			compile ctx false e1;
+			write ctx IsNull
+		| ("!=" , _ , (EConst Null,_)) ->
+			compile ctx false e1;
+			write ctx IsNotNull
+		| ("==" , (EConst Null,_) , _) ->
+			compile ctx false e2;
+			write ctx IsNull
+		| ("!=" , (EConst Null,_) , _) ->
+			compile ctx false e2;
+			write ctx IsNotNull
+		| ("-", (EConst (Int 0),_) , (EConst (Int i),_)) ->
+			compile ctx tail (EConst (Int (-i)),p)
+		| _ ->
+			compile ctx false e1;
+			write ctx Push;
+			compile ctx false e2;
+			write_op ctx op p
+
+and compile_function main params e =
+	let ctx = {
+		g = main.g;
+		(* // reset *)
+		ops = DynArray.create();
+		pos = DynArray.create();
+		breaks = [];
+		continues = [];
+		env = PMap.empty;
+		nenv = 0;
+		traps = [];
+		loop_traps = 0;
+		limit = main.stack;
+		(* // dup *)
+		version = main.version;
+		stack = main.stack;
+		locals = main.locals;
+		loop_limit = main.loop_limit;
+		curpos = main.curpos;
+		curfile = main.curfile;
+	} in
+	List.iter (fun v ->
+		ctx.stack <- ctx.stack + 1;
+		ctx.locals <- PMap.add v ctx.stack ctx.locals;
+	) params;
+	let s = ctx.stack in
+	compile ctx true e;
+	write ctx (Ret (ctx.stack - ctx.limit));
+	check_stack ctx s (snd e);
+	check_breaks ctx;
+	(* // add let *)
+	let gid = DynArray.length ctx.g.gtable in
+	ctx.g.functions <- (ctx.ops,ctx.pos,gid,List.length params) :: ctx.g.functions;
+	DynArray.add ctx.g.gtable (GlobalFunction(gid,-1));
+	(* // environment *)
+	if ctx.nenv > 0 then
+		let a = Array.make ctx.nenv "" in
+		PMap.iter (fun v i -> a.(i) <- v) ctx.env;
+		Array.iter (fun v ->
+			compile_constant main (Ident v) (snd e);
+			write main Push;
+		) a;
+		write main (AccGlobal gid);
+		write main (MakeEnv ctx.nenv);
+	else
+		write main (AccGlobal gid);
+
+and compile_builtin ctx tail b el p =
+	match (b , el) with
+	| ("istrue" , [e]) ->
+		compile ctx false e;
+		write ctx Bool
+	| ("not" , [e]) ->
+		compile ctx false e;
+		write ctx Not
+	| ("typeof" , [e]) ->
+		compile ctx false e;
+		write ctx TypeOf
+	| ("hash" , [e]) ->
+		compile ctx false e;
+		write ctx Hash
+	| ("new" , [e]) ->
+		compile ctx false e;
+		write ctx New
+	| ("compare" , [e1;e2]) ->
+		compile ctx false e1;
+		write ctx Push;
+		compile ctx false e2;
+		write ctx Compare
+	| ("pcompare" , [e1;e2]) ->
+		compile ctx false e1;
+		write ctx Push;
+		compile ctx false e2;
+		write ctx PhysCompare
+	| ("goto" , [(EConst (Ident l) , _)] ) ->
+		let l = (try Hashtbl.find ctx.g.labels l with Not_found -> error ("Unknown label " ^ l) p) in
+		let os = ctx.stack in
+		let rec loop l1 l2 =
+			match l1, l2 with
+			| x :: l1 , y :: l2 when x == y -> loop l1 l2
+			| _ -> (l1,l2)
+		in
+		let straps , dtraps = loop (List.rev ctx.traps) l.ltraps in
+		List.iter (fun l ->
+			if ctx.stack <> l then write ctx (Pop(ctx.stack - l));
+			write ctx EndTrap;
+		) (List.rev straps);
+		let dtraps = List.map (fun l ->
+			let l = l - trap_stack_delta in
+			if l < ctx.stack then write ctx (Pop(ctx.stack - l));
+			while ctx.stack < l do
+				write ctx Push;
+			done;
+			trap ctx
+		) dtraps in
+		if l.lstack < ctx.stack then write ctx (Pop(ctx.stack - l.lstack));
+		while l.lstack > ctx.stack do
+			write ctx Push;
+		done;
+		ctx.stack <- os;
+		(match l.lpos with
+		| None -> l.lwait <- jmp ctx :: l.lwait
+		| Some p -> write ctx (Jump p));
+		List.iter (fun t ->
+			t();
+			write ctx Push;
+			compile_constant ctx (Builtin "raise") p;
+			write ctx (Call 1);
+			(* // insert an infinite loop in order to
+			// comply with bytecode checker *)
+			let _ = jmp ctx in
+			()
+		) dtraps;
+	| ("goto" , _) ->
+		error "Invalid $goto statement" p
+	| ("array",e :: el) ->
+		let count = List.length el in
+		(* // a single let can't have >128 stack *)
+		if count > 120 - ctx.stack && count > 8 then begin
+			(* // split in 8 and recurse *)
+			let part = count lsr 3 in
+			let rec loop el acc count =
+				match el with
+				| [] -> [List.rev acc]
+				| e :: l ->
+					if count == part then
+						(List.rev acc) :: loop el [] 0
+					else
+						loop l (e :: acc) (count + 1)
+			in
+			let arr = make_array p (List.map (make_array p) (loop (e :: el) [] 0)) in
+			compile_builtin ctx tail "aconcat" [arr] p;
+		end else if ctx.version >= 2 then begin
+			compile ctx false e;
+			List.iter (fun e ->
+				write ctx Push;
+				compile ctx false e;
+			) el;
+			write ctx (MakeArray count);
+		end else begin
+			List.iter (fun e ->
+				compile ctx false e;
+				write ctx Push;
+			) el;
+			compile ctx false e;
+			write ctx (MakeArray count);
+		end
+	| ("apply",e :: el) ->
+		List.iter (fun e ->
+			compile ctx false e;
+			write ctx Push;
+		) el;
+		compile ctx false e;
+		let nargs = List.length el in
+		if nargs > 0 then write ctx (Apply nargs);
+	| _ ->
+		List.iter (fun e ->
+			compile ctx false e;
+			write ctx Push;
+		) el;
+		compile_constant ctx (Builtin b) p;
+		if tail then
+			write ctx (TailCall(List.length el,ctx.stack - ctx.limit))
+		else
+			write ctx (Call (List.length el))
+
+and compile ctx tail (e,p) =
+	set_pos ctx p;
+	match e with
+	| EConst c ->
+		compile_constant ctx c p
+	| EBlock [] ->
+		write ctx AccNull
+	| EBlock el ->
+		let locals = ctx.locals in
+		let stack = ctx.stack in
+		let rec loop(el) =
+			match el with
+			| [] -> assert false
+			| [e] -> compile ctx tail e
+			| [e; (ELabel _,_) as f] ->
+				compile ctx tail e;
+				compile ctx tail f
+			| e :: el ->
+				compile ctx false e;
+				loop el
+		in
+		loop el;
+		if stack < ctx.stack then write ctx (Pop (ctx.stack - stack));
+		check_stack ctx stack p;
+		ctx.locals <- locals
+	| EParenthesis e ->
+		compile ctx tail e
+	| EField (e,f) ->
+		compile ctx false e;
+		write ctx (AccField f)
+	| ECall (e,a :: b :: c :: d :: x1 :: x2 :: l) when (match e with (EConst (Builtin "array"),_) -> false | _ -> true) ->
+		let call = (EConst (Builtin "call"),p) in
+		let args = (ECall ((EConst (Builtin "array"),p),(a :: b :: c :: d :: x1 :: x2 :: l)),p) in
+		(match e with
+		| (EField (e,name) , p2) ->
+			let locals = ctx.locals in
+			let etmp = (EConst (Ident "$tmp"),p2) in
+			compile ctx false (EVars [("$tmp",Some e)],p2);
+			compile ctx tail (ECall (call,[(EField (etmp,name),p2);etmp;args]), p);
+			write ctx (Pop 1);
+			ctx.locals <- locals
+		| _ ->
+			compile ctx tail (ECall (call,[e; (EConst This,p); args]),p))
+	| ECall ((EConst (Builtin b),_),el) ->
+		compile_builtin ctx tail b el p
+	| ECall ((EField (e,f),_),el) ->
+		List.iter (fun e ->
+			compile ctx false e;
+			write ctx Push;
+		) el;
+		compile ctx false e;
+		write ctx Push;
+		write ctx (AccField f);
+		write ctx (ObjCall(List.length el))
+	| ECall (e,el) ->
+		List.iter (fun e ->
+			compile ctx false e;
+			write ctx Push;
+		) el;
+		compile ctx false e;
+		if tail then
+			write ctx (TailCall(List.length el,ctx.stack - ctx.limit))
+		else
+			write ctx (Call(List.length el))
+	| EArray (e1,(EConst (Int n),_)) ->
+		compile ctx false e1;
+		write ctx (if n == 0 then AccIndex0 else if n == 1 then AccIndex1 else AccIndex n)
+	| EArray (e1,e2) ->
+		compile ctx false e1;
+		write ctx Push;
+		compile ctx false e2;
+		write ctx AccArray
+	| EVars vl ->
+		List.iter (fun (v,o) ->
+			(match o with
+			| None -> write ctx AccNull
+			| Some e -> compile ctx false e);
+			write ctx Push;
+			ctx.locals <- PMap.add v ctx.stack ctx.locals;
+		) vl
+	| EWhile (econd,e,NormalWhile) ->
+		let start = pos ctx in
+		if ctx.version >= 2 then write ctx Loop;
+		compile ctx false econd;
+		let jend = cjmp false ctx in
+		let save = save_breaks ctx in
+		compile ctx false e;
+		process_continues save;
+		goto ctx start;
+		process_breaks save;
+		jend();
+	| EWhile (econd,e,DoWhile) ->
+		let start = pos ctx in
+		if ctx.version >= 2 then write ctx Loop;
+		let save = save_breaks ctx in
+		compile ctx false e;
+		process_continues save;
+		compile ctx false econd;
+		write ctx (JumpIf (start - pos ctx));
+		process_breaks save
+	| EIf (e,e1,e2) ->
+		let stack = ctx.stack in
+		compile ctx false e;
+		let jelse = cjmp false ctx in
+		compile ctx tail e1;
+		check_stack ctx stack p;
+		(match e2 with
+		| None ->
+			jelse()
+		| Some e2 ->
+			let jend = jmp ctx in
+			jelse();
+			compile ctx tail e2;
+			check_stack ctx stack p;
+			jend())
+	| ETry (e,v,ecatch) ->
+		let trap = trap ctx in
+		ctx.traps <- ctx.stack :: ctx.traps;
+		compile ctx false e;
+		write ctx EndTrap;
+		ctx.traps <- (match ctx.traps with [] -> assert false | _ :: l -> l);
+		let jend = jmp ctx in
+		trap();
+		write ctx Push;
+		let locals = ctx.locals in
+		ctx.locals <- PMap.add v ctx.stack ctx.locals;
+		compile ctx tail ecatch;
+		write ctx (Pop 1);
+		ctx.locals <- locals;
+		jend()
+	| EBinop (op,e1,e2) ->
+		compile_binop ctx tail op e1 e2 p
+	| EReturn e ->
+		(match e with None -> write ctx AccNull | Some e -> compile ctx (ctx.traps == []) e);
+		let stack = ctx.stack in
+		List.iter (fun t ->
+			if ctx.stack > t then write ctx (Pop(ctx.stack - t));
+			write ctx EndTrap;
+		) ctx.traps;
+		write ctx (Ret (ctx.stack - ctx.limit));
+		ctx.stack <- stack
+	| EBreak e ->
+		(match e with
+		| None -> ()
+		| Some e -> compile ctx false e);
+		let s = ctx.stack in
+		let n = ref (List.length ctx.traps - ctx.loop_traps) in
+		List.iter (fun t ->
+			if !n > 0 then begin
+				decr n;
+				if ctx.stack > t then write ctx (Pop(ctx.stack - t));
+				write ctx EndTrap;
+			end
+		) ctx.traps;
+		if ctx.loop_limit <> ctx.stack then write ctx (Pop(ctx.stack - ctx.loop_limit));
+		ctx.stack <- s;
+		ctx.breaks <- (jmp ctx , p) :: ctx.breaks
+	| EContinue ->
+		let s = ctx.stack in
+		let n = ref (List.length ctx.traps - ctx.loop_traps) in
+		List.iter (fun t ->
+			if !n > 0 then begin
+				decr n;
+				if ctx.stack > t then write ctx (Pop(ctx.stack - t));
+				write ctx EndTrap;
+			end
+		) ctx.traps;
+		if ctx.loop_limit <> ctx.stack then write ctx (Pop(ctx.stack - ctx.loop_limit));
+		ctx.stack <- s;
+		ctx.continues <- (jmp ctx , p) :: ctx.continues
+	| EFunction (params,e) ->
+		compile_function ctx params e
+	| ENext (e1,e2) ->
+		compile ctx false e1;
+		compile ctx tail e2
+	| EObject [] ->
+		write ctx AccNull;
+		write ctx New
+	| EObject fl ->
+		let fields = List.sort compare (List.map fst fl) in
+		let id = (try
+			Hashtbl.find ctx.g.gobjects fields
+		with Not_found ->
+			let id = global ctx (GlobalVar ("o:" ^ string_of_int (Hashtbl.length ctx.g.gobjects))) in
+			Hashtbl.add ctx.g.gobjects fields id;
+			id
+		) in
+		write ctx (AccGlobal id);
+		write ctx New;
+		write ctx Push;
+		List.iter (fun (f,e) ->
+			write ctx Push;
+			compile ctx false e;
+			write ctx (SetField f);
+			write ctx AccStack0;
+		) fl;
+		write ctx (Pop 1)
+	| ELabel l ->
+		let l = (try Hashtbl.find ctx.g.labels l with Not_found -> assert false) in
+		if ctx.stack <> l.lstack || List.rev ctx.traps <> l.ltraps then error (Printf.sprintf "Label failure %d %d" ctx.stack l.lstack) p;
+		List.iter (fun f -> f()) l.lwait;
+		l.lwait <- [];
+		l.lpos <- Some (pos ctx)
+	| ESwitch (e,[(econd,exec)],eo) ->
+		compile ctx tail (EIf ((EBinop ("==",e,econd),p),exec,eo),p)
+	| ENeko _ ->
+		assert false
+	| ESwitch (e,cases,eo) ->
+		try
+			let ints , size = get_cases_ints cases in
+			compile ctx false e;
+			write ctx (JumpTable size);
+			let tbl = Array.make size None in
+			List.iter (fun (i,e) ->
+				tbl.(i) <- Some e;
+			) ints;
+			let tbl = Array.map (fun e -> (jmp ctx,e)) tbl in
+			Array.iter (fun (j,e) ->
+				if e == None then j()
+			) tbl;
+			(match eo with
+			| None -> write ctx AccNull
+			| Some e -> compile ctx tail e);
+			let jump_end = jmp ctx in
+			let tbl = Array.map (fun (j,e) ->
+				match e with
+				| Some e ->
+					j();
+					compile ctx tail e;
+					jmp ctx
+				| None ->
+					(fun() -> ())
+			) tbl in
+			jump_end();
+			Array.iter (fun j -> j()) tbl
+		with Exit ->
+			compile ctx false e;
+			write ctx Push;
+			let jumps = List.map (fun (e1,e2) ->
+				write ctx AccStack0;
+				write ctx Push;
+				compile ctx false e1;
+				write ctx Eq;
+				(cjmp true ctx , e2)
+			) cases in
+			(match eo with
+			| None -> write ctx AccNull
+			| Some e -> compile ctx tail (EBlock [e],p));
+			let jump_end = jmp ctx in
+			let jumps = List.map (fun (j,e) ->
+				j();
+				compile ctx tail (EBlock [e],p);
+				jmp ctx;
+			) jumps in
+			jump_end();
+			List.iter (fun j -> j()) jumps;
+			write ctx (Pop 1)
+
+let compile version ast =
+	let g = {
+		globals = Hashtbl.create 0;
+		gobjects = Hashtbl.create 0;
+		gtable = DynArray.create();
+		functions = [];
+		labels = Hashtbl.create 0;
+		hfiles = Hashtbl.create 0;
+		files = DynArray.create();
+	} in
+	let ctx = {
+		g = g;
+		version = version;
+		stack = 0;
+		loop_limit = 0;
+		loop_traps = 0;
+		limit = -1;
+		locals = PMap.empty;
+		ops = DynArray.create();
+		breaks = [];
+		continues = [];
+		env = PMap.empty;
+		nenv = 0;
+		traps = [];
+		pos = DynArray.create();
+		curpos = (0,0);
+		curfile = "_";
+	} in
+	if version >= 2 then DynArray.add g.gtable (GlobalVersion version);
+	scan_labels ctx true true ast;
+	compile ctx false ast;
+	check_breaks ctx;
+	if g.functions <> [] || Hashtbl.length g.gobjects <> 0 then begin
+		let ctxops = ctx.ops in
+		let ctxpos = ctx.pos in
+		let ops = DynArray.create() in
+		let pos = DynArray.create() in
+		ctx.pos <- pos;
+		ctx.ops <- ops;
+		write ctx (Jump 0);
+		List.iter (fun (fops,fpos,gid,nargs) ->
+			DynArray.set g.gtable gid (GlobalFunction(DynArray.length ops,nargs));
+			DynArray.append fops ops;
+			DynArray.append fpos pos;
+		) (List.rev g.functions);
+		DynArray.set ops 0 (Jump (DynArray.length ops));
+		let objects = DynArray.create() in
+		Hashtbl.iter (fun fl g -> DynArray.add objects (fl,g)) g.gobjects;
+		let objects = DynArray.to_array objects in
+		Array.sort (fun (_,g1) (_,g2) -> g1 - g2) objects;
+		Array.iter (fun (fl,g) ->
+			write ctx AccNull;
+			write ctx New;
+			write ctx (SetGlobal g);
+			List.iter (fun f ->
+				write ctx (AccGlobal g);
+				write ctx Push;
+				write ctx (SetField f);
+			) fl
+		) objects;
+		DynArray.append ctxpos pos;
+		DynArray.append ctxops ops;
+	end;
+	DynArray.add g.gtable (GlobalDebug (DynArray.to_array ctx.g.files,DynArray.to_array ctx.pos));
+	(DynArray.to_array g.gtable, DynArray.to_array ctx.ops)
+

libs/neko/nxml.ml

@@ -0,0 +1,166 @@
+(*
+ *  Neko NXML for OCaml
+ *  Copyright (c)2005 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+open Nast
+
+type xml =
+	| Node of string * (string * string) list * xml list
+	| CData of string
+
+let node name att childs = Node(name,att,childs)
+
+let rec to_xml_rec p2 ast =
+	let e , p = ast in
+	let name = ref "" in
+	let aval = ref None in
+	let childs = ref [] in
+	(match e with
+	| EConst c ->
+		(match c with
+		| True
+		| False
+		| Null
+		| This
+		| Builtin _
+		| Ident _ ->
+			name := "v";
+			aval := Some (s_constant c)
+		| Int i ->
+			name := "i";
+			aval := Some (string_of_int i);
+		| Float s ->
+			name := "f";
+			aval := Some s;
+		| String s ->
+			name := "s";
+			aval := Some s;
+		| Int32 i ->
+			name := "i";
+			aval := Some (Int32.to_string i);
+		)
+	| EBlock el ->
+		name := "b";
+		childs := List.map (to_xml_rec p) el;
+	| EParenthesis e ->
+		name := "p";
+		childs := [to_xml_rec p e];
+	| EField (e,f) ->
+		name := "g";
+		aval := Some f;
+		childs := [to_xml_rec p e];
+	| ECall (e,el) ->
+		name := "c";
+		childs := to_xml_rec p e :: List.map (to_xml_rec p) el;
+	| EArray (a,b) ->
+		name := "a";
+		childs := [to_xml_rec p a; to_xml_rec p b];
+	| EVars vl ->
+		name := "var";
+		childs := List.map (fun(v,e) ->
+			node "v" [("v",v)] (match e with None -> [] | Some e -> [to_xml_rec p e])
+		) vl;
+	| EWhile (econd,e,NormalWhile) ->
+		name := "while";
+		childs := [to_xml_rec p econd; to_xml_rec p e];
+	| EWhile (econd,e,DoWhile) ->
+		name := "do";
+		childs := [to_xml_rec p e; to_xml_rec p econd];
+	| EIf (cond,e,eelse) ->
+		name := "if";
+		childs := to_xml_rec p cond :: to_xml_rec p e :: (match eelse with None -> [] | Some e -> [to_xml_rec p e])
+	| ETry (e1,v,e2) ->
+		name := "try";
+		aval := Some v;
+		childs := [to_xml_rec p e1; to_xml_rec p e2];
+	| EFunction (args,e) ->
+		name := "function";
+		aval := Some (String.concat ":" args);
+		childs := [to_xml_rec p e];
+	| EBinop (op,e1,e2) ->
+		name := "o";
+		aval := Some op;
+		childs := [to_xml_rec p e1; to_xml_rec p e2];
+	| EReturn e ->
+		name := "return";
+		childs := (match e with None -> [] | Some e -> [to_xml_rec p e]);
+	| EBreak e ->
+		name := "break";
+		childs := (match e with None -> [] | Some e -> [to_xml_rec p e]);
+	| EContinue ->
+		name := "continue";
+	| ENext (e1,e2) ->
+		name := "next";
+		childs := [to_xml_rec p e1; to_xml_rec p e2];
+	| EObject fl ->
+		name := "object";
+		childs := List.map (fun(v,e) -> node "v" [("v",v)] [to_xml_rec p e]) fl;
+	| ELabel v ->
+		name := "label";
+		aval := Some v;
+	| ESwitch (e,cases,def) ->
+		name := "switch";
+		let cases = List.map (fun(e1,e2) -> node "case" [] [to_xml_rec p e1; to_xml_rec p e2]) cases in
+		childs := to_xml_rec p e :: (match def with None -> cases | Some e -> node "default" [] [to_xml_rec p e] :: cases );
+	| ENeko s ->
+		name := "neko";
+		childs := [CData s];
+	);
+	let pos = (if p.psource <> p2.psource then
+		[("p",p.psource ^ ":" ^ string_of_int p.pline)]
+	else if p.pline <> p2.pline then
+		[("p",string_of_int p.pline)]
+	else
+		[]
+	) in
+	let aval = (match !aval with None -> [] | Some v -> [("v",v)]) in
+	node !name (List.append pos aval) !childs
+
+let to_xml ast =
+	to_xml_rec null_pos ast
+
+let rec write_fmt_rec tabs ch x =
+	match x with
+	| CData s ->
+		IO.printf ch "%s<![CDATA[%s]]>" tabs s
+	| Node (name,att,childs) ->
+		IO.printf ch "%s<%s%s" tabs name (String.concat "" (List.map (fun(a,v) -> " " ^ a ^ "=\"" ^ escape v ^ "\"") att));
+		match childs with
+		| [] -> IO.nwrite_string ch "/>"
+		| l ->
+			IO.nwrite_string ch ">\n";
+			List.iter (fun(x) -> write_fmt_rec (tabs ^ " ") ch x; IO.write ch '\n') l;
+			IO.printf ch "%s</%s>" tabs name
+
+let write_fmt ch x =
+	write_fmt_rec "" ch (node "nxml" [] [x])
+
+let rec write_rec ch x =
+	match x with
+	| CData s ->
+		IO.printf ch "<![CDATA[%s]]>" s
+	| Node (name,att,childs) ->
+		IO.printf ch "<%s%s" name (String.concat "" (List.map (fun(a,v) -> " " ^ a ^ "=\"" ^ escape v ^ "\"") att));
+		match childs with
+		| [] -> IO.nwrite_string ch "/>"
+		| l ->
+			IO.nwrite_string ch ">";
+			List.iter (fun(x) -> write_rec ch x) l;
+			IO.printf ch "</%s>" name
+
+let write ch x =
+	write_rec ch (node "nxml" [] [x])

libs/objsize/META

@@ -0,0 +1,3 @@
+version="0.16"
+archive(byte)="objsize.cma"
+archive(native)="objsize.cmxa"

libs/objsize/Makefile

@@ -0,0 +1,29 @@
+ALL_CFLAGS = $(CFLAGS) -I .
+LIBS =
+OCAMLOPT=ocamlopt
+OCAMLC=ocamlc
+SRC=objsize.mli objsize.ml
+
+all: bytecode native
+
+bytecode: objsize.cma
+
+native: objsize.cmxa
+
+objsize.cma: c_objsize.o $(SRC)
+	$(OCAMLC) -safe-string -a -o objsize.cma $(LIBS) $(SRC)
+
+objsize.cmxa: c_objsize.o $(SRC)
+	$(OCAMLOPT) -safe-string -a -o objsize.cmxa $(LIBS) $(SRC)
+
+c_objsize.o: c_objsize.c
+	$(OCAMLC) -safe-string $(ALL_CFLAGS) c_objsize.c
+
+clean:
+	rm -rf $(wildcard *.cma) $(wildcard *.cmxa) $(wildcard *.cmx) $(wildcard *.cmi) $(wildcard *.cmo) $(wildcard *.obj) $(wildcard *.o) $(wildcard *.a)
+
+.PHONY: all bytecode native clean
+
+Makefile: ;
+$(SRC): ;
+c_objsize.c: ;

libs/objsize/README

@@ -0,0 +1,89 @@
+What is this?
+
+  This is a small OCaml library for computing size of OCaml values.
+  It computes count of words used for values, count of values' headers,
+  maximal depth of values.  There are functions to get size of values
+  in bytes too.
+
+
+How to use it?
+
+  See objsize.mli for documentation.
+
+
+How to compile/install it?
+
+  Run "make <target>" in this directory.  Useful make targets are:
+  - lib : build objsize library
+  - tests : build tests with fresh-compiled library
+  - install : install package "objsize" using findlib
+  - uninstall : uninstall package "objsize"
+  - clean : clean working directory
+  - tests-installed : clean working directory and build test programs
+      assuming you have installed package "objsize" using findlib.
+
+
+How it works?
+
+  C-function walks through values and uses header's field "color"
+  to mark visited values, then restores original values' "color".
+  Colors are stored using rle-like compression to decrease memory
+  usage.
+
+
+Bugs?
+
+  1. Some constant values (like lists of integers) are
+     constructed at compile time and placed outside of both heaps,
+     and size of these values will be returned as 0.
+
+  2. Internal function is not fully tail-recursive,
+     so generally it uses stack proportionally to the depth
+     of the value.
+
+     There is an optimization to handle long lists and some
+     other datastructures: when objsize walks through the
+     structured block, the goto is used instead of recursive
+     call to walk into the last value that should be visited.
+
+     This optimization is not general, and the best solution
+     would be to use heap memory instead of stack memory to store
+     "walk path", but I don't need it now (please contribute
+     if you want).
+
+  3. It requires gnu make.  It's possible to write Makefile for
+     nmake, but I have no MSVC to test.  The best solution is
+     to use ocamlbuild.  Either I will write ocamlbuild script
+     later, or you will contribute it.  But it's possible
+     to build without any makefiles: see original Makefile for
+     details.
+
+  4. OCaml 3.11 has new implementation of heap.  Versions of
+     objsize >= 0.12 work only with OCaml 3.11 heap, versions
+     of objsize <= 0.11 work only with OCaml <= 3.10.2 heap.
+     Runtime failure will be raised if you link objsize >= 0.12
+     with OCaml < 3.11.
+
+  5. "Bugs" section is too long.
+
+
+License?
+
+  Dual: BSD/GPL.
+
+
+Changes?
+
+  0.1  - 2007-12-13 - Initial public release.
+  0.11 - 2007-12-14 - "configure" made right. Now it works on 64-bits too.
+  0.12 - 2009-04-08 - Works with OCaml 3.11, installs with findlib.
+  0.13 - 2009-09-01 - Tiny change about so/dll suffix for unix/windows.
+  0.14 - 2010-01-26 - Fixing so/dll again.
+                      Some stack usage optimization,
+                      see the modified Bug #2 description.
+  0.15 - 2010-04-15 - Fixing bug appeared in 0.14. (thanks to Steven Ramsay)
+  0.16 - 2010-08-11 - Fixing bug appeared in 0.14. (thanks to SerP)
+
+Author?
+
+  Dmitry Grebeniuk <gdsfh1 at gmail dot com>

libs/objsize/alloc.c

@@ -0,0 +1,40 @@
+#if (!defined(ALLOC_PRF) || !defined(ALLOC_TYPE))
+#error
+#endif
+
+#include "util.h"
+#include <stdlib.h>
+#include <stdio.h>
+
+
+ALLOC_TYPE* ALLOC_PRF(_alloc)(size_t count)
+ {
+ return malloc(count * sizeof(ALLOC_TYPE));
+ }
+
+void ALLOC_PRF(_free)(ALLOC_TYPE* arr)
+ {
+ free(arr);
+ }
+
+ALLOC_TYPE* ALLOC_PRF(_realloc)(ALLOC_TYPE* arr, size_t count)
+ {
+ size_t newsz = count * sizeof(ALLOC_TYPE);
+ ALLOC_TYPE* newarr = realloc(arr, newsz);
+ if (count != 0 && newarr == NULL)
+  {
+  static char msg[128];
+  sprintf
+    ( msg
+    , "realloc(%p, %u*%u=%u) failed: to provide an alternative behaviour."
+    , arr, (unsigned int) count, (unsigned int) sizeof(ALLOC_TYPE)
+    , (unsigned int) newsz
+    );
+  ABORT(msg);
+  };
+ return newarr;
+ }
+
+
+#undef ALLOC_PRF
+#undef ALLOC_TYPE

libs/objsize/bitarray.c

@@ -0,0 +1,103 @@
+#if ((!defined(PRF)))
+#error
+#endif
+
+#define BITS_OF_CHAR 8
+
+/*
+size_t PRF(_sizebytes)(size_t n);
+TYPE PRF(_get)(TYPE arr[], size_t i);
+void PRF(_set)(TYPE arr[], size_t i, TYPE val);
+*/
+
+#define ALPRF(x) bitarrayalloc##x
+
+#define ALLOC_TYPE unsigned char
+#define ALLOC_PRF(x) ALPRF(x)
+#include "alloc.c"
+
+
+size_t wordalign(size_t n)
+ {
+ size_t al = sizeof(int);
+ size_t m = al % n;
+ if (m == 0)
+  {
+  return n;
+  }
+ else
+  {
+  return n + al - m;
+  }
+ }
+
+
+size_t PRF(_sizebytes)(size_t n)
+ {
+ return wordalign(n/BITS_OF_CHAR);
+ }
+
+
+unsigned char* PRF(_alloc)(size_t count)
+ {
+ return ALPRF(_alloc)(PRF(_sizebytes)(count));
+ }
+
+
+void PRF(_free)(unsigned char* arr)
+ {
+ ALPRF(_free)(arr);
+ }
+
+
+unsigned char* PRF(_realloc)(unsigned char* arr, size_t newcount)
+ {
+ return ALPRF(_realloc)(arr, PRF(_sizebytes)(newcount));
+ }
+
+
+#define LVAL(arr, i) ((arr)[(i)/BITS_OF_CHAR])
+#define MASK(i) (1<<((i)%BITS_OF_CHAR))
+
+int PRF(_get)(unsigned char arr[], size_t i)
+ {
+ return ((LVAL(arr,i) & MASK(i)) ? 1 : 0);
+ }
+
+void PRF(_set)(unsigned char arr[], size_t i, int val)
+ {
+ unsigned char mask = MASK(i);
+ if (val)
+  {
+  LVAL(arr,i) |= mask;
+  }
+ else
+  {
+  LVAL(arr,i) &= ~mask;
+  }
+ return;
+ }
+
+void PRF(_init)(unsigned char arr[], size_t sz, int val)
+ {
+ size_t bytesize = sz/BITS_OF_CHAR;
+ size_t i;
+ unsigned char valbyte = val ? (-1) : 0;
+ for (i=0; i<bytesize; ++i)
+  {
+  arr[i] = valbyte;
+  };
+ i *= BITS_OF_CHAR;
+ while(i < sz)
+  {
+  PRF(_set)(arr, i, val);
+  ++i;
+  };
+ return;
+ }
+
+
+#undef MASK
+#undef LVAL
+
+#undef PRF

libs/objsize/c_objsize.c

@@ -0,0 +1,500 @@
+/*
+#define DBG(x) do { x; fflush(stdout); } while(0)
+*/
+#define DBG(x) do{}while(0)
+
+#define DUMP 0
+
+
+#define PRF(x) bitarray##x
+#include "bitarray.c"
+
+#include "util.h"
+
+#include <caml/memory.h>
+
+// FROM byterun/gc.h
+#define Caml_white (0 << 8)
+#define Caml_gray  (1 << 8)
+#define Caml_blue  (2 << 8)
+#define Caml_black (3 << 8)
+#define Colornum_hd(hd) ((color_t) (((hd) >> 8) & 3))
+#define Coloredhd_hd(hd,colnum) (((hd) & ~Caml_black) | ((colnum) << 8))
+
+#define Col_white (Caml_white >> 8)
+#define Col_gray  (Caml_gray >> 8)
+#define Col_blue  (Caml_blue >> 8)
+#define Col_black (Caml_black >> 8)
+
+
+#define COLORS_INIT_COUNT 256
+
+//--------------------------------------------------------
+// From byterun/memory.h:
+
+#define Not_in_heap 0
+#define In_heap 1
+#define In_young 2
+#define In_static_data 4
+#define In_code_area 8
+
+#ifdef ARCH_SIXTYFOUR
+
+// 64 bits: Represent page table as a sparse hash table
+int caml_page_table_lookup(void * addr);
+#define Classify_addr(a) (caml_page_table_lookup((void *)(a)))
+
+#else
+
+// 32 bits: Represent page table as a 2-level array
+#define Pagetable2_log 11
+#define Pagetable2_size (1 << Pagetable2_log)
+#define Pagetable1_log (Page_log + Pagetable2_log)
+#define Pagetable1_size (1 << (32 - Pagetable1_log))
+CAMLextern unsigned char * caml_page_table[Pagetable1_size];
+
+#define Pagetable_index1(a) (((uintnat)(a)) >> Pagetable1_log)
+#define Pagetable_index2(a) \
+  ((((uintnat)(a)) >> Page_log) & (Pagetable2_size - 1))
+#define Classify_addr(a) \
+  caml_page_table[Pagetable_index1(a)][Pagetable_index2(a)]
+
+#endif
+
+#define Is_in_heap_or_young(a) (Classify_addr(a) & (In_heap | In_young))
+
+//--------------------------------------------------------
+
+
+unsigned char* colors = NULL;
+size_t colors_bitcap = 0;
+size_t colors_writeindex = 0;
+size_t colors_readindex = 0;
+
+
+void colors_init(void)
+ {
+ ASSERT(colors==NULL, "colors_init");
+ colors_bitcap = COLORS_INIT_COUNT*2;
+ colors = bitarray_alloc(colors_bitcap);
+ colors_writeindex = 0;
+ colors_readindex = 0;
+ return;
+ }
+
+
+void colors_deinit(void)
+ {
+ bitarray_free(colors);
+ colors = NULL;
+ return;
+ }
+
+
+void writebit(int bit)
+ {
+ if (colors_writeindex == colors_bitcap)
+  {
+  size_t colors_new_bitcap = colors_bitcap * 2;
+  unsigned char* newarr = bitarray_realloc(colors, colors_new_bitcap);
+  ASSERT(newarr != NULL, "realloc");
+  colors = newarr;
+  colors_bitcap = colors_new_bitcap;
+  };
+ ASSERT(colors_writeindex < colors_bitcap, "bound on write");
+ bitarray_set(colors, colors_writeindex++, bit);
+ return;
+ }
+
+
+int readbit(void)
+ {
+ int res;
+ ASSERT(colors_readindex < colors_writeindex, "bound on read");
+ res = bitarray_get(colors, colors_readindex++);
+ ASSERT(res == 0 || res == 1, "bitarray_get");
+ return res;
+ }
+
+
+void writeint(unsigned int arg, unsigned int width)
+ {
+ while(width-- > 0)
+  {
+  writebit(arg&1);
+  arg >>= 1;
+  };
+ ASSERT(arg == 0, "writeint");
+ return;
+ }
+
+
+unsigned int readint(unsigned int width)
+ {
+ unsigned int acc = 0;
+ unsigned int hibit = 1 << (width-1);
+ ASSERT(width > 0, "readint width");
+ while(width-- > 0)
+  {
+  int bit = readbit();
+  acc >>= 1;
+  if (bit) acc |= hibit;
+  };
+ return acc;
+ }
+
+
+int prev_color = 0;
+int repeat_count = 0;
+
+#define BITS_FOR_COUNT 5
+#define BITS_FOR_ORDER 4
+
+#define MAX_REPEAT_COUNT (1<<BITS_FOR_COUNT)
+#define MAX_REPEAT_ORDER (1<<BITS_FOR_ORDER)
+
+void rle_write_repeats(void)
+ {
+ while(repeat_count >= MAX_REPEAT_COUNT)
+  {
+  unsigned int ord = 0;
+
+  while(ord < MAX_REPEAT_ORDER-1 && (1<<ord) <= repeat_count/2)
+   {
+   ++ord;
+   };
+
+  writeint(Col_blue, 2);
+  writeint(1, 1);
+  ASSERT((1<<ord) != 0, "write_repeats#2");
+  writeint(ord, BITS_FOR_ORDER);
+  repeat_count -= (1 << ord);
+  };
+
+ ASSERT(repeat_count < MAX_REPEAT_COUNT, "write_repeats");
+
+ if (repeat_count > 0)
+  {
+  writeint(Col_blue, 2);
+  writeint(0, 1);
+  writeint(repeat_count, BITS_FOR_COUNT);
+  repeat_count = 0;
+  };
+
+ return;
+ }
+
+
+void rle_write_flush(void)
+ {
+ if (repeat_count > 0)
+  {
+  rle_write_repeats();
+  };
+ ASSERT(repeat_count == 0, "rle_write_flush");
+ return;
+ }
+
+
+void rle_read_flush(void)
+ {
+ DBG(printf("rle_read_flush: repeat_count=%i, ri=%i, wi=%i\n",
+  repeat_count, colors_readindex, colors_writeindex)
+ );
+
+ ASSERT
+   ( repeat_count == 0
+     && colors_readindex == colors_writeindex
+   , "rle_reader_flush"
+   );
+ return;
+ }
+
+
+void rle_write(int color)
+ {
+ if (prev_color == color)
+  {
+  ++repeat_count;
+  }
+ else
+  {
+  rle_write_flush();
+  ASSERT(color != Col_blue, "rle_write");
+  writeint(color, 2);
+  prev_color = color;
+  };
+ }
+
+
+int rle_read(void);
+int rle_read(void)
+ {
+ if (repeat_count > 0)
+  {
+  --repeat_count;
+  return prev_color;
+  }
+ else
+  {
+  int c = readint(2);
+  if (c == Col_blue)
+   {
+   int rk = readint(1);
+   if (rk == 0)
+    { repeat_count = readint(BITS_FOR_COUNT); }
+   else
+    { repeat_count = 1 << readint(BITS_FOR_ORDER); };
+   ASSERT(repeat_count > 0, "rle_read");
+   return rle_read();
+   }
+  else
+   {
+   prev_color = c;
+   return c;
+   };
+  };
+ }
+
+
+void rle_init(void)
+ {
+ prev_color = 0;
+ repeat_count = 0;
+ return;
+ }
+
+
+
+void writecolor(int col)
+ {
+ ASSERT(col >= 0 && col <= 3 && col != Col_blue, "writecolor");
+ rle_write(col);
+ return;
+ }
+
+
+int readcolor(void)
+ {
+ int res = rle_read();
+ ASSERT(res >= 0 && res <= 3 && res != Col_blue, "readcolor");
+ return res;
+ }
+
+
+size_t acc_hdrs;
+size_t acc_data;
+size_t acc_depth;
+
+
+#define COND_BLOCK(q) \
+   (    Is_block(q) \
+     && (Is_in_heap_or_young(q)) \
+   )
+
+#define GEN_COND_NOTVISITED(v, op) \
+    ( Colornum_hd(Hd_val(v)) op Col_blue )
+
+#define ENTERING_COND_NOTVISITED(v) GEN_COND_NOTVISITED(v, != )
+
+#define RESTORING_COND_NOTVISITED(v) GEN_COND_NOTVISITED(v, == )
+
+#define REC_WALK(cond_notvisited, rec_call, rec_goto)                  \
+   size_t i;                                                           \
+   value prev_block;                                                   \
+   value f;                                                            \
+   prev_block = Val_unit;                                              \
+                                                                       \
+   for (i=0; i<sz; ++i)                                                \
+    {                                                                  \
+    f = Field(v,i);                                                    \
+    DBG(printf("(*%p)[%i/%i] = %p\n", (void*)v, i, sz, (void*)f));     \
+                                                                       \
+    if ( COND_BLOCK(f) )                                               \
+     {                                                                 \
+     if (prev_block != Val_unit && cond_notvisited(prev_block))        \
+      {                                                                \
+      rec_call                                                         \
+      };                                                               \
+     prev_block = f;                                                   \
+     };  /* if ( COND_BLOCK ) */                                       \
+    };                                                                 \
+                                                                       \
+   if (prev_block != Val_unit && cond_notvisited(prev_block) )         \
+    {                                                                  \
+    rec_goto                                                           \
+    };
+
+
+void c_rec_objsize(value v, size_t depth)
+ {
+  int col;
+  header_t hd;
+  size_t sz;
+
+  rec_enter:
+
+  DBG(printf("c_rec_objsize: v=%p\n"
+     , (void*)v)
+  );
+
+  sz = Wosize_val(v);
+
+  DBG(printf("after_if: v=%p\n", (void*)v));
+
+  acc_data += sz;
+  ++acc_hdrs;
+  if (depth > acc_depth) { acc_depth = depth; };
+
+  hd = Hd_val(v);
+  col = Colornum_hd(hd);
+  writecolor(col);
+
+  DBG(printf("COL: w %08lx %i\n", v, col));
+
+  Hd_val(v) = Coloredhd_hd(hd, Col_blue);
+
+  if (Tag_val(v) < No_scan_tag)
+   {
+   REC_WALK
+    ( ENTERING_COND_NOTVISITED
+    , c_rec_objsize(prev_block, (depth+1));
+    , v = prev_block;                                          \
+      depth = depth + 1;                                       \
+      DBG(printf("goto, depth=%i, v=%p\n", depth, (void*)v));  \
+      goto rec_enter;
+    )
+   }; /* (Tag_val(v) < No_scan_tag) */
+
+ return;
+ }
+
+
+void restore_colors(value v)
+ {
+  int col;
+
+  rec_restore:
+
+  col = readcolor();
+  DBG(printf("COL: r %08lx %i\n", v, col));
+  Hd_val(v) = Coloredhd_hd(Hd_val(v), col);
+
+  if (Tag_val(v) < No_scan_tag)
+   {
+   size_t sz = Wosize_val(v);
+
+   REC_WALK
+    ( RESTORING_COND_NOTVISITED
+    , restore_colors(prev_block);
+    , v = prev_block;                                          \
+      goto rec_restore;
+    )
+
+   };
+
+ return;
+ }
+
+
+int c_objsize(value v, value scan, value reach, size_t* headers, size_t* data, size_t* depth)
+ {
+ value head;
+ int reached = 0;
+ colors_init();
+ rle_init();
+ /*
+ DBG(printf("young heap from %p to %p\n", caml_young_start, caml_young_end));
+ DBG(printf("old heap from %p to %p\n", caml_heap_start, caml_heap_end));
+ */
+ DBG(printf("COL writing\n"));
+
+ head = scan;
+ while( COND_BLOCK(head) ) {
+	value v = Field(head,0);
+	header_t hd = Hd_val(v);
+	int col = Colornum_hd(hd);
+	head = Field(head,1);
+	if( col == Col_blue ) continue;
+	writecolor(col);
+	Hd_val(v) = Coloredhd_hd(hd, Col_blue);
+ }
+
+ acc_data = 0;
+ acc_hdrs = 0;
+ acc_depth = 0;
+ if ( COND_BLOCK(v) && Colornum_hd(Hd_val(v)) != Col_blue )
+  {
+  c_rec_objsize(v, 0);
+  };
+  if( headers != NULL ) {
+ *headers = acc_hdrs;
+ *data = acc_data;
+ *depth = acc_depth;
+  }
+
+ rle_write_flush();
+ DBG(printf("COL reading\n"));
+ rle_init();
+
+  head = scan;
+ while( COND_BLOCK(head) ) {
+	value v = Field(head,0);
+	int col;
+	head = Field(head,1);
+	if( Colornum_hd(Hd_val(v)) != Col_blue ) continue;
+	col = readcolor();
+	Hd_val(v) = Coloredhd_hd(Hd_val(v), col);
+ }
+
+  while( COND_BLOCK(reach) ) {
+	  value v = Field(reach,0);
+	  if( Colornum_hd(Hd_val(v)) == Col_blue ) {
+		reached = 1;
+		break;
+	  }
+	  reach = Field(reach,1);
+  }
+
+ if ( COND_BLOCK(v) && Colornum_hd(Hd_val(v)) == Col_blue )
+  {
+  restore_colors(v);
+  };
+ rle_read_flush();
+
+#if DUMP
+ printf("objsize: bytes for rle data = %i\n", colors_readindex/8);
+ fflush(stdout);
+
+  {
+  FILE* f = fopen("colors-dump", "w");
+  fwrite(colors, 1, colors_readindex/8, f);
+  fclose(f);
+  };
+#endif
+
+ colors_deinit();
+ DBG(printf("c_objsize done.\n"));
+
+ return reached;
+ }
+
+
+#include <caml/alloc.h>
+
+value ml_objsize(value start,value scan,value reach)
+ {
+ CAMLparam2(start,scan);
+ CAMLlocal1(res);
+ size_t hdrs, data, depth;
+ int reached = c_objsize(start, scan, reach, &hdrs, &data, &depth);
+
+ res = caml_alloc_small(4, 0);
+ Field(res, 0) = Val_int(data);
+ Field(res, 1) = Val_int(hdrs);
+ Field(res, 2) = Val_int(depth);
+ Field(res, 3) = Val_bool(reached);
+
+ CAMLreturn(res);
+ }
+