Merge remote-tracking branch 'libs-origin/refactor' into merge-libs-submodule

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/extc.ml

@@ -0,0 +1,211 @@
+(*
+ *  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"
+
+type library
+type sym
+type value
+
+external dlopen : string -> library = "sys_dlopen"
+external dlsym : library -> string -> sym = "sys_dlsym"
+external dlcall0 : sym -> value = "sys_dlcall0"
+external dlcall1 : sym -> value -> value = "sys_dlcall1"
+external dlcall2 : sym -> value -> value -> value = "sys_dlcall2"
+external dlcall3 : sym -> value -> value -> value -> value = "sys_dlcall3"
+external dlcall4 : sym -> value -> value -> value -> value -> value = "sys_dlcall4"
+external dlcall5 : sym -> value -> value -> value -> value -> value -> value = "sys_dlcall5_bc" "sys_dlcall5"
+external dlint : int -> value = "sys_dlint"
+external dltoint : value -> int = "sys_dltoint"
+external dlstring : string -> value = "%identity"
+external dladdr : value -> int -> value = "sys_dladdr"
+external dlptr : value -> value = "sys_dlptr"
+external dlsetptr : value -> value -> unit = "sys_dlsetptr"
+external dlalloc_string : value -> string = "sys_dlalloc_string"
+external dlmemcpy : value -> value -> int -> unit = "sys_dlmemcpy"
+external dlcallback : int -> value = "sys_dlcallback"
+external dlcaml_callback : int -> value = "sys_dlcaml_callback"
+external dlint32 : int32 -> value = "sys_dlint32"
+external getch : bool -> int = "sys_getch"
+
+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,710 @@
+/*
+ *  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);
+#else
+	struct timespec t;
+	clock_gettime(CLOCK_MONOTONIC_RAW, &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
+}
+
+// --------------- Support for NekoVM Bridge
+
+CAMLprim value sys_dlopen( value lib ) {
+#ifdef _WIN32
+	return (value)LoadLibrary(String_val(lib));
+#else
+	return (value)dlopen(String_val(lib),RTLD_LAZY);
+#endif
+}
+
+CAMLprim value sys_dlsym( value dl, value name ) {
+#ifdef _WIN32
+	return (value)GetProcAddress((HANDLE)dl,String_val(name));
+#else
+	return (value)dlsym((void*)dl,String_val(name));
+#endif
+}
+
+CAMLprim value sys_dlint( value i ) {
+	return Int_val(i);
+}
+
+CAMLprim value sys_dltoint( value i ) {
+	return Val_int((int)i);
+}
+
+CAMLprim value sys_dlint32( value i ) {
+	return (value)Int32_val(i);
+}
+
+typedef value (*c_prim0)();
+typedef value (*c_prim1)(value);
+typedef value (*c_prim2)(value,value);
+typedef value (*c_prim3)(value,value,value);
+typedef value (*c_prim4)(value,value,value,value);
+typedef value (*c_prim5)(value,value,value,value,value);
+
+CAMLprim value sys_dlcall0( value f ) {
+	return ((c_prim0)f)();
+}
+
+CAMLprim value sys_dlcall1( value f, value a ) {
+	return ((c_prim1)f)(a);
+}
+
+CAMLprim value sys_dlcall2( value f, value a, value b ) {
+	return ((c_prim2)f)(a,b);
+}
+
+CAMLprim value sys_dlcall3( value f, value a, value b, value c ) {
+	return ((c_prim3)f)(a,b,c);
+}
+
+CAMLprim value sys_dlcall4( value f, value a, value b, value c, value d ) {
+	return ((c_prim4)f)(a,b,c,d);
+}
+
+CAMLprim value sys_dlcall5( value f, value a, value b, value c, value d, value e ) {
+	return ((c_prim5)f)(a,b,c,d,e);
+}
+
+CAMLprim value sys_dlcall5_bc( value *args, int nargs ) {
+	return ((c_prim5)args[0])(args[1],args[2],args[3],args[4],args[5]);
+}
+
+CAMLprim value sys_dladdr( value v, value a ) {
+	return (value)((char*)v + Int_val(a));
+}
+
+CAMLprim value sys_dlptr( value v ) {
+	return *((value*)v);
+}
+
+CAMLprim value sys_dlsetptr( value p, value v ) {
+	*((value*)p) = v;
+	return Val_unit;
+}
+
+CAMLprim value sys_dlalloc_string( value v ) {
+	return caml_copy_string((char*)v);
+}
+
+CAMLprim value sys_dlmemcpy( value dst, value src, value len ) {
+	memcpy((char*)dst,(char*)src,Int_val(len));
+	return Val_unit;
+}
+
+static value __callb0( value callb ) {
+	return caml_callbackN(callb,0,NULL);
+}
+
+static value __callb1( value a, value callb ) {
+	return caml_callback(callb,a);
+}
+
+static value __callb2( value a, value b, value callb ) {
+	return caml_callback2(callb,a,b);
+}
+
+static value __callb3( value a, value b, value c, value callb ) {
+	return caml_callback3(callb,a,b,c);
+}
+
+CAMLprim value sys_dlcallback( value nargs ) {
+	switch( Int_val(nargs) ) {
+	case 0:
+		return (value)__callb0;
+	case 1:
+		return (value)__callb1;
+	case 2:
+		return (value)__callb2;
+	case 3:
+		return (value)__callb3;
+	default:
+		failwith("dlcallback(too_many_args)");
+	}
+	return Val_unit;
+}
+
+static value __caml_callb1( value a ) {
+	return caml_callback(*caml_named_value("dlcallb1"),a);
+}
+
+static value __caml_callb2( value a, value b ) {
+	return caml_callback2(*caml_named_value("dlcallb2"),a,b);
+}
+
+CAMLprim value sys_dlcaml_callback( value nargs ) {
+	switch( Int_val(nargs) ) {
+	case 1:
+		return (value)__caml_callb1;
+	case 2:
+		return (value)__caml_callb2;
+	default:
+		failwith("sys_dlcaml_callback(too_many_args)");
+	}
+	return Val_unit;
+}

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 uChar 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/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/uChar.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/uChar.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 UChar
+
+type t = string
+type index = int
+  
+let look s i =
+  let n' =
+    let n = Char.code s.[i] in
+    if n < 0x80 then n else
+    if n <= 0xdf then
+      (n - 0xc0) lsl 6 lor (0x7f land (Char.code s.[i + 1]))
+    else if n <= 0xef then
+      let n' = n - 0xe0 in
+      let m0 = Char.code s.[i + 2] in
+      let m = Char.code (String.unsafe_get s (i + 1)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      n' lsl 6 lor (0x7f land m0)
+    else if n <= 0xf7 then
+      let n' = n - 0xf0 in
+      let m0 = Char.code s.[i + 3] in
+      let m = Char.code (String.unsafe_get s (i + 1)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      let m = Char.code (String.unsafe_get s (i + 2)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      n' lsl 6 lor (0x7f land m0)     
+    else if n <= 0xfb then
+      let n' = n - 0xf8 in
+      let m0 = Char.code s.[i + 4] in
+      let m = Char.code (String.unsafe_get s (i + 1)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      let m = Char.code (String.unsafe_get s (i + 2)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      let m = Char.code (String.unsafe_get s (i + 3)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      n' lsl 6 lor (0x7f land m0)     
+    else if n <= 0xfd then
+      let n' = n - 0xfc in
+      let m0 = Char.code s.[i + 5] in
+      let m = Char.code (String.unsafe_get s (i + 1)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      let m = Char.code (String.unsafe_get s (i + 2)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      let m = Char.code (String.unsafe_get s (i + 3)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      let m = Char.code (String.unsafe_get s (i + 4)) in
+      let n' = n' lsl 6 lor (0x7f land m) in
+      n' lsl 6 lor (0x7f land m0)
+    else invalid_arg "UTF8.look"
+  in
+  Obj.magic n'
+
+let rec search_head s i =
+  if i >= String.length s then i else
+  let n = Char.code (String.unsafe_get s i) in
+  if n < 0x80 || n >= 0xc2 then i else
+  search_head s (i + 1)
+
+let next s i = 
+  let n = Char.code s.[i] in
+  if n < 0x80 then i + 1 else
+  if n < 0xc0 then search_head s (i + 1) else
+  if n <= 0xdf then i + 2
+  else if n <= 0xef then i + 3
+  else if n <= 0xf7 then i + 4
+  else if n <= 0xfb then i + 5
+  else if n <= 0xfd then i + 6
+  else invalid_arg "UTF8.next"
+
+let rec search_head_backward s i =
+  if i < 0 then -1 else
+  let n = Char.code s.[i] in
+  if n < 0x80 || n >= 0xc2 then i else
+  search_head_backward s (i - 1)
+
+let prev s i = search_head_backward s (i - 1)
+
+let move s i n =
+  if n >= 0 then
+    let rec loop i n = if n <= 0 then i else loop (next s i) (n - 1) in
+    loop i n
+  else
+    let rec loop i n = if n >= 0 then i else loop (prev s i) (n + 1) in
+    loop i n
+
+let rec nth_aux s i n =
+  if n = 0 then i else
+  nth_aux s (next s i) (n - 1)
+
+let nth s n = nth_aux s 0 n
+
+let last s = search_head_backward s (String.length s - 1)
+
+let out_of_range s i = i < 0 || i >= String.length s
+
+let compare_index _ i j = i - j
+
+let get s n = look s (nth s n)
+
+let add_uchar buf u =
+  let masq = 0b111111 in
+  let k = int_of_uchar u in
+  if k < 0 || k >= 0x4000000 then begin
+    Buffer.add_char buf (Char.chr (0xfc + (k lsr 30)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 24) land masq))); 
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 18) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 12) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq)));
+  end else if k <= 0x7f then
+    Buffer.add_char buf (Char.unsafe_chr k)
+  else if k <= 0x7ff then begin
+    Buffer.add_char buf (Char.unsafe_chr (0xc0 lor (k lsr 6)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq)))
+  end else if k <= 0xffff then begin
+    Buffer.add_char buf (Char.unsafe_chr (0xe0 lor (k lsr 12)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq)));
+  end else if k <= 0x1fffff then begin
+    Buffer.add_char buf (Char.unsafe_chr (0xf0 + (k lsr 18)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 12) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq)));
+  end else begin
+    Buffer.add_char buf (Char.unsafe_chr (0xf8 + (k lsr 24)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 18) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 12) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor ((k lsr 6) land masq)));
+    Buffer.add_char buf (Char.unsafe_chr (0x80 lor (k land masq)));
+  end 
+
+let init len f =
+  let buf = Buffer.create len in
+  for c = 0 to len - 1 do add_uchar buf (f c) done;
+  Buffer.contents buf
+
+let rec length_aux s c i =
+  if i >= String.length s then c else
+  let n = Char.code (String.unsafe_get s i) in
+  let k =
+    if n < 0x80 then 1 else
+    if n < 0xc0 then invalid_arg "UTF8.length" else
+    if n < 0xe0 then 2 else
+    if n < 0xf0 then 3 else
+    if n < 0xf8 then 4 else
+    if n < 0xfc then 5 else
+    if n < 0xfe then 6 else
+    invalid_arg "UTF8.length" in
+  length_aux s (c + 1) (i + k)
+
+let length s = length_aux s 0 0
+
+let rec iter_aux proc s i =
+  if i >= String.length s then () else
+  let u = look s i in
+  proc u;
+  iter_aux proc s (next s i)
+
+let iter proc s = iter_aux proc s 0
+
+let compare s1 s2 = Pervasives.compare s1 s2
+
+exception Malformed_code
+
+let validate s =
+  let rec trail c i a =
+    if c = 0 then a else
+    if i >= String.length s then raise Malformed_code else
+    let n = Char.code (String.unsafe_get s i) in
+    if n < 0x80 || n >= 0xc0 then raise Malformed_code else
+    trail (c - 1) (i + 1) (a lsl 6 lor (n - 0x80)) in
+  let rec main i =
+    if i >= String.length s then () else
+    let n = Char.code (String.unsafe_get s i) in
+    if n < 0x80 then main (i + 1) else
+    if n < 0xc2 then raise Malformed_code else
+    if n <= 0xdf then 
+      if trail 1 (i + 1) (n - 0xc0) < 0x80 then raise Malformed_code else 
+      main (i + 2)
+    else if n <= 0xef then 
+      if trail 2 (i + 1) (n - 0xe0) < 0x800 then raise Malformed_code else 
+      main (i + 3)
+    else if n <= 0xf7 then 
+      if trail 3 (i + 1) (n - 0xf0) < 0x10000 then raise Malformed_code else
+      main (i + 4)
+    else if n <= 0xfb then 
+      if trail 4 (i + 1) (n - 0xf8) < 0x200000 then raise Malformed_code else
+      main (i + 5)
+    else if n <= 0xfd then 
+      let n = trail 5 (i + 1) (n - 0xfc) in
+      if n lsr 16 < 0x400 then raise Malformed_code else
+      main (i + 6)
+    else raise Malformed_code in
+  main 0
+
+module Buf = 
+  struct
+    include Buffer
+    type buf = t
+    let add_char = add_uchar
+  end

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 UChar
+
+(** UTF-8 encoded Unicode strings. the type is normal string. *)
+type t = string
+
+exception Malformed_code
+
+(** [validate s]
+   Succeeds if s is valid UTF-8, otherwise raises Malformed_code.
+   Other functions assume strings are valid UTF-8, so it is prudent
+   to test their validity for strings from untrusted origins. *)
+val validate : t -> unit
+
+(* All functions below assume string are valid UTF-8.  If not,
+ * the result is unspecified. *)
+
+(** [get s n] returns [n]-th Unicode character of [s].
+   The call requires O(n)-time. *)
+val get : t -> int -> uchar
+
+(** [init len f]
+   returns a new string which contains [len] Unicode characters.
+   The i-th Unicode character is initialized by [f i] *)
+val init : int -> (int -> uchar) -> t
+
+(** [length s] returns the number of Unicode characters contained in s *)
+val length : t -> int
+
+(** Positions in the string represented by the number of bytes from the head.
+   The location of the first character is [0] *)
+type index = int
+
+(** [nth s n] returns the position of the [n]-th Unicode character.
+   The call requires O(n)-time *)
+val nth : t -> int -> index
+
+(** The position of the head of the last Unicode character. *)
+val last : t -> index
+
+(** [look s i]
+   returns the Unicode character of the location [i] in the string [s]. *)
+val look : t -> index -> uchar
+
+(** [out_of_range s i]
+   tests whether [i] is a position inside of [s]. *)
+val out_of_range : t -> index -> bool
+
+(** [compare_index s i1 i2] returns
+   a value < 0 if [i1] is the position located before [i2],
+   0 if [i1] and [i2] points the same location,
+   a value > 0 if [i1] is the position located after [i2]. *)
+val compare_index : t -> index -> index -> int
+
+(** [next s i]
+   returns the position of the head of the Unicode character
+   located immediately after [i].
+   If [i] is inside of [s], the function always successes.
+   If [i] is inside of [s] and there is no Unicode character after [i],
+   the position outside [s] is returned.
+   If [i] is not inside of [s], the behaviour is unspecified. *)
+val next : t -> index -> index
+
+(** [prev s i]
+   returns the position of the head of the Unicode character
+   located immediately before [i].
+   If [i] is inside of [s], the function always successes.
+   If [i] is inside of [s] and there is no Unicode character before [i],
+   the position outside [s] is returned.
+   If [i] is not inside of [s], the behaviour is unspecified. *)
+val prev : t -> index -> index
+
+(** [move s i n]
+   returns [n]-th Unicode character after [i] if n >= 0,
+   [n]-th Unicode character before [i] if n < 0.
+   If there is no such character, the result is unspecified. *)
+val move : t -> index -> int -> index
+
+(** [iter f s]
+   applies [f] to all Unicode characters in [s].
+   The order of application is same to the order
+   of the Unicode characters in [s]. *)
+val iter : (uchar -> unit) -> t -> unit
+
+(** Code point comparison by the lexicographic order.
+   [compare s1 s2] returns
+   a positive integer if [s1] > [s2],
+   0 if [s1] = [s2],
+   a negative integer if [s1] < [s2]. *)
+val compare : t -> t -> int
+
+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/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,2420 @@
+(*
+ *  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 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 *)
+		| 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 basic = match conv land 0xF with
+		| 0x0 -> CallDefault (* 0x0 *)
+		| 0x5 -> CallVararg (* 0x5 *)
+		| 0x6 -> CallField (* 0x6 *)
+		| 0x7 -> CallLocal (* 0x7 *)
+		| 0x8 -> CallProp (* 0x8 *)
+		| 0x9 -> CallUnmanaged (* 0x9 *)
+		| 0xa -> CallGenericInst (* 0xA *)
+		| i -> printf "error 0x%x\n" i; assert false
+	in
+	let basic = [basic] in
+	let pos, c = match conv land 0x10 with
+		| 0x10 ->
+			let pos, nparams = read_compressed_i32 s pos in
+			pos, CallGeneric nparams :: basic
+		| _ ->
+			pos, basic
+	in
+	match conv land 0x20 with
+		| 0x20 ->
+			pos, CallHasThis :: basic
+		| _ when conv land 0x40 = 0x40 ->
+			pos, CallExplicitThis :: basic
+		| _ -> pos, basic
+
+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
+		logor
+	int_of_type_def_layout f.tdf_layout
+		logor
+	int_of_type_def_semantics f.tdf_semantics
+		logor
+	int_of_type_def_impl f.tdf_impl
+		logor
+	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/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/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/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);
+ }
+

libs/objsize/objsize.ml

@@ -0,0 +1,19 @@
+if Sys.ocaml_version < "3.11"
+then
+  failwith "Objsize >=0.12 can only be used with OCaml >=3.11"
+
+type info =
+  { data : int
+  ; headers : int
+  ; depth : int
+  ; reached : bool
+  }
+
+external internal_objsize : Obj.t -> Obj.t list -> Obj.t list -> info = "ml_objsize"
+
+let objsize obj exclude reach = internal_objsize (Obj.repr obj) exclude reach
+
+let size_with_headers i = (Sys.word_size/8) * (i.data + i.headers)
+
+let size_without_headers i = (Sys.word_size/8) * i.data
+

libs/objsize/objsize.mli

@@ -0,0 +1,14 @@
+(* Information gathered while walking through values. *)
+type info =
+  { data : int
+  ; headers : int
+  ; depth : int
+  ; reached : bool
+  }
+
+(* Returns information for first argument, excluding the second arg list and telling if we can reach the third arg list *)
+val objsize : 'a -> Obj.t list -> Obj.t list -> info
+
+(* Calculates sizes in bytes: *)
+val size_with_headers : info -> int
+val size_without_headers : info -> int

libs/objsize/tests.ml

@@ -0,0 +1,60 @@
+open Printf
+;;
+
+let print title vl =
+  let i = Objsize.objsize vl in
+  printf "%S : data_words=%i headers=%i depth=%i\n    \
+bytes_without_headers=%i bytes_with_headers=%i\n%!"
+    title i.Objsize.data i.Objsize.headers i.Objsize.depth
+    (Objsize.size_without_headers i)
+    (Objsize.size_with_headers i)
+in
+
+print "string of 13 chars" ("0123456" ^ "789012")
+;
+print "some object"
+  ( object method x = 123; method y = print_int; end
+  )
+;
+
+print "some float" (Random.float 1.)
+;
+(*
+let rec cyc = [1 :: [2 :: [3 :: cyc]]] in
+
+print "cyclic list" cyc
+;
+*)
+let genlist n =
+  let rec inner acc n =
+    if n <= 0
+    then acc
+    else inner (n :: acc) (n-1)
+  in
+    inner [] n
+in
+
+print "big list" (genlist 300000)
+;
+
+print "big array" (Array.make 30000 true)
+;
+
+print "statically created value" [1; 2; 3]
+;
+
+print "objsize 0.14 bug"
+  (let rec val_a = (val_z, val_z)
+   and val_z = (123, val_y)
+   and val_y = (234, 345)
+   in
+     val_a
+  )
+;
+
+print "objsize 0.15 bug"
+  (let val_z = ((), ()) in
+   let val_y = (val_z, val_z, fun x -> x) in
+   val_y
+  )
+;

libs/objsize/util.h

@@ -0,0 +1,14 @@
+#ifndef UTIL_H
+#define UTIL_H
+
+#define ABORT(x) do { \
+  fprintf(stderr, "aborted at %s:%i: %s\n", __FILE__, __LINE__, x); \
+  exit(1); } while(0)
+
+#define ASSERT(b, err) do { \
+ if (!(b)) \
+  { ABORT("assert_failed: " err); \
+  }; \
+ } while(0)
+
+#endif

libs/ocamake/ocamake.dsp

@@ -0,0 +1,66 @@
+# Microsoft Developer Studio Project File - Name="ocamake" - Package Owner=<4>
+# Microsoft Developer Studio Generated Build File, Format Version 6.00
+# ** DO NOT EDIT **
+
+# TARGTYPE "Win32 (x86) External Target" 0x0106
+
+CFG=ocamake - Win32 Native code
+!MESSAGE This is not a valid makefile. To build this project using NMAKE,
+!MESSAGE use the Export Makefile command and run
+!MESSAGE 
+!MESSAGE NMAKE /f "ocamake.mak".
+!MESSAGE 
+!MESSAGE You can specify a configuration when running NMAKE
+!MESSAGE by defining the macro CFG on the command line. For example:
+!MESSAGE 
+!MESSAGE NMAKE /f "ocamake.mak" CFG="ocamake - Win32 Native code"
+!MESSAGE 
+!MESSAGE Possible choices for configuration are:
+!MESSAGE 
+!MESSAGE "ocamake - Win32 Native code" (based on "Win32 (x86) External Target")
+!MESSAGE 
+
+# Begin Project
+# PROP AllowPerConfigDependencies 0
+# PROP Scc_ProjName ""
+# PROP Scc_LocalPath ""
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 0
+# PROP BASE Output_Dir ""
+# PROP BASE Intermediate_Dir ""
+# PROP BASE Cmd_Line "ocamake -opt ocamake.dsp -o ocamake.exe"
+# PROP BASE Rebuild_Opt "-all"
+# PROP BASE Target_File "ocamake_opt.exe"
+# PROP BASE Bsc_Name ""
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 0
+# PROP Output_Dir ""
+# PROP Intermediate_Dir ""
+# PROP Cmd_Line "ocamake str.cmxa unix.cmxa -opt ocamake.dsp -o ocadbg.exe"
+# PROP Rebuild_Opt "-all"
+# PROP Target_File "ocadbg.exe"
+# PROP Bsc_Name ""
+# PROP Target_Dir ""
+# Begin Target
+
+# Name "ocamake - Win32 Native code"
+
+!IF  "$(CFG)" == "ocamake - Win32 Native code"
+
+!ENDIF 
+
+# Begin Group "ML Files"
+
+# PROP Default_Filter "ml;mly;mll"
+# Begin Source File
+
+SOURCE=.\ocamake.ml
+# End Source File
+# End Group
+# Begin Group "MLI Files"
+
+# PROP Default_Filter "mli"
+# End Group
+# End Target
+# End Project

libs/ocamake/ocamake.dsw

@@ -0,0 +1,29 @@
+Microsoft Developer Studio Workspace File, Format Version 6.00
+# WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE!
+
+###############################################################################
+
+Project: "ocamake"=.\ocamake.dsp - Package Owner=<4>
+
+Package=<5>
+{{{
+}}}
+
+Package=<4>
+{{{
+}}}
+
+###############################################################################
+
+Global:
+
+Package=<5>
+{{{
+}}}
+
+Package=<3>
+{{{
+}}}
+
+###############################################################################
+

libs/ocamake/ocamake.html

@@ -0,0 +1,94 @@
+<html>
+<body bgcolor="#ffffff" link="Black" vlink="Black">
+<center><b><font color="#000099" size="+2">OCamake</font></b></center>
+<br>
+<font color="#777777">
+	OCamake - Copyright (c)2002-2003 Nicolas Cannasse & Motion Twin.<br>
+	The last version of this software can be found at : <a href="http://tech.motion-twin.com">http://tech.motion-twin.com</a><br><br>
+	This software is provided "AS IS" without any warranty of any kind, merchantability or fitness for a particular purpose. You should use it at your own risks, as the author and his company won't be responsible for any problem that the usage of this software could raise.
+</font>
+<br>
+<br>
+
+<ul>
+
+<li><b><font color="#000099">Introduction:</font></b><br>
+<br>
+OCamake is an automatic compiler for the Objective Caml language. It removes pain from the user which does not need anymore to write a Makefile. OCamake can work either as an application which compile your program or as a Makefile generator (using the <code>-mak</code> flag). OCamake has also special features for integration under Microsoft Visual Studio.
+<br>
+<br>
+<li><b><font color="#000099">Installation:</font></b><br>
+<br>
+OCamake is a source-only distribution, so you need to compile it first. Type the following command-line:<br>
+&nbsp;&nbsp;<code>ocamlc unix.cma str.cma ocamake.ml -o ocamake.exe</code><br>
+This should produce a file "<code>ocamake.exe</code>". Copy this file in your <code>ocaml/bin</code> directory.<br>
+<br>
+<li><b><font color="#000099">Usage:</font></b><br>
+<br>
+To compile your project, simply call OCamake with the files you want to compile:<br>
+&nbsp;&nbsp;<code>ocamake *.ml *.mli</code><br>
+<br>
+To remove all intermediate files that have been produced by the compiler :<br>
+&nbsp;&nbsp;<code>ocamake -clean *.ml *.mli</code><br>
+<br>
+To generate a Makefile:<br>
+&nbsp;&nbsp;<code>ocamake -mak *.ml *.mli</code><br>
+&nbsp;&nbsp;<code>make all</code><br>
+&nbsp;&nbsp;<code>...</code><br>
+&nbsp;&nbsp;<code>make clean</code><br>
+<br>
+(Windows users can use <code>nmake</code> instead of make and should use <code>nmake wclean</code> to remove intermediate files)
+<br>
+<br>
+<li><b><font color="#000099">Features:</font></b><br>
+<br>
+OCamake works with the following files :
+<ul>
+	<li><code>ml, mli</code> : theses files are added to the list of files to build
+	<li><code>cmo, cmx, cma, cmxa, dll, so, lib, a, o, obj</code> : theses files are added to the library list
+	<li><code>mll, mly</code> : theses files are compiled using <code>ocamllex</code> and <code>ocamlyacc</code>, and their result are added to the list of files to build.
+	<li><code>dsp, vcproj</code> (Visual Studio Project) : all the files included in the project are added to the ocamake file list.
+</ul>
+<br>
+Once the final file list is made, OCamake run <code>ocamldep</code> to build module dependencies tree, and then build and link the tree in the good order (for more information on the algorithm used, see sources).
+Only modified sources files or files with one dependency modified are rebuilt.<br>
+<br>
+If one <code>dsp</code> file has been found or if the <code>-epp</code> flag has been set, then all compilation errors are processed by OCamake to transform them into a Visual Studio compatible format.<br>
+If one <code>dsp</code> file has been found or if the <code>-cpp</code> flag has been set, the character ranges in Ocaml errors are replaced by the corresponding expression found in the source file.
+<br>
+<br>
+<li><b><font color="#000099">Options:</font></b><br>
+<br>
+The following command-line options are available :
+<ul>
+	<li><code>-clean</code> : delete all the intermediate and ouput files for the target build.
+	<li><code>-mak</code> : generate a <code>Makefile</code> for this project (<i>still experimental</i>).
+	<li><code>-opt</code> : turn on native compilation.
+	<li><code>-a</code> : build a library (<code>cma or cmxa</code>).
+	<li><code>-o &lt;output&gt;</code> : set the output file for the project.
+	<li><code>-all</code> : rebuild the entire project.
+	<li><code>-cpp</code> : convert characters range in errors to file expression.
+	<li><code>-epp</code> : use MSVC error messages format.
+	<li><code>-g</code> : compile and link in debug mode.
+	<li><code>-pp &lt;command&gt;</code> : pipe source through preprocessor.
+	<li><code>-cp &lt;flag&gt;</code> : add this flag to the compiler command line paramaters.
+	<li><code>-lp &lt;flag&gt;</code> : add this flag to the linker command line paramaters.
+	<li><code>-I &lt;path&gt;</code> : add the path to the list of include directories.
+	<li><code>-n &lt;file&gt;</code> : remove that file from the file list : this can be useful when you want to have all the files but one (<code>ocamake -n myfile.ml *.ml *.mli</code>).
+	<li><code>-v</code> : verbose mode - this print all the commands that ocamake is running in order to build the project.
+	<li><code>-P &lt;file&gt;</code> : add priority to a given file when having cycle between modules.
+</ul>
+<br>
+<li><b><font color="#000099">Licence:</font></b><br>
+<br>
+The full source code of OCamake is included, so you can modify, use, and redistribute it as you want for any usage conform to the licence. This code is under the LGPL (GNU Lesser General Public Licence), you can get more information on www.gnu.org.<br>
+<br>
+<li><b><font color="#000099">Author:</font></b><br>
+<br>
+Nicolas Cannasse <a href="mailto:[email protected]">[email protected]</a><br>
+Website : <a href="http://tech.motion-twin.com">http://tech.motion-twin.com</a><br>
+Thanks to <a href="http://www.lexifi.com">Lexifi</a>.
+<br>
+<br>
+</body>
+</html>

libs/ocamake/ocamake.ml

@@ -0,0 +1,661 @@
+(* ************************************************************************ *)
+(*                                                                          *)
+(* OCAMAKE - OCaml Automatic compilation                                    *)
+(*      (c)2002 Nicolas Cannasse                                            *)
+(*      (c)2002 Motion-Twin                                                 *)
+(*                                                                          *)
+(* Last version : http://tech.motion-twin.com                               *)
+(*                                                                          *)
+(* ************************************************************************ *)
+open Unix
+open Printf
+open Arg
+
+type compile_mode =
+	| CM_DEFAULT
+	| CM_BYTE
+	| CM_OPT
+
+type file_ext =
+	| ML | MLI | MLL | MLY
+	| CMO | CMX | CMA | CMXA
+	| DLL | SO | EXE | LIB
+	| CMI | O | OBJ | A
+
+type file = {
+	name : string;
+	ext : file_ext;
+	target : string;
+	deps : string list;
+}
+
+(* ************************************************************************ *)
+(* GLOBALS *)
+
+let verbose = ref false (* print command calls in verbose mode *)
+let project_name = ref None (* for VC++ DSP *)
+let error_process = ref false (* VC++ error message processing *)
+let chars_process = ref false (* replace chars range in errors by file data *)
+
+(* ************************************************************************ *)
+(* USEFUL FUNCTIONS *)
+
+let if_some f opt def =
+	match opt with
+	| None -> def
+	| Some v -> f v
+
+let print str = print_endline str; flush Pervasives.stdout
+
+let (???) file =
+	failwith ("Don't know what to do with file " ^ file)
+
+let str_suffix = function
+	| ML -> "ml" | MLI -> "mli" | MLL -> "mll" | MLY -> "mly" | CMO -> "cmo"
+	| CMX -> "cmx" | CMA -> "cma" | CMXA -> "cmxa" | DLL -> "dll" | SO -> "so"
+	| EXE -> "exe" | CMI -> "cmi" | O -> "o" | A -> "a" | OBJ -> "obj"
+	| LIB -> "lib"
+
+let unescape file =
+	let l = String.length file in
+	if l >= 2 && file.[0] = '"' && file.[l-1] = '"' then String.sub file 1 (l-2) else file
+
+let extension file =
+	let rsplit_char str ch =
+		let p = String.rindex str ch in
+		let len = String.length str in
+		(String.sub str 0 p, String.sub str (p + 1) (len - p - 1))	
+	in
+	let file = unescape file in
+	let s = try snd(rsplit_char file '.') with Not_found -> "" in
+	String.uppercase s
+
+let (+!) file suff =
+	let base = Filename.chop_extension file in
+	base ^ "." ^ str_suffix suff
+
+let filter_all_in func ic =
+	let rec treat acc =
+	try
+		match func (input_line ic) with
+		| None -> treat acc
+		| Some data -> treat (data :: acc)
+	with
+		End_of_file -> close_in ic; acc
+	in
+	List.rev (treat [])
+
+let rec remove_duplicates = function
+	| [] -> []
+	| item :: q when List.exists ((=) item) q -> remove_duplicates q
+	| item :: q -> item :: remove_duplicates q
+
+let file_time fname =
+	try (Unix.stat fname).st_mtime with Unix_error _ -> 0.
+
+let flatten = String.concat " "
+
+let escape str =
+	try
+		ignore(String.index str ' ');
+		"\"" ^ str ^ "\"";
+	with Not_found -> str
+
+let delete_file file =
+	try Sys.remove file with Sys_error _ -> ()
+
+let check_existence (ext,name) =
+	match ext with
+	| ML | MLI ->
+		if not (Sys.file_exists name) then
+			failwith ("No such file : "^(escape name))
+	| _ -> ()
+		(* Others files can be found in Ocaml stdlib or
+		   user -I paths *)
+
+exception Found_pos of int
+
+let print_errors output msg =
+	let split str sep =
+		let find_sub str sub =
+			let len = String.length sub in
+			try
+				for i = 0 to String.length str - len do
+					if String.sub str i len = sub then raise (Found_pos i);
+				done;
+				raise Not_found
+			with Found_pos i -> i 
+		in
+		let p = find_sub str sep in
+		let len = String.length sep in
+		let slen = String.length str in
+		(String.sub str 0 p, String.sub str (p + len) (slen - p - len))
+	in
+	let process_chars file chars line =
+		let cmin, cmax = split chars "-" in
+		let cmin, cmax = int_of_string cmin, int_of_string cmax in
+		if cmax > cmin then begin
+			let f = open_in file in
+			for i = 1 to line-1 do ignore(input_line f) done;
+			seek_in f ((pos_in f)+cmin);
+			let s = String.create (cmax - cmin) in
+			ignore(input f s 0 (cmax - cmin));
+			prerr_endline (try
+					(String.sub s 0 (String.index s '\n'))^"..."
+				with
+					Not_found -> s);
+		end
+	in
+	let printer =
+		(match !error_process , !chars_process with
+		| true , _ -> (function line ->
+			try
+				let data, chars = split line ", characters " in
+				let data, lnumber = split data "\", line " in
+				let _, file = split data "File \"" in
+				prerr_string (file ^ "(" ^ lnumber ^ ") : ");
+				let chars, _ = split chars ":" in
+				if !chars_process then
+					(try process_chars file chars (int_of_string lnumber) with _ -> raise Not_found)
+ 			with
+				Not_found ->
+					prerr_endline line)
+		| false , true -> (function line ->
+			try
+				let edata, chars = split line ", characters " in
+				let data, lnumber = split edata "\", line " in
+				let _, file = split data "File \"" in
+				let chars, _ = split chars ":" in
+				prerr_string (edata^" : ");
+				if !chars_process then
+					process_chars file chars (int_of_string lnumber);
+ 			with
+				Not_found ->
+					prerr_endline line)
+
+		| false , false ->
+		      prerr_endline)
+	in
+	List.iter printer output;
+	failwith msg
+
+let exec ?(stdout=false) ?(outfirst=false) cmd errmsg =
+	if !verbose then print cmd;
+	let pout, pin, perr = open_process_full cmd (Unix.environment()) in
+	let read = filter_all_in (fun s -> Some s) in
+	let data, edata = 
+	(* this is made to prevent the program lock when one
+	   buffer is full and the process is waiting for us
+	   to read it before exiting... while we're reading
+	   the other output buffer ! *)
+	(if outfirst then
+		let d = read pout in
+		let ed = read perr in
+		d,ed
+	else	
+		let ed = read perr in
+		let d = read pout in
+		d,ed) in
+	match close_process_full (pout, pin, perr) with
+	| WEXITED 0 -> data,edata
+	| WEXITED exitcode -> print_errors (if stdout then edata @ data else edata) errmsg
+	| _ -> failwith "Build aborted by signal"
+
+(* ************************************************************************ *)
+(* DEPENDENCIES *)
+
+let line_regexp = Str.regexp "^\\([0-9A-Za-z:_\\./\\\\-]+\\.cm[oi]\\):\\( .*\\)$"
+let dep_regexp = Str.regexp " \\([0-9A-Za-z:_\\./\\\\-]+\\.cm[oi]\\)"
+
+let build_graph opt paramlist files =
+	let srcfiles = List.filter (fun (e,_) ->
+		match e with
+		| ML | MLI -> true
+		| _ -> false) files in
+	let get_name (_,f) = escape f in
+	let file_names = flatten (List.map get_name srcfiles) in
+	let params = flatten paramlist in
+	let command = sprintf "ocamldep %s %s" params file_names in	
+	let output,_ = exec command "Failed to make dependencies" ~outfirst:true in
+	let data = String.concat "\n" output in	
+	let data = Str.global_replace (Str.regexp "\\\\\r\n") "" data in (* win *)
+	let data = Str.global_replace (Str.regexp "\\\\\n") "" data in (* unix *)		
+	let rec get_deps data p =
+		try
+			let newp = Str.search_forward dep_regexp data p in
+			let file = Str.matched_group 1 data in
+			if opt && extension file = "CMO" then 
+				(file +! CMX)::(get_deps data (newp+1))
+			else
+				file::(get_deps data (newp+1))
+		with
+			Not_found -> []
+	in
+	let rec get_lines p =		
+		try
+			let newp = Str.search_forward line_regexp data p in	
+			let file = Str.matched_group 1 data in			
+			let lines = get_deps (Str.matched_group 2 data) 0 in			
+			(Filename.basename file,lines)::(get_lines (newp+1))
+		with
+			Not_found -> []
+	in
+	let lines = get_lines 0 in
+	let init_infos (ext,fname) =
+		let deptarget = Filename.basename (match ext with
+			| ML ->  fname +! CMO
+			| MLI -> fname +! CMI
+			| _ -> fname) in
+		let target = (match ext with
+			| ML -> fname +! (if opt then CMX else CMO)
+			| MLI -> fname +! CMI
+			| _ -> fname) in
+		{
+			name = fname;
+			ext = ext;
+			target = target;
+			deps =
+				(try
+					snd (List.find (fun (n,_) -> n = deptarget) lines)
+				with
+					Not_found -> []);
+		}
+	in	
+	let deps = List.map init_infos files in
+	match !verbose with
+	| false -> deps
+	| true ->
+		let print_dep d =
+			let dl = String.concat " " (List.map Filename.basename d.deps) in
+			printf "%s: %s\n" (Filename.basename d.target) dl;
+		in
+		List.iter print_dep deps;
+		deps
+
+let rec graph_topological_sort all g priority acc =
+	let has_dep where dep =	
+		List.exists (fun f -> Filename.basename f.target =
+							Filename.basename dep) where
+	in
+	let modified a b = (file_time a) < (file_time b) in
+	let is_free file = not(List.exists (has_dep g) file.deps) in
+	let rec has_priority = function
+		| [] -> raise Not_found
+		| x :: l ->
+			try
+				List.find (fun f -> x = (Filename.basename f.name)) g
+			with
+				Not_found -> has_priority l
+	in
+	let to_build file =
+		all || (* rebuild all *)
+		List.exists (has_dep acc) file.deps || (* a dep is rebuild *)
+		List.exists (modified file.target) file.deps || (* dep modified *)
+		(file_time file.target) < (file_time file.name) (* is modified *)
+	in
+	match g with
+	| [] -> acc
+	| _ ->
+		let free,g = List.partition is_free g in
+		match free with 
+		| [] ->
+			(try
+				let free = has_priority priority in
+				let g = List.filter ((<>) free) g in
+				if to_build free then
+					graph_topological_sort all g priority (acc@[free])
+				else
+					graph_topological_sort all g priority acc;
+			with Not_found ->
+				List.iter (fun f -> prerr_endline f.name) g;
+				failwith "Cycle detected in file dependencies !")
+		| _ ->
+			let to_build = List.filter to_build free in
+			graph_topological_sort all g priority (acc@to_build)
+
+(* ************************************************************************ *)
+(* COMPILATION *)
+
+let compile ?(precomp=false) opt paramlist f =
+	try
+		let command = (match f.ext with
+		| ML | MLI ->
+			let params = flatten paramlist in
+			let compiler = (if opt then "ocamlopt" else "ocamlc") in
+			sprintf "%s -c %s %s" compiler params (escape f.name)
+		| MLL when precomp -> "ocamllex " ^ (escape f.name)
+		| MLY when precomp -> "ocamlyacc " ^ (escape f.name)
+		| _ -> raise Exit) in
+		print (Filename.basename (unescape f.name));
+		let stdout,stderr = exec command "Build failed" in
+		try
+			print_errors (stderr@stdout) "";
+		with
+			Failure _ -> ()
+	with
+		Exit -> ()
+
+let pre_compile all (ext,name) =
+	match ext with
+	| MLL | MLY ->
+		let time = file_time name in
+		if time = 0. then failwith ("No such file : "^(escape name));
+		if all || (file_time (name +! ML)) < time then
+			compile ~precomp:true false [] {
+				name = name;
+				ext = ext;
+				deps = [];
+				target = "";
+			}
+	| _ -> () (* other files type does not need pre-compilation *)
+
+let clean_targets opt acc (ext,name) =	
+	match ext with
+	| MLY ->
+		(name +! ML) :: (name +! MLI) :: acc
+	| MLL ->
+		(name +! ML) :: acc
+	| ML when opt ->
+		(name +! (if Sys.os_type = "Win32" then OBJ else O)) :: (name +! CMX) :: (name +! CMI) :: acc
+	| ML ->
+		(name +! CMO) :: (name +! CMI) :: acc
+	| MLI ->
+		(name +! CMI) :: acc
+	| _ ->
+		acc
+
+(*
+	In order to link, we need to order the CMO files.
+	We currently have a ML/MLI dependency graph (in fact, tree) generated
+	by ocamldep.
+
+	To build the CMO list, we are reducing the dep-tree into one graph merging
+	corresponding ML & MLI nodes. ML-ML edges are keeped, ML-MLI edges
+	become ML-ML edges only if they do not create a cycle in the reduced
+	graph.
+
+	Then we sort the graph using topological ordering.
+*)
+let graph_reduce opt g =
+	let ext = (if opt then CMX else CMO) in
+	let rec path_exists g a b =
+		if a = b then true else
+		try
+			let f = List.find (fun f -> f.target = a) g in
+			List.exists (fun d -> path_exists g d b) f.deps
+		with
+			Not_found -> false
+	in
+	let rec deps_reduce f g = function		
+		| [] -> []
+		| dep::deps ->
+			match extension dep with
+			| "CMI" when not(path_exists g (dep +! ext) f.target) ->				
+				(dep +! ext)::(deps_reduce f g deps)
+			| "CMO" | "CMX" ->
+				dep::(deps_reduce f g deps)
+			| _ -> deps_reduce f g deps
+	in
+	let rec do_reduce g acc =
+		match g with
+		| [] -> acc
+		| f::g' ->			
+			let f = { f with deps = deps_reduce f (g@acc) f.deps } in
+			do_reduce g' (f::acc)
+	in
+	do_reduce g []	
+
+let is_lib f = match f.ext with
+	| CMA | CMXA | CMO | CMX | DLL | SO | LIB | A | O | OBJ -> true
+	| _ -> false
+
+let link opt paramlist files priority output =
+	print "Linking...";
+	let sources = List.filter (fun f -> f.ext = ML) files in
+	let libs = List.filter is_lib files in
+	let sources = graph_topological_sort true (graph_reduce opt sources) priority [] in
+	let lparams = flatten (List.map (fun f -> escape f.name) libs) in
+	let sparams = flatten (List.map (fun f -> escape f.target) sources) in
+	let params = flatten paramlist in
+	let cc = (if opt then "ocamlopt" else "ocamlc") in
+	let cmd = sprintf "%s %s %s %s -o %s" cc params lparams sparams output in
+	ignore(exec ~stdout:true cmd "Linking failed")
+
+(* ************************************************************************ *)
+(* FILE PROCESSING *)
+
+let dsp_get_files dsp_file =
+	let get_file line =
+		if String.length line > 7 && String.sub line 0 7 = "SOURCE=" then
+			Some (unescape (String.sub line 7 (String.length line-7)))
+		else
+			None
+	in
+	filter_all_in get_file (open_in dsp_file)
+
+let vcproj_get_files vcp_file =
+	let get_file line =
+		let len = String.length line in
+		let p = ref 0 in
+		while !p < len && (line.[!p] = ' ' || line.[!p] = '\t') do
+			incr p;
+		done;
+		let line = String.sub line !p (len - !p) in		
+		if String.length line > 13 && String.sub line 0 13 = "RelativePath=" then begin
+			let str = String.sub line 13 (String.length line - 14) in
+			Some (unescape str)
+		end else
+			None
+	in
+	filter_all_in get_file (open_in vcp_file)
+
+let rec list_files errors file =
+	match extension file with
+	| "ML" -> [(ML,file)]
+	| "MLI" -> [(MLI,file)]
+	| "VCPROJ" ->
+		project_name := Some (Filename.basename file);
+		error_process := true;
+		chars_process := true;
+		List.concat (List.map (list_files false) (vcproj_get_files file))
+	| "DSP" ->
+		project_name := Some (Filename.basename file);
+		error_process := true;
+		chars_process := true;
+		List.concat (List.map (list_files false) (dsp_get_files file))
+	| "CMA" -> [(CMA,file)]
+	| "CMXA" -> [(CMXA,file)]
+	| "CMX" -> [(CMX,file)]	
+	| "CMO" -> [(CMO,file)]
+	| "DLL" -> [(DLL,file)]
+	| "LIB" -> [(LIB,file)]
+	| "A" -> [(A,file)]
+	| "O" -> [(O,file)]
+	| "OBJ" -> [(OBJ,file)]
+	| "SO" -> [(SO,file)]
+	| "MLY" -> [(MLY,file);(ML,file +! ML);(MLI,file +! MLI)]
+	| "MLL" -> [(MLL,file);(ML,file +! ML)]	
+	| _ -> if errors then ??? file else []
+
+let rec get_compile_mode cm = function
+	| [] -> cm
+	| (ext,name)::files ->
+		let error() = failwith "Mixed bytecode and native compilation files." in
+		match ext with
+		| ML | MLI | MLL | MLY | DLL | SO ->
+			get_compile_mode cm files
+		| CMA | CMO ->
+			if cm = CM_OPT then error() else get_compile_mode CM_BYTE files
+		| CMXA | CMX | A | O | OBJ | LIB ->
+			if cm = CM_BYTE then error() else get_compile_mode CM_OPT files
+		| EXE | CMI ->
+			assert false
+
+let rec get_output_file islib cm =
+	match !project_name,islib,cm with
+	| None, _ , _ -> None
+	| Some name,false,_ -> Some (name +! EXE)
+	| Some name,true,CM_OPT -> Some (name +! CMXA)
+	| Some name,true,_ -> Some (name +! CMA)
+
+(* ************************************************************************ *)
+(* MAIN *)
+
+;;
+try
+
+let usage =
+	"OCAMAKE v1.4 - Copyright (C)2002-2005 Nicolas Cannasse"
+	^"\r\nLast version : http://tech.motion-twin.com" in
+let compile_mode = ref CM_DEFAULT in
+let compile_cma = ref false in
+let do_clean = ref false in
+let gen_make = ref false in
+let rebuild_all = ref false in
+let output_file = ref None in
+let preprocessor = ref None in
+let argfiles = ref [] in
+let paths = ref [] in
+let cflags = ref [] in
+let lflags = ref [] in
+let remf = ref [] in
+let priority = ref [] in
+let arg_spec = [
+  ("-all", Unit (fun () -> rebuild_all := true), ": rebuild all files");
+  ("-o", String (fun f -> output_file := Some f), "<file> : set output");
+  ("-a", Unit (fun () -> compile_cma := true), ": build a library");
+  ("-opt", Unit (fun () -> compile_mode := CM_OPT), ": native compilation");
+  ("-clean", Unit (fun () -> do_clean := true), ": delete intermediate files");
+  ("-I", String (fun p -> paths := p::!paths), "<path> : additional path");
+  ("-v", Unit (fun () -> verbose := true), ": turn on verbose mode");
+  ("-n", String (fun f -> remf := f::!remf),"<file>: don't compile this file");
+  ("-mak", Unit (fun () -> gen_make := true), ": generate Makefile");
+  ("-lp", String (fun f -> lflags := f::!lflags), "<p> : linker parameter");
+  ("-cp", String (fun f -> cflags := f::!cflags), "<p> : compiler parameter");
+  ("-pp", String (fun c -> preprocessor := Some c), "<cmd> : preprocessor");
+  ("-epp", Unit (fun() -> error_process := true), ": use MSVC error messages format");
+  ("-cpp", Unit (fun() -> chars_process := true), ": convert characters range in errors to file expression");
+  ("-g", Unit (fun () -> lflags := "-g"::!lflags; cflags := "-g"::!cflags), ": compile/link in debug mode");
+  ("-P", String (fun f -> priority := f::!priority), ": give linking priority to a file when linking ordering failed");
+] in
+Arg.parse arg_spec (fun arg -> argfiles := arg :: !argfiles) usage;
+let files = List.concat (List.map (list_files true) (List.rev !argfiles)) in
+let files = List.filter (fun (_,f) ->
+	let name = Filename.basename f in
+	not(List.exists (fun f -> Filename.basename f = name) !remf)) files in
+let compile_mode = get_compile_mode !compile_mode files in
+let output_file , compile_mode = (match !output_file with
+	| None -> get_output_file !compile_cma compile_mode , compile_mode
+	| Some file ->
+		match extension file , compile_mode with
+		| "CMA" , CM_OPT
+		| "CMXA", CM_BYTE -> failwith "Mixed bytecode and native compilation files."
+		| "CMA" , _ ->
+			compile_cma := true;
+			Some file , CM_BYTE
+		| "CMXA" , _ ->
+			compile_cma := true;
+			Some file , CM_OPT
+		| _ , _ ->
+			Some file , compile_mode)
+in
+let opt = (compile_mode = CM_OPT) in
+if !compile_cma then lflags := "-a"::!lflags;
+match files with
+  | [] -> Arg.usage arg_spec usage
+  | _ ->
+	let files = remove_duplicates files in
+	let get_path (_,f) = "-I " ^ escape (Filename.dirname f) in
+	let paths = List.map (fun p -> "-I " ^ (escape p)) !paths in
+	let paths = remove_duplicates (paths@(List.map get_path files)) in
+	let p4param = if_some (fun cmd -> "-pp " ^ (escape cmd)) !preprocessor "" in
+	match !do_clean,!gen_make with
+	| true,true ->
+		failwith "Cannot have -mak & -clean at the same time"
+	| false,false ->
+		if_some delete_file output_file ();
+		List.iter (pre_compile !rebuild_all) files;
+		List.iter check_existence files;
+		let g = build_graph opt (p4param::paths) files in
+		let files = graph_topological_sort !rebuild_all g [] [] in
+		List.iter (compile opt (!cflags @ p4param::paths)) files;
+		if_some (link opt (!lflags @ paths) g (List.rev !priority)) output_file ();
+		print "Done";
+	| true,false ->
+		print "Cleaning...";
+		if_some delete_file output_file ();
+		let to_clean = List.fold_left (clean_targets opt) [] files in
+		List.iter delete_file to_clean;
+		if opt && !compile_cma then
+			if_some (fun f -> delete_file (f +! (if Sys.os_type = "Win32" then LIB else A))) output_file ();
+	| false,true ->
+		List.iter (pre_compile !rebuild_all) files;
+		let g = build_graph opt (p4param::paths) files in
+		let out = open_out "Makefile" in
+		let fprint s = output_string out (s^"\n") in
+		let genmak f =
+			let ext = if opt then CMX else CMO in
+			match f.ext with
+			| MLL ->
+				fprint ((f.name +! ext)^": "^(f.name +! ML)^"\n")
+			| MLY ->
+				fprint ((f.name +! ext)^": "^(f.name +! ML)^"\n");
+				fprint ((f.name +! CMI)^": "^(f.name +! ML)^" "^(f.name +! MLI)^"\n")
+			| _ when f.deps <> [] ->
+				fprint (f.target^": "^(flatten f.deps)^"\n")
+			| _ ->
+				()
+		in
+		let compiles = graph_topological_sort true g [] [] in
+		let libs = List.filter is_lib compiles in
+		let cmos = List.filter (fun f -> f.ext = ML) compiles in
+		fprint "# Makefile generated by OCamake ";
+		fprint "# http://tech.motion-twin.com";
+		fprint ".SUFFIXES : .ml .mli .cmo .cmi .cmx .mll .mly";
+		fprint "";
+		fprint ("ALL_CFLAGS= $(CFLAGS) "^(flatten (!cflags @ p4param::paths)));
+		fprint ("LIBS="^(flatten (List.map (fun f -> f.name) libs)));
+		let targets = flatten (List.map (fun f -> f.target) cmos) in
+		(match output_file with
+		| None ->
+			fprint "";
+			fprint ("all: "^targets^"\n");
+		| Some out ->
+			fprint ("LFLAGS= -o "^out^" "^(flatten (!lflags @ paths)));
+			fprint "";
+			fprint ("all: "^out^"\n");
+			fprint (out^": "^targets);
+			(* I need to reuse the list of targets since $^ is for Make and $** for NMake *)
+			fprint ("\t"^(if opt then "ocamlopt" else "ocamlc")^" $(LFLAGS) $(LIBS) "^targets^"\n"));
+		List.iter genmak g;
+		fprint "";
+		fprint "clean:";
+		let cleanfiles = flatten (List.fold_left (clean_targets opt) [] files) in
+		if_some (fun o ->
+				fprint ("\trm -f "^o);
+				if opt && !compile_cma then fprint ("\trm -f "^(o +! LIB)^" "^(o +! A));
+			) output_file ();
+		fprint ("\trm -f "^cleanfiles);
+		fprint "";
+		fprint "wclean:";
+		if_some (fun o ->
+				fprint ("\t-@del "^o^" 2>NUL");
+				if opt && !compile_cma then fprint ("\t-@del "^(o +! LIB)^" "^(o +! A)^" 2>NUL");
+		) output_file ();
+		fprint ("\t-@del "^cleanfiles^" 2>NUL");
+		fprint "";
+		fprint "# SUFFIXES";
+		fprint ".ml.cmo:\n\tocamlc $(ALL_CFLAGS) -c $<\n";
+		fprint ".ml.cmx:\n\tocamlopt $(ALL_CFLAGS) -c $<\n";
+		fprint ".mli.cmi:\n\tocamlc $(ALL_CFLAGS) $<\n";
+		fprint ".mll.ml:\n\tocamllex $<\n";
+		fprint ".mly.ml:\n\tocamlyacc $<\n";
+		close_out out
+with
+	Failure msg ->
+		Pervasives.flush Pervasives.stdout;
+		prerr_endline msg;
+		Pervasives.flush Pervasives.stderr;
+		exit 1;
+
+(* ************************************************************************ *)

libs/pcre/Makefile

@@ -0,0 +1,28 @@
+ALL_CFLAGS = $(CFLAGS) -I pcre
+LIBS =
+OCAMLOPT=ocamlopt
+OCAMLC=ocamlc
+SRC = pcre.ml pcre_stubs.c
+
+all: bytecode native
+
+bytecode: pcre.cma
+
+native: pcre.cmxa
+
+pcre.cma: pcre_stubs.o pcre.ml
+	$(OCAMLC) -safe-string -a -o pcre.cma $(LIBS) pcre.ml
+
+pcre.cmxa: pcre.ml pcre_stubs.o
+	$(OCAMLOPT) -safe-string -a -o pcre.cmxa $(LIBS) pcre.ml
+
+pcre_stubs.o: pcre_stubs.c
+	$(OCAMLC) -safe-string $(ALL_CFLAGS) pcre_stubs.c
+
+clean:
+	rm -f pcre.cma pcre.cmi pcre.cmx pcre.cmxa pcre.o pcre.obj pcre_stubs.obj pcre_stubs.o
+	rm -f pcre.a libpcre.a libpcre.lib pcre.cmo
+
+.PHONY: all bytecode native clean
+Makefile: ;
+$(SRC): ;

libs/pcre/pcre.ml

@@ -0,0 +1,1034 @@
+(*
+   PCRE-OCAML - Perl Compatibility Regular Expressions for OCaml
+   Copyright (C) 1999-  Markus Mottl
+   email: [email protected]
+   WWW:   http://www.ocaml.info
+   This library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Lesser General Public
+   License as published by the Free Software Foundation; either
+   version 2.1 of the License, or (at your option) any later version.
+   This library is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+   Lesser General Public License for more details.
+   You should have received a copy of the GNU Lesser General Public
+   License along with this library; if not, write to the Free Software
+   Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+*)
+
+(* Public exceptions and their registration with the C runtime *)
+
+let string_copy str = str
+let buffer_add_subbytes = Buffer.add_subbytes
+
+type error =
+  | Partial
+  | BadPartial
+  | BadPattern of string * int
+  | BadUTF8
+  | BadUTF8Offset
+  | MatchLimit
+  | RecursionLimit
+  | InternalError of string
+
+exception Error of error
+exception Backtrack
+exception Regexp_or of string * error
+
+(* Puts exceptions into global C-variables for fast retrieval *)
+external pcre_ocaml_init : unit -> unit = "pcre_ocaml_init"
+
+(* Registers exceptions with the C runtime and caches polymorphic variants *)
+let () =
+  Callback.register_exception "Pcre.Error" (Error (InternalError ""));
+  Callback.register_exception "Pcre.Backtrack" Backtrack;
+  pcre_ocaml_init ()
+
+
+(* Compilation and runtime flags and their conversion functions *)
+
+type icflag = int
+type irflag = int
+
+(* Compilation flags *)
+
+type cflag =
+  [
+  | `CASELESS
+  | `MULTILINE
+  | `DOTALL
+  | `EXTENDED
+  | `ANCHORED
+  | `DOLLAR_ENDONLY
+  | `EXTRA
+  | `UNGREEDY
+  | `UTF8
+  | `NO_UTF8_CHECK
+  | `NO_AUTO_CAPTURE
+  | `AUTO_CALLOUT
+  | `FIRSTLINE
+  | `UCP
+  ]
+
+let int_of_cflag = function
+  | `CASELESS -> 0x0001
+  | `MULTILINE -> 0x0002
+  | `DOTALL -> 0x0004
+  | `EXTENDED -> 0x0008
+  | `ANCHORED -> 0x0010
+  | `DOLLAR_ENDONLY -> 0x0020
+  | `EXTRA -> 0x0040
+  | `UNGREEDY -> 0x0200
+  | `UTF8 -> 0x0800
+  | `NO_AUTO_CAPTURE -> 0x1000
+  | `NO_UTF8_CHECK -> 0x2000
+  | `AUTO_CALLOUT -> 0x4000
+  | `FIRSTLINE -> 0x40000
+  | `UCP -> 0x20000000
+
+let coll_icflag icflag flag = int_of_cflag flag lor icflag
+let cflags flags = List.fold_left coll_icflag 0 flags
+
+let cflag_of_int = function
+  | 0x0001 -> `CASELESS
+  | 0x0002 -> `MULTILINE
+  | 0x0004 -> `DOTALL
+  | 0x0008 -> `EXTENDED
+  | 0x0010 -> `ANCHORED
+  | 0x0020 -> `DOLLAR_ENDONLY
+  | 0x0040 -> `EXTRA
+  | 0x0200 -> `UNGREEDY
+  | 0x0800 -> `UTF8
+  | 0x1000 -> `NO_AUTO_CAPTURE
+  | 0x2000 -> `NO_UTF8_CHECK
+  | 0x4000 -> `AUTO_CALLOUT
+  | 0x40000 -> `FIRSTLINE
+  | 0x20000000 -> `UCP
+  | _ -> failwith "Pcre.cflag_list: unknown compilation flag"
+
+let all_cflags =
+  [
+    0x0001; 0x0002; 0x0004; 0x0008; 0x0010; 0x0020;
+    0x0040; 0x0200; 0x0800; 0x1000; 0x2000; 0x4000; 0x40000;
+	0x20000000
+  ]
+
+let cflag_list icflags =
+  let coll flag_list flag =
+    if icflags land flag <> 0 then cflag_of_int flag :: flag_list
+    else flag_list in
+  List.fold_left coll [] all_cflags
+
+
+(* Runtime flags *)
+
+type rflag =
+  [
+  | `ANCHORED
+  | `NOTBOL
+  | `NOTEOL
+  | `NOTEMPTY
+  | `PARTIAL
+  ]
+
+let int_of_rflag = function
+  | `ANCHORED -> 0x0010
+  | `NOTBOL -> 0x0080
+  | `NOTEOL -> 0x0100
+  | `NOTEMPTY -> 0x0400
+  | `PARTIAL -> 0x8000
+
+let coll_irflag irflag flag = int_of_rflag flag lor irflag
+let rflags flags = List.fold_left coll_irflag 0 flags
+
+let rflag_of_int = function
+  | 0x0010 -> `ANCHORED
+  | 0x0080 -> `NOTBOL
+  | 0x0100 -> `NOTEOL
+  | 0x0400 -> `NOTEMPTY
+  | 0x8000 -> `PARTIAL
+  | _ -> failwith "Pcre.rflag_list: unknown runtime flag"
+
+let all_rflags = [0x0010; 0x0080; 0x0100; 0x0400; 0x8000]
+
+let rflag_list irflags =
+  let coll flag_list flag =
+    if irflags land flag <> 0 then rflag_of_int flag :: flag_list
+    else flag_list in
+  List.fold_left coll [] all_rflags
+
+
+(* Information on the PCRE-configuration (build-time options) *)
+
+external pcre_version : unit -> string = "pcre_version_stub"
+
+external pcre_config_utf8 : unit -> bool = "pcre_config_utf8_stub" [@@noalloc]
+
+external pcre_config_newline :
+  unit -> char = "pcre_config_newline_stub" [@@noalloc]
+
+external pcre_config_link_size :
+  unit -> int = "pcre_config_link_size_stub" [@@noalloc]
+
+external pcre_config_match_limit :
+  unit -> int = "pcre_config_match_limit_stub" [@@noalloc]
+
+external pcre_config_match_limit_recursion :
+  unit -> int = "pcre_config_match_limit_recursion_stub" [@@noalloc]
+
+external pcre_config_stackrecurse :
+  unit -> bool = "pcre_config_stackrecurse_stub" [@@noalloc]
+
+let version = pcre_version ()
+let config_utf8 = pcre_config_utf8 ()
+let config_newline = pcre_config_newline ()
+let config_link_size = pcre_config_link_size ()
+let config_match_limit = pcre_config_match_limit ()
+let config_match_limit_recursion = pcre_config_match_limit_recursion ()
+let config_stackrecurse = pcre_config_stackrecurse ()
+
+
+(* Information on patterns *)
+
+type firstbyte_info =
+  [ `Char of char
+  | `Start_only
+  | `ANCHORED ]
+
+type study_stat =
+  [ `Not_studied
+  | `Studied
+  | `Optimal ]
+
+type regexp
+
+external options : regexp -> icflag = "pcre_options_stub"
+external size : regexp -> int = "pcre_size_stub"
+external studysize : regexp -> int = "pcre_studysize_stub"
+external capturecount : regexp -> int = "pcre_capturecount_stub"
+external backrefmax : regexp -> int = "pcre_backrefmax_stub"
+external namecount : regexp -> int = "pcre_namecount_stub"
+external names : regexp -> string array = "pcre_names_stub"
+external nameentrysize : regexp -> int = "pcre_nameentrysize_stub"
+external firstbyte : regexp -> firstbyte_info = "pcre_firstbyte_stub"
+external firsttable : regexp -> string option = "pcre_firsttable_stub"
+external lastliteral : regexp -> char option = "pcre_lastliteral_stub"
+external study_stat : regexp -> study_stat = "pcre_study_stat_stub" [@@noalloc]
+
+
+(* Compilation of patterns *)
+
+type chtables
+
+external maketables : unit -> chtables = "pcre_maketables_stub"
+
+(*  Internal use only! *)
+external pcre_study : regexp -> unit = "pcre_study_stub"
+
+external compile :
+  icflag -> chtables option -> string -> regexp = "pcre_compile_stub"
+
+external get_match_limit : regexp -> int option = "pcre_get_match_limit_stub"
+
+(* Internal use only! *)
+external set_imp_match_limit :
+  regexp -> int -> regexp = "pcre_set_imp_match_limit_stub" [@@noalloc]
+
+external get_match_limit_recursion :
+  regexp -> int option = "pcre_get_match_limit_recursion_stub"
+
+(* Internal use only! *)
+external set_imp_match_limit_recursion :
+  regexp -> int -> regexp = "pcre_set_imp_match_limit_recursion_stub" [@@noalloc]
+
+let regexp
+      ?(study = true) ?limit ?limit_recursion
+      ?(iflags = 0) ?flags ?chtables pat =
+  let rex =
+    match flags with
+    | Some flag_list -> compile (cflags flag_list) chtables pat
+    | _ -> compile iflags chtables pat
+  in
+  if study then pcre_study rex;
+  let rex =
+    match limit with
+    | None -> rex
+    | Some lim -> set_imp_match_limit rex lim
+  in
+  match limit_recursion with
+  | None -> rex
+  | Some lim -> set_imp_match_limit_recursion rex lim
+
+let regexp_or
+      ?study ?limit ?limit_recursion ?(iflags = 0) ?flags ?chtables pats =
+  let check pat =
+    try ignore (regexp ~study:false ~iflags ?flags ?chtables pat)
+    with Error error -> raise (Regexp_or (pat, error))
+  in
+  List.iter check pats;
+  let big_pat =
+    let cnv pat = "(?:" ^ pat ^ ")" in
+    String.concat "|" (List.rev (List.rev_map cnv pats))
+  in
+  regexp ?study ?limit ?limit_recursion ~iflags ?flags ?chtables big_pat
+
+let bytes_unsafe_blit_string str str_ofs bts bts_ofs len =
+  let str_bts = Bytes.unsafe_of_string str in
+  Bytes.unsafe_blit str_bts str_ofs bts bts_ofs len
+
+let string_unsafe_sub str ofs len =
+  let res = Bytes.create len in
+  bytes_unsafe_blit_string str ofs res 0 len;
+  Bytes.unsafe_to_string res
+
+let quote s =
+  let len = String.length s in
+  let buf = Bytes.create (len lsl 1) in
+  let pos = ref 0 in
+  for i = 0 to len - 1 do
+    match String.unsafe_get s i with
+    | '\\' | '^' | '$' | '.' | '[' | '|'
+    | '('  | ')' | '?' | '*' | '+' | '{' as c ->
+      Bytes.unsafe_set buf !pos '\\';
+      incr pos;
+      Bytes.unsafe_set buf !pos c;
+      incr pos
+    | c -> Bytes.unsafe_set buf !pos c; incr pos
+  done;
+  string_unsafe_sub (Bytes.unsafe_to_string buf) 0 !pos
+
+
+(* Matching of patterns and subpattern extraction *)
+
+(* Default regular expression when none is provided by the user *)
+let def_rex = regexp "\\s+"
+
+type substrings = string * int array
+
+type callout_data =
+  {
+    callout_number : int;
+    substrings : substrings;
+    start_match : int;
+    current_position : int;
+    capture_top : int;
+    capture_last : int;
+    pattern_position : int;
+    next_item_length : int;
+  }
+
+type callout = callout_data -> unit
+
+let get_subject (subj, _) = subj
+
+let num_of_subs (_, ovector) = Array.length ovector / 3
+
+let get_offset_start ovector str_num =
+  if str_num < 0 || str_num >= Array.length ovector / 3 then
+    invalid_arg "Pcre.get_offset_start: illegal offset";
+  let offset = str_num lsl 1 in
+  offset, Array.unsafe_get ovector offset
+
+let get_substring_aux (subj, ovector) offset start =
+  if start < 0 then raise Not_found
+  else
+    string_unsafe_sub subj start (Array.unsafe_get ovector (offset + 1) - start)
+
+let get_substring (_, ovector as substrings) str_num =
+  let offset, start = get_offset_start ovector str_num in
+  get_substring_aux substrings offset start
+
+let get_substring_ofs (_subj, ovector) str_num =
+  let offset, start = get_offset_start ovector str_num in
+  if start < 0 then raise Not_found
+  else start, Array.unsafe_get ovector (offset + 1)
+
+let unsafe_get_substring (_, ovector as substrings) str_num =
+  let offset = str_num lsl 1 in
+  try get_substring_aux substrings offset (Array.unsafe_get ovector offset)
+  with Not_found -> ""
+
+let get_substrings ?(full_match = true) (_, ovector as substrings) =
+  if full_match then
+    Array.init (Array.length ovector / 3) (unsafe_get_substring substrings)
+  else
+    let len = (Array.length ovector / 3) - 1 in
+    Array.init len (fun n -> unsafe_get_substring substrings (n + 1))
+
+let unsafe_get_opt_substring (_, ovector as substrings) str_num =
+  let offset = str_num lsl 1 in
+  try
+    let start = Array.unsafe_get ovector offset in
+    let str = get_substring_aux substrings offset start in
+    Some str
+  with Not_found -> None
+
+let get_opt_substrings ?(full_match = true) (_, ovector as substrings) =
+  if full_match then
+    Array.init (Array.length ovector / 3) (unsafe_get_opt_substring substrings)
+  else
+    let len = (Array.length ovector / 3) - 1 in
+    Array.init len (fun n -> unsafe_get_opt_substring substrings (n + 1))
+
+external get_stringnumber :
+  regexp -> string -> int = "pcre_get_stringnumber_stub"
+
+let get_named_substring rex name substrings =
+  get_substring substrings (get_stringnumber rex name)
+
+let get_named_substring_ofs rex name substrings =
+  get_substring_ofs substrings (get_stringnumber rex name)
+
+external unsafe_pcre_exec :
+  irflag ->
+  regexp ->
+  pos : int ->
+  subj_start : int ->
+  subj : string ->
+  int array ->
+  callout option ->
+  unit = "pcre_exec_stub_bc" "pcre_exec_stub"
+
+let make_ovector rex =
+  let subgroups1 = capturecount rex + 1 in
+  let subgroups2 = subgroups1 lsl 1 in
+  subgroups2, Array.make (subgroups1 + subgroups2) 0
+
+let pcre_exec ?(iflags = 0) ?flags ?(rex = def_rex) ?pat ?(pos = 0)
+              ?callout subj =
+  let rex = match pat with Some str -> regexp str | _ -> rex in
+  let iflags = match flags with Some flags -> rflags flags | _ -> iflags in
+  let _, ovector = make_ovector rex in
+  unsafe_pcre_exec iflags rex ~pos ~subj_start:0 ~subj ovector callout;
+  ovector
+
+let exec ?iflags ?flags ?rex ?pat ?pos ?callout subj =
+  subj, pcre_exec ?iflags ?flags ?rex ?pat ?pos ?callout subj
+
+let next_match ?iflags ?flags ?rex ?pat ?(pos = 0) ?callout (subj, ovector) =
+  let pos = Array.unsafe_get ovector 1 + pos in
+  let subj_len = String.length subj in
+  if pos < 0 || pos > subj_len then
+    invalid_arg "Pcre.next_match: illegal offset";
+  subj, pcre_exec ?iflags ?flags ?rex ?pat ~pos ?callout subj
+
+let rec copy_lst ar n = function
+  | [] -> ar
+  | h :: t -> Array.unsafe_set ar n h; copy_lst ar (n - 1) t
+
+let exec_all ?(iflags = 0) ?flags ?(rex = def_rex) ?pat ?pos ?callout subj =
+  let rex = match pat with Some str -> regexp str | _ -> rex in
+  let iflags = match flags with Some flags -> rflags flags | _ -> iflags in
+  let (_, ovector as sstrs) = exec ~iflags ~rex ?pos ?callout subj in
+  let null_flags = iflags lor 0x0400 in
+  let subj_len = String.length subj in
+  let rec loop pos (subj, ovector as sstrs) n lst =
+    let maybe_ovector =
+      try
+        let first = Array.unsafe_get ovector 0 in
+        if first = pos && Array.unsafe_get ovector 1 = pos then
+          if pos = subj_len then None
+          else Some (pcre_exec ~iflags:null_flags ~rex ~pos ?callout subj)
+        else Some (pcre_exec ~iflags ~rex ~pos ?callout subj)
+      with Not_found -> None in
+    match maybe_ovector with
+    | Some ovector ->
+        let new_pos = Array.unsafe_get ovector 1 in
+        loop new_pos (subj, ovector) (n + 1) (sstrs :: lst)
+    | None -> copy_lst (Array.make (n + 1) sstrs) (n - 1) lst in
+  loop (Array.unsafe_get ovector 1) sstrs 0 []
+
+let extract ?iflags ?flags ?rex ?pat ?pos ?full_match ?callout subj =
+  get_substrings ?full_match (exec ?iflags ?flags ?rex ?pat ?pos ?callout subj)
+
+let extract_opt ?iflags ?flags ?rex ?pat ?pos ?full_match ?callout subj =
+  get_opt_substrings
+    ?full_match (exec ?iflags ?flags ?rex ?pat ?pos ?callout subj)
+
+let extract_all ?iflags ?flags ?rex ?pat ?pos ?full_match ?callout subj =
+  let many_sstrs = exec_all ?iflags ?flags ?rex ?pat ?pos ?callout subj in
+  Array.map (get_substrings ?full_match) many_sstrs
+
+let extract_all_opt ?iflags ?flags ?rex ?pat ?pos ?full_match ?callout subj =
+  let many_sstrs = exec_all ?iflags ?flags ?rex ?pat ?pos ?callout subj in
+  Array.map (get_opt_substrings ?full_match) many_sstrs
+
+let pmatch ?iflags ?flags ?rex ?pat ?pos ?callout subj =
+  try ignore (pcre_exec ?iflags ?flags ?rex ?pat ?pos ?callout subj); true
+  with Not_found -> false
+
+
+(* String substitution *)
+
+(* Elements of a substitution pattern *)
+type subst =
+  | SubstString of int * int (* Denotes a substring in the substitution *)
+  | Backref of int           (* nth backreference ($0 is program name!) *)
+  | Match                    (* The whole matched string *)
+  | PreMatch                 (* The string before the match *)
+  | PostMatch                (* The string after the match *)
+  | LastParenMatch           (* The last matched group *)
+
+(* Information on substitution patterns *)
+type substitution = string     (* The substitution string *)
+                  * int        (* Highest group number of backreferences *)
+                  * bool       (* Makes use of "LastParenMatch" *)
+                  * subst list (* The list of substitution elements *)
+
+(* Only used internally in "subst" *)
+exception FoundAt of int
+
+let zero = Char.code '0'
+
+let subst str =
+  let max_br = ref 0 in
+  let with_lp = ref false in
+  let lix = String.length str - 1 in
+  let rec loop acc n =
+    if lix < n then acc
+    else
+      try
+        for i = n to lix do
+          if String.unsafe_get str i = '$' then raise (FoundAt i)
+        done;
+        SubstString (n, lix - n + 1) :: acc
+      with FoundAt i ->
+        if i = lix then SubstString (n, lix - n + 1) :: acc
+        else
+          let i1 = i + 1 in
+          let acc = if n = i then acc else SubstString (n, i - n) :: acc in
+          match String.unsafe_get str i1 with
+          | '0'..'9' as c ->
+              let subpat_nr = ref (Char.code c - zero) in
+              (try
+                for j = i1 + 1 to lix do
+                  let c = String.unsafe_get str j in
+                  if c >= '0' && c <= '9' then
+                    subpat_nr := 10 * !subpat_nr + Char.code c - zero
+                  else raise (FoundAt j)
+                done;
+                max_br := max !subpat_nr !max_br;
+                Backref !subpat_nr :: acc
+              with FoundAt j ->
+                max_br := max !subpat_nr !max_br;
+                loop (Backref !subpat_nr :: acc) j)
+          | '!'  -> loop acc (i1 + 1)
+          | '$'  -> loop (SubstString (i1, 1) :: acc) (i1 + 1)
+          | '&'  -> loop (Match :: acc) (i1 + 1)
+          | '`'  -> loop (PreMatch :: acc) (i1 + 1)
+          | '\'' -> loop (PostMatch :: acc) (i1 + 1)
+          | '+'  ->
+              with_lp := true;
+              loop (LastParenMatch :: acc) (i1 + 1)
+          | _    -> loop acc i1 in
+  let subst_lst = loop [] 0 in
+  str, !max_br, !with_lp, subst_lst
+
+let def_subst = subst ""
+
+(* Calculates a list of tuples (str, offset, len) which contain
+   substrings to be copied on substitutions. Internal use only! *)
+let calc_trans_lst subgroups2 ovector subj templ subst_lst =
+  let prefix_len = Array.unsafe_get ovector 0 in
+  let last = Array.unsafe_get ovector 1 in
+  let coll (res_len, trans_lst as accu) =
+    let return_lst (_str, _ix, len as el) =
+      if len = 0 then accu else res_len + len, el :: trans_lst in
+    function
+    | SubstString (ix, len) -> return_lst (templ, ix, len)
+    | Backref 0 ->
+        let prog_name = Sys.argv.(0) in
+        return_lst (prog_name, 0, String.length prog_name)
+    | Backref n ->
+        let offset = n lsl 1 in
+        let start = Array.unsafe_get ovector offset in
+        let len = Array.unsafe_get ovector (offset + 1) - start in
+        return_lst (subj, start, len)
+    | Match -> return_lst (subj, prefix_len, last - prefix_len)
+    | PreMatch -> return_lst (subj, 0, prefix_len)
+    | PostMatch -> return_lst (subj, last, String.length subj - last)
+    | LastParenMatch ->
+        let subgroups2_2 = subgroups2 - 2 in
+        let pos = ref subgroups2_2 in
+        let ix = ref (Array.unsafe_get ovector subgroups2_2) in
+        while !ix < 0 do
+          let pos_2 = !pos - 2 in
+          pos := pos_2;
+          ix := Array.unsafe_get ovector pos_2
+        done;
+        return_lst (subj, !ix, Array.unsafe_get ovector (!pos + 1) - !ix) in
+  List.fold_left coll (0, []) subst_lst
+
+let replace ?(iflags = 0) ?flags ?(rex = def_rex) ?pat
+            ?(pos = 0) ?(itempl = def_subst) ?templ ?callout subj =
+  let rex = match pat with Some str -> regexp str | _ -> rex in
+  let iflags = match flags with Some flags -> rflags flags | _ -> iflags in
+  let templ, max_br, with_lp, subst_lst =
+    match templ with
+    | Some str -> subst str
+    | _ -> itempl in
+  let subj_len = String.length subj in
+  if pos < 0 || pos > subj_len then invalid_arg "Pcre.replace: illegal offset";
+  let subgroups2, ovector = make_ovector rex in
+  let nsubs = (subgroups2 lsr 1) - 1 in
+  if max_br > nsubs then
+    failwith "Pcre.replace: backreference denotes nonexistent subpattern";
+  if with_lp && nsubs = 0 then failwith "Pcre.replace: no backreferences";
+  let rec loop full_len trans_lsts cur_pos =
+    if
+      cur_pos > subj_len ||
+      try
+        unsafe_pcre_exec
+          iflags rex ~pos:cur_pos ~subj_start:0 ~subj
+          ovector callout;
+        false
+      with Not_found -> true
+    then
+      let postfix_len = max (subj_len - cur_pos) 0 in
+      let left = pos + full_len in
+      let res = Bytes.create (left + postfix_len) in
+      bytes_unsafe_blit_string subj 0 res 0 pos;
+      bytes_unsafe_blit_string subj cur_pos res left postfix_len;
+      let inner_coll ofs (templ, ix, len) =
+        bytes_unsafe_blit_string templ ix res ofs len; ofs + len in
+      let coll ofs (res_len, trans_lst) =
+        let new_ofs = ofs - res_len in
+        let _ = List.fold_left inner_coll new_ofs trans_lst in
+        new_ofs in
+      let _ = List.fold_left coll left trans_lsts in
+      Bytes.unsafe_to_string res
+    else
+      let first = Array.unsafe_get ovector 0 in
+      let len = first - cur_pos in
+      let res_len, _ as trans_lst_el =
+        calc_trans_lst subgroups2 ovector subj templ subst_lst in
+      let trans_lsts =
+        if len > 0 then
+          trans_lst_el :: (len, [(subj, cur_pos, len)]) :: trans_lsts
+        else trans_lst_el :: trans_lsts in
+      let full_len = full_len + len + res_len in
+      let next = first + 1 in
+      let last = Array.unsafe_get ovector 1 in
+      if last < next then
+        if first < subj_len then
+          let new_trans_lsts = (1, [(subj, cur_pos + len, 1)]) :: trans_lsts in
+          loop (full_len + 1) new_trans_lsts next
+        else loop full_len trans_lsts next
+      else loop full_len trans_lsts last in
+  loop 0 [] pos
+
+let qreplace ?(iflags = 0) ?flags ?(rex = def_rex) ?pat
+             ?(pos = 0) ?(templ = "") ?callout subj =
+  let rex = match pat with Some str -> regexp str | _ -> rex in
+  let iflags = match flags with Some flags -> rflags flags | _ -> iflags in
+  let subj_len = String.length subj in
+  if pos < 0 || pos > subj_len then invalid_arg "Pcre.qreplace: illegal offset";
+  let templ_len = String.length templ in
+  let _, ovector = make_ovector rex in
+  let rec loop full_len subst_lst cur_pos =
+    if
+      cur_pos > subj_len ||
+      try
+        unsafe_pcre_exec
+          iflags rex ~pos:cur_pos ~subj_start:0 ~subj ovector callout;
+        false
+      with Not_found -> true
+    then
+      let postfix_len = max (subj_len - cur_pos) 0 in
+      let left = pos + full_len in
+      let res = Bytes.create (left + postfix_len) in
+      bytes_unsafe_blit_string subj 0 res 0 pos;
+      bytes_unsafe_blit_string subj cur_pos res left postfix_len;
+      let coll ofs = function
+        | Some (substr, ix, len) ->
+            let new_ofs = ofs - len in
+            bytes_unsafe_blit_string substr ix res new_ofs len;
+            new_ofs
+        | None ->
+            let new_ofs = ofs - templ_len in
+            bytes_unsafe_blit_string templ 0 res new_ofs templ_len;
+            new_ofs in
+      let _ = List.fold_left coll left subst_lst in
+      Bytes.unsafe_to_string res
+    else
+      let first = Array.unsafe_get ovector 0 in
+      let len = first - cur_pos in
+      let subst_lst =
+        if len > 0 then None :: Some (subj, cur_pos, len) :: subst_lst
+        else None :: subst_lst in
+      let last = Array.unsafe_get ovector 1 in
+      let full_len = full_len + len + templ_len in
+      let next = first + 1 in
+      if last < next then
+        if first < subj_len then
+          loop (full_len + 1) (Some (subj, cur_pos + len, 1) :: subst_lst) next
+        else loop full_len subst_lst next
+      else loop full_len subst_lst last in
+  loop 0 [] pos
+
+let substitute_substrings ?(iflags = 0) ?flags ?(rex = def_rex) ?pat
+                          ?(pos = 0) ?callout ~subst subj =
+  let rex = match pat with Some str -> regexp str | _ -> rex in
+  let iflags = match flags with Some flags -> rflags flags | _ -> iflags in
+  let subj_len = String.length subj in
+  if pos < 0 || pos > subj_len then invalid_arg "Pcre.substitute: illegal offset";
+  let _, ovector = make_ovector rex in
+  let rec loop full_len subst_lst cur_pos =
+    if
+      cur_pos > subj_len ||
+      try
+        unsafe_pcre_exec
+          iflags rex ~pos:cur_pos ~subj_start:0 ~subj ovector callout;
+        false
+      with Not_found -> true
+    then
+      let postfix_len = max (subj_len - cur_pos) 0 in
+      let left = pos + full_len in
+      let res = Bytes.create (left + postfix_len) in
+      bytes_unsafe_blit_string subj 0 res 0 pos;
+      bytes_unsafe_blit_string subj cur_pos res left postfix_len;
+      let coll ofs (templ, ix, len) =
+        let new_ofs = ofs - len in
+        bytes_unsafe_blit_string templ ix res new_ofs len;
+        new_ofs in
+      let _ = List.fold_left coll left subst_lst in
+      Bytes.unsafe_to_string res
+    else
+      let first = Array.unsafe_get ovector 0 in
+      let len = first - cur_pos in
+      let templ = subst (subj, ovector) in
+      let templ_len = String.length templ in
+      let subst_lst =
+        if len > 0 then
+          (templ, 0, templ_len) :: (subj, cur_pos, len) :: subst_lst
+        else (templ, 0, templ_len) :: subst_lst in
+      let last = Array.unsafe_get ovector 1 in
+      let full_len = full_len + len + templ_len in
+      let next = first + 1 in
+      if last < next then
+        if first < subj_len then
+          loop (full_len + 1) ((subj, cur_pos + len, 1) :: subst_lst) next
+        else loop full_len subst_lst next
+      else loop full_len subst_lst last in
+  loop 0 [] pos
+
+let substitute ?iflags ?flags ?rex ?pat ?pos ?callout ~subst:str_subst subj =
+  let subst (subj, ovector) =
+    let first = Array.unsafe_get ovector 0 in
+    let last = Array.unsafe_get ovector 1 in
+    str_subst (string_unsafe_sub subj first (last - first)) in
+  substitute_substrings ?iflags ?flags ?rex ?pat ?pos ?callout ~subst subj
+
+let replace_first ?(iflags = 0) ?flags ?(rex = def_rex) ?pat ?(pos = 0)
+                  ?(itempl = def_subst) ?templ ?callout subj =
+  let rex = match pat with Some str -> regexp str | _ -> rex in
+  let iflags = match flags with Some flags -> rflags flags | _ -> iflags in
+  let templ, max_br, with_lp, subst_lst =
+    match templ with
+    | Some str -> subst str
+    | _ -> itempl in
+  let subgroups2, ovector = make_ovector rex in
+  let nsubs = (subgroups2 lsr 1) - 1 in
+  if max_br > nsubs then
+    failwith "Pcre.replace_first: backreference denotes nonexistent subpattern";
+  if with_lp && nsubs = 0 then failwith "Pcre.replace_first: no backreferences";
+  try
+    unsafe_pcre_exec iflags rex ~pos ~subj_start:0 ~subj ovector callout;
+    let res_len, trans_lst =
+      calc_trans_lst subgroups2 ovector subj templ subst_lst in
+    let first = Array.unsafe_get ovector 0 in
+    let last = Array.unsafe_get ovector 1 in
+    let rest = String.length subj - last in
+    let res = Bytes.create (first + res_len + rest) in
+    bytes_unsafe_blit_string subj 0 res 0 first;
+    let coll ofs (templ, ix, len) =
+      bytes_unsafe_blit_string templ ix res ofs len; ofs + len in
+    let ofs = List.fold_left coll first trans_lst in
+    bytes_unsafe_blit_string subj last res ofs rest;
+    Bytes.unsafe_to_string res
+  with Not_found -> string_copy subj
+
+let qreplace_first ?(iflags = 0) ?flags ?(rex = def_rex) ?pat
+                   ?(pos = 0) ?(templ = "") ?callout subj =
+  let rex = match pat with Some str -> regexp str | _ -> rex in
+  let iflags = match flags with Some flags -> rflags flags | _ -> iflags in
+  let _, ovector = make_ovector rex in
+  try
+    unsafe_pcre_exec iflags rex ~pos ~subj_start:0 ~subj ovector callout;
+    let first = Array.unsafe_get ovector 0 in
+    let last = Array.unsafe_get ovector 1 in
+    let len = String.length templ in
+    let rest = String.length subj - last in
+    let postfix_start = first + len in
+    let res = Bytes.create (postfix_start + rest) in
+    bytes_unsafe_blit_string subj 0 res 0 first;
+    bytes_unsafe_blit_string templ 0 res first len;
+    bytes_unsafe_blit_string subj last res postfix_start rest;
+    Bytes.unsafe_to_string res
+  with Not_found -> string_copy subj
+
+let substitute_substrings_first ?(iflags = 0) ?flags ?(rex = def_rex) ?pat
+                                ?(pos = 0) ?callout ~subst subj =
+  let rex = match pat with Some str -> regexp str | _ -> rex in
+  let iflags = match flags with Some flags -> rflags flags | _ -> iflags in
+  let _, ovector = make_ovector rex in
+  try
+    unsafe_pcre_exec iflags rex ~pos ~subj_start:0 ~subj ovector callout;
+    let subj_len = String.length subj in
+    let prefix_len = Array.unsafe_get ovector 0 in
+    let last = Array.unsafe_get ovector 1 in
+    let templ = subst (subj, ovector) in
+    let postfix_len = subj_len - last in
+    let templ_len = String.length templ in
+    let postfix_start = prefix_len + templ_len in
+    let res = Bytes.create (postfix_start + postfix_len) in
+    bytes_unsafe_blit_string subj 0 res 0 prefix_len;
+    bytes_unsafe_blit_string templ 0 res prefix_len templ_len;
+    bytes_unsafe_blit_string subj last res postfix_start postfix_len;
+    Bytes.unsafe_to_string res
+  with Not_found -> string_copy subj
+
+let substitute_first ?iflags ?flags ?rex ?pat ?pos
+                     ?callout ~subst:str_subst subj =
+  let subst (subj, ovector) =
+    let first = Array.unsafe_get ovector 0 in
+    let last = Array.unsafe_get ovector 1 in
+    str_subst (string_unsafe_sub subj first (last - first)) in
+  substitute_substrings_first
+    ?iflags ?flags ?rex ?pat ?pos ?callout ~subst subj
+
+
+(* Splitting *)
+
+let internal_psplit flags rex max pos callout subj =
+  let subj_len = String.length subj in
+  if subj_len = 0 then []
+  else if max = 1 then [string_copy subj]
+  else
+    let subgroups2, ovector = make_ovector rex in
+
+    (* Adds contents of subgroups to the string accumulator *)
+    let handle_subgroups strs =
+      let strs = ref strs in
+      let i = ref 2 in
+      while !i < subgroups2 do
+        let first = Array.unsafe_get ovector !i in
+        incr i;
+        let last = Array.unsafe_get ovector !i in
+        let str =
+          if first < 0 then ""
+          else string_unsafe_sub subj first (last - first) in
+        strs := str :: !strs; incr i
+      done;
+      !strs in
+
+    (* Performs the recursive split *)
+    let rec loop strs cnt pos prematch =
+      let len = subj_len - pos in
+      if len < 0 then strs
+      else
+        (* Checks termination due to max restriction *)
+        if cnt = 0 then
+          if prematch &&
+            try
+              unsafe_pcre_exec
+                flags rex ~pos ~subj_start:pos ~subj ovector callout;
+              true
+            with Not_found -> false
+          then
+            let last = Array.unsafe_get ovector 1 in
+            let strs = handle_subgroups strs in
+            string_unsafe_sub subj last (subj_len - last) :: strs
+          else string_unsafe_sub subj pos len :: strs
+
+        (* Calculates next accumulator state for splitting *)
+        else
+          if
+            try
+              unsafe_pcre_exec
+                flags rex ~pos ~subj_start:pos ~subj ovector callout;
+              false
+            with Not_found -> true
+          then string_unsafe_sub subj pos len :: strs
+          else
+            let first = Array.unsafe_get ovector 0 in
+            let last = Array.unsafe_get ovector 1 in
+            if first = pos then
+              if last = pos then
+                let strs = if prematch then handle_subgroups strs else strs in
+                if len = 0 then "" :: strs
+                else if
+                  try
+                    unsafe_pcre_exec
+                      (flags lor 0x0410) rex ~pos ~subj_start:pos ~subj
+                      ovector callout;
+                    true
+                  with Not_found -> false
+                then
+                  let new_strs = handle_subgroups ("" :: strs) in
+                  loop new_strs (cnt - 1) (Array.unsafe_get ovector 1) false
+                else
+                  let new_strs = string_unsafe_sub subj pos 1 :: strs in
+                  loop new_strs (cnt - 1) (pos + 1) true
+              else
+                if prematch then loop (handle_subgroups strs) cnt last false
+                else loop (handle_subgroups ("" :: strs)) (cnt - 1) last false
+            else
+              let new_strs = string_unsafe_sub subj pos (first - pos) :: strs in
+              loop (handle_subgroups new_strs) (cnt - 1) last false in
+    loop [] (max - 1) pos false
+
+let rec strip_all_empty = function "" :: t -> strip_all_empty t | l -> l
+
+external isspace : char -> bool = "pcre_isspace_stub" [@@noalloc]
+
+let rec find_no_space ix len str =
+  if ix = len || not (isspace (String.unsafe_get str ix)) then ix
+  else find_no_space (ix + 1) len str
+
+let split ?(iflags = 0) ?flags ?rex ?pat ?(pos = 0) ?(max = 0) ?callout subj =
+  let iflags = match flags with Some flags -> rflags flags | _ -> iflags in
+  let res =
+    match pat, rex with
+    | Some str, _ -> internal_psplit iflags (regexp str) max pos callout subj
+    | _, Some rex -> internal_psplit iflags rex max pos callout subj
+    | _ ->
+        (* special case for Perl-splitting semantics *)
+        let len = String.length subj in
+        if pos > len || pos < 0 then failwith "Pcre.split: illegal offset";
+        let new_pos = find_no_space pos len subj in
+        internal_psplit iflags def_rex max new_pos callout subj in
+  List.rev (if max = 0 then strip_all_empty res else res)
+
+let asplit ?iflags ?flags ?rex ?pat ?pos ?max ?callout subj =
+  Array.of_list (split ?iflags ?flags ?rex ?pat ?pos ?max ?callout subj)
+
+
+(* Full splitting *)
+
+type split_result = Text of string
+                  | Delim of string
+                  | Group of int * string
+                  | NoGroup
+
+let rec strip_all_empty_full = function
+  | Delim _ :: rest -> strip_all_empty_full rest
+  | l -> l
+
+let full_split ?(iflags = 0) ?flags ?(rex = def_rex) ?pat
+               ?(pos = 0) ?(max = 0) ?callout subj =
+  let rex = match pat with Some str -> regexp str | _ -> rex in
+  let iflags = match flags with Some flags -> rflags flags | _ -> iflags in
+  let subj_len = String.length subj in
+  if subj_len = 0 then []
+  else if max = 1 then [Text (string_copy subj)]
+  else
+    let subgroups2, ovector = make_ovector rex in
+
+    (* Adds contents of subgroups to the string accumulator *)
+    let handle_subgroups strs =
+      let strs = ref strs in
+      let i = ref 2 in
+      while !i < subgroups2 do
+        let group_nr = !i lsr 1 in
+        let first = Array.unsafe_get ovector !i in
+        incr i;
+        let last = Array.unsafe_get ovector !i in
+        let str =
+          if first < 0 then NoGroup
+          else
+            let group_str = string_unsafe_sub subj first (last - first) in
+            Group (group_nr, group_str) in
+        strs := str :: !strs; incr i
+      done;
+      !strs in
+
+    (* Performs the recursive split *)
+    let rec loop strs cnt pos prematch =
+      let len = subj_len - pos in
+      if len < 0 then strs
+      else
+        (* Checks termination due to max restriction *)
+        if cnt = 0 then
+          if prematch &&
+            try
+              unsafe_pcre_exec
+                iflags rex ~pos ~subj_start:pos ~subj ovector callout;
+               true
+            with Not_found -> false
+          then
+            let first = Array.unsafe_get ovector 0 in
+            let last = Array.unsafe_get ovector 1 in
+            let delim = Delim (string_unsafe_sub subj first (last - first)) in
+            Text (string_unsafe_sub subj last (subj_len - last))
+              :: handle_subgroups (delim :: strs)
+          else
+            if len = 0 then strs
+            else Text (string_unsafe_sub subj pos len) :: strs
+
+        (* Calculates next accumulator state for splitting *)
+        else
+          if
+            try
+              unsafe_pcre_exec
+                iflags rex ~pos ~subj_start:pos ~subj ovector callout;
+              false
+            with Not_found -> true
+          then
+            if len = 0 then strs
+            else Text (string_unsafe_sub subj pos len) :: strs
+          else
+            let first = Array.unsafe_get ovector 0 in
+            let last = Array.unsafe_get ovector 1 in
+            if first = pos then
+              if last = pos then
+                if len = 0 then handle_subgroups (Delim "" :: strs)
+                else
+                  let empty_groups = handle_subgroups [] in
+                  if
+                    try
+                      unsafe_pcre_exec
+                        (iflags lor 0x0410) rex ~pos ~subj_start:pos ~subj
+                        ovector callout;
+                      true
+                    with Not_found -> false
+                  then
+                    let first = Array.unsafe_get ovector 0 in
+                    let last = Array.unsafe_get ovector 1 in
+                    let delim =
+                      Delim (string_unsafe_sub subj first (last - first)) in
+                    let new_strs =
+                      handle_subgroups (
+                        delim :: (if prematch then strs
+                                  else empty_groups @ (Delim "" :: strs))) in
+                    loop new_strs (cnt - 1) last false
+                  else
+                    let new_strs =
+                      Text (string_unsafe_sub subj pos 1)
+                        :: empty_groups @ Delim "" :: strs in
+                    loop new_strs (cnt - 1) (pos + 1) true
+              else
+                  let delim =
+                    Delim (string_unsafe_sub subj first (last - first)) in
+                  loop (handle_subgroups (delim :: strs)) cnt last false
+            else
+              let delim = Delim (string_unsafe_sub subj first (last - first)) in
+              let pre_strs =
+                Text (string_unsafe_sub subj pos (first - pos)) :: strs in
+              loop
+                (handle_subgroups (delim :: pre_strs)) (cnt - 1) last false in
+    let res = loop [] (max - 1) pos true in
+    List.rev (if max = 0 then strip_all_empty_full res else res)
+
+
+(* Additional convenience functions useful in combination with this library *)
+
+let foreach_line ?(ic = stdin) f =
+  try while true do f (input_line ic) done with End_of_file -> ()
+
+let foreach_file filenames f =
+  let do_with_file filename =
+    let file = open_in filename in
+    try f filename file; close_in file
+    with exn -> close_in file; raise exn in
+  List.iter do_with_file filenames

libs/pcre/pcre_stubs.c

@@ -0,0 +1,737 @@
+/*
+   PCRE-OCAML - Perl Compatibility Regular Expressions for OCaml
+
+   Copyright (C) 1999-  Markus Mottl
+   email: [email protected]
+   WWW:   http://www.ocaml.info
+
+   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 of the License, or (at your option) any later version.
+
+   This library is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+   Lesser General Public License for more details.
+
+   You should have received a copy of the GNU Lesser General Public
+   License along with this library; if not, write to the Free Software
+   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+*/
+
+#if defined(_WIN32)
+#  define snprintf _snprintf
+#  if defined(_DLL)
+#    define PCREextern __declspec(dllexport)
+#  else
+#    define PCREextern
+#  endif
+#endif
+
+#if _WIN64
+  typedef long long *ovec_dst_ptr;
+#else
+  typedef long *ovec_dst_ptr;
+#endif
+
+#if __GNUC__ >= 3
+# define inline inline __attribute__ ((always_inline))
+# define __unused __attribute__ ((unused))
+#else
+# define __unused
+# define inline
+#endif
+
+#include <ctype.h>
+#include <string.h>
+#include <stdio.h>
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+
+#include "pcre.h"
+
+/* Error codes as defined for pcre 7.9, undefined in pcre 4.5 */
+#ifndef PCRE_ERROR_PARTIAL
+#define PCRE_ERROR_PARTIAL        (-12)
+#endif
+#ifndef PCRE_ERROR_BADPARTIAL
+#define PCRE_ERROR_BADPARTIAL     (-13)
+#endif
+#ifndef PCRE_ERROR_RECURSIONLIMIT
+#define PCRE_ERROR_RECURSIONLIMIT (-21)
+#endif
+
+typedef const unsigned char *chartables;  /* Type of chartable sets */
+
+/* Contents of callout data */
+struct cod {
+  long subj_start;        /* Start of subject string */
+  value *v_substrings_p;  /* Pointer to substrings matched so far */
+  value *v_cof_p;         /* Pointer to callout function */
+  value v_exn;            /* Possible exception raised by callout function */
+};
+
+/* Cache for exceptions */
+static value *pcre_exc_Error         = NULL;  /* Exception [Error] */
+static value *pcre_exc_Backtrack     = NULL;  /* Exception [Backtrack] */
+
+/* Cache for polymorphic variants */
+static value var_Start_only;   /* Variant [`Start_only] */
+static value var_ANCHORED;     /* Variant [`ANCHORED] */
+static value var_Char;         /* Variant [`Char char] */
+static value var_Not_studied;  /* Variant [`Not_studied] */
+static value var_Studied;      /* Variant [`Studied] */
+static value var_Optimal;      /* Variant [`Optimal] */
+
+static value None = Val_int(0);
+
+/* Converts subject offsets from C-integers to OCaml-Integers.
+
+   This is a bit tricky, because there are 32- and 64-bit platforms around
+   and OCaml chooses the larger possibility for representing integers when
+   available (also in arrays) - not so the PCRE!
+*/
+static inline void copy_ovector(
+  long subj_start, const int *ovec_src, ovec_dst_ptr ovec_dst, int subgroups2)
+{
+  if (subj_start == 0)
+    while (subgroups2--) {
+      *ovec_dst = Val_int(*ovec_src);
+      --ovec_src; --ovec_dst;
+    }
+  else
+    while (subgroups2--) {
+      *ovec_dst = Val_long(*ovec_src + subj_start);
+      --ovec_src; --ovec_dst;
+    }
+}
+
+/* Callout handler */
+static int pcre_callout_handler(pcre_callout_block* cb)
+{
+  struct cod *cod = (struct cod *) cb->callout_data;
+
+  if (cod != NULL) {
+    /* Callout is available */
+    value v_res;
+
+    /* Set up parameter array */
+    value v_callout_data = caml_alloc_small(8, 0);
+
+    const value v_substrings = *cod->v_substrings_p;
+
+    const int capture_top = cb->capture_top;
+    int subgroups2 = capture_top << 1;
+    const int subgroups2_1 = subgroups2 - 1;
+
+    const int *ovec_src = cb->offset_vector + subgroups2_1;
+    ovec_dst_ptr ovec_dst = &Field(Field(v_substrings, 1), 0) + subgroups2_1;
+    long subj_start = cod->subj_start;
+
+    copy_ovector(subj_start, ovec_src, ovec_dst, subgroups2);
+
+    Field(v_callout_data, 0) = Val_int(cb->callout_number);
+    Field(v_callout_data, 1) = v_substrings;
+    Field(v_callout_data, 2) = Val_int(cb->start_match + subj_start);
+    Field(v_callout_data, 3) = Val_int(cb->current_position + subj_start);
+    Field(v_callout_data, 4) = Val_int(capture_top);
+    Field(v_callout_data, 5) = Val_int(cb->capture_last);
+    Field(v_callout_data, 6) = Val_int(cb->pattern_position);
+    Field(v_callout_data, 7) = Val_int(cb->next_item_length);
+
+    /* Perform callout */
+    v_res = caml_callback_exn(*cod->v_cof_p, v_callout_data);
+
+    if (Is_exception_result(v_res)) {
+      /* Callout raised an exception */
+      const value v_exn = Extract_exception(v_res);
+      if (Field(v_exn, 0) == *pcre_exc_Backtrack) return 1;
+      cod->v_exn = v_exn;
+      return PCRE_ERROR_CALLOUT;
+    }
+  }
+
+  return 0;
+}
+
+/* Fetchs the named OCaml-values + caches them and
+   calculates + caches the variant hash values */
+CAMLprim value pcre_ocaml_init(value __unused v_unit)
+{
+  pcre_exc_Error     = caml_named_value("Pcre.Error");
+  pcre_exc_Backtrack = caml_named_value("Pcre.Backtrack");
+
+  var_Start_only  = caml_hash_variant("Start_only");
+  var_ANCHORED    = caml_hash_variant("ANCHORED");
+  var_Char        = caml_hash_variant("Char");
+  var_Not_studied = caml_hash_variant("Not_studied");
+  var_Studied     = caml_hash_variant("Studied");
+  var_Optimal     = caml_hash_variant("Optimal");
+
+  pcre_callout = &pcre_callout_handler;
+
+  return Val_unit;
+}
+
+/* Finalizing deallocation function for chartable sets */
+static void pcre_dealloc_tables(value v_table)
+{ (pcre_free)((void *) Field(v_table, 1)); }
+
+/* Finalizing deallocation function for compiled regular expressions */
+static void pcre_dealloc_regexp(value v_rex)
+{
+  void *extra = (void *) Field(v_rex, 2);
+  (pcre_free)((void *) Field(v_rex, 1));
+  if (extra != NULL)
+#ifdef PCRE_STUDY_JIT_COMPILE
+    pcre_free_study(extra);
+#else
+    pcre_free(extra);
+#endif
+}
+
+/* Makes OCaml-string from PCRE-version */
+CAMLprim value pcre_version_stub(value __unused v_unit)
+{
+  return caml_copy_string((char *) pcre_version());
+}
+
+
+/* Raising exceptions */
+
+static inline void raise_pcre_error(value v_arg) Noreturn;
+static inline void raise_partial() Noreturn;
+static inline void raise_bad_partial() Noreturn;
+static inline void raise_bad_utf8() Noreturn;
+static inline void raise_bad_utf8_offset() Noreturn;
+static inline void raise_match_limit() Noreturn;
+static inline void raise_recursion_limit() Noreturn;
+static inline void raise_bad_pattern(const char *msg, int pos) Noreturn;
+static inline void raise_internal_error(char *msg) Noreturn;
+
+static inline void raise_pcre_error(value v_arg)
+{ caml_raise_with_arg(*pcre_exc_Error, v_arg); }
+
+static inline void raise_partial() { raise_pcre_error(Val_int(0)); }
+static inline void raise_bad_partial() { raise_pcre_error(Val_int(1)); }
+static inline void raise_bad_utf8() { raise_pcre_error(Val_int(2)); }
+static inline void raise_bad_utf8_offset() { raise_pcre_error(Val_int(3)); }
+static inline void raise_match_limit() { raise_pcre_error(Val_int(4)); }
+static inline void raise_recursion_limit() { raise_pcre_error(Val_int(5)); }
+
+static inline void raise_bad_pattern(const char *msg, int pos)
+{
+  CAMLparam0();
+  CAMLlocal1(v_msg);
+  value v_arg;
+  v_msg = caml_copy_string(msg);
+  v_arg = caml_alloc_small(2, 0);
+  Field(v_arg, 0) = v_msg;
+  Field(v_arg, 1) = Val_int(pos);
+  raise_pcre_error(v_arg);
+  CAMLnoreturn;
+}
+
+static inline void raise_internal_error(char *msg)
+{
+  CAMLparam0();
+  CAMLlocal1(v_msg);
+  value v_arg;
+  v_msg = caml_copy_string(msg);
+  v_arg = caml_alloc_small(1, 1);
+  Field(v_arg, 0) = v_msg;
+  raise_pcre_error(v_arg);
+  CAMLnoreturn;
+}
+
+/* PCRE pattern compilation */
+
+/* Makes compiled regular expression from compilation options, an optional
+   value of chartables and the pattern string */
+CAMLprim value pcre_compile_stub(value v_opt, value v_tables, value v_pat)
+{
+  value v_rex;  /* Final result -> value of type [regexp] */
+  const char *error = NULL;  /* pointer to possible error message */
+  int error_ofs = 0;  /* offset in the pattern at which error occurred */
+
+  /* If v_tables = [None], then pointer to tables is NULL, otherwise
+     set it to the appropriate value */
+  chartables tables =
+    (v_tables == None) ? NULL : (chartables) Field(Field(v_tables, 0), 1);
+
+  /* Compiles the pattern */
+  pcre *regexp = pcre_compile(String_val(v_pat), Int_val(v_opt), &error,
+                              &error_ofs, tables);
+
+  /* Raises appropriate exception with [BadPattern] if the pattern
+     could not be compiled */
+  if (regexp == NULL) raise_bad_pattern(error, error_ofs);
+
+  /* GC will do a full cycle every 1_000_000 regexp allocations (a typical
+     regexp probably consumes less than 100 bytes -> maximum of 100_000_000
+     bytes unreclaimed regexps) */
+  v_rex = caml_alloc_final(4, pcre_dealloc_regexp, 1, 1000000);
+
+  /* Field[1]: compiled regular expression (Field[0] is finalizing
+     function! See above!) */
+  Field(v_rex, 1) = (value) regexp;
+
+  /* Field[2]: extra information about regexp when it has been studied
+     successfully */
+  Field(v_rex, 2) = (value) NULL;
+
+  /* Field[3]: If 0 -> regexp has not yet been studied
+                  1 -> regexp has already been studied */
+  Field(v_rex, 3) = 0;
+
+  return v_rex;
+}
+
+/* Studies a regexp */
+CAMLprim value pcre_study_stub(value v_rex)
+{
+  /* If it has not yet been studied */
+  if (! (int) Field(v_rex, 3)) {
+    const char *error = NULL;
+    pcre_extra *extra = pcre_study((pcre *) Field(v_rex, 1), 0, &error);
+    if (error != NULL) caml_invalid_argument((char *) error);
+    Field(v_rex, 2) = (value) extra;
+    Field(v_rex, 3) = Val_int(1);
+  }
+  return v_rex;
+}
+
+/* Sets a match limit recursion for a regular expression imperatively */
+CAMLprim value pcre_set_imp_match_limit_recursion_stub(value v_rex, value v_lim)
+{
+  pcre_extra *extra = (pcre_extra *) Field(v_rex, 2);
+  if (extra == NULL) {
+    extra = pcre_malloc(sizeof(pcre_extra));
+    extra->flags = PCRE_EXTRA_MATCH_LIMIT_RECURSION;
+    Field(v_rex, 2) = (value) extra;
+  } else {
+    unsigned long *flags_ptr = &extra->flags;
+    *flags_ptr = PCRE_EXTRA_MATCH_LIMIT_RECURSION | *flags_ptr;
+  }
+  extra->match_limit_recursion = Int_val(v_lim);
+  return v_rex;
+}
+
+/* Gets the match limit recursion of a regular expression if it exists */
+CAMLprim value pcre_get_match_limit_recursion_stub(value v_rex)
+{
+  pcre_extra *extra = (pcre_extra *) Field(v_rex, 2);
+  if (extra == NULL) return None;
+  if (extra->flags & PCRE_EXTRA_MATCH_LIMIT_RECURSION) {
+    value v_lim = Val_int(extra->match_limit_recursion);
+    value v_res = caml_alloc_small(1, 0);
+    Field(v_res, 0) = v_lim;
+    return v_res;
+  }
+  return None;
+}
+
+/* Sets a match limit for a regular expression imperatively */
+CAMLprim value pcre_set_imp_match_limit_stub(value v_rex, value v_lim)
+{
+  pcre_extra *extra = (pcre_extra *) Field(v_rex, 2);
+  if (extra == NULL) {
+    extra = pcre_malloc(sizeof(pcre_extra));
+    extra->flags = PCRE_EXTRA_MATCH_LIMIT;
+    Field(v_rex, 2) = (value) extra;
+  } else {
+    unsigned long *flags_ptr = &extra->flags;
+    *flags_ptr = PCRE_EXTRA_MATCH_LIMIT | *flags_ptr;
+  }
+  extra->match_limit = Int_val(v_lim);
+  return v_rex;
+}
+
+/* Gets the match limit of a regular expression if it exists */
+CAMLprim value pcre_get_match_limit_stub(value v_rex)
+{
+  pcre_extra *extra = (pcre_extra *) Field(v_rex, 2);
+  if (extra == NULL) return None;
+  if (extra->flags & PCRE_EXTRA_MATCH_LIMIT) {
+    value v_lim = Val_int(extra->match_limit);
+    value v_res = caml_alloc_small(1, 0);
+    Field(v_res, 0) = v_lim;
+    return v_res;
+  }
+  return None;
+}
+
+/* Performs the call to the pcre_fullinfo function */
+static inline int pcre_fullinfo_stub(value v_rex, int what, void *where)
+{
+  return pcre_fullinfo((pcre *) Field(v_rex, 1), (pcre_extra *) Field(v_rex, 2),
+                       what, where);
+}
+
+/* Some stubs for info-functions */
+
+/* Generic macro for getting integer results from pcre_fullinfo */
+#define make_info(tp, cnv, name, option) \
+  CAMLprim value pcre_##name##_stub(value v_rex) \
+  { \
+    tp options; \
+    const int ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_##option, &options); \
+    if (ret != 0) raise_internal_error("pcre_##name##_stub"); \
+    return cnv(options); \
+  }
+
+make_info(unsigned long, Val_long, options, OPTIONS)
+make_info(size_t, Val_long, size, SIZE)
+make_info(size_t, Val_long, studysize, STUDYSIZE)
+make_info(int, Val_int, capturecount, CAPTURECOUNT)
+make_info(int, Val_int, backrefmax, BACKREFMAX)
+make_info(int, Val_int, namecount, NAMECOUNT)
+make_info(int, Val_int, nameentrysize, NAMEENTRYSIZE)
+
+CAMLprim value pcre_firstbyte_stub(value v_rex)
+{
+  int firstbyte;
+  const int ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_FIRSTBYTE, &firstbyte);
+
+  if (ret != 0) raise_internal_error("pcre_firstbyte_stub");
+
+  switch (firstbyte) {
+    case -1 : return var_Start_only; break;  /* [`Start_only] */
+    case -2 : return var_ANCHORED; break;    /* [`ANCHORED] */
+    default :
+      if (firstbyte < 0 )  /* Should not happen */
+        raise_internal_error("pcre_firstbyte_stub");
+      else {
+        value v_firstbyte;
+        /* Allocates the non-constant constructor [`Char of char] and fills
+           in the appropriate value */
+        v_firstbyte = caml_alloc_small(2, 0);
+        Field(v_firstbyte, 0) = var_Char;
+        Field(v_firstbyte, 1) = Val_int(firstbyte);
+        return v_firstbyte;
+      }
+  }
+}
+
+CAMLprim value pcre_firsttable_stub(value v_rex)
+{
+  const unsigned char *ftable;
+
+  int ret =
+    pcre_fullinfo_stub(v_rex, PCRE_INFO_FIRSTTABLE, (void *) &ftable);
+
+  if (ret != 0) raise_internal_error("pcre_firsttable_stub");
+
+  if (ftable == NULL) return None;
+  else {
+    value v_res, v_res_str;
+    char *ptr;
+    int i;
+
+    Begin_roots1(v_rex);
+      v_res_str = caml_alloc_string(32);
+    End_roots();
+
+    ptr = String_val(v_res_str);
+    for (i = 0; i <= 31; ++i) { *ptr = *ftable; ++ptr; ++ftable; }
+
+    Begin_roots1(v_res_str);
+      /* Allocates [Some string] from firsttable */
+      v_res = caml_alloc_small(1, 0);
+    End_roots();
+
+    Field(v_res, 0) = v_res_str;
+
+    return v_res;
+  }
+}
+
+CAMLprim value pcre_lastliteral_stub(value v_rex)
+{
+  int lastliteral;
+  const int ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_LASTLITERAL,
+                                        &lastliteral);
+
+  if (ret != 0) raise_internal_error("pcre_lastliteral_stub");
+
+  if (lastliteral == -1) return None;
+  if (lastliteral < 0) raise_internal_error("pcre_lastliteral_stub");
+  else {
+    /* Allocates [Some char] */
+    value v_res = caml_alloc_small(1, 0);
+    Field(v_res, 0) = Val_int(lastliteral);
+    return v_res;
+  }
+}
+
+CAMLprim value pcre_study_stat_stub(value v_rex)
+{
+  /* Generates the appropriate constant constructor [`Optimal] or
+     [`Studied] if regexp has already been studied */
+  if (Field(v_rex, 3))
+    return ((pcre_extra *) Field(v_rex, 2) == NULL) ? var_Optimal : var_Studied;
+
+  return var_Not_studied;  /* otherwise [`Not_studied] */
+}
+
+static inline void handle_exec_error(char *loc, const int ret) Noreturn;
+
+static inline void handle_exec_error(char *loc, const int ret)
+{
+  switch (ret) {
+    /* Dedicated exceptions */
+    case PCRE_ERROR_NOMATCH : caml_raise_not_found();
+    case PCRE_ERROR_PARTIAL : raise_partial();
+    case PCRE_ERROR_MATCHLIMIT : raise_match_limit();
+    case PCRE_ERROR_BADPARTIAL : raise_bad_partial();
+    case PCRE_ERROR_BADUTF8 : raise_bad_utf8();
+    case PCRE_ERROR_BADUTF8_OFFSET : raise_bad_utf8_offset();
+    case PCRE_ERROR_RECURSIONLIMIT : raise_recursion_limit();
+    /* Unknown error */
+    default : {
+      char err_buf[100];
+      snprintf(err_buf, 100, "%s: unhandled PCRE error code: %d", loc, ret);
+      raise_internal_error(err_buf);
+    }
+  }
+}
+
+static inline void handle_pcre_exec_result(
+  int *ovec, value v_ovec, long ovec_len, long subj_start, int ret)
+{
+  ovec_dst_ptr ocaml_ovec = (ovec_dst_ptr) &Field(v_ovec, 0);
+  const int subgroups2 = ret * 2;
+  const int subgroups2_1 = subgroups2 - 1;
+  const int *ovec_src = ovec + subgroups2_1;
+  ovec_dst_ptr ovec_clear_stop = ocaml_ovec + (ovec_len * 2) / 3;
+  ovec_dst_ptr ovec_dst = ocaml_ovec + subgroups2_1;
+  copy_ovector(subj_start, ovec_src, ovec_dst, subgroups2);
+  while (++ovec_dst < ovec_clear_stop) *ovec_dst = -1;
+}
+
+/* Executes a pattern match with runtime options, a regular expression, a
+   matching position, the start of the the subject string, a subject string,
+   a number of subgroup offsets, an offset vector and an optional callout
+   function */
+CAMLprim value pcre_exec_stub(value v_opt, value v_rex, value v_pos,
+                              value v_subj_start, value v_subj,
+                              value v_ovec, value v_maybe_cof)
+{
+  int ret;
+  long
+    pos = Long_val(v_pos),
+    len = caml_string_length(v_subj),
+    subj_start = Long_val(v_subj_start);
+  long ovec_len = Wosize_val(v_ovec);
+
+  if (pos > len || pos < subj_start)
+    caml_invalid_argument("Pcre.pcre_exec_stub: illegal position");
+
+  if (subj_start > len || subj_start < 0)
+    caml_invalid_argument("Pcre.pcre_exec_stub: illegal subject start");
+
+  pos -= subj_start;
+  len -= subj_start;
+
+  {
+    const pcre *code = (pcre *) Field(v_rex, 1);  /* Compiled pattern */
+    const pcre_extra *extra = (pcre_extra *) Field(v_rex, 2);  /* Extra info */
+    const char *ocaml_subj =
+      String_val(v_subj) + subj_start;  /* Subject string */
+    const int opt = Int_val(v_opt);  /* Runtime options */
+
+    /* Special case when no callout functions specified */
+    if (v_maybe_cof == None) {
+      int *ovec = (int *) &Field(v_ovec, 0);
+
+      /* Performs the match */
+      ret = pcre_exec(code, extra, ocaml_subj, len, pos, opt, ovec, ovec_len);
+
+      if (ret < 0) handle_exec_error("pcre_exec_stub", ret);
+      else handle_pcre_exec_result(ovec, v_ovec, ovec_len, subj_start, ret);
+    }
+
+    /* There are callout functions */
+    else {
+      value v_cof = Field(v_maybe_cof, 0);
+      value v_substrings;
+      char *subj = caml_stat_alloc(sizeof(char) * len);
+      int *ovec = caml_stat_alloc(sizeof(int) * ovec_len);
+      struct cod cod = { 0, (value *) NULL, (value *) NULL, (value) NULL };
+      struct pcre_extra new_extra =
+#ifdef PCRE_EXTRA_MATCH_LIMIT_RECURSION
+# ifdef PCRE_EXTRA_MARK
+#  ifdef PCRE_EXTRA_EXECUTABLE_JIT
+        { PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0, NULL, NULL };
+#  else
+        { PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0, NULL };
+#  endif
+# else
+        { PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0 };
+# endif
+#else
+        { PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL };
+#endif
+
+      cod.subj_start = subj_start;
+      memcpy(subj, ocaml_subj, len);
+
+      Begin_roots4(v_rex, v_cof, v_substrings, v_ovec);
+        Begin_roots1(v_subj);
+          v_substrings = caml_alloc_small(2, 0);
+        End_roots();
+
+        Field(v_substrings, 0) = v_subj;
+        Field(v_substrings, 1) = v_ovec;
+
+        cod.v_substrings_p = &v_substrings;
+        cod.v_cof_p = &v_cof;
+        new_extra.callout_data = &cod;
+
+        if (extra == NULL) {
+          ret = pcre_exec(code, &new_extra, subj, len, pos, opt, ovec,
+                          ovec_len);
+        }
+        else {
+          new_extra.flags = PCRE_EXTRA_CALLOUT_DATA | extra->flags;
+          new_extra.study_data = extra->study_data;
+          new_extra.match_limit = extra->match_limit;
+          new_extra.tables = extra->tables;
+#ifdef PCRE_EXTRA_MATCH_LIMIT_RECURSION
+          new_extra.match_limit_recursion = extra->match_limit_recursion;
+#endif
+
+          ret = pcre_exec(code, &new_extra, subj, len, pos, opt, ovec,
+                          ovec_len);
+        }
+
+        caml_stat_free(subj);
+      End_roots();
+
+      if (ret < 0) {
+        caml_stat_free(ovec);
+        if (ret == PCRE_ERROR_CALLOUT) caml_raise(cod.v_exn);
+        else handle_exec_error("pcre_exec_stub(callout)", ret);
+      } else {
+        handle_pcre_exec_result(ovec, v_ovec, ovec_len, subj_start, ret);
+        caml_stat_free(ovec);
+      }
+    }
+  }
+
+  return Val_unit;
+}
+
+/* Byte-code hook for pcre_exec_stub
+   Needed, because there are more than 5 arguments */
+CAMLprim value pcre_exec_stub_bc(value *argv, int __unused argn)
+{
+  return pcre_exec_stub(argv[0], argv[1], argv[2], argv[3],
+                        argv[4], argv[5], argv[6]);
+}
+
+/* Generates a new set of chartables for the current locale (see man
+   page of PCRE */
+CAMLprim value pcre_maketables_stub(value __unused v_unit)
+{
+  /* GC will do a full cycle every 1_000_000 table set allocations (one
+     table set consumes 864 bytes -> maximum of 864_000_000 bytes unreclaimed
+     table sets) */
+  const value v_res = caml_alloc_final(2, pcre_dealloc_tables, 1, 1000000);
+  Field(v_res, 1) = (value) pcre_maketables();
+  return v_res;
+}
+
+/* Wraps around the isspace-function */
+CAMLprim value pcre_isspace_stub(value v_c)
+{
+  return Val_bool(isspace(Int_val(v_c)));
+}
+
+/* Returns number of substring associated with a name */
+CAMLprim value pcre_get_stringnumber_stub(value v_rex, value v_name)
+{
+  const int ret = pcre_get_stringnumber((pcre *) Field(v_rex, 1),
+                                        String_val(v_name));
+  if (ret == PCRE_ERROR_NOSUBSTRING)
+    caml_invalid_argument("Named string not found");
+
+  return Val_int(ret);
+}
+
+/* Returns array of names of named substrings in a regexp */
+CAMLprim value pcre_names_stub(value v_rex)
+{
+  CAMLparam0();
+  CAMLlocal1(v_res);
+  int name_count;
+  int entry_size;
+  const char *tbl_ptr;
+  int i;
+
+  int ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMECOUNT, &name_count);
+  if (ret != 0) raise_internal_error("pcre_names_stub: namecount");
+
+  ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMEENTRYSIZE, &entry_size);
+  if (ret != 0) raise_internal_error("pcre_names_stub: nameentrysize");
+
+  ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMETABLE, &tbl_ptr);
+  if (ret != 0) raise_internal_error("pcre_names_stub: nametable");
+
+  v_res = caml_alloc(name_count, 0);
+
+  for (i = 0; i < name_count; ++i) {
+    value v_name = caml_copy_string(tbl_ptr + 2);
+    Store_field(v_res, i, v_name);
+    tbl_ptr += entry_size;
+  }
+
+  CAMLreturn(v_res);
+}
+
+/* Generic stub for getting integer results from pcre_config */
+static inline int pcre_config_int(int what)
+{
+  int ret;
+  pcre_config(what, (void *) &ret);
+  return ret;
+}
+
+/* Generic stub for getting long integer results from pcre_config */
+static inline int pcre_config_long(int what)
+{
+  long ret;
+  pcre_config(what, (void *) &ret);
+  return ret;
+}
+
+/* Some stubs for config-functions */
+
+/* Returns boolean indicating UTF8-support */
+CAMLprim value pcre_config_utf8_stub(value __unused v_unit)
+{ return Val_bool(pcre_config_int(PCRE_CONFIG_UTF8)); }
+
+/* Returns character used as newline */
+CAMLprim value pcre_config_newline_stub(value __unused v_unit)
+{ return Val_int(pcre_config_int(PCRE_CONFIG_NEWLINE)); }
+
+/* Returns number of bytes used for internal linkage of regular expressions */
+CAMLprim value pcre_config_link_size_stub(value __unused v_unit)
+{ return Val_int(pcre_config_int(PCRE_CONFIG_LINK_SIZE)); }
+
+/* Returns boolean indicating use of stack recursion */
+CAMLprim value pcre_config_stackrecurse_stub(value __unused v_unit)
+{ return Val_bool(pcre_config_int(PCRE_CONFIG_STACKRECURSE)); }
+
+/* Returns default limit for calls to internal matching function */
+CAMLprim value pcre_config_match_limit_stub(value __unused v_unit)
+{ return Val_long(pcre_config_long(PCRE_CONFIG_MATCH_LIMIT)); }
+
+/* Returns default limit for calls to internal matching function */
+CAMLprim value pcre_config_match_limit_recursion_stub(value __unused v_unit)
+{ return Val_long(pcre_config_long(PCRE_CONFIG_MATCH_LIMIT_RECURSION)); }

libs/swflib/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/swflib/Makefile

@@ -0,0 +1,81 @@
+# Makefile generated by OCamake
+# http://tech.motion-twin.com
+OCAMLOPT=ocamlopt
+OCAMLC=ocamlc
+.SUFFIXES : .ml .mli .cmo .cmi .cmx .mll .mly
+
+ALL_CFLAGS= $(CFLAGS) -safe-string -package extlib -I ../extlib-leftovers -I ../extc -g
+LIBS=
+
+SRC=actionScript.ml as3hl.mli as3.mli png.ml swflib.sln swf.ml swfPic.ml as3code.ml as3hlparse.ml as3parse.ml png.mli swfParser.ml
+
+MODULES=as3code.cmx png.cmx swf.cmx actionScript.cmx as3parse.cmx swfPic.cmx as3hlparse.cmx swfParser.cmx
+
+all: native bytecode
+
+native: swflib.cmxa
+
+bytecode: swflib.cma
+
+swflib.cmxa: $(MODULES)
+	ocamlfind $(OCAMLOPT) -safe-string -o swflib.cmxa -a $(LIBS) $(MODULES)
+
+swflib.cma: $(MODULES:.cmx=.cmo)
+	ocamlfind $(OCAMLC) -safe-string -o swflib.cma -a $(LFLAGS) $(LIBS) $(MODULES:.cmx=.cmo)
+
+actionScript.cmx: swf.cmx
+
+actionScript.cmo: swf.cmi
+
+as3code.cmo: as3.cmi
+
+as3code.cmx: as3.cmi
+
+as3hl.cmi: as3.cmi
+
+as3hlparse.cmo: as3parse.cmo as3hl.cmi as3code.cmo as3.cmi
+
+as3hlparse.cmx: as3parse.cmx as3hl.cmi as3code.cmx as3.cmi
+
+as3parse.cmo: as3code.cmo as3.cmi
+
+as3parse.cmx: as3code.cmx as3.cmi
+
+png.cmo: png.cmi
+
+png.cmx: png.cmi
+
+swf.cmo: as3.cmi
+
+swf.cmx: as3.cmi
+
+swfParser.cmo: swf.cmo as3parse.cmo actionScript.cmo
+
+swfParser.cmx: swf.cmx as3parse.cmx actionScript.cmx
+
+swfPic.cmx: swf.cmx png.cmi
+
+clean:
+	rm -f swflib.cmxa swflib.cma swflib.lib swflib.a as3.cmi as3hl.cmi
+	rm -f $(MODULES) $(MODULES:.cmx=.obj) $(MODULES:.cmx=.cmi) $(MODULES:.cmx=.o) $(MODULES:.cmx=.cmo)
+
+# SUFFIXES
+.ml.cmo:
+	ocamlfind $(OCAMLC) $(ALL_CFLAGS) -c $<
+
+.ml.cmx:
+	ocamlfind $(OCAMLOPT) $(ALL_CFLAGS) -c $<
+
+.mli.cmi:
+	ocamlfind $(OCAMLC) $(ALL_CFLAGS) $<
+
+.mll.ml:
+	ocamlfind ocamllex $<
+
+.mly.ml:
+	ocamlfind ocamlyacc $<
+
+.PHONY: all bytecode native clean
+
+Makefile: ;
+$(SRC): ;

libs/swflib/actionScript.ml

@@ -0,0 +1,679 @@
+(*
+ *  This file is part of SwfLib
+ *  Copyright (c)2004 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+open Swf
+open IO
+open Printf
+
+let push_item_length = function
+	| PString s -> String.length s + 1
+	| PFloat _ -> 4
+	| PNull -> 0
+	| PUndefined -> 0
+	| PReg _ -> 1
+	| PBool _ -> 1
+	| PDouble _ -> 8
+	| PInt _ -> 4
+	| PStack _ -> 1
+	| PStack2 _ -> 2
+
+let push_item_id = function
+	| PString s -> 0
+	| PFloat _ -> 1
+	| PNull -> 2
+	| PUndefined -> 3
+	| PReg _ -> 4
+	| PBool _ -> 5
+	| PDouble _ -> 6
+	| PInt _ -> 7
+	| PStack _ -> 8
+	| PStack2 _ -> 9
+
+
+let opcodes = Hashtbl.create 0
+let opcodes_rev = Hashtbl.create 0
+let opcodes_names = Hashtbl.create 0
+
+let ( => ) code (op,name) =
+	Hashtbl.add opcodes op code;
+	Hashtbl.add opcodes_rev code op;
+	Hashtbl.add opcodes_names op name
+
+let short_op_codes = begin
+	0x00 => (AEnd,"END");
+	0x04 => (ANextFrame,"NEXTFRAME");
+	0x05 => (APrevFrame,"PREVFRAME");
+	0x06 => (APlay,"PLAY");
+	0x07 => (AStop,"STOP");
+	0x08 => (AToggleHighQuality,"TGLHIGHQULTY");
+	0x09 => (AStopSounds,"STOPSOUNDS");
+	0x0A => (AAddNum,"ADDNUM");
+	0x0B => (ASubtract,"SUB");
+	0x0C => (AMultiply,"MULT");
+	0x0D => (ADivide,"DIV");
+	0x0E => (ACompareNum,"CMP");
+	0x0F => (AEqualNum,"EQNUM");
+	0x10 => (ALogicalAnd,"LAND");
+	0x11 => (ALogicalOr,"LOR");
+	0x12 => (ANot,"NOT");
+	0x13 => (AStringEqual,"STREQ");
+	0x14 => (AStringLength,"STRLEN");
+	0x15 => (ASubString,"SUBSTR");
+	0x17 => (APop,"POP");
+	0x18 => (AToInt,"TOINT");
+	0x1C => (AEval,"EVAL");
+	0x1D => (ASet,"SET");
+	0x20 => (ATellTarget,"TELLTARGET");
+	0x21 => (AStringAdd,"STRADD");
+	0x22 => (AGetProperty,"GETPROP");
+	0x23 => (ASetProperty,"SETPROP");
+	0x24 => (ADuplicateMC,"DUPLICATEMC");
+	0x25 => (ARemoveMC,"REMOVEMC");
+	0x26 => (ATrace,"TRACE");
+	0x27 => (AStartDrag,"STARTDRAG");
+	0x28 => (AStopDrag,"STOPDRAG");
+	0x2A => (AThrow,"THROW");
+	0x2B => (ACast,"CAST");
+	0x2C => (AImplements,"IMPLEMENTS");
+	0x2D => (AFSCommand2,"FSCOMMAND2");
+	0x30 => (ARandom,"RANDOM");
+	0x31 => (AMBStringLength,"MBSTRLEN");
+	0x32 => (AOrd,"ORD");
+	0x33 => (AChr,"CHR");
+	0x34 => (AGetTimer,"GETTIMER");
+	0x35 => (AMBStringSub,"MBSTRSUB");
+	0x36 => (AMBOrd,"MBORD");
+	0x37 => (AMBChr,"MBCHR");
+	0x3A => (ADeleteObj,"DELETEOBJ");
+	0x3B => (ADelete,"DELETE");
+	0x3C => (ALocalAssign,"VARSET");
+	0x3D => (ACall,"CALL");
+	0x3E => (AReturn,"RET");
+	0x3F => (AMod,"MOD");
+	0x40 => (ANew,"NEW");
+	0x41 => (ALocalVar,"VAR");
+	0x42 => (AInitArray,"ARRAY");
+	0x43 => (AObject,"OBJECT");
+	0x44 => (ATypeOf,"TYPEOF");
+	0x45 => (ATargetPath,"TARGETPATH");
+	0x46 => (AEnum,"ENUM");
+	0x47 => (AAdd,"ADD");
+	0x48 => (ACompare,"CMP");
+	0x49 => (AEqual,"EQ");
+	0x4A => (AToNumber,"TONUMBER");
+	0x4B => (AToString,"TOSTRING");
+	0x4C => (ADup,"DUP");
+	0x4D => (ASwap,"SWAP");
+	0x4E => (AObjGet,"OBJGET");
+	0x4F => (AObjSet,"OBJSET");
+	0x50 => (AIncrement,"INCR");
+	0x51 => (ADecrement,"DECR");
+	0x52 => (AObjCall,"OBJCALL");
+	0x53 => (ANewMethod,"NEWMETHOD");
+	0x54 => (AInstanceOf,"INSTANCEOF");
+	0x55 => (AEnum2,"ENUM2");
+	0x60 => (AAnd,"AND");
+	0x61 => (AOr,"OR");
+	0x62 => (AXor,"XOR");
+	0x63 => (AShl,"SHL");
+	0x64 => (AShr,"SHR");
+	0x65 => (AAsr,"ASR");
+	0x66 => (APhysEqual,"PHYSEQ");
+	0x67 => (AGreater,"GT");
+	0x68 => (AStringGreater,"STRGT");
+	0x69 => (AExtends,"EXTENDS");
+	0x9E => (ACallFrame,"CALLFRAME"); (* special case *)
+
+end
+
+let action_id = function
+	| AGotoFrame _ -> 0x81
+	| AGetURL _ -> 0x83
+	| ASetReg _ -> 0x87
+	| AStringPool _ -> 0x88
+	| AWaitForFrame _ -> 0x8A
+	| ASetTarget _ -> 0x8B
+	| AGotoLabel _ -> 0x8C
+	| AWaitForFrame2 _ -> 0x8D
+	| AFunction2 _ -> 0x8E
+	| ATry _ -> 0x8F
+	| AWith _ -> 0x94
+	| APush _ -> 0x96
+	| AJump _ -> 0x99
+	| AGetURL2 _ -> 0x9A
+	| AFunction _ -> 0x9B
+	| ACondJump _ -> 0x9D
+	| AGotoFrame2 _ -> 0x9F
+	| AUnknown (id,_) -> id
+
+	| op ->
+		try
+			Hashtbl.find opcodes op
+		with
+			Not_found -> error "Unknown opcode id"
+
+let action_data_length = function
+	| AGotoFrame _ ->
+		2
+	| AGetURL (url,target) ->
+		2 + String.length url + String.length target
+	| ASetReg _ ->
+		1
+	| AStringPool strs ->
+		List.fold_left (fun acc item -> acc + 1 + String.length item) 2 strs
+	| AWaitForFrame _ ->
+		3
+	| AFunction2 f ->
+		let base = String.length f.f2_name + 1 + 2 + 1 + 2 + 2 in
+		List.fold_left (fun acc (_,s) -> acc + 2 + String.length s) base f.f2_args
+	| ASetTarget target ->
+		String.length target + 1
+	| AGotoLabel label ->
+		String.length label + 1
+	| AWaitForFrame2 _ ->
+		1
+	| ATry t ->
+		1 + 6 + (match t.tr_style with TryVariable n -> String.length n + 1 | TryRegister _ -> 1)
+	| AWith _ ->
+		2 (* the string does not count in length *)
+	| APush items ->
+		List.fold_left (fun acc item -> acc + 1 + push_item_length item) 0 items
+	| AJump _ ->
+		2
+	| AGetURL2 _ ->
+		1
+	| AFunction f ->
+		List.fold_left (fun acc s -> acc + 1 + String.length s) 4 (f.f_name :: f.f_args)
+	| ACondJump _ ->
+		2
+	| AGotoFrame2 (_,id) ->
+		1 + (if id = None then 0 else 2)
+	| AUnknown (_,data) ->
+		String.length data
+	| _ ->
+		0
+
+let action_length a =
+	let len = (if action_id a >= 0x80 then 3 else 1) in
+	len + action_data_length a
+
+let actions_length acts =
+	DynArray.fold_left (fun acc a -> acc + action_length a) (action_length AEnd) acts
+
+let read_mm_double ch =
+	let i1 = Int64.of_int32 (read_real_i32 ch) in
+	let i2 = Int64.of_int32 (read_real_i32 ch) in
+	let i2 = (if i2 < Int64.zero then Int64.add i2 (Int64.shift_left Int64.one 32) else i2) in
+	Int64.float_of_bits (Int64.logor i2 (Int64.shift_left i1 32))
+
+let write_mm_double ch f =
+	let i64 = Int64.bits_of_float f in
+	write_real_i32 ch (Int64.to_int32 (Int64.shift_right_logical i64 32));
+	write_real_i32 ch (Int64.to_int32 i64)
+
+let read_string_max ch len =
+	let b = Buffer.create 0 in
+	let rec loop l =
+		if l = 0 then begin
+			let s = Buffer.contents b in
+			String.sub s 0 (String.length s - 1)
+		end else
+			let c = read ch in
+			if c = '\000' then
+				Buffer.contents b
+			else begin
+				Buffer.add_char b c;
+				loop (l - 1)
+			end;
+	in
+	loop len
+
+let parse_push_item ch len =
+	let id = read_byte ch in
+	match id with
+	| 0 -> PString (read_string_max ch len)
+	| 1 -> PFloat (read_real_i32 ch)
+	| 2 -> PNull
+	| 3 -> PUndefined
+	| 4 -> PReg (read_byte ch)
+	| 5 -> PBool (read_byte ch <> 0)
+	| 6 -> PDouble (read_mm_double ch)
+	| 7 -> PInt (read_real_i32 ch)
+	| 8 -> PStack (read_byte ch)
+	| 9 -> PStack2 (read_ui16 ch)
+	| _ -> error (sprintf "Unknown PUSH item id : %d" id)
+
+let rec parse_push_items ch len =
+	if len < 0 then error "PUSH parse overflow";
+	if len = 0 then
+		 []
+	else
+		let item = parse_push_item ch len in
+		item :: parse_push_items ch (len - 1 - push_item_length item)
+
+let rec read_strings ch n =
+	if n = 0 then
+		[]
+	else
+		let s = read_string ch in
+		s :: read_strings ch (n-1)
+
+let parse_function_decl ch =
+	let name = read_string ch in
+	let nargs = read_ui16 ch in
+	let args = read_strings ch nargs in
+	let clen = read_ui16 ch in
+	{
+		f_name = name;
+		f_args = args;
+		f_codelen = clen;
+	}
+
+let parse_f2_flags n =
+	let flags = ref [] in
+	let v = ref 1 in
+	let add_flag f =
+		if n land !v <> 0 then flags := f :: !flags;
+		v := !v lsl 1
+	in
+	List.iter add_flag
+		[ThisRegister; ThisNoVar; ArgumentsRegister; ArgumentsNoVar; SuperRegister;
+		 SuperNoVar; RootRegister; ParentRegister; GlobalRegister];
+	!flags
+
+let parse_function_decl2 ch =
+	let name = read_string ch in
+	let nargs = read_ui16 ch in
+	let nregs = read_byte ch in
+	let flags = parse_f2_flags (read_ui16 ch) in
+	let rec loop n =
+		if n = 0 then
+			[]
+		else
+			let r = read_byte ch in
+			let s = read_string ch in
+			(r,s) :: loop (n-1)
+	in
+	let args = loop nargs in
+	let clen = read_ui16 ch in
+	{
+		f2_name = name;
+		f2_args = args;
+		f2_flags = flags;
+		f2_codelen = clen;
+		f2_nregs = nregs;
+	}
+
+
+let parse_action ch =
+	let id = read_byte ch in
+	let len = (if id >= 0x80 then read_ui16 ch else 0) in
+	let len = (if len = 0xFFFF then 0 else len) in
+	let act =
+		(match id with
+		| 0x81 ->
+			AGotoFrame (read_ui16 ch)
+		| 0x83 ->
+			let url = read_string ch in
+			let target = read_string ch in
+			AGetURL (url,target)
+		| 0x87 ->
+			ASetReg (read_byte ch)
+		| 0x88 ->
+			let nstrs = read_ui16 ch in
+			AStringPool (read_strings ch nstrs)
+		| 0x8A ->
+			let frame = read_ui16 ch in
+			let skip = read_byte ch in
+			AWaitForFrame (frame,skip)
+		| 0x8B ->
+			ASetTarget (read_string ch)
+		| 0x8C ->
+			AGotoLabel (read_string ch)
+		| 0x8D ->
+			AWaitForFrame2 (read_byte ch)
+		| 0x8E ->
+			AFunction2 (parse_function_decl2 ch)
+		| 0x8F ->
+			let flags = read_byte ch in
+			let tsize = read_ui16 ch in
+			let csize = read_ui16 ch in
+			let fsize = read_ui16 ch in
+			let tstyle = (if flags land 4 == 0 then TryVariable (read_string ch) else TryRegister (read_byte ch)) in
+			ATry {
+				tr_style = tstyle;
+				tr_trylen = tsize;
+				tr_catchlen = (if flags land 1 == 0 then None else Some csize);
+				tr_finallylen = (if flags land 2 == 0 then None else Some fsize);
+			}
+		| 0x94 ->
+			let size = read_ui16 ch in
+			AWith size
+		| 0x96 ->
+			APush (parse_push_items ch len)
+		| 0x99 ->
+			AJump (read_i16 ch)
+		| 0x9A ->
+			AGetURL2 (read_byte ch)
+		| 0x9B ->
+			AFunction (parse_function_decl ch)
+		| 0x9D ->
+			ACondJump (read_i16 ch)
+		| 0x9E ->
+			ACallFrame
+		| 0x9F ->
+			let flags = read_byte ch in
+			let play = flags land 1 <> 0 in
+			let delta = (if flags land 2 == 0 then None else Some (read_ui16 ch)) in
+			AGotoFrame2 (play,delta)
+		| _ ->
+			try
+				Hashtbl.find opcodes_rev id
+			with
+				Not_found ->
+					printf "Unknown Action 0x%.2X (%d)\n" id len;
+					AUnknown (id,nread_string ch len)
+	) in
+(*	let len2 = action_data_length act in
+	if len <> len2 then error (sprintf "Datalen mismatch for action 0x%.2X (%d != %d)" id len len2);
+*)	act
+
+let size_to_jump_index acts curindex size =
+	let delta = ref 0 in
+	let size = ref size in
+	if !size >= 0 then begin
+		while !size > 0 do
+			incr delta;
+			size := !size - action_length (DynArray.get acts (curindex + !delta));
+			if !size < 0 then error "Unaligned code";
+		done;
+	end else begin
+		while !size < 0 do
+			size := !size + action_length (DynArray.get acts (curindex + !delta));
+			if !size > 0 then error "Unaligned code";
+			decr delta;
+		done;
+	end;
+	!delta
+
+let parse_actions ch =
+	let acts = DynArray.create() in
+	let rec loop() =
+		match parse_action ch with
+		| AEnd -> ()
+		| AUnknown (0xFF,"") ->
+			DynArray.add acts APlay;
+			DynArray.add acts APlay;
+			DynArray.add acts APlay;
+			loop()
+		| a ->
+			DynArray.add acts a;
+			loop();
+	in
+	loop();
+	(* process jump indexes *)
+	let process_jump curindex = function
+		| AJump size ->
+			let index = size_to_jump_index acts curindex size in
+			DynArray.set acts curindex (AJump index)
+		| ACondJump size ->
+			let index = size_to_jump_index acts curindex size in
+			DynArray.set acts curindex (ACondJump index)
+		| AFunction f ->
+			let index = size_to_jump_index acts curindex f.f_codelen in
+			DynArray.set acts curindex (AFunction { f with f_codelen = index })
+		| AFunction2 f ->
+			let index = size_to_jump_index acts curindex f.f2_codelen in
+			DynArray.set acts curindex (AFunction2 { f with f2_codelen = index })
+		| AWith size ->
+			let index = size_to_jump_index acts curindex size in
+			DynArray.set acts curindex (AWith index)
+		| ATry t ->
+			let tindex = size_to_jump_index acts curindex t.tr_trylen in
+			let cindex = (match t.tr_catchlen with None -> None | Some size -> Some (size_to_jump_index acts (curindex + tindex) size)) in
+			let findex = (match t.tr_finallylen with None -> None | Some size -> Some (size_to_jump_index acts (curindex + tindex + (match cindex with None -> 0 | Some i -> i)) size)) in
+			DynArray.set acts curindex (ATry { t with tr_trylen = tindex; tr_catchlen = cindex; tr_finallylen = findex })
+		| _ ->
+			()
+	in
+	DynArray.iteri process_jump acts;
+	acts
+
+let jump_index_to_size acts curindex target =
+	let size = ref 0 in
+	if target >= 0 then begin
+		for i = 1 to target do
+			size := !size + action_length (DynArray.get acts (curindex + i));
+		done;
+	end else begin
+		for i = 0 downto target+1 do
+			size := !size - action_length (DynArray.get acts (curindex + i));
+		done;
+	end;
+	!size
+
+let rec write_strings ch = function
+	| [] -> ()
+	| s :: l ->
+		write_string ch s;
+		write_strings ch l
+
+let write_push_item_data ch = function
+	| PString s -> write_string ch s
+	| PFloat f -> write_real_i32 ch f
+	| PNull -> ()
+	| PUndefined -> ()
+	| PReg r -> write_byte ch r
+	| PBool b -> write_byte ch (if b then 1 else 0)
+	| PDouble f -> write_mm_double ch f
+	| PInt n -> write_real_i32 ch n
+	| PStack index -> write_byte ch index
+	| PStack2 index -> write_ui16 ch index
+
+let f2_flags_value flags =
+	let fval = function
+		| ThisRegister -> 1
+		| ThisNoVar -> 2
+		| ArgumentsRegister -> 4
+		| ArgumentsNoVar -> 8
+		| SuperRegister -> 16
+		| SuperNoVar -> 32
+		| RootRegister -> 64
+		| ParentRegister -> 128
+		| GlobalRegister -> 256
+	in
+	List.fold_left (fun n f -> n lor (fval f)) 0 flags
+
+let write_action_data acts curindex ch = function
+	| AGotoFrame frame ->
+		write_ui16 ch frame
+	| AGetURL (url,target) ->
+		write_string ch url;
+		write_string ch target
+	| ASetReg reg ->
+		write_byte ch reg
+	| AStringPool strs ->
+		write_ui16 ch (List.length strs);
+		write_strings ch strs
+	| AWaitForFrame (frame,skip) ->
+		write_ui16 ch frame;
+		write_byte ch skip
+	| ASetTarget target ->
+		write_string ch target
+	| AGotoLabel label ->
+		write_string ch label
+	| AWaitForFrame2 n ->
+		write_byte ch n
+	| AFunction2 f ->
+		write_string ch f.f2_name;
+		write_ui16 ch (List.length f.f2_args);
+		write_byte ch f.f2_nregs;
+		write_ui16 ch (f2_flags_value f.f2_flags);
+		List.iter (fun (r,s) ->
+			write_byte ch r;
+			write_string ch s;
+		) f.f2_args;
+		let size = jump_index_to_size acts curindex f.f2_codelen in
+		write_ui16 ch size;
+	| ATry t ->
+		let tsize = jump_index_to_size acts curindex t.tr_trylen in
+		let csize = (match t.tr_catchlen with None -> 0 | Some idx -> jump_index_to_size acts (curindex + t.tr_trylen) idx) in
+		let fsize = (match t.tr_finallylen with None -> 0 | Some idx -> jump_index_to_size acts (curindex + t.tr_trylen + (match t.tr_catchlen with None -> 0 | Some n -> n)) idx) in
+		let flags = (if t.tr_catchlen <> None then 1 else 0) lor (if t.tr_finallylen <> None then 2 else 0) lor (match t.tr_style with TryRegister _ -> 4 | TryVariable _ -> 0) in
+		write_byte ch flags;
+		write_ui16 ch tsize;
+		write_ui16 ch csize;
+		write_ui16 ch fsize;
+		(match t.tr_style with
+		| TryVariable v -> write_string ch v
+		| TryRegister r -> write_byte ch r)
+	| AWith target ->
+		let size = jump_index_to_size acts curindex target in
+		write_ui16 ch size
+	| APush items ->
+		List.iter (fun item ->
+			write_byte ch (push_item_id item);
+			write_push_item_data ch item
+		) items
+	| AJump target ->
+		let size = jump_index_to_size acts curindex target in
+		write_i16 ch size
+	| AGetURL2 n ->
+		write_byte ch n
+	| AFunction f ->
+		write_string ch f.f_name;
+		write_ui16 ch (List.length f.f_args);
+		write_strings ch f.f_args;
+		let size = jump_index_to_size acts curindex f.f_codelen in
+		write_ui16 ch size;
+	| ACondJump target ->
+		let size = jump_index_to_size acts curindex target in
+		write_i16 ch size;
+	| AGotoFrame2 (play,None) ->
+		write_byte ch (if play then 1 else 0)
+	| AGotoFrame2 (play,Some delta) ->
+		write_byte ch (if play then 3 else 2);
+		write_ui16 ch delta;
+	| ACallFrame ->
+		()
+	| AUnknown (_,data) ->
+		nwrite_string ch data
+	| _ ->
+		assert false
+
+let write_action acts curindex ch a =
+	let id = action_id a in
+	let len = action_data_length a in
+	if id < 0x80 && len > 0 then error "Invalid Action Written";
+	write_byte ch id;
+	if len > 0 || id >= 0x80 then begin
+		write_ui16 ch len;
+		write_action_data acts curindex ch a;
+	end
+
+let write_actions ch acts =
+	DynArray.iteri (fun index act -> write_action acts index ch act) acts;
+	write_action acts (DynArray.length acts) ch AEnd
+
+let sprintf = Printf.sprintf
+
+let action_string get_ident pos = function
+	| AGotoFrame n -> sprintf "GOTOFRAME %d" n
+	| AGetURL (a,b) -> sprintf "GETURL '%s' '%s'" a b
+	| ASetReg n -> sprintf "SETREG %d" n
+	| AStringPool strlist ->
+		let b = Buffer.create 0 in
+		Buffer.add_string b "STRINGS ";
+		let p = ref 0 in
+		List.iter (fun s ->
+			Buffer.add_string b (string_of_int !p);
+			incr p;
+			Buffer.add_char b ':';
+			Buffer.add_string b s;
+			Buffer.add_char b ' ';
+		) strlist;
+		Buffer.contents b
+	| AWaitForFrame (i,j) -> sprintf "WAITFORFRAME %d %d" i j
+	| ASetTarget s -> sprintf "SETTARGET %s" s
+	| AGotoLabel s -> sprintf "GOTOLABEL %s" s
+	| AWaitForFrame2 n -> sprintf "WAITFORFRAME2 %d" n
+	| AFunction2 f ->
+		let b = Buffer.create 0 in
+		Buffer.add_string b "FUNCTION2 ";
+		Buffer.add_string b f.f2_name;
+		Buffer.add_char b '(';
+		Buffer.add_string b (String.concat "," (List.map (fun (n,str) -> sprintf "%d:%s" n str) f.f2_args));
+		Buffer.add_char b ')';
+		Buffer.add_string b (sprintf " nregs:%d flags:%d " f.f2_nregs (f2_flags_value f.f2_flags));
+		Buffer.add_string b (sprintf "0x%.4X" (pos + 1 + f.f2_codelen));
+		Buffer.contents b
+	| APush pl ->
+		let b = Buffer.create 0 in
+		Buffer.add_string b "PUSH";
+		List.iter (fun it ->
+			Buffer.add_char b ' ';
+			match it with
+			| PString s ->
+				Buffer.add_char b '"';
+				Buffer.add_string b s;
+				Buffer.add_char b '"'
+			| PFloat _ ->
+				Buffer.add_string b "<float>"
+			| PNull ->
+				Buffer.add_string b "null"
+			| PUndefined ->
+				Buffer.add_string b "undefined"
+			| PReg n ->
+				Buffer.add_string b (sprintf "reg:%d" n)
+			| PBool fl ->
+				Buffer.add_string b (if fl then "true" else "false")
+			| PDouble _ ->
+				Buffer.add_string b "<double>"
+			| PInt i ->
+				Buffer.add_string b (Int32.to_string i)
+			| PStack n
+			| PStack2 n ->
+				Buffer.add_char b '[';
+				Buffer.add_string b (string_of_int n);
+				Buffer.add_char b ':';
+				Buffer.add_string b (get_ident n);
+				Buffer.add_char b ']';
+		) pl;
+		Buffer.contents b
+	| ATry _ -> sprintf "TRY"
+	| AWith n -> sprintf "WITH %d" n
+	| AJump n -> sprintf "JUMP 0x%.4X" (n + pos + 1)
+	| AGetURL2 n -> sprintf "GETURL2 %d" n
+	| AFunction f ->
+		let b = Buffer.create 0 in
+		Buffer.add_string b "FUNCTION ";
+		Buffer.add_string b f.f_name;
+		Buffer.add_char b '(';
+		Buffer.add_string b (String.concat "," f.f_args);
+		Buffer.add_char b ')';
+		Buffer.add_string b (sprintf " 0x%.4X" (pos + 1 + f.f_codelen));
+		Buffer.contents b
+	| ACondJump n -> sprintf "CJMP 0x%.4X" (n + pos + 1)
+	| AGotoFrame2 (b,None) -> sprintf "GOTOFRAME2 %b" b
+	| AGotoFrame2 (b,Some i) -> sprintf "GOTOFRAME2 %b %d" b i
+	| AUnknown (tag,_) -> sprintf "??? 0x%.2X" tag
+	| op ->
+		try
+			Hashtbl.find opcodes_names op
+		with
+			Not_found -> assert false

libs/swflib/as3.mli

@@ -0,0 +1,330 @@
+(*
+ *  This file is part of SwfLib
+ *  Copyright (c)2004-2006 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+
+type 'a index
+type 'a index_nz
+
+type as3_ident = string
+type as3_int = int32
+type as3_uint = int32
+type as3_float = float
+type as3_slot = int
+
+type reg = int
+type nargs = int
+
+type as3_jump =
+	| J3NotLt
+	| J3NotLte
+	| J3NotGt
+	| J3NotGte
+	| J3Always
+	| J3True
+	| J3False
+	| J3Eq
+	| J3Neq
+	| J3Lt
+	| J3Lte
+	| J3Gt
+	| J3Gte
+	| J3PhysEq
+	| J3PhysNeq
+
+type as3_op =
+	| A3OAs
+	| A3ONeg
+	| A3OIncr
+	| A3ODecr
+	| A3ONot
+	| A3OBitNot
+	| A3OAdd
+	| A3OSub
+	| A3OMul
+	| A3ODiv
+	| A3OMod
+	| A3OShl
+	| A3OShr
+	| A3OUShr
+	| A3OAnd
+	| A3OOr
+	| A3OXor
+	| A3OEq
+	| A3OPhysEq
+	| A3OLt
+	| A3OLte
+	| A3OGt
+	| A3OGte
+	| A3OIs
+	| A3OIn
+	| A3OIIncr
+	| A3OIDecr
+	| A3OINeg
+	| A3OIAdd
+	| A3OISub
+	| A3OIMul
+	| A3OMemSet8
+	| A3OMemSet16
+	| A3OMemSet32
+	| A3OMemSetFloat
+	| A3OMemSetDouble
+	| A3OMemGet8
+	| A3OMemGet16
+	| A3OMemGet32
+	| A3OMemGetFloat
+	| A3OMemGetDouble
+	| A3OSign1
+	| A3OSign8
+	| A3OSign16
+
+type as3_name = as3_multi_name index
+
+and as3_opcode =
+	| A3BreakPoint
+	| A3Nop
+	| A3Throw
+	| A3GetSuper of as3_name
+	| A3SetSuper of as3_name
+	| A3DxNs of as3_ident index
+	| A3DxNsLate
+	| A3RegKill of reg
+	| A3Label
+	| A3Jump of as3_jump * int
+	| A3Switch of int * int list
+	| A3PushWith
+	| A3PopScope
+	| A3ForIn
+	| A3HasNext
+	| A3Null
+	| A3Undefined
+	| A3ForEach
+	| A3SmallInt of int
+	| A3Int of int
+	| A3True
+	| A3False
+	| A3NaN
+	| A3Pop
+	| A3Dup
+	| A3Swap
+	| A3String of as3_ident index
+	| A3IntRef of as3_int index
+	| A3UIntRef of as3_uint index
+	| A3Float of as3_float index
+	| A3Scope
+	| A3Namespace of as3_namespace index
+	| A3Next of reg * reg
+	| A3Function of as3_method_type index_nz
+	| A3CallStack of nargs
+	| A3Construct of nargs
+	| A3CallMethod of as3_slot * nargs
+	| A3CallStatic of as3_method_type index * nargs
+	| A3CallSuper of as3_name * nargs
+	| A3CallProperty of as3_name * nargs
+	| A3RetVoid
+	| A3Ret
+	| A3ConstructSuper of nargs
+	| A3ConstructProperty of as3_name * nargs
+	| A3CallPropLex of as3_name * nargs
+	| A3CallSuperVoid of as3_name * nargs
+	| A3CallPropVoid of as3_name * nargs
+	| A3ApplyType of nargs
+	| A3Object of nargs
+	| A3Array of nargs
+	| A3NewBlock
+	| A3ClassDef of unit index_nz
+	| A3GetDescendants of as3_name
+	| A3Catch of int
+	| A3FindPropStrict of as3_name
+	| A3FindProp of as3_name
+	| A3FindDefinition of as3_name
+	| A3GetLex of as3_name
+	| A3SetProp of as3_name
+	| A3Reg of reg
+	| A3SetReg of reg
+	| A3GetGlobalScope
+	| A3GetScope of int
+	| A3GetProp of as3_name
+	| A3InitProp of as3_name
+	| A3DeleteProp of as3_name
+	| A3GetSlot of as3_slot
+	| A3SetSlot of as3_slot
+	| A3ToString
+	| A3ToXml
+	| A3ToXmlAttr
+	| A3ToInt
+	| A3ToUInt
+	| A3ToNumber
+	| A3ToBool
+	| A3ToObject
+	| A3CheckIsXml
+	| A3Cast of as3_name
+	| A3AsAny
+	| A3AsString
+	| A3AsType of as3_name
+	| A3AsObject
+	| A3IncrReg of reg
+	| A3DecrReg of reg
+	| A3Typeof
+	| A3InstanceOf
+	| A3IsType of as3_name
+	| A3IncrIReg of reg
+	| A3DecrIReg of reg
+	| A3This
+	| A3SetThis
+	| A3DebugReg of as3_ident index * reg * int
+	| A3DebugLine of int
+	| A3DebugFile of as3_ident index
+	| A3BreakPointLine of int
+	| A3Timestamp
+	| A3Op of as3_op
+	| A3Unk of char
+
+and as3_namespace =
+	| A3NPrivate of as3_ident index option
+	| A3NPublic of as3_ident index option
+	| A3NInternal of as3_ident index option
+	| A3NProtected of as3_ident index
+	| A3NNamespace of as3_ident index
+	| A3NExplicit of as3_ident index
+	| A3NStaticProtected of as3_ident index option
+
+and as3_ns_set = as3_namespace index list
+
+and as3_multi_name =
+	| A3MName of as3_ident index * as3_namespace index
+	| A3MMultiName of as3_ident index option * as3_ns_set index
+	| A3MRuntimeName of as3_ident index
+	| A3MRuntimeNameLate
+	| A3MMultiNameLate of as3_ns_set index
+	| A3MAttrib of as3_multi_name
+	| A3MParams of as3_multi_name index * as3_multi_name index list
+	| A3MNSAny of as3_ident index
+	| A3MAny
+
+and as3_value =
+	| A3VNone
+	| A3VNull
+	| A3VBool of bool
+	| A3VString of as3_ident index
+	| A3VInt of as3_int index
+	| A3VUInt of as3_uint index
+	| A3VFloat of as3_float index
+	| A3VNamespace of int * as3_namespace index (* int : kind of namespace *)
+
+and as3_method_type = {
+	mt3_ret : as3_name option;
+	mt3_args : as3_name option list;
+	mt3_native : bool;
+	mt3_var_args : bool;
+	mt3_arguments_defined : bool;
+	mt3_uses_dxns : bool;
+	mt3_new_block : bool;
+	mt3_unused_flag : bool;
+	mt3_debug_name : as3_ident index option;
+	mt3_dparams : as3_value list option;
+	mt3_pnames : as3_ident index option list option;
+}
+
+type as3_method_kind =
+	| MK3Normal
+	| MK3Getter
+	| MK3Setter
+
+type as3_method = {
+	m3_type : as3_method_type index_nz;
+	m3_final : bool;
+	m3_override : bool;
+	m3_kind : as3_method_kind;
+}
+
+type as3_var = {
+	v3_type : as3_name option;
+	v3_value : as3_value;
+	v3_const : bool;
+}
+
+type as3_metadata = {
+	meta3_name : as3_ident index;
+	meta3_data : (as3_ident index option * as3_ident index) array;
+}
+
+type as3_field_kind =
+	| A3FMethod of as3_method
+	| A3FVar of as3_var
+	| A3FClass of as3_class index_nz
+	| A3FFunction of as3_method_type index_nz
+
+and as3_field = {
+	f3_name : as3_name;
+	f3_slot : as3_slot;
+	f3_kind : as3_field_kind;
+	f3_metas : as3_metadata index_nz array option;
+}
+
+and as3_class = {
+	cl3_name : as3_name;
+	cl3_super : as3_name option;
+	cl3_sealed : bool;
+	cl3_final : bool;
+	cl3_interface : bool;
+	cl3_namespace : as3_namespace index option;
+	cl3_implements : as3_name array;
+	cl3_construct : as3_method_type index_nz;
+	cl3_fields : as3_field array;
+}
+
+type as3_static = {
+	st3_method : as3_method_type index_nz;
+	st3_fields : as3_field array;
+}
+
+type as3_try_catch = {
+	tc3_start : int;
+	tc3_end : int;
+	tc3_handle : int;
+	tc3_type : as3_name option;
+	tc3_name : as3_name option;
+}
+
+type as3_function = {
+	fun3_id : as3_method_type index_nz;
+	fun3_stack_size : int;
+	fun3_nregs : int;
+	fun3_init_scope : int;
+	fun3_max_scope : int;
+	fun3_code : as3_opcode MultiArray.t;
+	fun3_trys : as3_try_catch array;
+	fun3_locals : as3_field array;
+}
+
+type as3_tag = {
+	as3_ints : as3_int array;
+	as3_uints : as3_uint array;
+	as3_floats : as3_float array;
+	as3_idents : as3_ident array;
+	as3_namespaces : as3_namespace array;
+	as3_nsets : as3_ns_set array;
+	mutable as3_names : as3_multi_name array;
+	mutable as3_method_types : as3_method_type array;
+	mutable as3_metadatas : as3_metadata array;
+	mutable as3_classes : as3_class array;
+	mutable as3_statics : as3_static array;
+	mutable as3_inits : as3_static array;
+	mutable as3_functions : as3_function array;
+	mutable as3_unknown : string; (* only for partial parsing *)
+}

libs/swflib/as3code.ml

@@ -0,0 +1,914 @@
+(*
+ *  This file is part of SwfLib
+ *  Copyright (c)2004-2006 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+open IO
+open As3
+
+let s = Printf.sprintf
+
+let f_int_length : (int -> int) ref = ref (fun _ -> assert false)
+let f_int_read : (IO.input -> int) ref = ref (fun _ -> assert false)
+let f_int_write : (unit IO.output -> int -> unit) ref = ref (fun _ _ -> assert false)
+
+let int_length i = (!f_int_length) i
+let read_int ch = (!f_int_read) ch
+let write_int (ch : 'a IO.output) i = (!f_int_write) (Obj.magic ch) i
+
+let int_index (x : 'a index) : int = Obj.magic x
+let index_int (x : int) : 'a index = Obj.magic x
+let int_index_nz (x : 'a index_nz) : int = Obj.magic x
+let index_nz_int (x : int) : 'a index_nz = Obj.magic x
+
+let read_index ch = index_int (read_int ch)
+let write_index ch i = write_int ch (int_index i)
+
+let read_index_nz ch = index_nz_int (read_int ch)
+let write_index_nz ch i = write_int ch (int_index_nz i)
+
+let iget (t : 'a array) (i : 'a index) : 'a =
+	t.(Obj.magic i - 1)
+
+let write_signed_byte = write_byte
+
+let max_i24 = 1 lsl 23 - 1
+
+let read_i24 ch =
+	let a = read_byte ch in
+	let b = read_byte ch in
+	let c = read_byte ch in
+	let n = a lor (b lsl 8) lor (c lsl 16) in
+	if c land 128 <> 0 then
+		n - (1 lsl 24)
+	else
+		n
+
+let rec write_i24 ch n =
+	if n < -max_i24 || n > max_i24 then assert false;
+	let n = (if n land (1 lsl 23) <> 0 then n + (1 lsl 24) else n) in
+	write_byte ch n;
+	write_byte ch (n lsr 8);
+	write_byte ch (n lsr 16)
+
+let ops , ops_ids =
+	let h = Hashtbl.create 0 in
+	let h2 = Hashtbl.create 0 in
+	List.iter (fun (o,b) -> Hashtbl.add h b o; Hashtbl.add h2 o b)
+	[
+		A3OAs, 0x87;
+		A3ONeg, 0x90;
+		A3OIncr, 0x91;
+		(* 0x92 : REGINCR *)
+		A3ODecr, 0x93;
+		(* 0x94 : REGDECR *)
+		(* 0x95 : TYPEOF *)
+		A3ONot, 0x96;
+		A3OBitNot, 0x97;
+		A3OAdd, 0xA0;
+		A3OSub, 0xA1;
+		A3OMul, 0xA2;
+		A3ODiv, 0xA3;
+		A3OMod, 0xA4;
+		A3OShl, 0xA5;
+		A3OShr, 0xA6;
+		A3OUShr, 0xA7;
+		A3OAnd, 0xA8;
+		A3OOr, 0xA9;
+		A3OXor, 0xAA;
+		A3OEq, 0xAB;
+		A3OPhysEq, 0xAC;
+		A3OLt, 0xAD;
+		A3OLte, 0xAE;
+		A3OGt, 0xAF;
+		A3OGte, 0xB0;
+		A3OIs, 0xB3;
+		A3OIn, 0xB4;
+		A3OIIncr, 0xC0;
+		A3OIDecr, 0xC1;
+		A3OINeg, 0xC4;
+		A3OIAdd, 0xC5;
+		A3OISub, 0xC6;
+		A3OIMul, 0xC7;
+		A3OMemGet8, 0x35;
+		A3OMemGet16, 0x36;
+		A3OMemGet32, 0x37;
+		A3OMemGetFloat, 0x38;
+		A3OMemGetDouble, 0x39;
+		A3OMemSet8, 0x3A;
+		A3OMemSet16, 0x3B;
+		A3OMemSet32, 0x3C;
+		A3OMemSetFloat, 0x3D;
+		A3OMemSetDouble, 0x3E;
+		A3OSign1, 0x50;
+		A3OSign8, 0x51;
+		A3OSign16, 0x52;
+	];
+	h , h2
+
+let length = function
+	| A3SmallInt _ -> 2
+	| A3Construct n
+	| A3Object n
+	| A3RegKill n
+	| A3Catch n
+	| A3IncrReg n
+	| A3DecrReg n
+	| A3IncrIReg n
+	| A3DecrIReg n
+	| A3Array n
+	| A3Int n
+	| A3CallStack n
+	| A3ConstructSuper n
+	| A3BreakPointLine n
+	| A3ApplyType n
+	| A3DebugLine n ->
+		1 + int_length n
+	| A3GetSlot s
+	| A3SetSlot s ->
+		1 + int_length s
+	| A3ClassDef n ->
+		1 + int_length (int_index_nz n)
+	| A3DxNs f
+	| A3String f
+	| A3DebugFile f ->
+		1 + int_length (int_index f)
+	| A3IntRef f ->
+		1 + int_length (int_index f)
+	| A3UIntRef f ->
+		1 + int_length (int_index f)
+	| A3Float f ->
+		1 + int_length (int_index f)
+	| A3Function f ->
+		1 + int_length (int_index_nz f)
+	| A3Namespace f ->
+		1 + int_length (int_index f)
+	| A3GetProp f
+	| A3InitProp f
+	| A3DeleteProp f
+	| A3FindPropStrict f
+	| A3FindProp f
+	| A3FindDefinition f
+	| A3GetLex f
+	| A3SetProp f
+	| A3Cast f
+	| A3GetSuper f
+	| A3GetDescendants f
+	| A3SetSuper f ->
+		1 + int_length (int_index f)
+	| A3Op _
+	| A3Undefined
+	| A3Null
+	| A3True
+	| A3False
+	| A3NaN
+	| A3RetVoid
+	| A3Ret
+	| A3Pop
+	| A3Dup
+	| A3Swap
+	| A3AsAny
+	| A3ToString
+	| A3ToXml
+	| A3ToXmlAttr
+	| A3ToInt
+	| A3ToUInt
+	| A3ToNumber
+	| A3ToBool
+	| A3ToObject
+	| A3AsString
+	| A3AsObject
+	| A3This
+	| A3Throw
+	| A3Nop
+	| A3Typeof
+	| A3InstanceOf
+	| A3Scope
+	| A3ForIn
+	| A3NewBlock
+	| A3ForEach
+	| A3PopScope
+	| A3CheckIsXml
+	| A3Label
+	| A3BreakPoint
+	| A3PushWith
+	| A3HasNext
+	| A3SetThis
+	| A3Timestamp
+	| A3DxNsLate
+	| A3Unk _ -> 1
+	| A3AsType n | A3IsType n ->
+		1 + int_length (int_index n)
+	| A3DebugReg (name,reg,line) -> 1 + 1 + int_length (int_index name) + 1 + int_length line
+	| A3GetGlobalScope -> 1
+	| A3GetScope n -> 1 + int_length n
+	| A3Reg n | A3SetReg n -> if n >= 1 && n <= 3 then 1 else (1 + int_length n)
+	| A3CallSuper (f,n) | A3CallProperty (f,n) | A3ConstructProperty (f,n) | A3CallPropLex (f,n) | A3CallPropVoid (f,n) | A3CallSuperVoid (f,n) ->
+		1 + int_length n + int_length (int_index f)
+	| A3CallMethod (f,n) ->
+		1 + int_length n + int_length f
+	| A3CallStatic (f,n) ->
+		1 + int_length n + int_length (int_index f)
+	| A3Jump _ -> 4
+	| A3Next (a,b) -> 1 + int_length a + int_length b
+	| A3Switch (_,cases) ->
+		let ncases = List.length cases in
+		1 + 3 + int_length (ncases - 1) + 3 * ncases
+
+let jump ch kind =
+	A3Jump (kind,read_i24 ch)
+
+let opcode ch =
+	let op = (try read_byte ch with IO.No_more_input -> raise Exit) in
+	match op with
+	| 0x01 -> A3BreakPoint
+	| 0x02 -> A3Nop
+	| 0x03 -> A3Throw
+	| 0x04 -> A3GetSuper (read_index ch)
+	| 0x05 -> A3SetSuper (read_index ch)
+	| 0x06 -> A3DxNs (read_index ch)
+	| 0x07 -> A3DxNsLate
+	| 0x08 -> A3RegKill (read_int ch)
+	| 0x09 -> A3Label
+	(* 0x0A -> NONE *)
+	(* 0x0B -> NONE *)
+	| 0x0C -> jump ch J3NotLt
+	| 0x0D -> jump ch J3NotLte
+	| 0x0E -> jump ch J3NotGt
+	| 0x0F -> jump ch J3NotGte
+	| 0x10 -> jump ch J3Always
+	| 0x11 -> jump ch J3True
+	| 0x12 -> jump ch J3False
+	| 0x13 -> jump ch J3Eq
+	| 0x14 -> jump ch J3Neq
+	| 0x15 -> jump ch J3Lt
+	| 0x16 -> jump ch J3Lte
+	| 0x17 -> jump ch J3Gt
+	| 0x18 -> jump ch J3Gte
+	| 0x19 -> jump ch J3PhysEq
+	| 0x1A -> jump ch J3PhysNeq
+	| 0x1B ->
+		let def = read_i24 ch in
+		let rec loop n =
+			if n = 0 then
+				[]
+			else
+				let j = read_i24 ch in
+				j :: loop (n - 1)
+		in
+		let cases = loop (read_int ch + 1) in
+		A3Switch (def,cases)
+	| 0x1C -> A3PushWith
+	| 0x1D -> A3PopScope
+	| 0x1E -> A3ForIn
+	| 0x1F -> A3HasNext
+	| 0x20 -> A3Null
+	| 0x21 -> A3Undefined
+	(* 0x22 -> NONE *)
+	| 0x23 -> A3ForEach
+	| 0x24 -> A3SmallInt (read_signed_byte ch)
+	| 0x25 -> A3Int (read_int ch)
+	| 0x26 -> A3True
+	| 0x27 -> A3False
+	| 0x28 -> A3NaN
+	| 0x29 -> A3Pop
+	| 0x2A -> A3Dup
+	| 0x2B -> A3Swap
+	| 0x2C -> A3String (read_index ch)
+	| 0x2D -> A3IntRef (read_index ch)
+	| 0x2E -> A3UIntRef (read_index ch)
+	| 0x2F -> A3Float (read_index ch)
+	| 0x30 -> A3Scope
+	| 0x31 -> A3Namespace (read_index ch)
+	| 0x32 ->
+		let r1 = read_int ch in
+		let r2 = read_int ch in
+		A3Next (r1,r2)
+	(* 0x33 - 0x3F -> NONE *)
+	| 0x40 -> A3Function (read_index_nz ch)
+	| 0x41 -> A3CallStack (read_int ch)
+	| 0x42 -> A3Construct (read_int ch)
+	| 0x43 ->
+		let id = read_int ch in
+		let nargs = read_int ch in
+		A3CallMethod (id,nargs)
+	| 0x44 ->
+		let id = read_index ch in
+		let nargs = read_int ch in
+		A3CallStatic (id,nargs)
+	| 0x45 ->
+		let id = read_index ch in
+		let nargs = read_int ch in
+		A3CallSuper (id,nargs)
+	| 0x46 ->
+		let id = read_index ch in
+		let nargs = read_int ch in
+		A3CallProperty (id,nargs)
+	| 0x47 -> A3RetVoid
+	| 0x48 -> A3Ret
+	| 0x49 -> A3ConstructSuper (read_int ch)
+	| 0x4A ->
+		let id = read_index ch in
+		let nargs = read_int ch in
+		A3ConstructProperty (id,nargs)
+	(* 0x4B -> NONE *)
+	| 0x4C ->
+		let id = read_index ch in
+		let nargs = read_int ch in
+		A3CallPropLex (id,nargs)
+	(* 0x4D -> NONE *)
+	| 0x4E ->
+		let id = read_index ch in
+		let nargs = read_int ch in
+		A3CallSuperVoid (id,nargs)
+	| 0x4F ->
+		let id = read_index ch in
+		let nargs = read_int ch in
+		A3CallPropVoid (id,nargs)
+	(* 0x50 - 0x52 -> NONE *)
+	| 0x53 -> A3ApplyType (read_int ch)
+	(* 0x54 -> NONE *)
+	| 0x55 -> A3Object (read_int ch)
+	| 0x56 -> A3Array (read_int ch)
+	| 0x57 -> A3NewBlock
+	| 0x58 -> A3ClassDef (read_index_nz ch)
+	| 0x59 -> A3GetDescendants (read_index ch)
+	| 0x5A -> A3Catch (read_int ch)
+	(* 0x5B -> NONE *)
+	(* 0x5C -> NONE *)
+	| 0x5D -> A3FindPropStrict (read_index ch)
+	| 0x5E -> A3FindProp (read_index ch)
+	| 0x5F -> A3FindDefinition (read_index ch)
+	| 0x60 -> A3GetLex (read_index ch)
+	| 0x61 -> A3SetProp (read_index ch)
+	| 0x62 -> A3Reg (read_int ch)
+	| 0x63 -> A3SetReg (read_int ch)
+	| 0x64 -> A3GetGlobalScope
+	| 0x65 -> A3GetScope (IO.read_byte ch)
+	| 0x66 -> A3GetProp (read_index ch)
+	(* 0x67 -> NONE *)
+	| 0x68 -> A3InitProp (read_index ch)
+	(* 0x69 -> NONE *)
+	| 0x6A -> A3DeleteProp (read_index ch)
+	(* 0x6B -> NONE *)
+	| 0x6C -> A3GetSlot (read_int ch)
+	| 0x6D -> A3SetSlot (read_int ch)
+	(* 0x6E -> DEPRECATED getglobalslot *)
+	(* 0x6F -> DEPRECATED setglobalslot *)
+	| 0x70 -> A3ToString
+	| 0x71 -> A3ToXml
+	| 0x72 -> A3ToXmlAttr
+	| 0x73 -> A3ToInt
+	| 0x74 -> A3ToUInt
+	| 0x75 -> A3ToNumber
+	| 0x76 -> A3ToBool
+	| 0x77 -> A3ToObject
+	| 0x78 -> A3CheckIsXml
+	(* 0x79 -> NONE *)
+	| 0x80 -> A3Cast (read_index ch)
+	(* 0x81 -> DEPRECATED asbool *)
+	| 0x82 -> A3AsAny
+	(* 0x83 -> DEPRECATED asint *)
+	(* 0x84 -> DEPRECATED asnumber *)
+	| 0x85 -> A3AsString
+	| 0x86 -> A3AsType (read_index ch)
+	(* 0x87 -> OP *)
+	(* 0x88 -> DEPRECATED asuint *)
+	| 0x89 -> A3AsObject
+	(* 0x8A - 0x8F -> NONE *)
+	(* 0x90 - 0x91 -> OP *)
+	| 0x92 -> A3IncrReg (read_int ch)
+	(* 0x93 -> OP *)
+	| 0x94 -> A3DecrReg (read_int ch)
+	| 0x95 -> A3Typeof
+	(* 0x96 -> OP *)
+	(* 0x97 -> OP *)
+	(* 0x98 - 0x9F -> NONE *)
+	(* 0xA0 - 0xB0 -> OP *)
+	| 0xB1 -> A3InstanceOf
+	| 0xB2 -> A3IsType (read_index ch)
+	(* 0xB3 -> OP *)
+	(* 0xB4 -> OP *)
+	(* 0xB5 - 0xBF -> NONE *)
+	(* 0xC0 -> OP *)
+	(* 0xC1 -> OP *)
+	| 0xC2 -> A3IncrIReg (read_int ch)
+	| 0xC3 -> A3DecrIReg (read_int ch)
+	(* 0xC4 - 0xC7 -> OP *)
+	(* 0xC8 - 0xCF -> NONE *)
+	| 0xD0 -> A3This
+	| 0xD1 -> A3Reg 1
+	| 0xD2 -> A3Reg 2
+	| 0xD3 -> A3Reg 3
+	| 0xD4 -> A3SetThis
+	| 0xD5 -> A3SetReg 1
+	| 0xD6 -> A3SetReg 2
+	| 0xD7 -> A3SetReg 3
+	(* 0xD8 - 0xEE -> NONE *)
+	| 0xEF ->
+		if IO.read_byte ch <> 1 then assert false;
+		let name = read_index ch in
+		let reg = read_byte ch + 1 in
+		let line = read_int ch in
+		A3DebugReg (name,reg,line)
+	| 0xF0 -> A3DebugLine (read_int ch)
+	| 0xF1 -> A3DebugFile (read_index ch)
+	| 0xF2 -> A3BreakPointLine (read_int ch)
+	| 0xF3 -> A3Timestamp
+	(* 0xF4 - 0xFF -> NONE *)
+	| _ ->
+		try
+			A3Op (Hashtbl.find ops op)
+		with Not_found ->
+			Printf.printf "Unknown opcode 0x%.2X\n" op;
+			A3Unk (char_of_int op)
+
+let parse ch len =
+	let data = nread_string ch len in
+	let ch = input_string data in
+	let a = MultiArray.create() in
+	let rec loop() =
+		MultiArray.add a (opcode ch);
+		loop();
+	in
+	(try loop() with Exit -> ());
+	a
+
+let write ch = function
+	| A3BreakPoint ->
+		write_byte ch 0x01
+	| A3Nop ->
+		write_byte ch 0x02
+	| A3Throw ->
+		write_byte ch 0x03
+	| A3GetSuper f ->
+		write_byte ch 0x04;
+		write_index ch f
+	| A3SetSuper f ->
+		write_byte ch 0x05;
+		write_index ch f
+	| A3DxNs i ->
+		write_byte ch 0x06;
+		write_index ch i
+	| A3DxNsLate ->
+		write_byte ch 0x07
+	| A3RegKill n ->
+		write_byte ch 0x08;
+		write_int ch n
+	| A3Label ->
+		write_byte ch 0x09
+	| A3Jump (k,n) ->
+		write_byte ch (match k with
+			| J3NotLt -> 0x0C
+			| J3NotLte -> 0x0D
+			| J3NotGt -> 0x0E
+			| J3NotGte -> 0x0F
+			| J3Always -> 0x10
+			| J3True -> 0x11
+			| J3False -> 0x12
+			| J3Eq -> 0x13
+			| J3Neq -> 0x14
+			| J3Lt -> 0x15
+			| J3Lte -> 0x16
+			| J3Gt -> 0x17
+			| J3Gte -> 0x18
+			| J3PhysEq -> 0x19
+			| J3PhysNeq -> 0x1A
+		);
+		write_i24 ch n
+	| A3Switch (def,cases) ->
+		write_byte ch 0x1B;
+		write_i24 ch def;
+		write_int ch (List.length cases - 1);
+		List.iter (write_i24 ch) cases
+	| A3PushWith ->
+		write_byte ch 0x1C
+	| A3PopScope ->
+		write_byte ch 0x1D
+	| A3ForIn ->
+		write_byte ch 0x1E
+	| A3HasNext ->
+		write_byte ch 0x1F
+	| A3Null ->
+		write_byte ch 0x20
+	| A3Undefined ->
+		write_byte ch 0x21
+	| A3ForEach ->
+		write_byte ch 0x23
+	| A3SmallInt b ->
+		write_byte ch 0x24;
+		write_signed_byte ch b
+	| A3Int i ->
+		write_byte ch 0x25;
+		write_int ch i
+	| A3True ->
+		write_byte ch 0x26
+	| A3False ->
+		write_byte ch 0x27
+	| A3NaN ->
+		write_byte ch 0x28
+	| A3Pop ->
+		write_byte ch 0x29
+	| A3Dup ->
+		write_byte ch 0x2A
+	| A3Swap ->
+		write_byte ch 0x2B
+	| A3String s ->
+		write_byte ch 0x2C;
+		write_index ch s
+	| A3IntRef i ->
+		write_byte ch 0x2D;
+		write_index ch i
+	| A3UIntRef i ->
+		write_byte ch 0x2E;
+		write_index ch i
+	| A3Float f ->
+		write_byte ch 0x2F;
+		write_index ch f
+	| A3Scope ->
+		write_byte ch 0x30
+	| A3Namespace f ->
+		write_byte ch 0x31;
+		write_index ch f
+	| A3Next (r1,r2) ->
+		write_byte ch 0x32;
+		write_int ch r1;
+		write_int ch r2
+	| A3Function f ->
+		write_byte ch 0x40;
+		write_index_nz ch f
+	| A3CallStack n ->
+		write_byte ch 0x41;
+		write_int ch n
+	| A3Construct n ->
+		write_byte ch 0x42;
+		write_int ch n
+	| A3CallMethod (f,n) ->
+		write_byte ch 0x43;
+		write_int ch f;
+		write_int ch n
+	| A3CallStatic (f,n) ->
+		write_byte ch 0x44;
+		write_index ch f;
+		write_int ch n
+	| A3CallSuper (f,n) ->
+		write_byte ch 0x45;
+		write_index ch f;
+		write_int ch n
+	| A3CallProperty (f,n) ->
+		write_byte ch 0x46;
+		write_index ch f;
+		write_int ch n
+	| A3RetVoid ->
+		write_byte ch 0x47
+	| A3Ret ->
+		write_byte ch 0x48
+	| A3ConstructSuper n ->
+		write_byte ch 0x49;
+		write_int ch n
+	| A3ConstructProperty (f,n) ->
+		write_byte ch 0x4A;
+		write_index ch f;
+		write_int ch n
+	| A3CallPropLex (f,n) ->
+		write_byte ch 0x4C;
+		write_index ch f;
+		write_int ch n
+	| A3CallSuperVoid (f,n) ->
+		write_byte ch 0x4E;
+		write_index ch f;
+		write_int ch n
+	| A3CallPropVoid (f,n) ->
+		write_byte ch 0x4F;
+		write_index ch f;
+		write_int ch n
+	| A3ApplyType n ->
+		write_byte ch 0x53;
+		write_int ch n
+	| A3Object n ->
+		write_byte ch 0x55;
+		write_int ch n
+	| A3Array n ->
+		write_byte ch 0x56;
+		write_int ch n
+	| A3NewBlock ->
+		write_byte ch 0x57
+	| A3ClassDef f ->
+		write_byte ch 0x58;
+		write_index_nz ch f
+	| A3GetDescendants f ->
+		write_byte ch 0x59;
+		write_index ch f
+	| A3Catch n ->
+		write_byte ch 0x5A;
+		write_int ch n
+	| A3FindPropStrict f ->
+		write_byte ch 0x5D;
+		write_index ch f
+	| A3FindProp f ->
+		write_byte ch 0x5E;
+		write_index ch f
+	| A3FindDefinition f ->
+		write_byte ch 0x5F;
+		write_index ch f
+	| A3GetLex f ->
+		write_byte ch 0x60;
+		write_index ch f
+	| A3SetProp f ->
+		write_byte ch 0x61;
+		write_index ch f
+	| A3Reg n ->
+		if n >= 0 && n < 4 then
+			write_byte ch (0xD0 + n)
+		else begin
+			write_byte ch 0x62;
+			write_int ch n
+		end
+	| A3SetReg n ->
+		if n >= 0 && n < 4 then
+			write_byte ch (0xD4 + n)
+		else begin
+			write_byte ch 0x63;
+			write_int ch n
+		end
+	| A3GetGlobalScope ->
+		write_byte ch 0x64
+	| A3GetScope n ->
+		write_byte ch 0x65;
+		write_byte ch n
+	| A3GetProp f ->
+		write_byte ch 0x66;
+		write_index ch f
+	| A3InitProp f ->
+		write_byte ch 0x68;
+		write_index ch f
+	| A3DeleteProp f ->
+		write_byte ch 0x6A;
+		write_index ch f
+	| A3GetSlot n ->
+		write_byte ch 0x6C;
+		write_int ch n
+	| A3SetSlot n ->
+		write_byte ch 0x6D;
+		write_int ch n
+	| A3ToString ->
+		write_byte ch 0x70
+	| A3ToXml ->
+		write_byte ch 0x71
+	| A3ToXmlAttr ->
+		write_byte ch 0x72
+	| A3ToInt ->
+		write_byte ch 0x73
+	| A3ToUInt ->
+		write_byte ch 0x74
+	| A3ToNumber ->
+		write_byte ch 0x75
+	| A3ToBool ->
+		write_byte ch 0x76
+	| A3ToObject ->
+		write_byte ch 0x77
+	| A3CheckIsXml ->
+		write_byte ch 0x78
+	| A3Cast f ->
+		write_byte ch 0x80;
+		write_index ch f
+	| A3AsAny ->
+		write_byte ch 0x82
+	| A3AsString ->
+		write_byte ch 0x85
+	| A3AsType n ->
+		write_byte ch 0x86;
+		write_index ch n
+	| A3AsObject ->
+		write_byte ch 0x89
+	| A3IncrReg r ->
+		write_byte ch 0x92;
+		write_int ch r
+	| A3DecrReg r ->
+		write_byte ch 0x94;
+		write_int ch r
+	| A3Typeof ->
+		write_byte ch 0x95
+	| A3InstanceOf ->
+		write_byte ch 0xB1
+	| A3IsType n ->
+		write_byte ch 0xB2;
+		write_index ch n
+	| A3IncrIReg r ->
+		write_byte ch 0xC2;
+		write_int ch r
+	| A3DecrIReg r ->
+		write_byte ch 0xC3;
+		write_int ch r
+	| A3This ->
+		write_byte ch 0xD0
+	| A3SetThis ->
+		write_byte ch 0xD4
+	| A3DebugReg (name,reg,line) ->
+		write_byte ch 0xEF;
+		write_byte ch 0x01;
+		write_index ch name;
+		write_byte ch (reg - 1);
+		write_int ch line;
+	| A3DebugLine f ->
+		write_byte ch 0xF0;
+		write_int ch f;
+	| A3DebugFile f ->
+		write_byte ch 0xF1;
+		write_index ch f;
+	| A3BreakPointLine l ->
+		write_byte ch 0xF2;
+		write_int ch l
+	| A3Timestamp ->
+		write_byte ch 0xF3
+	| A3Op op ->
+		write_byte ch (try Hashtbl.find ops_ids op with Not_found -> assert false)
+	| A3Unk x ->
+		write ch x
+
+let dump_op = function
+	| A3OAs -> "as"
+	| A3ONeg -> "neg"
+	| A3OIncr -> "incr"
+	| A3ODecr -> "decr"
+	| A3ONot -> "not"
+	| A3OBitNot -> "bitnot"
+	| A3OAdd -> "add"
+	| A3OSub -> "sub"
+	| A3OMul -> "mul"
+	| A3ODiv -> "div"
+	| A3OMod -> "mod"
+	| A3OShl -> "shl"
+	| A3OShr -> "shr"
+	| A3OUShr -> "ushr"
+	| A3OAnd -> "and"
+	| A3OOr -> "or"
+	| A3OXor -> "xor"
+	| A3OEq -> "eq"
+	| A3OPhysEq -> "physeq"
+	| A3OLt -> "lt"
+	| A3OLte -> "lte"
+	| A3OGt -> "gt"
+	| A3OGte -> "gte"
+	| A3OIs -> "is"
+	| A3OIn -> "in"
+	| A3OIIncr -> "iincr"
+	| A3OIDecr -> "idecr"
+	| A3OINeg -> "ineg"
+	| A3OIAdd -> "iadd"
+	| A3OISub -> "isub"
+	| A3OIMul -> "imul"
+	| A3OMemSet8 -> "mset8"
+	| A3OMemSet16 -> "set16"
+	| A3OMemSet32 -> "mset32"
+	| A3OMemSetFloat -> "msetfloat"
+	| A3OMemSetDouble -> "msetdouble"
+	| A3OMemGet8 -> "mget8"
+	| A3OMemGet16 -> "mget16"
+	| A3OMemGet32 -> "mget32"
+	| A3OMemGetFloat -> "mgetfloat"
+	| A3OMemGetDouble -> "mgetdouble"
+	| A3OSign1 -> "sign1"
+	| A3OSign8 -> "sign8"
+	| A3OSign16 -> "sign16"
+
+let dump_jump = function
+	| J3NotLt -> "-nlt"
+	| J3NotLte -> "-nlte"
+	| J3NotGt -> "-ngt"
+	| J3NotGte -> "-ngte"
+	| J3Always -> ""
+	| J3True -> "-if"
+	| J3False -> "-ifnot"
+	| J3Eq -> "-eq"
+	| J3Neq -> "-neq"
+	| J3Lt -> "-lt"
+	| J3Lte -> "-lte"
+	| J3Gt -> "-gt"
+	| J3Gte -> "-gte"
+	| J3PhysEq -> "-peq"
+	| J3PhysNeq -> "-pneq"
+
+let dump ctx op =
+	let ident n = ctx.as3_idents.(int_index n - 1) in
+	let rec field n =
+		let t = ctx.as3_names.(int_index n - 1) in
+		match t with
+		| A3MMultiName (Some ident,_) -> "[" ^ iget ctx.as3_idents ident ^ "]"
+		| A3MName (ident,_) -> iget ctx.as3_idents ident
+		| A3MMultiNameLate idx -> "~array"
+		| A3MParams (t,params) -> field t ^ "<" ^ String.concat "." (List.map field params) ^ ">"
+		| _ -> "???"
+	in
+	match op with
+	| A3BreakPoint -> "bkpt"
+	| A3Nop -> "nop"
+	| A3Throw -> "throw"
+	| A3GetSuper f -> s "getsuper %s" (field f)
+	| A3SetSuper f -> s "setsuper %s" (field f)
+	| A3DxNs i -> s "dxns %s" (ident i)
+	| A3DxNsLate -> "dxnslate"
+	| A3RegKill n -> s "kill %d" n
+	| A3Label -> "label"
+	| A3Jump (k,n) -> s "jump%s %d" (dump_jump k) n
+	| A3Switch (def,cases) -> s "switch %d [%s]" def (String.concat "," (List.map (s "%d") cases))
+	| A3PushWith -> "pushwith"
+	| A3PopScope -> "popscope"
+	| A3ForIn -> "forin"
+	| A3HasNext -> "hasnext"
+	| A3Null -> "null"
+	| A3Undefined -> "undefined"
+	| A3ForEach -> "foreach"
+	| A3SmallInt b -> s "int %d" b
+	| A3Int n -> s "int %d" n
+	| A3True -> "true"
+	| A3False -> "false"
+	| A3NaN -> "nan"
+	| A3Pop -> "pop"
+	| A3Dup -> "dup"
+	| A3Swap -> "swap"
+	| A3String n -> s "string [%s]" (ident n)
+	| A3IntRef n -> s "int [%ld]" ctx.as3_ints.(int_index n - 1)
+	| A3UIntRef n -> s "uint [%ld]" ctx.as3_uints.(int_index n - 1)
+	| A3Float n -> s "float [%f]" ctx.as3_floats.(int_index n - 1)
+	| A3Scope -> "scope"
+	| A3Namespace f -> s "namespace [%d]" (int_index f)
+	| A3Next (r1,r2) -> s "next %d %d" r1 r2
+	| A3Function f -> s "function #%d" (int_index_nz f)
+	| A3CallStack n -> s "callstack (%d)" n
+	| A3Construct n -> s "construct (%d)" n
+	| A3CallMethod (f,n) -> s "callmethod %d (%d)" f n
+	| A3CallStatic (f,n) -> s "callstatic %d (%d)" (int_index f) n
+	| A3CallSuper (f,n) -> s "callsuper %s (%d)" (field f) n
+	| A3CallProperty (f,n) -> s "callprop %s (%d)" (field f) n
+	| A3RetVoid -> "retvoid"
+	| A3Ret -> "ret"
+	| A3ConstructSuper n -> s "constructsuper %d" n
+	| A3ConstructProperty (f,n) -> s "constructprop %s (%d)" (field f) n
+	| A3CallPropLex (f,n) -> s "callproplex %s (%d)" (field f) n
+	| A3CallSuperVoid (f,n) -> s "callsupervoid %s (%d)" (field f) n
+	| A3CallPropVoid (f,n) -> s "callpropvoid %s (%d)" (field f) n
+	| A3ApplyType n -> s "applytype %d" n
+	| A3Object n -> s "object %d" n
+	| A3Array n -> s "array %d" n
+	| A3NewBlock -> "newblock"
+	| A3ClassDef n -> s "classdef %d" (int_index_nz n)
+	| A3GetDescendants f -> s "getdescendants %s" (field f)
+	| A3Catch n -> s "catch %d" n
+	| A3FindPropStrict f -> s "findpropstrict %s" (field f)
+	| A3FindProp f -> s "findprop %s" (field f)
+	| A3FindDefinition f -> s "finddefinition %s" (field f)
+	| A3GetLex f -> s "getlex %s" (field f)
+	| A3SetProp f -> s "setprop %s" (field f)
+	| A3Reg n -> s "reg %d" n
+	| A3SetReg n -> s "setreg %d" n
+	| A3GetGlobalScope -> "getglobalscope"
+	| A3GetScope n -> s "getscope %d" n
+	| A3GetProp f -> s "getprop %s" (field f)
+	| A3InitProp f -> s "initprop %s" (field f)
+	| A3DeleteProp f -> s "deleteprop %s" (field f)
+	| A3GetSlot n -> s "getslot %d" n
+	| A3SetSlot n -> s "setslot %d" n
+	| A3ToString -> "tostring"
+	| A3ToXml -> "toxml"
+	| A3ToXmlAttr -> "toxmlattr"
+	| A3ToInt -> "toint"
+	| A3ToUInt -> "touint"
+	| A3ToNumber -> "tonumber"
+	| A3ToBool -> "tobool"
+	| A3ToObject -> "toobject"
+	| A3CheckIsXml -> "checkisxml"
+	| A3Cast f -> s "cast %s" (field f)
+	| A3AsAny -> "asany"
+	| A3AsString -> "asstring"
+	| A3AsType f -> s "astype %s" (field f)
+	| A3AsObject -> "asobject"
+	| A3IncrReg r -> s "incrreg %d" r
+	| A3DecrReg r -> s "decrreg %d" r
+	| A3Typeof -> "typeof"
+	| A3InstanceOf -> "instanceof"
+	| A3IsType f -> s "istype %s" (field f)
+	| A3IncrIReg r -> s "incrireg %d" r
+	| A3DecrIReg r -> s "decrireg %d" r
+	| A3This -> "this"
+	| A3SetThis -> "setthis"
+	| A3DebugReg (name,reg,line) -> s ".reg %d:%s line:%d" reg (ident name) line
+	| A3DebugLine l -> s ".line %d" l
+	| A3DebugFile f -> s ".file %s" (ident f)
+	| A3BreakPointLine l -> s ".bkptline %d" l
+	| A3Timestamp -> ".time"
+	| A3Op o -> dump_op o
+	| A3Unk x -> s "??? 0x%X" (int_of_char x)

libs/swflib/as3hl.mli

@@ -0,0 +1,249 @@
+(*
+ *  This file is part of SwfLib
+ *  Copyright (c)2004-2008 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+open As3
+
+type hl_ident = string
+type hl_int = int32
+type hl_uint = int32
+type hl_float = float
+type hl_slot = int
+type hl_jump = as3_jump
+type hl_op = as3_op
+
+type hl_opcode =
+	| HBreakPoint
+	| HNop
+	| HThrow
+	| HGetSuper of hl_name
+	| HSetSuper of hl_name
+	| HDxNs of hl_ident
+	| HDxNsLate
+	| HRegKill of reg
+	| HLabel
+	| HJump of hl_jump * int
+	| HSwitch of int * int list
+	| HPushWith
+	| HPopScope
+	| HForIn
+	| HHasNext
+	| HNull
+	| HUndefined
+	| HForEach
+	| HSmallInt of int
+	| HInt of int
+	| HTrue
+	| HFalse
+	| HNaN
+	| HPop
+	| HDup
+	| HSwap
+	| HString of hl_ident
+	| HIntRef of hl_int
+	| HUIntRef of hl_uint
+	| HFloat of hl_float
+	| HScope
+	| HNamespace of hl_namespace
+	| HNext of reg * reg
+	| HFunction of hl_method
+	| HCallStack of nargs
+	| HConstruct of nargs
+	| HCallMethod of hl_slot * nargs
+	| HCallStatic of hl_method * nargs
+	| HCallSuper of hl_name * nargs
+	| HCallProperty of hl_name * nargs
+	| HRetVoid
+	| HRet
+	| HConstructSuper of nargs
+	| HConstructProperty of hl_name * nargs
+	| HCallPropLex of hl_name * nargs
+	| HCallSuperVoid of hl_name * nargs
+	| HCallPropVoid of hl_name * nargs
+	| HApplyType of nargs
+	| HObject of nargs
+	| HArray of nargs
+	| HNewBlock
+	| HClassDef of hl_class
+	| HGetDescendants of hl_name
+	| HCatch of int
+	| HFindPropStrict of hl_name
+	| HFindProp of hl_name
+	| HFindDefinition of hl_name
+	| HGetLex of hl_name
+	| HSetProp of hl_name
+	| HReg of reg
+	| HSetReg of reg
+	| HGetGlobalScope
+	| HGetScope of int
+	| HGetProp of hl_name
+	| HInitProp of hl_name
+	| HDeleteProp of hl_name
+	| HGetSlot of hl_slot
+	| HSetSlot of hl_slot
+	| HToString
+	| HToXml
+	| HToXmlAttr
+	| HToInt
+	| HToUInt
+	| HToNumber
+	| HToBool
+	| HToObject
+	| HCheckIsXml
+	| HCast of hl_name
+	| HAsAny
+	| HAsString
+	| HAsType of hl_name
+	| HAsObject
+	| HIncrReg of reg
+	| HDecrReg of reg
+	| HTypeof
+	| HInstanceOf
+	| HIsType of hl_name
+	| HIncrIReg of reg
+	| HDecrIReg of reg
+	| HThis
+	| HSetThis
+	| HDebugReg of hl_ident * reg * int
+	| HDebugLine of int
+	| HDebugFile of hl_ident
+	| HBreakPointLine of int
+	| HTimestamp
+	| HOp of hl_op
+	| HUnk of char
+
+and hl_namespace =
+	| HNPrivate of hl_ident option
+	| HNPublic of hl_ident option
+	| HNInternal of hl_ident option
+	| HNProtected of hl_ident
+	| HNNamespace of hl_ident
+	| HNExplicit of hl_ident
+	| HNStaticProtected of hl_ident option
+
+and hl_ns_set = hl_namespace list
+
+and hl_name =
+	| HMPath of hl_ident list * hl_ident
+	| HMName of hl_ident * hl_namespace
+	| HMMultiName of hl_ident option * hl_ns_set
+	| HMRuntimeName of hl_ident
+	| HMRuntimeNameLate
+	| HMMultiNameLate of hl_ns_set
+	| HMAttrib of hl_name
+	| HMParams of hl_name * hl_name list
+	| HMNSAny of hl_ident
+	| HMAny
+
+and hl_value =
+	| HVNone
+	| HVNull
+	| HVBool of bool
+	| HVString of hl_ident
+	| HVInt of hl_int
+	| HVUInt of hl_uint
+	| HVFloat of hl_float
+	| HVNamespace of int * hl_namespace
+
+and hl_method = {
+	hlmt_index : int; (* used to sort methods (preserve order) *)
+	hlmt_ret : hl_name option;
+	hlmt_args : hl_name option list;
+	hlmt_native : bool;
+	hlmt_var_args : bool;
+	hlmt_arguments_defined : bool;
+	hlmt_uses_dxns : bool;
+	hlmt_new_block : bool;
+	hlmt_unused_flag : bool;
+	hlmt_debug_name : hl_ident option;
+	hlmt_dparams : hl_value list option;
+	hlmt_pnames : hl_ident option list option;
+	mutable hlmt_function : hl_function option; (* None for interfaces constructors only *)
+}
+
+and hl_try_catch = {
+	hltc_start : int;
+	hltc_end : int;
+	hltc_handle : int;
+	hltc_type : hl_name option;
+	hltc_name : hl_name option;
+}
+
+and hl_function = {
+	hlf_stack_size : int;
+	hlf_nregs : int;
+	hlf_init_scope : int;
+	hlf_max_scope : int;
+	mutable hlf_code : hl_opcode MultiArray.t;
+	mutable hlf_trys : hl_try_catch array;
+	hlf_locals : (hl_name * hl_name option * hl_slot * bool) array; (* bool = const - mostly false *)
+}
+
+and hl_method_kind = as3_method_kind
+
+and hl_method_field = {
+	hlm_type : hl_method;
+	hlm_final : bool;
+	hlm_override : bool;
+	hlm_kind : hl_method_kind;
+}
+
+and hl_var_field = {
+	hlv_type : hl_name option;
+	hlv_value : hl_value;
+	hlv_const : bool;
+}
+
+and hl_metadata = {
+	hlmeta_name : hl_ident;
+	hlmeta_data : (hl_ident option * hl_ident) array;
+}
+
+and hl_field_kind =
+	| HFMethod of hl_method_field
+	| HFVar of hl_var_field
+	| HFFunction of hl_method
+	| HFClass of hl_class (* only for hl_static fields *)
+
+and hl_field = {
+	hlf_name : hl_name;
+	hlf_slot : hl_slot;
+	hlf_kind : hl_field_kind;
+	hlf_metas : hl_metadata array option;
+}
+
+and hl_class = {
+	hlc_index : int;
+	hlc_name : hl_name;
+	hlc_super : hl_name option;
+	hlc_sealed : bool;
+	hlc_final : bool;
+	hlc_interface : bool;
+	hlc_namespace : hl_namespace option;
+	hlc_implements : hl_name array;
+	mutable hlc_construct : hl_method;
+	mutable hlc_fields : hl_field array;
+	mutable hlc_static_construct : hl_method;
+	mutable hlc_static_fields : hl_field array;
+}
+
+and hl_static = {
+	hls_method : hl_method;
+	hls_fields : hl_field array;
+}
+
+and hl_tag = hl_static list

libs/swflib/as3hlparse.ml

@@ -0,0 +1,922 @@
+(*
+ *  This file is part of SwfLib
+ *  Copyright (c)2004-2008 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+open As3
+open As3hl
+
+type parse_ctx = {
+	as3 : as3_tag;
+	mutable namespaces : hl_namespace array;
+	mutable nsets : hl_ns_set array;
+	mutable names : hl_name array;
+	mutable methods : hl_method array;
+	mutable classes : hl_class array;
+	mutable jumps : (int * int) list;
+	mutable pos : int;
+	delta_mt : int;
+	delta_cl : int;
+}
+
+let get = As3parse.iget
+let no_nz = As3parse.no_nz
+let idx n = As3parse.index_int n - 1
+
+let ident ctx i = get ctx.as3.as3_idents i
+let name ctx n = ctx.names.(idx n)
+let method_type ctx n = ctx.methods.(idx (no_nz n))
+let getclass ctx n = ctx.classes.(idx (no_nz n))
+
+let opt f ctx = function
+	| None -> None
+	| Some x -> Some (f ctx x)
+
+let stack_delta = function
+	| HBreakPoint -> 0
+	| HNop -> 0
+	| HThrow -> -1
+	| HGetSuper _ -> 0
+	| HSetSuper _ -> -2
+	| HDxNs _ -> 0
+	| HDxNsLate -> -1
+	| HRegKill _ -> 0
+	| HLabel -> 0
+	| HJump (cond,_) ->
+		(match cond with
+		| J3Always -> 0
+		| J3True
+		| J3False -> -1
+		| _ -> -2)
+	| HSwitch _ -> -1
+	| HPushWith -> -1
+	| HPopScope -> 0
+	| HForIn -> -1
+	| HHasNext -> -1
+	| HNull
+	| HUndefined -> 1
+	| HForEach -> -1
+	| HSmallInt _
+	| HInt _
+	| HTrue
+	| HFalse
+	| HString _
+	| HIntRef _
+	| HUIntRef _
+	| HFunction _
+	| HFloat _
+	| HNaN -> 1
+	| HPop -> -1
+	| HDup -> 1
+	| HSwap -> 0
+	| HScope -> -1
+	| HNamespace _ -> 1
+	| HNext _ -> 1
+	| HCallStack n -> -(n + 1)
+	| HConstruct n -> -n
+	| HCallMethod (_,n) -> -n
+	| HCallStatic (_,n) -> -n
+	| HCallSuper (_,n) -> -n
+	| HCallProperty (_,n) -> -n
+	| HRetVoid -> 0
+	| HRet -> -1
+	| HConstructSuper n -> -(n + 1)
+	| HConstructProperty (_,n) -> -n
+	| HCallPropLex (_,n) -> -n
+	| HCallSuperVoid (_,n) -> -(n + 1)
+	| HCallPropVoid (_,n) -> -(n + 1)
+	| HApplyType n -> -n
+	| HObject n -> -(n * 2) + 1
+	| HArray n -> -n + 1
+	| HNewBlock -> 1
+	| HClassDef _ -> 0
+	| HGetDescendants _ -> 0
+	| HCatch _ -> 1
+	| HFindPropStrict _ -> 1
+	| HFindProp _ -> 1
+	| HFindDefinition _ -> 1
+	| HGetLex _ -> 1
+	| HSetProp _ -> -2
+	| HReg _ -> 1
+	| HSetReg _ | HSetThis -> -1
+	| HGetGlobalScope | HGetScope _ -> 1
+	| HGetProp _ -> 0
+	| HInitProp _ -> -2
+	| HDeleteProp _ -> -1 (* true/false *)
+	| HGetSlot _ -> 0
+	| HSetSlot _ -> -2
+	| HToString
+	| HToXml
+	| HToXmlAttr
+	| HToInt
+	| HToUInt
+	| HToNumber
+	| HToObject
+	| HAsAny
+	| HAsType _
+	| HIsType _
+	| HAsObject
+	| HAsString
+	| HToBool -> 0
+	| HCheckIsXml -> 0
+	| HCast _ -> 0
+	| HTypeof -> 0
+	| HInstanceOf -> -1
+	| HIncrReg _ | HDecrReg _ | HIncrIReg _ | HDecrIReg _ -> 0
+	| HThis -> 1
+	| HDebugReg _
+	| HDebugLine _
+	| HBreakPointLine _
+	| HTimestamp
+	| HDebugFile _ -> 0
+	| HOp op ->
+		(match op with
+		| A3ONeg | A3OINeg | A3OIncr | A3ODecr | A3ONot | A3OBitNot | A3OIIncr | A3OIDecr -> 0
+		| A3OMemGet8 | A3OMemGet16 | A3OMemGet32 | A3OMemGetFloat | A3OMemGetDouble | A3OSign1 | A3OSign8 | A3OSign16 -> 0
+		| A3OMemSet8 | A3OMemSet16 | A3OMemSet32 | A3OMemSetFloat | A3OMemSetDouble -> -2
+		| _ -> -1)
+	| HUnk _ -> assert false
+
+let parse_opcode ctx i = function
+	| A3BreakPoint -> HBreakPoint
+	| A3Nop -> HNop
+	| A3Throw -> HThrow
+	| A3GetSuper n -> HGetSuper (name ctx n)
+	| A3SetSuper n -> HSetSuper (name ctx n)
+	| A3DxNs s -> HDxNs (ident ctx s)
+	| A3DxNsLate -> HDxNsLate
+	| A3RegKill r -> HRegKill r
+	| A3Label -> HLabel
+	| A3Jump (j,n) ->
+		ctx.jumps <- (i,ctx.pos) :: ctx.jumps;
+		HJump (j,n)
+	| A3Switch (n,infos) as op ->
+		ctx.jumps <- (i,ctx.pos - As3code.length op) :: ctx.jumps;
+		HSwitch(n,infos)
+	| A3PushWith -> HPushWith
+	| A3PopScope -> HPopScope
+	| A3ForIn -> HForIn
+	| A3HasNext -> HHasNext
+	| A3Null -> HNull
+	| A3Undefined -> HUndefined
+	| A3ForEach -> HForEach
+	| A3SmallInt n -> HSmallInt n
+	| A3Int n -> HInt n
+	| A3True -> HTrue
+	| A3False -> HFalse
+	| A3NaN -> HNaN
+	| A3Pop -> HPop
+	| A3Dup -> HDup
+	| A3Swap -> HSwap
+	| A3String i -> HString (ident ctx i)
+	| A3IntRef i -> HIntRef (get ctx.as3.as3_ints i)
+	| A3UIntRef i -> HUIntRef (get ctx.as3.as3_uints i)
+	| A3Float f -> HFloat (get ctx.as3.as3_floats f)
+	| A3Scope -> HScope
+	| A3Namespace n -> HNamespace ctx.namespaces.(idx n)
+	| A3Next (r1,r2) -> HNext (r1,r2)
+	| A3Function f -> HFunction (method_type ctx f)
+	| A3CallStack n -> HCallStack n
+	| A3Construct n -> HConstruct n
+	| A3CallMethod (s,n) -> HCallMethod (s,n)
+	| A3CallStatic (m,n) -> HCallStatic (ctx.methods.(idx m),n)
+	| A3CallSuper (p,n) -> HCallSuper (name ctx p,n)
+	| A3CallProperty (p,n) -> HCallProperty (name ctx p,n)
+	| A3RetVoid -> HRetVoid
+	| A3Ret -> HRet
+	| A3ConstructSuper n -> HConstructSuper n
+	| A3ConstructProperty (p,n) -> HConstructProperty (name ctx p,n)
+	| A3CallPropLex (p,n) -> HCallPropLex (name ctx p,n)
+	| A3CallSuperVoid (p,n) -> HCallSuperVoid (name ctx p,n)
+	| A3CallPropVoid (p,n) -> HCallPropVoid (name ctx p,n)
+	| A3ApplyType n -> HApplyType n
+	| A3Object n -> HObject n
+	| A3Array n -> HArray n
+	| A3NewBlock -> HNewBlock
+	| A3ClassDef n -> HClassDef (getclass ctx n)
+	| A3GetDescendants p -> HGetDescendants (name ctx p)
+	| A3Catch n -> HCatch n
+	| A3FindPropStrict p -> HFindPropStrict (name ctx p)
+	| A3FindProp p -> HFindProp (name ctx p)
+	| A3FindDefinition p -> HFindDefinition (name ctx p)
+	| A3GetLex p -> HGetLex (name ctx p)
+	| A3SetProp p -> HSetProp (name ctx p)
+	| A3Reg r -> HReg r
+	| A3SetReg r -> HSetReg r
+	| A3GetGlobalScope -> HGetGlobalScope
+	| A3GetScope n -> HGetScope n
+	| A3GetProp p -> HGetProp (name ctx p)
+	| A3InitProp p -> HInitProp (name ctx p)
+	| A3DeleteProp p -> HDeleteProp (name ctx p)
+	| A3GetSlot n -> HGetSlot n
+	| A3SetSlot n -> HSetSlot n
+	| A3ToString -> HToString
+	| A3ToXml -> HToXml
+	| A3ToXmlAttr -> HToXmlAttr
+	| A3ToInt -> HToInt
+	| A3ToUInt -> HToUInt
+	| A3ToNumber -> HToNumber
+	| A3ToBool -> HToBool
+	| A3ToObject -> HToObject
+	| A3CheckIsXml -> HCheckIsXml
+	| A3Cast p -> HCast (name ctx p)
+	| A3AsAny -> HAsAny
+	| A3AsString -> HAsString
+	| A3AsType p -> HAsType (name ctx p)
+	| A3AsObject -> HAsObject
+	| A3IncrReg r -> HIncrReg r
+	| A3DecrReg r -> HDecrReg r
+	| A3Typeof -> HTypeof
+	| A3InstanceOf -> HInstanceOf
+	| A3IsType p -> HIsType (name ctx p)
+	| A3IncrIReg r -> HIncrIReg r
+	| A3DecrIReg r -> HDecrIReg r
+	| A3This -> HThis
+	| A3SetThis -> HSetThis
+	| A3DebugReg (id,r,n) -> HDebugReg (ident ctx id,r,n)
+	| A3DebugLine n -> HDebugLine n
+	| A3DebugFile p -> HDebugFile (ident ctx p)
+	| A3BreakPointLine n -> HBreakPointLine n
+	| A3Timestamp -> HTimestamp
+	| A3Op op -> HOp op
+	| A3Unk n -> HUnk n
+
+let parse_code ctx f trys =
+	let code = f.fun3_code in
+	let old = ctx.pos , ctx.jumps in
+	let indexes = MultiArray.create() in
+	ctx.pos <- 0;
+	ctx.jumps <- [];
+	let codepos pos delta =
+		let id = (try MultiArray.get indexes (pos + delta) with _ -> -1) in
+		if id = -1 then begin
+			(*Printf.eprintf "MISALIGNED JUMP AT %d %c %d IN #%d\n" pos (if delta < 0 then '-' else '+') (if delta < 0 then -delta else delta) (idx (no_nz f.fun3_id));*)
+			MultiArray.get indexes pos; (* jump 0 *)
+		end else
+			id
+	in
+	let hcode = MultiArray.mapi (fun i op ->
+		let len = As3code.length op in
+		MultiArray.add indexes i;
+		for k = 2 to len do MultiArray.add indexes (-1); done;
+		ctx.pos <- ctx.pos + len;
+		parse_opcode ctx i op
+	) code in
+	(* in case we have a dead-jump at the end of code *)
+	MultiArray.add indexes (MultiArray.length code);
+	(* patch jumps *)
+	List.iter (fun (j,pos) ->
+		MultiArray.set hcode j (match MultiArray.get hcode j with
+			| HJump (jc,n) ->
+				HJump (jc,codepos pos n - j)
+			| HSwitch (n,infos) ->
+				HSwitch (codepos pos n - j, List.map (fun n -> codepos pos n - j) infos)
+			| _ -> assert false)
+	) ctx.jumps;
+	(* patch try/catches *)
+	Array.iteri (fun i t ->
+		Array.set trys i {
+			hltc_start = codepos 0 t.hltc_start;
+			hltc_end = codepos 0 t.hltc_end;
+			hltc_handle = codepos 0 t.hltc_handle;
+			hltc_type = t.hltc_type;
+			hltc_name = t.hltc_name;
+		}
+	) trys;
+	ctx.pos <- fst old;
+	ctx.jumps <- snd old;
+	hcode
+
+let parse_metadata ctx m =
+	{
+		hlmeta_name = ident ctx m.meta3_name;
+		hlmeta_data = Array.map (fun (i1,i2) -> opt ident ctx i1, ident ctx i2) m.meta3_data;
+	}
+
+let parse_method ctx m =
+	{
+		hlm_type = method_type ctx m.m3_type;
+		hlm_final = m.m3_final;
+		hlm_override = m.m3_override;
+		hlm_kind = m.m3_kind;
+	}
+
+let parse_value ctx = function
+	| A3VNone -> HVNone
+	| A3VNull -> HVNull
+	| A3VBool b -> HVBool b
+	| A3VString s -> HVString (ident ctx s)
+	| A3VInt i -> HVInt (get ctx.as3.as3_ints i)
+	| A3VUInt i -> HVUInt (get ctx.as3.as3_uints i)
+	| A3VFloat f -> HVFloat (get ctx.as3.as3_floats f)
+	| A3VNamespace (n,ns) -> HVNamespace (n,ctx.namespaces.(idx ns))
+
+let parse_var ctx v =
+	{
+		hlv_type = opt name ctx v.v3_type;
+		hlv_value = parse_value ctx v.v3_value;
+		hlv_const = v.v3_const;
+	}
+
+let parse_field_kind ctx = function
+	| A3FMethod m -> HFMethod (parse_method ctx m)
+	| A3FVar v -> HFVar (parse_var ctx v)
+	| A3FFunction f -> HFFunction (method_type ctx f)
+	| A3FClass c -> HFClass (getclass ctx c)
+
+let parse_field ctx f =
+	{
+		hlf_name = name ctx f.f3_name;
+		hlf_slot = f.f3_slot;
+		hlf_kind = parse_field_kind ctx f.f3_kind;
+		hlf_metas =
+			match f.f3_metas with
+			| None -> None
+			| Some a ->
+				Some (Array.map (fun i ->
+					parse_metadata ctx (get ctx.as3.as3_metadatas (no_nz i))
+				) a);
+	}
+
+let parse_static ctx s =
+	{
+		hls_method = method_type ctx s.st3_method;
+		hls_fields = Array.map (parse_field ctx) s.st3_fields;
+	}
+
+let parse_namespace ctx = function
+	| A3NPrivate id -> HNPrivate (opt ident ctx id)
+	| A3NPublic id -> HNPublic (opt ident ctx id)
+	| A3NInternal id -> HNInternal (opt ident ctx id)
+	| A3NProtected id -> HNProtected (ident ctx id)
+	| A3NNamespace id -> HNNamespace (ident ctx id)
+	| A3NExplicit id -> HNExplicit (ident ctx id)
+	| A3NStaticProtected id -> HNStaticProtected (opt ident ctx id)
+
+let parse_nset ctx l = List.map (fun n -> ctx.namespaces.(idx n)) l
+
+let rec parse_name names ctx = function
+	| A3MName (id,ns) ->
+		(match ctx.namespaces.(idx ns) with
+		| HNPublic p ->
+			let pack = (match p with None -> [] | Some i -> ExtString.String.nsplit i ".") in
+			HMPath (pack, ident ctx id)
+		| ns ->
+			HMName (ident ctx id, ns))
+	| A3MNSAny (id) -> HMNSAny(ident ctx id)
+	| A3MAny -> HMAny
+	| A3MMultiName (id,ns) -> HMMultiName (opt ident ctx id,ctx.nsets.(idx ns))
+	| A3MRuntimeName id -> HMRuntimeName (ident ctx id)
+	| A3MRuntimeNameLate -> HMRuntimeNameLate
+	| A3MMultiNameLate ns -> HMMultiNameLate ctx.nsets.(idx ns)
+	| A3MAttrib multi -> HMAttrib (parse_name names ctx multi)
+	| A3MParams (id,pl) -> HMParams (parse_name names ctx names.(idx id),List.map (fun id -> if idx id = -1 then HMAny else parse_name names ctx names.(idx id)) pl)
+
+let parse_try_catch ctx t =
+	{
+		hltc_start = t.tc3_start;
+		hltc_end = t.tc3_end;
+		hltc_handle = t.tc3_handle;
+		hltc_type = opt name ctx t.tc3_type;
+		hltc_name = opt name ctx t.tc3_name;
+	}
+
+let parse_function ctx f =
+	{
+		hlf_stack_size = f.fun3_stack_size;
+		hlf_nregs = f.fun3_nregs;
+		hlf_init_scope = f.fun3_init_scope;
+		hlf_max_scope = f.fun3_max_scope;
+		hlf_code = MultiArray.create(); (* keep for later *)
+		hlf_trys = Array.map (parse_try_catch ctx) f.fun3_trys;
+		hlf_locals = Array.map (fun f ->
+			if f.f3_metas <> None then assert false;
+			match f.f3_kind with
+			| A3FVar v ->
+				(* v3_value can be <> None if it's a fun parameter with a default value
+					- which looks like a bug of the AS3 compiler *)
+				name ctx f.f3_name , opt name ctx v.v3_type , f.f3_slot, v.v3_const
+			| _ -> assert false
+		) f.fun3_locals;
+	}
+
+let parse_method_type ctx idx f =
+	let m = ctx.as3.as3_method_types.(idx) in
+	{
+		hlmt_index = idx + ctx.delta_mt;
+		hlmt_ret = opt name ctx m.mt3_ret;
+		hlmt_args = List.map (opt name ctx) m.mt3_args;
+		hlmt_native = m.mt3_native;
+		hlmt_var_args = m.mt3_var_args;
+		hlmt_arguments_defined = m.mt3_arguments_defined;
+		hlmt_uses_dxns = m.mt3_uses_dxns;
+		hlmt_new_block = m.mt3_new_block;
+		hlmt_unused_flag = m.mt3_unused_flag;
+		hlmt_debug_name = opt ident ctx m.mt3_debug_name;
+		hlmt_dparams = opt (fun ctx -> List.map (parse_value ctx)) ctx m.mt3_dparams;
+		hlmt_pnames = opt (fun ctx -> List.map (opt ident ctx)) ctx m.mt3_pnames;
+		hlmt_function = opt parse_function ctx f;
+	}
+
+let parse_class ctx c s index =
+	{
+		hlc_index = index + ctx.delta_cl;
+		hlc_name = name ctx c.cl3_name;
+		hlc_super = opt name ctx c.cl3_super;
+		hlc_sealed = c.cl3_sealed;
+		hlc_final = c.cl3_final;
+		hlc_interface = c.cl3_interface;
+		hlc_namespace = opt (fun ctx i -> ctx.namespaces.(idx i)) ctx c.cl3_namespace;
+		hlc_implements = Array.map (name ctx) c.cl3_implements;
+		hlc_construct = method_type ctx c.cl3_construct;
+		hlc_fields = Array.map (parse_field ctx) c.cl3_fields;
+		hlc_static_construct = method_type ctx s.st3_method;
+		hlc_static_fields = Array.map (parse_field ctx) s.st3_fields;
+	}
+
+let parse_static ctx s =
+	{
+		hls_method = method_type ctx s.st3_method;
+		hls_fields = Array.map (parse_field ctx) s.st3_fields;
+	}
+
+let parse ?(delta_mt=0) ?(delta_cl=0) t =
+	let ctx = {
+		as3 = t;
+		namespaces = [||];
+		nsets = [||];
+		names = [||];
+		methods = [||];
+		classes = [||];
+		jumps = [];
+		pos = 0;
+		delta_mt = delta_mt;
+		delta_cl = delta_cl;
+	} in
+	ctx.namespaces <- Array.map (parse_namespace ctx) t.as3_namespaces;
+	ctx.nsets <- Array.map (parse_nset ctx) t.as3_nsets;
+	ctx.names <- Array.map (parse_name t.as3_names ctx) t.as3_names;
+	let hfunctions = Hashtbl.create 0 in
+	Array.iter (fun f -> Hashtbl.add hfunctions (idx (no_nz f.fun3_id)) f) t.as3_functions;
+	ctx.methods <- Array.mapi (fun i m ->
+		parse_method_type ctx i (try Some (Hashtbl.find hfunctions i) with Not_found -> None);
+	) t.as3_method_types;
+	ctx.classes <- Array.mapi (fun i c ->
+		parse_class ctx c t.as3_statics.(i) i
+	) t.as3_classes;
+	let inits = List.map (parse_static ctx) (Array.to_list t.as3_inits) in
+	Array.iter (fun f ->
+		match (method_type ctx f.fun3_id).hlmt_function with
+		| None -> assert false
+		| Some fl -> fl.hlf_code <- parse_code ctx f fl.hlf_trys
+	) t.as3_functions;
+	inits
+
+(* ************************************************************************ *)
+(*			FLATTEN															*)
+(* ************************************************************************ *)
+
+type ('hl,'item) lookup = {
+	h : ('hl,int) Hashtbl.t;
+	a : 'item DynArray.t;
+	f : flatten_ctx -> 'hl -> 'item;
+}
+
+and ('hl,'item) index_lookup = {
+	ordered_list : 'hl list;
+	ordered_array : 'item option DynArray.t;
+	map_f : flatten_ctx -> 'hl -> 'item;
+}
+
+and flatten_ctx = {
+	fints : (hl_int,as3_int) lookup;
+	fuints : (hl_uint,as3_uint) lookup;
+	ffloats : (hl_float,as3_float) lookup;
+	fidents : (hl_ident,as3_ident) lookup;
+	fnamespaces : (hl_namespace,as3_namespace) lookup;
+	fnsets : (hl_ns_set,as3_ns_set) lookup;
+	fnames : (hl_name,as3_multi_name) lookup;
+	fmetas : (hl_metadata,as3_metadata) lookup;
+	fmethods : (hl_method,as3_method_type) index_lookup;
+	fclasses : (hl_class,as3_class * as3_static) index_lookup;
+	mutable ffunctions : as3_function list;
+	mutable fjumps : int list;
+}
+
+let new_lookup f =
+	{
+		h = Hashtbl.create 0;
+		a = DynArray.create();
+		f = f;
+	}
+
+let new_index_lookup l f =
+	{
+		ordered_list = l;
+		ordered_array = DynArray.init (List.length l) (fun _ -> None);
+		map_f = f;
+	}
+
+let lookup_array l = DynArray.to_array l.a
+
+let lookup_index_array l =
+	Array.map (function None -> assert false | Some x -> x) (DynArray.to_array l.ordered_array)
+
+let lookup ctx (l:('a,'b) lookup) item : 'b index =
+	let idx = try
+		Hashtbl.find l.h item
+	with Not_found ->
+		let idx = DynArray.length l.a in
+		(* set dummy value for recursion *)
+		DynArray.add l.a (Obj.magic 0);
+		Hashtbl.add l.h item (idx + 1);
+		DynArray.set l.a idx (l.f ctx item);
+		idx + 1
+	in
+	As3parse.magic_index idx
+
+let lookup_index_nz ctx (l:('a,'b) index_lookup) item : 'c index_nz =
+	let rec loop n = function
+		| [] -> assert false
+		| x :: l ->
+			if x == item then n else loop (n + 1) l
+	in
+	let idx = loop 0 l.ordered_list in
+	if DynArray.get l.ordered_array idx = None then begin
+		(* set dummy value for recursion *)
+		DynArray.set l.ordered_array idx (Some (Obj.magic 0));
+		DynArray.set l.ordered_array idx (Some (l.map_f ctx item));
+	end;
+	As3parse.magic_index_nz idx
+
+let lookup_nz ctx l item =
+	As3parse.magic_index_nz (As3parse.index_int (lookup ctx l item) - 1)
+
+let lookup_ident ctx i = lookup ctx ctx.fidents i
+
+let lookup_name ctx n = lookup ctx ctx.fnames n
+
+let lookup_method ctx m : as3_method_type index_nz =
+	lookup_index_nz ctx ctx.fmethods m
+
+let lookup_class ctx c : as3_class index_nz =
+	lookup_index_nz ctx ctx.fclasses c
+
+let flatten_namespace ctx = function
+	| HNPrivate i -> A3NPrivate (opt lookup_ident ctx i)
+	| HNPublic i -> A3NPublic (opt lookup_ident ctx i)
+	| HNInternal i -> A3NInternal (opt lookup_ident ctx i)
+	| HNProtected i -> A3NProtected (lookup_ident ctx i)
+	| HNNamespace i -> A3NNamespace (lookup_ident ctx i)
+	| HNExplicit i -> A3NExplicit (lookup_ident ctx i)
+	| HNStaticProtected i -> A3NStaticProtected (opt lookup_ident ctx i)
+
+let flatten_ns_set ctx n =
+	List.map (lookup ctx ctx.fnamespaces) n
+
+let rec flatten_name ctx = function
+	| HMPath (pack,i) ->
+		let ns = HNPublic (match pack with [] -> None | l -> Some (String.concat "." l)) in
+		A3MName (lookup_ident ctx i,lookup ctx ctx.fnamespaces ns)
+	| HMName (i,n) -> A3MName (lookup_ident ctx i,lookup ctx ctx.fnamespaces n)
+	| HMNSAny (i) ->  A3MNSAny (lookup_ident ctx i)
+	| HMAny -> A3MAny
+	| HMMultiName (i,ns) -> A3MMultiName (opt lookup_ident ctx i,lookup ctx ctx.fnsets ns)
+	| HMRuntimeName i -> A3MRuntimeName (lookup_ident ctx i)
+	| HMRuntimeNameLate -> A3MRuntimeNameLate
+	| HMMultiNameLate ns -> A3MMultiNameLate (lookup ctx ctx.fnsets ns)
+	| HMAttrib n -> A3MAttrib (flatten_name ctx n)
+	| HMParams (i,nl) -> A3MParams (lookup_name ctx i,List.map (lookup_name ctx) nl)
+
+let flatten_meta ctx m =
+	{
+		meta3_name = lookup_ident ctx m.hlmeta_name;
+		meta3_data = Array.map (fun (i,i2) -> opt lookup_ident ctx i, lookup_ident ctx i2) m.hlmeta_data;
+	}
+
+let flatten_value ctx = function
+	| HVNone -> A3VNone
+	| HVNull -> A3VNull
+	| HVBool b -> A3VBool b
+	| HVString s -> A3VString (lookup_ident ctx s)
+	| HVInt i -> A3VInt (lookup ctx ctx.fints i)
+	| HVUInt i -> A3VUInt (lookup ctx ctx.fuints i)
+	| HVFloat f -> A3VFloat (lookup ctx ctx.ffloats f)
+	| HVNamespace (n,ns) -> A3VNamespace (n,lookup ctx ctx.fnamespaces ns)
+
+let flatten_field ctx f =
+	{
+		f3_name = lookup_name ctx f.hlf_name;
+		f3_slot = f.hlf_slot;
+		f3_kind = (match f.hlf_kind with
+			| HFMethod m ->
+				A3FMethod {
+					m3_type = lookup_method ctx m.hlm_type;
+					m3_final = m.hlm_final;
+					m3_override = m.hlm_override;
+					m3_kind = m.hlm_kind;
+				}
+			| HFVar v ->
+				A3FVar {
+					v3_type = opt lookup_name ctx v.hlv_type;
+					v3_value = flatten_value ctx v.hlv_value;
+					v3_const = v.hlv_const;
+				}
+			| HFFunction f ->
+				A3FFunction (lookup_method ctx f)
+			| HFClass c ->
+				A3FClass (lookup_class ctx c)
+		);
+		f3_metas = opt (fun ctx -> Array.map (fun m -> lookup_nz ctx ctx.fmetas m)) ctx f.hlf_metas;
+	}
+
+let flatten_class ctx c =
+	{
+		cl3_name = lookup_name ctx c.hlc_name;
+		cl3_super = opt lookup_name ctx c.hlc_super;
+		cl3_sealed = c.hlc_sealed;
+		cl3_final = c.hlc_final;
+		cl3_interface = c.hlc_interface;
+		cl3_namespace = opt (fun ctx -> lookup ctx ctx.fnamespaces) ctx c.hlc_namespace;
+		cl3_implements = Array.map (lookup_name ctx) c.hlc_implements;
+		cl3_construct = lookup_method ctx c.hlc_construct;
+		cl3_fields = Array.map (flatten_field ctx) c.hlc_fields;
+	},
+	{
+		st3_method = lookup_method ctx c.hlc_static_construct;
+		st3_fields = Array.map (flatten_field ctx) c.hlc_static_fields;
+	}
+
+let flatten_opcode ctx i = function
+	| HBreakPoint -> A3BreakPoint
+	| HNop -> A3Nop
+	| HThrow -> A3Throw
+	| HGetSuper n -> A3GetSuper (lookup_name ctx n)
+	| HSetSuper n -> A3SetSuper (lookup_name ctx n)
+	| HDxNs s -> A3DxNs (lookup_ident ctx s)
+	| HDxNsLate -> A3DxNsLate
+	| HRegKill r -> A3RegKill r
+	| HLabel -> A3Label
+	| HJump (j,n) ->
+		ctx.fjumps <- i :: ctx.fjumps;
+		A3Jump (j,n)
+	| HSwitch (n,l) ->
+		ctx.fjumps <- i :: ctx.fjumps;
+		A3Switch (n,l)
+	| HPushWith -> A3PushWith
+	| HPopScope -> A3PopScope
+	| HForIn -> A3ForIn
+	| HHasNext -> A3HasNext
+	| HNull -> A3Null
+	| HUndefined -> A3Undefined
+	| HForEach -> A3ForEach
+	| HSmallInt n -> A3SmallInt n
+	| HInt n -> A3Int n
+	| HTrue -> A3True
+	| HFalse -> A3False
+	| HNaN -> A3NaN
+	| HPop -> A3Pop
+	| HDup -> A3Dup
+	| HSwap -> A3Swap
+	| HString s -> A3String (lookup_ident ctx s)
+	| HIntRef i -> A3IntRef (lookup ctx ctx.fints i)
+	| HUIntRef i -> A3UIntRef (lookup ctx ctx.fuints i)
+	| HFloat f -> A3Float (lookup ctx ctx.ffloats f)
+	| HScope -> A3Scope
+	| HNamespace n -> A3Namespace (lookup ctx ctx.fnamespaces n)
+	| HNext (r1,r2) -> A3Next (r1,r2)
+	| HFunction m -> A3Function (lookup_method ctx m)
+	| HCallStack n -> A3CallStack n
+	| HConstruct n -> A3Construct n
+	| HCallMethod (s,n) -> A3CallMethod (s,n)
+	| HCallStatic (m,n) -> A3CallStatic (no_nz (lookup_method ctx m),n)
+	| HCallSuper (i,n) -> A3CallSuper (lookup_name ctx i,n)
+	| HCallProperty (i,n) -> A3CallProperty (lookup_name ctx i,n)
+	| HRetVoid -> A3RetVoid
+	| HRet -> A3Ret
+	| HConstructSuper n -> A3ConstructSuper n
+	| HConstructProperty (i,n) -> A3ConstructProperty (lookup_name ctx i,n)
+	| HCallPropLex (i,n) -> A3CallPropLex (lookup_name ctx i,n)
+	| HCallSuperVoid (i,n) -> A3CallSuperVoid (lookup_name ctx i,n)
+	| HCallPropVoid (i,n)-> A3CallPropVoid (lookup_name ctx i,n)
+	| HApplyType n -> A3ApplyType n
+	| HObject n -> A3Object n
+	| HArray n -> A3Array n
+	| HNewBlock -> A3NewBlock
+	| HClassDef c -> A3ClassDef (As3parse.magic_index_nz (As3parse.index_nz_int (lookup_class ctx c)))
+	| HGetDescendants i -> A3GetDescendants (lookup_name ctx i)
+	| HCatch n -> A3Catch n
+	| HFindPropStrict i -> A3FindPropStrict (lookup_name ctx i)
+	| HFindProp i -> A3FindProp (lookup_name ctx i)
+	| HFindDefinition i -> A3FindDefinition (lookup_name ctx i)
+	| HGetLex i -> A3GetLex (lookup_name ctx i)
+	| HSetProp i -> A3SetProp (lookup_name ctx i)
+	| HReg r -> A3Reg r
+	| HSetReg r -> A3SetReg r
+	| HGetGlobalScope -> A3GetGlobalScope
+	| HGetScope n -> A3GetScope n
+	| HGetProp n -> A3GetProp (lookup_name ctx n)
+	| HInitProp n -> A3InitProp (lookup_name ctx n)
+	| HDeleteProp n -> A3DeleteProp (lookup_name ctx n)
+	| HGetSlot s -> A3GetSlot s
+	| HSetSlot s -> A3SetSlot s
+	| HToString -> A3ToString
+	| HToXml -> A3ToXml
+	| HToXmlAttr -> A3ToXmlAttr
+	| HToInt -> A3ToInt
+	| HToUInt -> A3ToUInt
+	| HToNumber -> A3ToNumber
+	| HToBool -> A3ToBool
+	| HToObject -> A3ToObject
+	| HCheckIsXml -> A3CheckIsXml
+	| HCast n -> A3Cast (lookup_name ctx n)
+	| HAsAny -> A3AsAny
+	| HAsString -> A3AsString
+	| HAsType n -> A3AsType (lookup_name ctx n)
+	| HAsObject -> A3AsObject
+	| HIncrReg r -> A3IncrReg r
+	| HDecrReg r -> A3DecrReg r
+	| HTypeof -> A3Typeof
+	| HInstanceOf -> A3InstanceOf
+	| HIsType t -> A3IsType (lookup_name ctx t)
+	| HIncrIReg r -> A3IncrIReg r
+	| HDecrIReg r -> A3DecrIReg r
+	| HThis -> A3This
+	| HSetThis -> A3SetThis
+	| HDebugReg (i,r,l) -> A3DebugReg (lookup_ident ctx i,r,l)
+	| HDebugLine l -> A3DebugLine l
+	| HDebugFile f -> A3DebugFile (lookup_ident ctx f)
+	| HBreakPointLine n -> A3BreakPointLine n
+	| HTimestamp -> A3Timestamp
+	| HOp op -> A3Op op
+	| HUnk c -> A3Unk c
+
+let flatten_code ctx hcode trys =
+	let positions = MultiArray.make (MultiArray.length hcode + 1) 0 in
+	let pos = ref 0 in
+	let old = ctx.fjumps in
+	ctx.fjumps <- [];
+	let code = MultiArray.mapi (fun i op ->
+		let op = flatten_opcode ctx i op in
+		pos := !pos + As3code.length op;
+		MultiArray.set positions (i + 1) !pos;
+		op
+	) hcode in
+	(* patch jumps *)
+	List.iter (fun j ->
+		MultiArray.set code j (match MultiArray.get code j with
+			| A3Jump (jc,n) ->
+				A3Jump (jc,MultiArray.get positions (j+n) - MultiArray.get positions (j+1))
+			| A3Switch (n,infos) ->
+				A3Switch (MultiArray.get positions (j+n) - MultiArray.get positions (j),List.map (fun n -> MultiArray.get positions (j+n) - MultiArray.get positions (j)) infos)
+			| _ -> assert false);
+	) ctx.fjumps;
+	(* patch trys *)
+	let trys = Array.mapi (fun i t ->
+		{
+			tc3_start = MultiArray.get positions t.hltc_start;
+			tc3_end = MultiArray.get positions t.hltc_end;
+			tc3_handle = MultiArray.get positions t.hltc_handle;
+			tc3_type = opt lookup_name ctx t.hltc_type;
+			tc3_name = opt lookup_name ctx t.hltc_name;
+		}
+	) trys in
+	ctx.fjumps <- old;
+	code, trys
+
+let flatten_function ctx f mid =
+	let code, trys = flatten_code ctx f.hlf_code f.hlf_trys in
+	{
+		fun3_id = mid;
+		fun3_stack_size = f.hlf_stack_size;
+		fun3_nregs = f.hlf_nregs;
+		fun3_init_scope = f.hlf_init_scope;
+		fun3_max_scope = f.hlf_max_scope;
+		fun3_code = code;
+		fun3_trys = trys;
+		fun3_locals = Array.map (fun (n,t,s,c) ->
+			{
+				f3_name = lookup_name ctx n;
+				f3_slot = s;
+				f3_kind = A3FVar { v3_type = opt lookup_name ctx t; v3_value = A3VNone; v3_const = c };
+				f3_metas = None;
+			}
+		) f.hlf_locals;
+	}
+
+let flatten_method ctx m =
+	let mid = lookup_method ctx m in
+	(match m.hlmt_function with
+	| None -> ()
+	| Some f ->
+		let x = flatten_function ctx f mid in
+		ctx.ffunctions <- x :: ctx.ffunctions);
+	{
+		mt3_ret = opt lookup_name ctx m.hlmt_ret;
+		mt3_args = List.map (opt lookup_name ctx) m.hlmt_args;
+		mt3_native = m.hlmt_native;
+		mt3_var_args = m.hlmt_var_args;
+		mt3_arguments_defined = m.hlmt_arguments_defined;
+		mt3_uses_dxns = m.hlmt_uses_dxns;
+		mt3_new_block = m.hlmt_new_block;
+		mt3_unused_flag = m.hlmt_unused_flag;
+		mt3_debug_name = opt lookup_ident ctx m.hlmt_debug_name;
+		mt3_dparams = opt (fun ctx -> List.map (flatten_value ctx)) ctx m.hlmt_dparams;
+		mt3_pnames = opt (fun ctx -> List.map (opt lookup_ident ctx)) ctx m.hlmt_pnames;
+	}
+
+let flatten_static ctx s =
+	{
+		st3_method = lookup_method ctx s.hls_method;
+		st3_fields = Array.map (flatten_field ctx) s.hls_fields;
+	}
+
+let rec browse_method ctx m =
+	let ml, _ = ctx in
+	if not (List.memq m !ml) then begin
+		ml := m :: !ml;
+		match m.hlmt_function with
+		| None -> ()
+		| Some f ->
+			MultiArray.iter (function
+				| HFunction f | HCallStatic (f,_) -> browse_method ctx f
+				| HClassDef _ -> () (* ignore, should be in fields list anyway *)
+				| _ -> ()
+			) f.hlf_code
+	end
+
+and browse_class ctx c =
+	let _, cl = ctx in
+	if not (List.memq c !cl) then begin
+		cl := c :: !cl;
+		browse_method ctx c.hlc_construct;
+		browse_method ctx c.hlc_static_construct;
+		Array.iter (browse_field ctx) c.hlc_fields;
+		Array.iter (browse_field ctx) c.hlc_static_fields;
+	end
+
+and browse_field ctx f =
+	match f.hlf_kind with
+	| HFMethod m -> browse_method ctx m.hlm_type
+	| HFVar _ -> ()
+	| HFFunction m -> browse_method ctx m
+	| HFClass c -> browse_class ctx c
+
+let flatten t =
+	let id _ x = x in
+	(* collect methods and classes, sort by index and force evaluation in order to keep order *)
+	let methods = ref [] in
+	let classes = ref [] in
+	let ctx = (methods,classes) in
+	List.iter (fun s ->
+		Array.iter (browse_field ctx) s.hls_fields;
+		browse_method ctx s.hls_method;
+	) t;
+	let methods = List.sort (fun m1 m2 -> m1.hlmt_index - m2.hlmt_index) (List.rev !methods) in
+	(* done *)
+	let rec ctx = {
+		fints = new_lookup id;
+		fuints = new_lookup id;
+		ffloats = new_lookup id;
+		fidents = new_lookup id;
+		fnamespaces = new_lookup flatten_namespace;
+		fnsets = new_lookup flatten_ns_set;
+		fnames = new_lookup flatten_name;
+		fmetas = new_lookup flatten_meta;
+		fmethods = new_index_lookup methods flatten_method;
+		fclasses = new_index_lookup (List.rev !classes) flatten_class;
+		fjumps = [];
+		ffunctions = [];
+	} in
+	ignore(lookup_ident ctx "");
+	let inits = List.map (flatten_static ctx) t in
+	let classes = lookup_index_array ctx.fclasses in
+	{
+		as3_ints = lookup_array ctx.fints;
+		as3_uints = lookup_array ctx.fuints;
+		as3_floats = lookup_array ctx.ffloats;
+		as3_idents = lookup_array ctx.fidents;
+		as3_namespaces = lookup_array ctx.fnamespaces;
+		as3_nsets = lookup_array ctx.fnsets;
+		as3_names = lookup_array ctx.fnames;
+		as3_metadatas = lookup_array ctx.fmetas;
+		as3_method_types = lookup_index_array ctx.fmethods;
+		as3_classes = Array.map fst classes;
+		as3_statics = Array.map snd classes;
+		as3_functions = Array.of_list (List.rev ctx.ffunctions);
+		as3_inits = Array.of_list inits;
+		as3_unknown = "";
+	}

libs/swflib/as3parse.ml

@@ -0,0 +1,1110 @@
+(*
+ *  This file is part of SwfLib
+ *  Copyright (c)2004-2006 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+open As3
+
+let parse_idents = true
+let parse_namespaces = true && parse_idents
+let parse_ns_sets = true && parse_namespaces
+let parse_names = true && parse_ns_sets
+let parse_mtypes = true && parse_names
+let parse_metadata = true && parse_mtypes
+let parse_classes = true && parse_metadata
+let parse_statics = true && parse_classes
+let parse_inits = true && parse_statics
+let parse_functions = true && parse_inits
+let parse_bytecode = true && parse_functions
+
+let magic_index (i : int) : 'a index =
+	Obj.magic i
+
+let magic_index_nz (i : int) : 'a index_nz =
+	Obj.magic i
+
+let index (t : 'a array) (i : int) : 'a index =
+	if i <= 0 || i - 1 >= Array.length t then assert false;
+	magic_index i
+
+let index_opt t i =
+	if i = 0 then
+		None
+	else
+		Some (index t i)
+
+let index_nz (t : 'a array) (i : int) : 'a index_nz =
+	if i < 0 || i >= Array.length t then assert false;
+	Obj.magic i
+
+let index_int (i : 'a index) =
+	(Obj.magic i : int)
+
+let index_nz_int (i : 'a index_nz) =
+	(Obj.magic i : int)
+
+let iget (t : 'a array) (i : 'a index) : 'a =
+	t.(index_int i - 1)
+
+let no_nz (i : 'a index_nz) : 'a index =
+	Obj.magic ((Obj.magic i) + 1)
+
+(* ************************************************************************ *)
+(* LENGTH *)
+
+let as3_empty_index ctx =
+	let empty_index = ref 0 in
+	try
+		Array.iteri (fun i x -> if x = "" then begin empty_index := (i + 1); raise Exit; end) ctx.as3_idents;
+		if parse_idents then assert false;
+		magic_index 0
+	with Exit ->
+		index ctx.as3_idents (!empty_index)
+
+let as3_int_length i =
+	if Int32.compare (Int32.shift_right_logical i 28) 0l > 0 then
+		5
+	else if Int32.compare (Int32.shift_right i 21) 0l > 0 then
+		4
+	else if Int32.compare (Int32.shift_right i 14) 0l > 0 then
+		3
+	else if Int32.compare (Int32.shift_right i 7) 0l > 0 then
+		2
+	else
+		1
+
+let as3_uint_length i =
+	as3_int_length i
+
+let sum f l =
+	List.fold_left (fun acc n -> acc + f n) 0 l
+
+let int_length i =
+	as3_int_length (Int32.of_int i)
+
+let idx_length i =
+	int_length (index_int i)
+
+let idx_length_nz i =
+	int_length (index_nz_int i)
+
+let idx_opt_length = function
+	| None -> int_length 0
+	| Some i -> idx_length i
+
+let as3_ident_length s =
+	let n = String.length s in
+	n + int_length n
+
+let as3_namespace_length ei = function
+	| A3NStaticProtected o
+	| A3NPrivate o ->
+		1 + (match o with None -> int_length 0 | Some n -> idx_length n)
+	| A3NPublic o
+	| A3NInternal o ->
+		1 + idx_length (match o with None -> ei | Some n -> n)
+	| A3NExplicit n
+	| A3NNamespace n
+	| A3NProtected n ->
+		1 + idx_length n
+
+let as3_ns_set_length l =
+	int_length (List.length l) + sum idx_length l
+
+let rec as3_name_length t =
+	1 +
+	match t with
+	| A3MMultiName (id,r) ->
+		idx_opt_length id + idx_length r
+	| A3MName (id,r) ->
+		idx_length r + idx_length id
+	| A3MNSAny (id) ->
+		int_length 0 + idx_length id
+	| A3MAny ->
+		int_length 0 + int_length 0
+	| A3MRuntimeName i ->
+		idx_length i
+	| A3MRuntimeNameLate ->
+		0
+	| A3MMultiNameLate idx ->
+		idx_length idx
+	| A3MAttrib n ->
+		as3_name_length n - 1
+	| A3MParams (id,pl) ->
+		idx_length id + 1 + (sum idx_length pl)
+
+let as3_value_length extra = function
+	| A3VNone -> if extra then 2 else 1
+	| A3VNull | A3VBool _ -> 2
+	| A3VString s -> 1 + idx_length s
+	| A3VInt s -> 1 + idx_length s
+	| A3VUInt s -> 1 + idx_length s
+	| A3VFloat s -> 1 + idx_length s
+	| A3VNamespace (_,s) -> 1 + idx_length s
+
+let as3_method_type_length m =
+	1 +
+	idx_opt_length m.mt3_ret +
+	sum idx_opt_length m.mt3_args +
+	idx_opt_length m.mt3_debug_name +
+	1 +
+	(match m.mt3_dparams with None -> 0 | Some l -> 1 + sum (as3_value_length true) l) +
+	(match m.mt3_pnames with None -> 0 | Some l -> sum idx_opt_length l)
+
+let list_length f l =
+	match Array.length l with
+	| 0 -> int_length 0
+	| n ->
+		Array.fold_left (fun acc x -> acc + f x) (int_length (n + 1)) l
+
+let list2_length f l =
+	Array.fold_left (fun acc x -> acc + f x) (int_length (Array.length l)) l
+
+let as3_field_length f =
+	idx_length f.f3_name +
+	1 +
+	int_length f.f3_slot +
+	(match f.f3_kind with
+	| A3FMethod m ->
+		idx_length_nz m.m3_type
+	| A3FClass c ->
+		idx_length_nz c
+	| A3FFunction id ->
+		idx_length_nz id
+	| A3FVar v ->
+		idx_opt_length v.v3_type + as3_value_length false v.v3_value) +
+	match f.f3_metas with
+	| None -> 0
+	| Some l -> list2_length idx_length_nz l
+
+let as3_class_length c =
+	idx_length c.cl3_name +
+	idx_opt_length c.cl3_super +
+	1 +
+	(match c.cl3_namespace with None -> 0 | Some r -> idx_length r) +
+	list2_length idx_length c.cl3_implements +
+	idx_length_nz c.cl3_construct +
+	list2_length as3_field_length c.cl3_fields
+
+let as3_static_length s =
+	idx_length_nz s.st3_method +
+	list2_length as3_field_length s.st3_fields
+
+let as3_metadata_length m =
+	idx_length m.meta3_name +
+	list2_length (fun (i1,i2) -> idx_opt_length i1 + idx_length i2) m.meta3_data
+
+let as3_try_catch_length t =
+	int_length t.tc3_start +
+	int_length t.tc3_end +
+	int_length t.tc3_handle +
+	idx_opt_length t.tc3_type +
+	idx_opt_length t.tc3_name
+
+let as3_function_length f =
+	let clen = MultiArray.fold_left (fun acc op -> acc + As3code.length op) 0 f.fun3_code in
+	idx_length_nz f.fun3_id +
+	int_length f.fun3_stack_size +
+	int_length f.fun3_nregs +
+	int_length f.fun3_init_scope +
+	int_length f.fun3_max_scope +
+	int_length clen +
+	clen +
+	list2_length as3_try_catch_length f.fun3_trys +
+	list2_length as3_field_length f.fun3_locals
+
+let as3_length ctx =
+	let ei = as3_empty_index ctx in
+	String.length ctx.as3_unknown +
+	4 +
+	list_length as3_int_length ctx.as3_ints +
+	list_length as3_uint_length ctx.as3_uints +
+	list_length (fun _ -> 8) ctx.as3_floats
+	+ if parse_idents then list_length as3_ident_length ctx.as3_idents
+	+ if parse_namespaces then list_length (as3_namespace_length ei) ctx.as3_namespaces
+	+ if parse_ns_sets then list_length as3_ns_set_length ctx.as3_nsets
+	+ if parse_names then list_length as3_name_length ctx.as3_names
+	+ if parse_mtypes then list2_length as3_method_type_length ctx.as3_method_types
+	+ if parse_metadata then list2_length as3_metadata_length ctx.as3_metadatas
+	+ if parse_classes then list2_length as3_class_length ctx.as3_classes
+	+ if parse_statics then Array.fold_left (fun acc x -> acc + as3_static_length x) 0 ctx.as3_statics
+	+ if parse_inits then list2_length as3_static_length ctx.as3_inits
+	+ if parse_functions then list2_length as3_function_length ctx.as3_functions
+	  else 0 else 0 else 0 else 0 else 0 else 0 else 0 else 0 else 0 else 0
+
+(* ************************************************************************ *)
+(* PARSING *)
+
+let read_as3_int ch =
+	let a = IO.read_byte ch in
+	if a < 128 then
+		Int32.of_int a
+	else
+	let a = a land 127 in
+	let b = IO.read_byte ch in
+	if b < 128 then
+		Int32.of_int ((b lsl 7) lor a)
+	else
+	let b = b land 127 in
+	let c = IO.read_byte ch in
+	if c < 128 then
+		Int32.of_int ((c lsl 14) lor (b lsl 7) lor a)
+	else
+	let c = c land 127 in
+	let d = IO.read_byte ch in
+	if d < 128 then
+		Int32.of_int ((d lsl 21) lor (c lsl 14) lor (b lsl 7) lor a)
+	else
+	let d = d land 127 in
+	let e = IO.read_byte ch in
+	if e > 15 then assert false;
+	let small = Int32.of_int ((d lsl 21) lor (c lsl 14) lor (b lsl 7) lor a) in
+	let big = Int32.shift_left (Int32.of_int e) 28 in
+	Int32.logor big small
+
+let read_as3_uint ch =
+	read_as3_int ch
+
+let read_int ch =
+	Int32.to_int (read_as3_int ch)
+
+let read_ident ch =
+	IO.nread_string ch (read_int ch)
+
+let read_namespace idents ch =
+	let k = IO.read_byte ch in
+	let p = index_opt idents (read_int ch) in
+	match k with
+	| 0x05 ->
+		A3NPrivate p
+	| 0x08 ->
+		(match p with
+		| None -> assert false
+		| Some idx -> A3NNamespace idx)
+	| 0x16 ->
+		(match p with
+		| None -> assert false
+		| Some p when iget idents p = "" -> A3NPublic None
+		| _ -> A3NPublic p)
+	| 0x17 ->
+		(match p with
+		| None -> assert false
+		| Some p when iget idents p = "" -> A3NInternal None
+		| _ -> A3NInternal p)
+	| 0x18 ->
+		(match p with
+		| None -> assert false
+		| Some idx -> A3NProtected idx)
+	| 0x19 ->
+		(match p with
+		| None -> assert false
+		| Some idx -> A3NExplicit idx)
+	| 0x1A ->
+		A3NStaticProtected p
+	| _ ->
+		assert false
+
+let read_ns_set namespaces ch =
+	let rec loop n =
+		if n = 0 then
+			[]
+		else
+			let r = index namespaces (read_int ch) in
+			r :: loop (n - 1)
+	in
+	loop (IO.read_byte ch)
+
+let rec read_name ctx ?k ch =
+	let k = (match k with None -> IO.read_byte ch | Some k -> k) in
+	match k with
+	| 0x07 ->
+		let i = read_int ch in
+		let j = read_int ch in
+		if i = 0 && j = 0 then
+			A3MAny
+		else if i = 0 && j <> 0 then
+			let id = index ctx.as3_idents j in
+			A3MNSAny(id)
+		else
+		let ns = index ctx.as3_namespaces i in
+		let id = index ctx.as3_idents j in
+		(* both ns and id can be 0 <=> '*' *)
+		A3MName (id,ns)
+	| 0x09 ->
+		let id = index_opt ctx.as3_idents (read_int ch) in
+		let ns = index ctx.as3_nsets (read_int ch) in
+		A3MMultiName (id,ns)
+	| 0x0D ->
+		A3MAttrib (read_name ctx ~k:0x07 ch)
+	| 0x0E ->
+		A3MAttrib (read_name ctx ~k:0x09 ch)
+	| 0x0F ->
+		let id = index ctx.as3_idents (read_int ch) in
+		A3MRuntimeName id
+	| 0x10 ->
+		A3MAttrib (read_name ctx ~k:0x0F ch)
+	| 0x11 ->
+		A3MRuntimeNameLate
+	| 0x12 ->
+		A3MAttrib (read_name ctx ~k:0x11 ch)
+	| 0x1B ->
+		let ns = index ctx.as3_nsets (read_int ch) in
+		A3MMultiNameLate ns
+	| 0x1C ->
+		A3MAttrib (read_name ctx ~k:0x1B ch)
+	| 0x1D ->
+		let rec loop n =
+			if n = 0 then
+				[]
+			else
+				let name = magic_index (read_int ch) in
+				name :: loop (n - 1)
+		in
+		let id = magic_index (read_int ch) in
+		A3MParams (id,loop (IO.read_byte ch))
+	| n ->
+		prerr_endline (string_of_int n);
+		assert false
+
+let read_value ctx ch extra =
+	let idx = read_int ch in
+	if idx = 0 then begin
+		if extra && IO.read_byte ch <> 0 then assert false;
+		A3VNone
+	end else match IO.read_byte ch with
+	| 0x01 ->
+		A3VString (index ctx.as3_idents idx)
+	| 0x03 ->
+		A3VInt (index ctx.as3_ints idx)
+	| 0x04 ->
+		A3VUInt (index ctx.as3_uints idx)
+	| 0x06 ->
+		A3VFloat (index ctx.as3_floats idx)
+	| 0x08 | 0x16 | 0x17 | 0x18 | 0x19 | 0x1A | 0x05 as n->
+		A3VNamespace (n,index ctx.as3_namespaces idx)
+	| 0x0A ->
+		if idx <> 0x0A then assert false;
+		A3VBool false
+	| 0x0B ->
+		if idx <> 0x0B then assert false;
+		A3VBool true
+	| 0x0C ->
+		if idx <> 0x0C then assert false;
+		A3VNull
+	| _ ->
+		assert false
+
+let read_method_type ctx ch =
+	let nargs = IO.read_byte ch in
+	let tret = index_opt ctx.as3_names (read_int ch) in
+	let targs = Array.to_list (Array.init nargs (fun _ -> index_opt ctx.as3_names (read_int ch))) in
+	let dname = index_opt ctx.as3_idents (read_int ch) in
+	let flags = IO.read_byte ch in
+	let dparams = (if flags land 0x08 <> 0 then
+		Some (Array.to_list (Array.init (IO.read_byte ch) (fun _ -> read_value ctx ch true)))
+	else
+		None
+	) in
+	let pnames = (if flags land 0x80 <> 0 then
+		Some (Array.to_list (Array.init nargs (fun _ -> index_opt ctx.as3_idents (read_int ch))))
+	else
+		None
+	) in
+	{
+		mt3_ret = tret;
+		mt3_args = targs;
+		mt3_var_args = flags land 0x04 <> 0;
+		mt3_native = flags land 0x20 <> 0;
+		mt3_new_block = flags land 0x02 <> 0;
+		mt3_debug_name = dname;
+		mt3_dparams = dparams;
+		mt3_pnames = pnames;
+		mt3_arguments_defined = flags land 0x01 <> 0;
+		mt3_uses_dxns = flags land 0x40 <> 0;
+		mt3_unused_flag = flags land 0x10 <> 0;
+	}
+
+let read_list ch f =
+	match read_int ch with
+	| 0 -> [||]
+	| n -> Array.init (n - 1) (fun _ -> f ch)
+
+let read_list2 ch f =
+	Array.init (read_int ch) (fun _ -> f ch)
+
+let read_field ctx ch =
+	let name = index ctx.as3_names (read_int ch) in
+	let kind = IO.read_byte ch in
+	let has_meta = kind land 0x40 <> 0 in
+	let slot = read_int ch in
+	let kind = (match kind land 0xF with
+		| 0x00 | 0x06 as kind ->
+			let t = index_opt ctx.as3_names (read_int ch) in
+			let value = read_value ctx ch false in
+			A3FVar {
+				v3_type = t;
+				v3_value = value;
+				v3_const = kind = 0x06;
+			}
+		| 0x02
+		| 0x03
+		| 0x01 ->
+			let meth = index_nz ctx.as3_method_types (read_int ch) in
+			let final = kind land 0x10 <> 0 in
+			let override = kind land 0x20 <> 0 in
+			A3FMethod {
+				m3_type = meth;
+				m3_final = final;
+				m3_override = override;
+				m3_kind = (match kind land 0xF with 0x01 -> MK3Normal | 0x02 -> MK3Getter | 0x03 -> MK3Setter | _ -> assert false);
+			}
+		| 0x04 ->
+			let c = index_nz ctx.as3_classes (read_int ch) in
+			A3FClass c
+		| 0x05 ->
+			let f = index_nz ctx.as3_method_types (read_int ch) in
+			A3FFunction f
+		| _ ->
+			assert false
+	) in
+	let metas = (if has_meta then
+		Some (read_list2 ch (fun _ -> index_nz ctx.as3_metadatas (read_int ch)))
+	else
+		None
+	) in
+	{
+		f3_name = name;
+		f3_slot = slot;
+		f3_kind = kind;
+		f3_metas = metas;
+	}
+
+let read_class ctx ch =
+	let name = index ctx.as3_names (read_int ch) in
+	let csuper = index_opt ctx.as3_names (read_int ch) in
+	let flags = IO.read_byte ch in
+	let namespace =
+		if flags land 8 <> 0 then
+			let r = index ctx.as3_namespaces (read_int ch) in
+			Some r
+		else
+			None
+	in
+	let impls = read_list2 ch (fun _ -> index ctx.as3_names (read_int ch)) in
+	let construct = index_nz ctx.as3_method_types (read_int ch) in
+	let fields = read_list2 ch (read_field ctx) in
+	{
+		cl3_name = name;
+		cl3_super = csuper;
+		cl3_sealed = (flags land 1) <> 0;
+		cl3_final = (flags land 2) <> 0;
+		cl3_interface = (flags land 4) <> 0;
+		cl3_namespace = namespace;
+		cl3_implements = impls;
+		cl3_construct = construct;
+		cl3_fields = fields;
+	}
+
+let read_static ctx ch =
+	let meth = index_nz ctx.as3_method_types (read_int ch) in
+	let fields = read_list2 ch (read_field ctx) in
+	{
+		st3_method = meth;
+		st3_fields = fields;
+	}
+
+let read_metadata ctx ch =
+	let name = index ctx.as3_idents (read_int ch) in
+	let data = read_list2 ch (fun _ -> index_opt ctx.as3_idents (read_int ch)) in
+	let data = Array.map (fun i1 -> i1 , index ctx.as3_idents (read_int ch)) data in
+	{
+		meta3_name = name;
+		meta3_data = data;
+	}
+
+let read_try_catch ctx ch =
+	let start = read_int ch in
+	let pend = read_int ch in
+	let handle = read_int ch in
+	let t = index_opt ctx.as3_names (read_int ch) in
+	let name = index_opt ctx.as3_names (read_int ch) in
+	{
+		tc3_start = start;
+		tc3_end = pend;
+		tc3_handle = handle;
+		tc3_type = t;
+		tc3_name = name;
+	}
+
+let read_function ctx ch =
+	let id = index_nz ctx.as3_method_types (read_int ch) in
+	let ss = read_int ch in
+	let nregs = read_int ch in
+	let init_scope = read_int ch in
+	let max_scope = read_int ch in
+	let size = read_int ch in
+	let code = if parse_bytecode then As3code.parse ch size else MultiArray.init size (fun _ -> A3Unk (IO.read ch)) in
+	let trys = read_list2 ch (read_try_catch ctx) in
+	let local_funs = read_list2 ch (read_field ctx) in
+	{
+		fun3_id = id;
+		fun3_stack_size = ss;
+		fun3_nregs = nregs;
+		fun3_init_scope = init_scope;
+		fun3_max_scope = max_scope;
+		fun3_code = code;
+		fun3_trys = trys;
+		fun3_locals = local_funs;
+	}
+
+let header_magic = 0x002E0010
+
+let parse ch len =
+	let ch, get_pos = IO.pos_in ch in
+	if IO.read_i32 ch <> header_magic then assert false;
+	let ints = read_list ch read_as3_int in
+	let uints = read_list ch read_as3_uint in
+	let floats = read_list ch IO.read_double in
+	let idents = (if parse_idents then read_list ch read_ident else [||]) in
+	let idents = (if parse_idents then begin if ExtArray.Array.exists (fun i -> i="") idents then idents else Array.append idents [|""|] end else [||]) in
+	let namespaces = (if parse_namespaces then read_list ch (read_namespace idents) else [||]) in
+	let nsets = (if parse_ns_sets then read_list ch (read_ns_set namespaces) else [||]) in
+	let ctx = {
+		as3_ints = ints;
+		as3_uints = uints;
+		as3_floats = floats;
+		as3_idents = idents;
+		as3_namespaces = namespaces;
+		as3_nsets = nsets;
+		as3_names = [||];
+		as3_method_types = [||];
+		as3_metadatas = [||];
+		as3_classes = [||];
+		as3_statics = [||];
+		as3_inits = [||];
+		as3_functions = [||];
+		as3_unknown = "";
+	} in
+	if parse_names then ctx.as3_names <- read_list ch (read_name ctx);
+	if parse_mtypes then ctx.as3_method_types <- read_list2 ch (read_method_type ctx);
+	if parse_metadata then ctx.as3_metadatas <- read_list2 ch (read_metadata ctx);
+	if parse_classes then ctx.as3_classes <- read_list2 ch (read_class ctx);
+	if parse_statics then ctx.as3_statics <- Array.map (fun _ -> read_static ctx ch) ctx.as3_classes;
+	if parse_inits then ctx.as3_inits <- read_list2 ch (read_static ctx);
+	if parse_functions then ctx.as3_functions <- read_list2 ch (read_function ctx);
+	ctx.as3_unknown <- IO.really_nread_string ch (len - (get_pos()));
+	if parse_functions && String.length ctx.as3_unknown <> 0 then assert false;
+(*	let len2 = as3_length ctx in
+	if len2 <> len then begin Printf.printf "%d != %d" len len2; assert false; end;
+*)	ctx
+
+(* ************************************************************************ *)
+(* WRITING *)
+
+let write_as3_int ch i =
+	let e = Int32.to_int (Int32.shift_right_logical i 28) in
+	let d = Int32.to_int (Int32.shift_right i 21) land 0x7F in
+	let c = Int32.to_int (Int32.shift_right i 14) land 0x7F in
+	let b = Int32.to_int (Int32.shift_right i 7) land 0x7F in
+	let a = Int32.to_int (Int32.logand i 0x7Fl) in
+	if b <> 0 || c <> 0 || d <> 0 || e <> 0 then begin
+		IO.write_byte ch (a lor 0x80);
+		if c <> 0 || d <> 0 || e <> 0 then begin
+			IO.write_byte ch (b lor 0x80);
+			if d <> 0 || e <> 0 then begin
+				IO.write_byte ch (c lor 0x80);
+				if e <> 0 then begin
+					IO.write_byte ch (d lor 0x80);
+					IO.write_byte ch e;
+				end else
+					IO.write_byte ch d;
+			end else
+				IO.write_byte ch c;
+		end else
+			IO.write_byte ch b;
+	end else
+		IO.write_byte ch a
+
+let write_as3_uint = write_as3_int
+
+let write_int ch i =
+	write_as3_int ch (Int32.of_int i)
+
+let write_index ch n =
+	write_int ch (index_int n)
+
+let write_index_nz ch n =
+	write_int ch (index_nz_int n)
+
+let write_index_opt ch = function
+	| None -> write_int ch 0
+	| Some n -> write_index ch n
+
+let write_as3_ident ch id =
+	write_int ch (String.length id);
+	IO.nwrite_string ch id
+
+let write_namespace empty_index ch = function
+	| A3NPrivate n ->
+		IO.write_byte ch 0x05;
+		(match n with
+		| None -> write_int ch 0
+		| Some n -> write_index ch n);
+	| A3NPublic n ->
+		IO.write_byte ch 0x16;
+		(match n with
+		| None -> write_index ch empty_index
+		| Some n -> write_index ch n);
+	| A3NInternal n ->
+		IO.write_byte ch 0x17;
+		(match n with
+		| None -> write_index ch empty_index
+		| Some n -> write_index ch n);
+	| A3NProtected n ->
+		IO.write_byte ch 0x18;
+		write_index ch n
+	| A3NNamespace n ->
+		IO.write_byte ch 0x08;
+		write_index ch n
+	| A3NExplicit n ->
+		IO.write_byte ch 0x19;
+		write_index ch n
+	| A3NStaticProtected n ->
+		IO.write_byte ch 0x1A;
+		(match n with
+		| None -> write_int ch 0
+		| Some n -> write_index ch n)
+
+let write_rights ch l =
+	IO.write_byte ch (List.length l);
+	List.iter (write_index ch) l
+
+let rec write_name ch ?k x =
+	let b n = match k with None -> n | Some v -> v in
+	match x with
+	| A3MMultiName (id,r) ->
+		IO.write_byte ch (b 0x09);
+		write_index_opt ch id;
+		write_index ch r;
+	| A3MName (id,r) ->
+		IO.write_byte ch (b 0x07);
+		write_index ch r;
+		write_index ch id
+	| A3MNSAny(id) ->
+		IO.write_byte ch (b 0x07);
+		write_int ch 0;
+		write_index ch id;
+	| A3MAny ->
+		IO.write_byte ch (b 0x07);
+		write_int ch 0;
+		write_int ch 0;
+	| A3MRuntimeName i ->
+		IO.write_byte ch (b 0x0F);
+		write_index ch i
+	| A3MRuntimeNameLate ->
+		IO.write_byte ch (b 0x11);
+	| A3MMultiNameLate id ->
+		IO.write_byte ch (b 0x1B);
+		write_index ch id
+	| A3MAttrib n ->
+		write_name ch ~k:(match n with
+			| A3MName _ | A3MNSAny _ | A3MAny -> 0x0D
+			| A3MMultiName _ -> 0x0E
+			| A3MRuntimeName _ -> 0x10
+			| A3MRuntimeNameLate -> 0x12
+			| A3MMultiNameLate _ -> 0x1C
+			| A3MAttrib _ | A3MParams _ -> assert false
+		) n
+	| A3MParams (id,pl) ->
+		IO.write_byte ch (b 0x1D);
+		write_index ch id;
+		IO.write_byte ch (List.length pl);
+		List.iter (write_index ch) pl
+
+let write_value ch extra v =
+	match v with
+	| A3VNone ->
+		IO.write_byte ch 0x00;
+		if extra then IO.write_byte ch 0x00;
+	| A3VNull ->
+		IO.write_byte ch 0x0C;
+		IO.write_byte ch 0x0C;
+	| A3VBool b ->
+		IO.write_byte ch (if b then 0x0B else 0x0A);
+		IO.write_byte ch (if b then 0x0B else 0x0A);
+	| A3VString s ->
+		write_index ch s;
+		IO.write_byte ch 0x01;
+	| A3VInt s ->
+		write_index ch s;
+		IO.write_byte ch 0x03;
+	| A3VUInt s ->
+		write_index ch s;
+		IO.write_byte ch 0x04;
+	| A3VFloat s ->
+		write_index ch s;
+		IO.write_byte ch 0x06
+	| A3VNamespace (n,s) ->
+		write_index ch s;
+		IO.write_byte ch n
+
+let write_method_type ch m =
+	let nargs = List.length m.mt3_args in
+	IO.write_byte ch nargs;
+	write_index_opt ch m.mt3_ret;
+	List.iter (write_index_opt ch) m.mt3_args;
+	write_index_opt ch m.mt3_debug_name;
+	let flags =
+		(if m.mt3_arguments_defined then 0x01 else 0) lor
+		(if m.mt3_new_block then 0x02 else 0) lor
+		(if m.mt3_var_args then 0x04 else 0) lor
+		(if m.mt3_dparams <> None then 0x08 else 0) lor
+		(if m.mt3_unused_flag then 0x10 else 0) lor
+		(if m.mt3_native then 0x20 else 0) lor
+		(if m.mt3_uses_dxns then 0x40 else 0) lor
+		(if m.mt3_pnames <> None then 0x80 else 0)
+	in
+	IO.write_byte ch flags;
+	(match m.mt3_dparams with
+	| None -> ()
+	| Some l ->
+		IO.write_byte ch (List.length l);
+		List.iter (write_value ch true) l);
+	match m.mt3_pnames with
+	| None -> ()
+	| Some l ->
+		if List.length l <> nargs then assert false;
+		List.iter (write_index_opt ch) l
+
+let write_list ch f l =
+	match Array.length l with
+	| 0 -> IO.write_byte ch 0
+	| n ->
+		write_int ch (n + 1);
+		Array.iter (f ch) l
+
+let write_list2 ch f l =
+	write_int ch (Array.length l);
+	Array.iter (f ch) l
+
+let write_field ch f =
+	write_index ch f.f3_name;
+	let flags = (if f.f3_metas <> None then 0x40 else 0) in
+	(match f.f3_kind with
+	| A3FMethod m ->
+		let base = (match m.m3_kind with MK3Normal -> 0x01 | MK3Getter -> 0x02 | MK3Setter -> 0x03) in
+		let flags = flags lor (if m.m3_final then 0x10 else 0) lor (if m.m3_override then 0x20 else 0) in
+		IO.write_byte ch (base lor flags);
+		write_int ch f.f3_slot;
+		write_index_nz ch m.m3_type;
+	| A3FClass c ->
+		IO.write_byte ch (0x04 lor flags);
+		write_int ch f.f3_slot;
+		write_index_nz ch c
+	| A3FFunction i ->
+		IO.write_byte ch (0x05 lor flags);
+		write_int ch f.f3_slot;
+		write_index_nz ch i
+	| A3FVar v ->
+		IO.write_byte ch (flags lor (if v.v3_const then 0x06 else 0x00));
+		write_int ch f.f3_slot;
+		write_index_opt ch v.v3_type;
+		write_value ch false v.v3_value);
+	match f.f3_metas with
+	| None -> ()
+	| Some l ->
+		write_list2 ch write_index_nz l
+
+let write_class ch c =
+	write_index ch c.cl3_name;
+	write_index_opt ch c.cl3_super;
+	let flags =
+		(if c.cl3_sealed then 1 else 0) lor
+		(if c.cl3_final then 2 else 0) lor
+		(if c.cl3_interface then 4 else 0) lor
+		(if c.cl3_namespace <> None then 8 else 0)
+	in
+	IO.write_byte ch flags;
+	(match c.cl3_namespace with
+	| None -> ()
+	| Some r -> write_index ch r);
+	write_list2 ch write_index c.cl3_implements;
+	write_index_nz ch c.cl3_construct;
+	write_list2 ch write_field c.cl3_fields
+
+let write_static ch s =
+	write_index_nz ch s.st3_method;
+	write_list2 ch write_field s.st3_fields
+
+let write_metadata ch m =
+	write_index ch m.meta3_name;
+	write_list2 ch (fun _ (i1,_) -> write_index_opt ch i1) m.meta3_data;
+	Array.iter (fun (_,i2) -> write_index ch i2) m.meta3_data
+
+let write_try_catch ch t =
+	write_int ch t.tc3_start;
+	write_int ch t.tc3_end;
+	write_int ch t.tc3_handle;
+	write_index_opt ch t.tc3_type;
+	write_index_opt ch t.tc3_name
+
+let write_function ch f =
+	write_index_nz ch f.fun3_id;
+	write_int ch f.fun3_stack_size;
+	write_int ch f.fun3_nregs;
+	write_int ch f.fun3_init_scope;
+	write_int ch f.fun3_max_scope;
+	let clen = MultiArray.fold_left (fun acc op -> acc + As3code.length op) 0 f.fun3_code in
+	write_int ch clen;
+	MultiArray.iter (As3code.write ch) f.fun3_code;
+	write_list2 ch write_try_catch f.fun3_trys;
+	write_list2 ch write_field f.fun3_locals
+
+let write ch1 ctx =
+	let ch = IO.output_strings() in
+	let empty_index = as3_empty_index ctx in
+	IO.write_i32 ch header_magic;
+	write_list ch write_as3_int ctx.as3_ints;
+	write_list ch write_as3_uint ctx.as3_uints;
+	write_list ch IO.write_double ctx.as3_floats;
+	if parse_idents then write_list ch write_as3_ident ctx.as3_idents;
+	if parse_namespaces then write_list ch (write_namespace empty_index) ctx.as3_namespaces;
+	if parse_ns_sets then write_list ch write_rights ctx.as3_nsets;
+	if parse_names then write_list ch (write_name ?k:None) ctx.as3_names;
+	if parse_mtypes then write_list2 ch write_method_type ctx.as3_method_types;
+	if parse_metadata then write_list2 ch write_metadata ctx.as3_metadatas;
+	if parse_classes then write_list2 ch write_class ctx.as3_classes;
+	if parse_statics then Array.iter (write_static ch) ctx.as3_statics;
+	if parse_inits then write_list2 ch write_static ctx.as3_inits;
+	if parse_functions then write_list2 ch write_function ctx.as3_functions;
+	IO.nwrite_string ch ctx.as3_unknown;
+	let str = IO.close_out ch in
+	List.iter (IO.nwrite_string ch1) str
+
+(* ************************************************************************ *)
+(* DUMP *)
+
+let dump_code_size = ref true
+
+let ident_str ctx i =
+	iget ctx.as3_idents i
+
+let namespace_str ctx i =
+	match iget ctx.as3_namespaces i with
+	| A3NPrivate None -> "private"
+	| A3NPrivate (Some n) -> "private:" ^ ident_str ctx n
+	| A3NPublic None -> "public"
+	| A3NPublic (Some n) -> "public:" ^ ident_str ctx n
+	| A3NInternal None -> "internal"
+	| A3NInternal (Some n) -> "internal:" ^ ident_str ctx n
+	| A3NProtected n -> "protected:" ^ ident_str ctx n
+	| A3NExplicit n -> "explicit:" ^ ident_str ctx n
+	| A3NStaticProtected None -> "static_protected"
+	| A3NStaticProtected (Some n) -> "static_protectec:" ^ ident_str ctx n
+	| A3NNamespace n -> "namespace:" ^ ident_str ctx n
+
+let ns_set_str ctx i =
+	let l = iget ctx.as3_nsets i in
+	String.concat " " (List.map (fun r -> namespace_str ctx r) l)
+
+let rec name_str ctx kind t =
+	let rec loop = function
+		| A3MName (id,r) -> Printf.sprintf "%s %s%s" (namespace_str ctx r) kind (ident_str ctx id)
+		| A3MNSAny (id) -> Printf.sprintf "%s %s%s" "ANY" kind (ident_str ctx id)
+		| A3MAny -> "ANY"
+		| A3MMultiName (id,r) -> Printf.sprintf "[%s %s%s]" (ns_set_str ctx r) kind (match id with None -> "NO" | Some i -> ident_str ctx i)
+		| A3MRuntimeName id -> Printf.sprintf "'%s'" (ident_str ctx id)
+		| A3MRuntimeNameLate -> "RTLATE"
+		| A3MMultiNameLate id -> Printf.sprintf "late:(%s)" (ns_set_str ctx id)
+		| A3MAttrib n -> "attrib " ^ loop n
+		| A3MParams (id,pl) -> Printf.sprintf "%s<%s>" (name_str ctx kind id) (String.concat "," (List.map (name_str ctx kind) pl))
+	in
+	loop (iget ctx.as3_names t)
+
+let value_str ctx v =
+	match v with
+	| A3VNone -> "<none>"
+	| A3VNull -> "null"
+	| A3VString s -> "\"" ^ ident_str ctx s ^ "\""
+	| A3VBool b -> if b then "true" else "false"
+	| A3VInt s -> Printf.sprintf "%ld" (iget ctx.as3_ints s)
+	| A3VUInt s -> Printf.sprintf "%ld" (iget ctx.as3_uints s)
+	| A3VFloat s -> Printf.sprintf "%f" (iget ctx.as3_floats s)
+	| A3VNamespace (_,s) -> "ns::" ^ namespace_str ctx s
+
+let metadata_str ctx i =
+	let m = iget ctx.as3_metadatas i in
+	let data = List.map (fun (i1,i2) -> Printf.sprintf "%s=\"%s\"" (match i1 with None -> "NO" | Some i -> ident_str ctx i) (ident_str ctx i2)) (Array.to_list m.meta3_data) in
+	Printf.sprintf "%s(%s)" (ident_str ctx m.meta3_name) (String.concat ", " data)
+
+let method_str ?(infos=false) ctx m =
+	let m = iget ctx.as3_method_types m in
+	let pcount = ref 0 in
+	Printf.sprintf "%s(%s%s)%s"
+	(if m.mt3_native then " native " else "")
+	(String.concat ", " (List.map (fun a ->
+		let id = (match m.mt3_pnames with
+			| None -> "p" ^ string_of_int !pcount
+			| Some l ->
+				match List.nth l !pcount with
+				| None -> "p" ^ string_of_int !pcount
+				| Some i -> ident_str ctx i
+		) in
+		let p = (match a with None -> id | Some t -> name_str ctx (id ^ " : ") t) in
+
+		let p = (match m.mt3_dparams with
+		| None -> p
+		| Some l ->
+			let vargs = List.length m.mt3_args - List.length l in
+			if !pcount >= vargs then
+				let v = List.nth l (!pcount - vargs) in
+				p  ^ " = " ^ value_str ctx v
+			else
+				p
+		) in
+		incr pcount;
+		p
+	) m.mt3_args))
+	(if m.mt3_var_args then " ..." else "")
+	(match m.mt3_ret with None -> "" | Some t -> " : " ^ name_str ctx "" t)
+	^ (if infos then begin
+		let name = (match m.mt3_debug_name with None -> "" | Some idx -> Printf.sprintf " '%s'" (ident_str ctx idx))  in
+		Printf.sprintf "%s blk:%b args:%b dxns:%b%s" name m.mt3_new_block m.mt3_arguments_defined m.mt3_uses_dxns (if m.mt3_unused_flag then " SPECIAL-FLAG" else "")
+	end else "")
+
+let dump_field ctx ch stat f =
+(*	(match f.f3_metas with
+	| None -> ()
+	| Some l -> Array.iter (fun i -> IO.printf ch "    [%s]\n" (metadata_str ctx (no_nz i))) l);
+*)	IO.printf ch "    ";
+	if stat then IO.printf ch "static ";
+	(match f.f3_kind with
+	| A3FVar v ->
+		IO.printf ch "%s" (name_str ctx (if v.v3_const then "const " else "var ") f.f3_name);
+		(match v.v3_type with
+		| None -> ()
+		| Some id -> IO.printf ch " : %s" (name_str ctx "" id));
+		if v.v3_value <> A3VNone then IO.printf ch " = %s" (value_str ctx v.v3_value);
+	| A3FClass c ->
+		let c = iget ctx.as3_classes (no_nz c) in
+		IO.printf ch "%s = %s" (name_str ctx "CLASS " c.cl3_name) (name_str ctx "class " f.f3_name);
+	| A3FFunction id ->
+		IO.printf ch "%s = %s" (method_str ~infos:false ctx (no_nz id)) (name_str ctx "method " f.f3_name);
+	| A3FMethod m ->
+		if m.m3_final then IO.printf ch "final ";
+		if m.m3_override then IO.printf ch "override ";
+		let k = "function " ^ (match m.m3_kind with
+			| MK3Normal -> ""
+			| MK3Getter -> "get "
+			| MK3Setter -> "set "
+		) in
+		IO.printf ch "%s%s #%d" (name_str ctx k f.f3_name) (method_str ctx (no_nz m.m3_type)) (index_nz_int m.m3_type);
+	);
+	if f.f3_slot <> 0 then IO.printf ch " = [SLOT:%d]" f.f3_slot;
+	IO.printf ch ";\n"
+
+let dump_class ctx ch idx c =
+	let st = if parse_statics then ctx.as3_statics.(idx) else { st3_method = magic_index_nz (-1); st3_fields = [||] } in
+	if not c.cl3_sealed then IO.printf ch "dynamic ";
+	if c.cl3_final then IO.printf ch "final ";
+	(match c.cl3_namespace with
+	| None -> ()
+	| Some r -> IO.printf ch "%s " (namespace_str ctx r));
+	let kind = (if c.cl3_interface then "interface " else "class ") in
+	IO.printf ch "%s " (name_str ctx kind c.cl3_name);
+	(match c.cl3_super with
+	| None -> ()
+	| Some s -> IO.printf ch "extends %s " (name_str ctx "" s));
+	(match Array.to_list c.cl3_implements with
+	| [] -> ()
+	| l ->
+		IO.printf ch "implements %s " (String.concat ", " (List.map (fun i -> name_str ctx "" i) l)));
+	IO.printf ch "{\n";
+	Array.iter (dump_field ctx ch false) c.cl3_fields;
+	Array.iter (dump_field ctx ch true) st.st3_fields;
+	IO.printf ch "} constructor#%d statics#%d\n\n" (index_nz_int c.cl3_construct) (index_nz_int st.st3_method)
+
+let dump_init ctx ch idx s =
+	IO.printf ch "init #%d {\n" (index_nz_int s.st3_method);
+	Array.iter (dump_field ctx ch false) s.st3_fields;
+	IO.printf ch "}\n\n"
+
+let dump_try_catch ctx ch t =
+	IO.printf ch "    try %d %d %d (%s) (%s)\n"
+		t.tc3_start t.tc3_end t.tc3_handle
+		(match t.tc3_type with None -> "*" | Some idx -> name_str ctx "" idx)
+		(match t.tc3_name with None -> "NO" | Some idx -> name_str ctx "" idx)
+
+let dump_function ctx ch idx f =
+	IO.printf ch "function #%d %s\n" (index_nz_int f.fun3_id) (method_str ~infos:true ctx (no_nz f.fun3_id));
+	IO.printf ch "    stack:%d nregs:%d scope:%d-%d\n" f.fun3_stack_size f.fun3_nregs f.fun3_init_scope f.fun3_max_scope;
+	Array.iter (dump_field ctx ch false) f.fun3_locals;
+	Array.iter (dump_try_catch ctx ch) f.fun3_trys;
+	let pos = ref 0 in
+	MultiArray.iter (fun op ->
+		IO.printf ch "%4d    %s\n" !pos (As3code.dump ctx op);
+		if !dump_code_size then pos := !pos + As3code.length op else incr pos;
+	) f.fun3_code;
+	IO.printf ch "\n"
+
+let dump_ident ctx ch idx _ =
+	IO.printf ch "I%d = %s\n" (idx + 1) (ident_str ctx (index ctx.as3_idents (idx + 1)))
+
+let dump_namespace ctx ch idx _ =
+	IO.printf ch "N%d = %s\n" (idx + 1) (namespace_str ctx (index ctx.as3_namespaces (idx + 1)))
+
+let dump_ns_set ctx ch idx _ =
+	IO.printf ch "S%d = %s\n" (idx + 1) (ns_set_str ctx (index ctx.as3_nsets (idx + 1)))
+
+let dump_name ctx ch idx _ =
+	IO.printf ch "T%d = %s\n" (idx + 1) (name_str ctx "" (index ctx.as3_names (idx + 1)))
+
+let dump_method_type ctx ch idx _ =
+	IO.printf ch "M%d = %s\n" (idx + 1) (method_str ~infos:true ctx (index ctx.as3_method_types (idx + 1)))
+
+let dump_metadata ctx ch idx _ =
+	IO.printf ch "D%d = %s\n" (idx + 1) (metadata_str ctx (index ctx.as3_metadatas (idx + 1)))
+
+let dump_int ctx ch idx i =
+	IO.printf ch "INT %d = 0x%lX\n" (idx + 1) i
+
+let dump_float ctx ch idx f =
+	IO.printf ch "FLOAT %d = %f\n" (idx + 1) f
+
+let dump ch ctx id =
+	(match id with
+	| None -> IO.printf ch "\n---------------- AS3 -------------------------\n\n";
+	| Some (id,f) -> IO.printf ch "\n---------------- AS3 %s [%d] -----------------\n\n" f id);
+(*	Array.iteri (dump_int ctx ch) ctx.as3_ints;
+	Array.iteri (dump_float ctx ch) ctx.as3_floats;
+	Array.iteri (dump_ident ctx ch) ctx.as3_idents;
+	IO.printf ch "\n";
+	Array.iteri (dump_namespace ctx ch) ctx.as3_namespaces;
+	IO.printf ch "\n";
+	Array.iteri (dump_ns_set ctx ch) ctx.as3_nsets;
+	IO.printf ch "\n";
+	Array.iteri (dump_name ctx ch) ctx.as3_names;
+	IO.printf ch "\n"; *)
+(*	Array.iteri (dump_metadata ctx ch) ctx.as3_metadatas; *)
+	Array.iteri (dump_class ctx ch) ctx.as3_classes;
+	Array.iteri (dump_init ctx ch) ctx.as3_inits;
+	Array.iteri (dump_function ctx ch) ctx.as3_functions;
+	IO.printf ch "\n"
+
+;;
+As3code.f_int_length := int_length;
+As3code.f_int_read := read_int;
+As3code.f_int_write := write_int;

libs/swflib/png.ml

@@ -0,0 +1,393 @@
+(*
+ *  PNG File Format Library
+ *  Copyright (c)2005 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+
+type grey_bits =
+	| GBits1
+	| GBits2
+	| GBits4
+	| GBits8
+	| GBits16
+
+type grey_alpha_bits =
+	| GABits8
+	| GABits16
+
+type true_bits =
+	| TBits8
+	| TBits16
+
+type index_bits =
+	| IBits1
+	| IBits2
+	| IBits4
+	| IBits8
+
+type alpha =
+	| NoAlpha
+	| HaveAlpha
+
+type color =
+	| ClGreyScale of grey_bits
+	| ClGreyAlpha of grey_alpha_bits
+	| ClTrueColor of true_bits * alpha
+	| ClIndexed of index_bits
+
+type header = {
+	png_width : int;
+	png_height : int;
+	png_color : color;
+	png_interlace : bool;
+}
+
+type chunk_id = string
+
+type chunk =
+	| CEnd
+	| CHeader of header
+	| CData of string
+	| CPalette of string
+	| CUnknown of chunk_id * string
+
+type png = chunk list
+
+type error_msg =
+	| Invalid_header
+	| Invalid_file
+	| Truncated_file
+	| Invalid_CRC
+	| Invalid_colors
+	| Unsupported_colors
+	| Invalid_datasize
+	| Invalid_filter of int
+	| Invalid_array
+
+exception Error of error_msg
+
+let error_msg = function
+	| Invalid_header -> "Invalid header"
+	| Invalid_file -> "Invalid file"
+	| Truncated_file -> "Truncated file"
+	| Invalid_CRC -> "Invalid CRC"
+	| Invalid_colors -> "Invalid color model"
+	| Unsupported_colors -> "Unsupported color model"
+	| Invalid_datasize -> "Invalid data size"
+	| Invalid_filter f -> "Invalid filter " ^ string_of_int f
+	| Invalid_array -> "Invalid array"
+
+let error msg = raise (Error msg)
+
+let is_upper c = ((int_of_char c) land 32) <> 0
+
+let is_critical id = is_upper id.[0]
+
+let is_public id = is_upper id.[1]
+
+let is_reseverd id = is_upper id.[2]
+
+let is_safe_to_copy id = is_upper id.[3]
+
+let is_id_char c =
+	(c >= '\065' && c <= '\090') || (c >= '\097' && c <= '\122')
+
+let rec header = function
+	| [] -> error Invalid_file
+	| CHeader h :: _ -> h
+	| _ :: l -> header l
+
+let data f =
+	let rec loop acc = function
+		| [] ->
+			(match List.rev acc with
+			| [] -> error Invalid_file
+			| l -> String.concat "" l)
+		| CData s :: l -> loop (s :: acc) l
+		| _ :: l -> loop acc l
+	in
+	loop [] f
+
+let color_bits = function
+	| ClGreyScale g -> (match g with
+		| GBits1 -> 1
+		| GBits2 -> 2
+		| GBits4 -> 4
+		| GBits8 -> 8
+		| GBits16 -> 16)
+	| ClGreyAlpha g -> (match g with
+		| GABits8 -> 8
+		| GABits16 -> 16)
+	| ClTrueColor (t,_) -> (match t with
+		| TBits8 -> 8
+		| TBits16 -> 16)
+	| ClIndexed i -> (match i with
+		| IBits1 -> 1
+		| IBits2 -> 2
+		| IBits4 -> 4
+		| IBits8 -> 8)
+
+let crc_table = Array.init 256 (fun n ->
+	let c = ref (Int32.of_int n) in
+	for k = 0 to 7 do
+		if Int32.logand !c 1l <> 0l then
+			c := Int32.logxor 0xEDB88320l (Int32.shift_right_logical !c 1)
+		else
+			c := (Int32.shift_right_logical !c 1);
+	done;
+	!c)
+
+let input_crc ch =
+	let crc = ref 0xFFFFFFFFl in
+	let update c =
+		let c = Int32.of_int (int_of_char c) in
+		let k = Array.unsafe_get crc_table (Int32.to_int (Int32.logand (Int32.logxor !crc c) 0xFFl)) in
+		crc := Int32.logxor k (Int32.shift_right_logical !crc 8)
+	in
+	let ch2 = IO.create_in
+		~read:(fun () ->
+			let c = IO.read ch in
+			update c;
+			c
+		)
+		~input:(fun s p l ->
+			let l = IO.input ch s p l in
+			for i = 0 to l - 1 do
+				update (Bytes.get s (p+i))
+			done;
+			l
+		)
+		~close:(fun () ->
+			IO.close_in ch
+		)
+	in
+	ch2 , (fun () -> Int32.logxor !crc 0xFFFFFFFFl)
+
+let output_crc ch =
+	let crc = ref 0xFFFFFFFFl in
+	let update c =
+		let c = Int32.of_int (int_of_char c) in
+		let k = Array.unsafe_get crc_table (Int32.to_int (Int32.logand (Int32.logxor !crc c) 0xFFl)) in
+		crc := Int32.logxor k (Int32.shift_right_logical !crc 8)
+	in
+	let ch2 = IO.create_out
+		~write:(fun c ->
+			IO.write ch c;
+			update c;
+		)
+		~output:(fun s p l ->
+			let l = IO.output ch s p l in
+			for i = 0 to l - 1 do
+				update (Bytes.get s (p+i))
+			done;
+			l
+		)
+		~flush:(fun () ->
+			IO.flush ch
+		)
+		~close:(fun () ->
+			IO.close_out ch
+		)
+	in
+	ch2 , (fun () -> Int32.logxor !crc 0xFFFFFFFFl)
+
+let parse_header ch =
+	let width = IO.BigEndian.read_i32 ch in
+	let height = IO.BigEndian.read_i32 ch in
+	if width < 0 || height < 0 then error Invalid_header;
+	let bits = IO.read_byte ch in
+	let color = IO.read_byte ch in
+	let color = (match color with
+		| 0 -> ClGreyScale (match bits with 1 -> GBits1 | 2 -> GBits2 | 4 -> GBits4 | 8 -> GBits8 | 16 -> GBits16 | _ -> error Invalid_colors)
+		| 2 -> ClTrueColor ((match bits with 8 -> TBits8 | 16 -> TBits16 | _ -> error Invalid_colors) , NoAlpha)
+		| 3 -> ClIndexed (match bits with 1 -> IBits1 | 2 -> IBits2 | 4 -> IBits4 | 8 -> IBits8 | _ -> error Invalid_colors)
+		| 4 -> ClGreyAlpha (match bits with 8 -> GABits8 | 16 -> GABits16 | _ -> error Invalid_colors)
+		| 6 -> ClTrueColor ((match bits with 8 -> TBits8 | 16 -> TBits16 | _ -> error Invalid_colors) , HaveAlpha)
+		| _ -> error Invalid_colors)
+	in
+	let compress = IO.read_byte ch in
+	let filter = IO.read_byte ch in
+	if compress <> 0 || filter <> 0 then error Invalid_header;
+	let interlace = IO.read_byte ch in
+	let interlace = (match interlace with 0 -> false | 1 -> true | _ -> error Invalid_header) in
+	{
+		png_width = width;
+		png_height = height;
+		png_color = color;
+		png_interlace = interlace;
+	}
+
+let parse_chunk ch =
+	let len = IO.BigEndian.read_i32 ch in
+	let ch2 , crc = input_crc ch in
+	let id = IO.nread_string ch2 4 in
+	if len < 0 || not (is_id_char id.[0]) || not (is_id_char id.[1]) || not (is_id_char id.[2]) || not (is_id_char id.[3]) then error Invalid_file;
+	let data = IO.nread_string ch2 len in
+	let crc_val = IO.BigEndian.read_real_i32 ch in
+	if crc_val <> crc() then error Invalid_CRC;
+	match id with
+	| "IEND" -> CEnd
+	| "IHDR" -> CHeader (parse_header (IO.input_string data))
+	| "IDAT" -> CData data
+	| "PLTE" -> CPalette data
+	| _ -> CUnknown (id,data)
+
+let png_sign = "\137\080\078\071\013\010\026\010"
+
+let parse ch =
+	let sign = (try IO.nread_string ch (String.length png_sign) with IO.No_more_input -> error Invalid_header) in
+	if sign <> png_sign then error Invalid_header;
+	let rec loop acc =
+		match parse_chunk ch with
+		| CEnd -> List.rev acc
+		| c -> loop (c :: acc)
+	in
+	try
+		loop []
+	with
+		| IO.No_more_input -> error Truncated_file
+		| IO.Overflow _ -> error Invalid_file
+
+let write_chunk ch cid cdata =
+	IO.BigEndian.write_i32 ch (String.length cdata);
+	let ch2 , crc = output_crc ch in
+	IO.nwrite_string ch2 cid;
+	IO.nwrite_string ch2 cdata;
+	IO.BigEndian.write_real_i32 ch (crc())
+
+let write_header real_ch h =
+	let ch = IO.output_string() in
+	IO.BigEndian.write_i32 ch h.png_width;
+	IO.BigEndian.write_i32 ch h.png_height;
+	IO.write_byte ch (color_bits h.png_color);
+	IO.write_byte ch (match h.png_color with
+		| ClGreyScale _ -> 0
+		| ClTrueColor (_,NoAlpha) -> 2
+		| ClIndexed _ -> 3
+		| ClGreyAlpha _ -> 4
+		| ClTrueColor (_,HaveAlpha) -> 6);
+	IO.write_byte ch 0;
+	IO.write_byte ch 0;
+	IO.write_byte ch (if h.png_interlace then 1 else 0);
+	let data = IO.close_out ch in
+	write_chunk real_ch "IHDR" data
+
+let write ch png =
+	IO.nwrite_string ch png_sign;
+	List.iter (function
+		| CEnd -> write_chunk ch "IEND" ""
+		| CHeader h -> write_header ch h
+		| CData s -> write_chunk ch "IDAT" s
+		| CPalette s -> write_chunk ch "PLTE" s
+		| CUnknown (id,data) -> write_chunk ch id data
+	) png
+
+let filter png data =
+	let head = header png in
+	let w = head.png_width in
+	let h = head.png_height in
+	match head.png_color with
+	| ClGreyScale _
+	| ClGreyAlpha _
+	| ClIndexed _
+	| ClTrueColor (TBits16,_) -> error Unsupported_colors
+	| ClTrueColor (TBits8,alpha) ->
+		let alpha = (match alpha with NoAlpha -> false | HaveAlpha -> true) in
+		let buf = Bytes.create (w * h * 4) in
+		let nbytes = if alpha then 4 else 3 in
+		let stride = nbytes * w + 1 in
+		if String.length data < h * stride then error Invalid_datasize;
+		let bp = ref 0 in
+		let get p = int_of_char (String.unsafe_get data p) in
+		let bget p = int_of_char (Bytes.unsafe_get buf p) in
+		let set v = Bytes.unsafe_set buf !bp (Char.unsafe_chr v); incr bp in
+		let filters = [|
+			(fun x y v -> v
+			);
+			(fun x y v ->
+				let v2 = if x = 0 then 0 else bget (!bp - 4) in
+				v + v2
+			);
+			(fun x y v ->
+				let v2 = if y = 0 then 0 else bget (!bp - 4*w) in
+				v + v2
+			);
+			(fun x y v ->
+				let v2 = if x = 0 then 0 else bget (!bp - 4) in
+				let v3 = if y = 0 then 0 else bget (!bp - 4*w) in
+				v + (v2 + v3) / 2
+			);
+			(fun x y v ->
+				let a = if x = 0 then 0 else bget (!bp - 4) in
+				let b = if y = 0 then 0 else bget (!bp - 4*w) in
+				let c = if x = 0 || y = 0 then 0 else bget (!bp - 4 - 4*w) in
+				let p = a + b - c in
+				let pa = abs (p - a) in
+				let pb = abs (p - b) in
+				let pc = abs (p - c) in
+				let d = (if pa <= pb && pa <= pc then a else if pb <= pc then b else c) in
+				v + d
+			);
+		|] in
+		for y = 0 to h - 1 do
+			let f = get (y * stride) in
+			let f = (if f < 5 then filters.(f) else error (Invalid_filter f)) in
+			for x = 0 to w - 1 do
+				let p = x * nbytes + y * stride in
+				if not alpha then begin
+					set 255;
+					for c = 1 to 3 do
+						let v = get (p + c) in
+						set (f x y v)
+					done;
+				end else begin
+					let v = get (p + 4) in
+					let a = f x y v in
+					set a;
+					for c = 1 to 3 do
+						let v = get (p + c) in
+						set (f x y v)
+					done;
+				end;
+			done;
+		done;
+		Bytes.to_string buf
+
+let make ~width ~height ~pixel ~compress =
+	let data = Bytes.create (width * height * 4 + height) in
+	let p = ref 0 in
+	let set v = Bytes.unsafe_set data !p (Char.unsafe_chr v); incr p in
+	for y = 0 to height - 1 do
+		set 0;
+		for x = 0 to width - 1 do
+			let c = pixel x y in
+			let ic = Int32.to_int c in
+			(* RGBA *)
+			set (ic lsr 16);
+			set (ic lsr 8);
+			set ic;
+			set (Int32.to_int (Int32.shift_right_logical c 24));
+		done;
+	done;
+	let data = Bytes.to_string data in
+	let data = compress data in
+	let header = {
+		png_width = width;
+		png_height = height;
+		png_color = ClTrueColor (TBits8,HaveAlpha);
+		png_interlace = false;
+	} in
+	[CHeader header; CData data; CEnd]

libs/swflib/png.mli

@@ -0,0 +1,97 @@
+(*
+ *  PNG File Format Library
+ *  Copyright (c)2005 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+
+type grey_bits =
+	| GBits1
+	| GBits2
+	| GBits4
+	| GBits8
+	| GBits16
+
+type grey_alpha_bits =
+	| GABits8
+	| GABits16
+
+type true_bits =
+	| TBits8
+	| TBits16
+
+type index_bits =
+	| IBits1
+	| IBits2
+	| IBits4
+	| IBits8
+
+type alpha =
+	| NoAlpha
+	| HaveAlpha
+
+type color =
+	| ClGreyScale of grey_bits
+	| ClGreyAlpha of grey_alpha_bits
+	| ClTrueColor of true_bits * alpha
+	| ClIndexed of index_bits
+
+type header = {
+	png_width : int;
+	png_height : int;
+	png_color : color;
+	png_interlace : bool;
+}
+
+type chunk_id = string
+
+type chunk =
+	| CEnd
+	| CHeader of header
+	| CData of string
+	| CPalette of string
+	| CUnknown of chunk_id * string
+
+type png = chunk list
+
+type error_msg =
+	| Invalid_header
+	| Invalid_file
+	| Truncated_file
+	| Invalid_CRC
+	| Invalid_colors
+	| Unsupported_colors
+	| Invalid_datasize
+	| Invalid_filter of int
+	| Invalid_array
+
+exception Error of error_msg
+
+val error_msg : error_msg -> string
+
+val is_critical : chunk_id -> bool
+val is_public : chunk_id -> bool
+val is_reseverd : chunk_id -> bool
+val is_safe_to_copy : chunk_id -> bool
+
+val header : png -> header
+val data : png -> string
+
+val color_bits : color -> int
+val parse : IO.input -> png
+val write : 'a IO.output -> png -> unit
+val filter : png -> string -> string
+
+val make : width:int -> height:int -> pixel:(int -> int -> int32) -> compress:(string -> string) -> png

libs/swflib/swf.ml

@@ -0,0 +1,678 @@
+(*
+ *  This file is part of SwfLib
+ *  Copyright (c)2004 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+type float16 = int
+
+type unknown = string
+
+type binary = string
+
+type action_count = int
+
+type rgb = {
+	cr : int;
+	cg : int;
+	cb : int;
+}
+
+type rgba = {
+	r : int;
+	g : int;
+	b : int;
+	a : int;
+}
+
+type color =
+	| ColorRGB of rgb
+	| ColorRGBA of rgba
+
+type gradient =
+	| GradientRGB of ((int * rgb) list * int)
+	| GradientRGBA of ((int * rgba) list * int)
+
+type rect = {
+	rect_nbits : int;
+	left : int;
+	right : int;
+	top : int;
+	bottom : int;
+}
+
+type big_rect = {
+	brect_nbits : int;
+	bleft : int list;
+	bright : int list;
+	btop : int list;
+	bbottom : int list;
+}
+
+type matrix_part = {
+	m_nbits : int;
+	mx : int;
+	my : int;
+}
+
+type matrix = {
+	scale : matrix_part option;
+	rotate : matrix_part option;
+	trans : matrix_part;
+}
+
+type color_transform_alpha = {
+	cxa_nbits : int;
+	cxa_add : rgba option;
+	cxa_mult : rgba option;
+}
+
+type function_decl = {
+	f_name : string;
+	f_args : string list;
+	mutable f_codelen : action_count;
+}
+
+type func2_flags =
+	| ThisRegister
+	| ThisNoVar
+	| ArgumentsRegister
+	| ArgumentsNoVar
+	| SuperRegister
+	| SuperNoVar
+	| RootRegister
+	| ParentRegister
+	| GlobalRegister
+
+type function_decl2 = {
+	f2_name : string;
+	f2_flags : func2_flags list;
+	f2_args : (int * string) list;
+	mutable f2_nregs : int;
+	mutable f2_codelen : action_count;
+}
+
+type try_style =
+	| TryRegister of int
+	| TryVariable of string
+
+type try_block = {
+	tr_style : try_style;
+	mutable tr_trylen : action_count;
+	mutable tr_catchlen : action_count option;
+	mutable tr_finallylen : action_count option
+}
+
+type push_item =
+	| PString of string
+	| PFloat of int32
+	| PNull
+	| PUndefined
+	| PReg of int
+	| PBool of bool
+	| PDouble of float
+	| PInt of int32
+	| PStack of int
+	| PStack2 of int
+
+type property =
+	| PX
+	| PY
+	| PXScale
+	| PYScale
+	| PCurrentFrame
+	| PTotalFrames
+	| PAlpha
+	| PVisible
+	| PWidth
+	| PHeight
+	| PRotation
+	| PTarget
+	| PFramesLoaded
+	| PName
+	| PDropTarget
+	| PUrl
+	| PHighQuality
+	| PFocusRect
+	| PSoundBufTime
+	| PQuality
+	| PXMouse
+	| PYMouse
+
+type action =
+	| AEnd
+
+	| ANextFrame
+	| APrevFrame
+	| APlay
+	| AStop
+	| AToggleHighQuality
+	| AStopSounds
+	| AAddNum
+	| ASubtract
+	| AMultiply
+	| ADivide
+	| ACompareNum
+	| AEqualNum
+	| ALogicalAnd
+	| ALogicalOr
+	| ANot
+	| AStringEqual
+	| AStringLength
+	| ASubString
+	| APop
+	| AToInt
+	| AEval
+	| ASet
+	| ATellTarget
+	| AStringAdd
+	| AGetProperty
+	| ASetProperty
+	| ADuplicateMC
+	| ARemoveMC
+	| ATrace
+	| AStartDrag
+	| AStopDrag
+	| AThrow
+	| ACast
+	| AImplements
+	| AFSCommand2
+	| ARandom
+	| AMBStringLength
+	| AOrd
+	| AChr
+	| AGetTimer
+	| AMBStringSub
+	| AMBOrd
+	| AMBChr
+	| ADeleteObj
+	| ADelete
+	| ALocalAssign
+	| ACall
+	| AReturn
+	| AMod
+	| ANew
+	| ALocalVar
+	| AInitArray
+	| AObject
+	| ATypeOf
+	| ATargetPath
+	| AEnum
+	| AAdd
+	| ACompare
+	| AEqual
+	| AToNumber
+	| AToString
+	| ADup
+	| ASwap
+	| AObjGet
+	| AObjSet
+	| AIncrement
+	| ADecrement
+	| AObjCall
+	| ANewMethod
+	| AInstanceOf
+	| AEnum2
+	| AAnd
+	| AOr
+	| AXor
+	| AShl
+	| AShr
+	| AAsr
+	| APhysEqual
+	| AGreater
+	| AStringGreater
+	| AExtends
+
+	| AGotoFrame of int
+	| AGetURL of string * string
+	| ASetReg of int
+	| AStringPool of string list
+	| AWaitForFrame of int * int
+	| ASetTarget of string
+	| AGotoLabel of string
+	| AWaitForFrame2 of int
+	| AFunction2 of function_decl2
+	| ATry of try_block
+	| AWith of int
+	| APush of push_item list
+	| AJump of action_count
+	| AGetURL2 of int
+	| AFunction of function_decl
+	| ACondJump of action_count
+	| ACallFrame (* no data *)
+	| AGotoFrame2 of bool * int option
+
+	| AUnknown of int * unknown
+
+type actions = action DynArray.t
+
+type header = {
+	mutable h_version : int;
+	mutable h_size : rect;
+	mutable h_fps : float16;
+	mutable h_frame_count : int;
+	mutable h_compressed : bool;
+}
+
+type export = {
+	mutable exp_id : int;
+	exp_name : string;
+}
+
+type import = {
+	mutable imp_id : int;
+	imp_name : string;
+}
+
+type do_init_action = {
+	mutable dia_id : int;
+	dia_actions : actions;
+}
+
+type sound = {
+	mutable so_id : int;
+	so_flags : int;
+	so_samples : int;
+	so_data : unknown;
+}
+
+type start_sound = {
+	mutable sts_id : int;
+	sts_data : unknown;
+}
+
+type sfs_bitmap = {
+	sfb_repeat : bool;
+	sfb_smooth : bool;
+	mutable sfb_cid : int;
+	sfb_mpos : matrix;
+}
+
+type shape_fill_style =
+	| SFSSolid of rgb
+	| SFSSolid3 of rgba
+	| SFSLinearGradient of matrix * gradient
+	| SFSRadialGradient of matrix * gradient * int option
+	| SFSBitmap of sfs_bitmap
+
+type shape_line_style = {
+	sls_width : int;
+	sls_color : color;
+	sls_flags : int option;
+	sls_fill : shape_fill_style option;
+	sls_miter : int option;
+}
+
+type shape_new_styles = {
+	sns_fill_styles : shape_fill_style list;
+	sns_line_styles : shape_line_style list;
+	sns_nlbits : int;
+	sns_nfbits : int;
+}
+
+type shape_change_style_record = {
+	scsr_move : (int * int * int) option;
+	scsr_fs0 : int option;
+	scsr_fs1 : int option;
+	scsr_ls : int option;
+	scsr_new_styles : shape_new_styles option;
+}
+
+type shape_curved_edge_record = {
+	scer_nbits : int;
+	scer_cx : int;
+	scer_cy : int;
+	scer_ax : int;
+	scer_ay : int;
+}
+
+type shape_straight_edge_record = {
+	sser_nbits : int;
+	sser_line : int option * int option;
+}
+
+type shape_record =
+	| SRStyleChange of shape_change_style_record
+	| SRCurvedEdge of shape_curved_edge_record
+	| SRStraightEdge of shape_straight_edge_record
+
+type shape_records = {
+	srs_nlbits : int;
+	srs_nfbits : int;
+	srs_records : shape_record list;
+}
+
+type shape_with_style = {
+	sws_fill_styles : shape_fill_style list;
+	sws_line_styles : shape_line_style list;
+	sws_records : shape_records;
+}
+
+type shape = {
+	mutable sh_id : int;
+	sh_bounds : rect;
+	sh_bounds2 : (rect * int) option;
+	sh_style : shape_with_style;
+}
+
+type filter_gradient = {
+	fgr_colors : (rgba * int) list;
+	fgr_data : unknown;
+}
+
+type filter =
+	| FDropShadow of unknown
+	| FBlur of unknown
+	| FGlow of unknown
+	| FBevel of unknown
+	| FGradientGlow of filter_gradient
+	| FAdjustColor of unknown
+	| FGradientBevel of filter_gradient
+
+type bitmap_jpg = {
+	mutable jpg_id : int;
+	jpg_data : binary;
+}
+
+type bitmap_data = {
+	mutable bd_id : int;
+	bd_table : binary option;
+	bd_data : binary;
+	bd_alpha : binary option;
+	bd_deblock : int option;
+}
+
+type bitmap_lossless = {
+	mutable bll_id : int;
+	bll_format : int;
+	bll_width : int;
+	bll_height : int;
+	bll_data : unknown;
+}
+
+type morph_shape = {
+	mutable msh_id : int;
+	msh_start_bounds : rect;
+	msh_end_bounds : rect;
+	msh_data : unknown;
+}
+
+type cid_data = {
+	mutable cd_id : int;
+	cd_data : binary;
+}
+
+type text_glyph = {
+	txg_index : int;
+	txg_advanced : int;
+}
+
+type text_record = {
+	mutable txr_font : (int * int) option;
+	txr_color : color option;
+	txr_dx : int option;
+	txr_dy : int option;
+	txr_glyphs : text_glyph list;
+}
+
+type text = {
+	mutable txt_id : int;
+	txt_bounds : big_rect;
+	txt_matrix : matrix;
+	txt_ngbits : int;
+	txt_nabits : int;
+	txt_records : text_record list;
+}
+
+type button_record = {
+	btr_flags : int;
+	mutable btr_cid : int;
+	btr_depth : int;
+	btr_mpos : matrix;
+	btr_color : color_transform_alpha option;
+	btr_filters : filter list option;
+	btr_blendmode : int option;
+}
+
+type button_action = {
+	bta_flags : int;
+	bta_actions : actions;
+}
+
+type button2 = {
+	mutable bt2_id : int;
+	bt2_track_as_menu : bool;
+	bt2_records : button_record list;
+	bt2_actions : button_action list;
+}
+
+type remove_object = {
+	mutable rmo_id : int;
+	rmo_depth : int;
+}
+
+type edit_text_layout = {
+	edtl_align : int;
+	edtl_left_margin : int;
+	edtl_right_margin : int;
+	edtl_indent : int;
+	edtl_leading : int;
+}
+
+type edit_text = {
+	mutable edt_id : int;
+	edt_bounds : rect;
+	mutable edt_font : (int * int) option;
+	edt_color : rgba option;
+	edt_maxlen : int option;
+	edt_layout : edit_text_layout option;
+	edt_variable : string;
+	edt_text : string option;
+	edt_wordwrap : bool;
+	edt_multiline : bool;
+	edt_password : bool;
+	edt_readonly : bool;
+	edt_autosize : bool;
+	edt_noselect : bool;
+	edt_border : bool;
+	edt_html : bool;
+	edt_outlines : bool;
+}
+
+type f9class = {
+	mutable f9_cid : int option;
+	f9_classname : string;
+}
+
+type files_attrib = {
+	fa_network : bool;
+	fa_as3 : bool;
+	fa_metadata : bool;
+	fa_gpu : bool;
+	fa_direct_blt : bool;
+}
+
+type tag_data =
+	| TEnd
+	| TShowFrame
+	| TShape of shape
+	| TRemoveObject of remove_object
+	| TBitsJPEG of bitmap_jpg
+	| TJPEGTables of binary
+	| TSetBgColor of rgb
+	| TFont of cid_data
+	| TText of text
+	| TDoAction of actions
+	| TFontInfo of cid_data
+	| TSound of sound
+	| TStartSound of start_sound
+	| TBitsLossless of bitmap_lossless
+	| TBitsJPEG2 of bitmap_data
+	| TShape2 of shape
+	| TProtect
+	| TPlaceObject2 of place_object
+	| TRemoveObject2 of int
+	| TShape3 of shape
+	| TText2 of text
+	| TButton2 of button2
+	| TBitsJPEG3 of bitmap_data
+	| TBitsLossless2 of bitmap_lossless
+	| TEditText of edit_text
+	| TClip of clip
+	| TProductInfo of unknown
+	| TFrameLabel of string * char option
+	| TSoundStreamHead2 of unknown
+	| TMorphShape of morph_shape
+	| TFont2 of cid_data
+	| TExport of export list
+	| TImport of string * import list
+	| TDoInitAction of do_init_action
+	| TVideoStream of cid_data
+	| TVideoFrame of cid_data
+	| TFontInfo2 of cid_data
+	| TDebugID of unknown
+	| TEnableDebugger2 of int * string
+	| TScriptLimits of int * int
+	| TFilesAttributes of files_attrib
+	| TPlaceObject3 of place_object
+	| TImport2 of string * import list
+	| TFontAlignZones of cid_data
+	| TCSMSettings of cid_data
+	| TFont3 of cid_data
+	| TF9Classes of f9class list
+	| TMetaData of string
+	| TScale9 of int * rect
+	| TActionScript3 of (int * string) option * As3.as3_tag
+	| TShape4 of shape
+	| TMorphShape2 of morph_shape
+	| TScenes of (int * string) list * (int * string) list
+	| TBinaryData of int * binary
+	| TBigBinaryData of int * binary list
+	| TFontName of cid_data
+	| TBitsJPEG4 of bitmap_data
+	| TFont4 of cid_data
+	| TUnknown of int * unknown
+
+and tag = {
+	mutable tid : int;
+	mutable textended : bool;
+	mutable tdata : tag_data;
+}
+
+and clip_event = {
+	cle_events : int;
+	cle_key : char option;
+	cle_actions : actions;
+}
+
+and place_object = {
+	po_depth : int;
+	po_move : bool;
+	mutable po_cid : int option;
+	po_matrix : matrix option;
+	po_color : color_transform_alpha option;
+	po_ratio : float16 option;
+	po_inst_name : string option;
+	po_clip_depth : int option;
+	po_events : clip_event list option;
+	po_filters : filter list option;
+	po_blend : int option;
+	po_bcache : int option;
+}
+
+and clip = {
+	mutable c_id : int;
+	c_frame_count : int;
+	c_tags : tag list;
+}
+
+type font_language_code =
+	| LCNone (*0*)
+	| LCLatin (*1*)
+	| LCJapanese (*2*)
+	| LCKorean (*3*)
+	| LCSimplifiedChinese (*4*)
+	| LCTraditionalChinese (*5*)
+
+type font_glyph_data = {
+	font_char_code: int;
+	font_shape: shape_records;
+}
+
+type font_layout_glyph_data = {
+	font_advance: int;
+	font_bounds: rect;
+}
+
+type font_kerning_data = {
+	font_char_code1: int;
+	font_char_code2: int;
+	font_adjust: int;
+}
+
+type font_layout_data = {
+	font_ascent: int;
+	font_descent: int;
+	font_leading: int;
+	font_glyphs_layout: font_layout_glyph_data array;
+	font_kerning: font_kerning_data list;
+}
+
+type font2_data = {
+	font_shift_jis: bool;
+	font_is_small: bool;
+	font_is_ansi: bool;
+	font_wide_codes: bool;
+	font_wide_offsets: bool;
+	font_is_italic: bool;
+	font_is_bold: bool;
+	font_language: font_language_code;
+	font_name: string;
+	font_glyphs: font_glyph_data array;
+	font_layout: font_layout_data;
+}
+
+type swf = header * tag list
+
+let __deflate = ref (fun (_:unit IO.output) -> assert false)
+let __inflate = ref (fun _ -> assert false)
+let __parser = ref (fun _ -> assert false)
+let __printer = ref (fun (_:unit IO.output) _ -> ())
+
+exception Error of string
+
+let error msg = raise (Error msg)
+
+let warnings = ref true
+
+let to_float16 f =
+	let sign , f = (if f < 0. then true , 0. -. f else false , f) in
+	let high = int_of_float f in
+	let low = int_of_float ((f -. (float high)) *. 256.) in
+	if high > 127 then failwith "to_float16";
+	(high lsl 8) lor (if sign then low lor (1 lsl 15) else low)
+
+let parse (ch : IO.input) =
+	(!__parser ch : swf)
+
+let write (ch : 'a IO.output) (data : swf) =
+	!__printer (Obj.magic ch) data
+
+let deflate (ch : 'a IO.output) =
+	(Obj.magic (!__deflate (Obj.magic ch) : unit IO.output) : 'a IO.output)
+
+let inflate (ch : IO.input) =
+	(!__inflate ch : IO.input)

libs/swflib/swfParser.ml

@@ -0,0 +1,2258 @@
+(*
+ *  This file is part of SwfLib
+ *  Copyright (c)2004 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+open Swf
+open ActionScript
+open IO
+
+(* ************************************************************************ *)
+(* TOOLS *)
+
+let full_parsing = ref true
+let force_as3_parsing = ref false
+let swf_version = ref 0
+let id_count = ref 0
+let tag_end = { tid = 0; textended = false; tdata = TEnd }
+
+let sum f l =
+	List.fold_left (fun acc x -> acc + f x) 0 l
+
+let gen_id() =
+	incr id_count;
+	!id_count
+
+let const n = fun _ -> n
+
+let opt_len f = function
+	| None -> 0
+	| Some x -> f x
+
+let opt_flag flags fid f fparam =
+	if (flags land fid) = 0 then
+		None
+	else
+		Some (f fparam)
+
+let opt f = function
+	| None -> ()
+	| Some x -> f x
+
+let flag = function
+	| None -> false
+	| Some _ -> true
+
+let rec make_flags = function
+	| [] -> 0
+	| true :: l -> 1 lor ((make_flags l) lsl 1)
+	| false :: l -> (make_flags l) lsl 1
+
+let f16_value (a,b) =
+	let k = int_of_char a lor (int_of_char b lsl 8) in
+	float_of_int k /. float_of_int (1 lsl 8)
+
+let rec read_count n f arg =
+	if n = 0 then
+		[]
+	else
+		let v = f arg in
+		v :: read_count (n - 1) f arg
+
+(* ************************************************************************ *)
+(* LENGTH *)
+
+let _nbits x =
+	if x < 0 then error "Negative nbits";
+	if x = 0 then
+		0
+	else
+		let x = ref x in
+		let nbits = ref 0 in
+		while !x > 0 do
+			x := !x lsr 1;
+			incr nbits;
+		done;
+		!nbits
+
+let rect_nbits r =
+	r.rect_nbits
+
+let bigrect_nbits r =
+	r.brect_nbits
+
+let rgba_nbits c =
+	max
+		(max (_nbits c.r) (_nbits c.g))
+		(max (_nbits c.b) (_nbits c.a))
+
+let cxa_nbits c =
+	c.cxa_nbits
+
+let matrix_part_nbits m =
+	m.m_nbits
+
+let rgb_length = 3
+
+let rgba_length = 4
+
+let string_length s = String.length s + 1
+
+let color_length = function
+	| ColorRGB _ -> rgb_length
+	| ColorRGBA _ -> rgba_length
+
+let rect_length r =
+	let nbits = rect_nbits r in
+	let nbits = nbits * 4 + 5 in
+	(nbits + 7) / 8
+
+let big_rect_length r =
+	let nbits = bigrect_nbits r in
+	let nbits = nbits * 4 + 5 in
+	(nbits + 7) / 8
+
+let gradient_length = function
+	| GradientRGB (l,_) -> 1 + (1 + rgb_length) * List.length l
+	| GradientRGBA (l,_) -> 1 + (1 + rgba_length) * List.length l
+
+let matrix_length m =
+	let matrix_part_len m = 5 + matrix_part_nbits m * 2 in
+	let nbits = 2 + opt_len matrix_part_len m.scale + opt_len matrix_part_len m.rotate + matrix_part_len m.trans in
+	(nbits + 7) / 8
+
+let cxa_length c =
+	let nbits = cxa_nbits c in
+	let nbits = 6 + opt_len (const (nbits * 4)) c.cxa_add + opt_len (const (nbits * 4)) c.cxa_mult in
+	(nbits + 7) / 8
+
+let clip_event_length c =
+	(if !swf_version >= 6 then 4 else 2) + 4 + (opt_len (const 1) c.cle_key) + actions_length c.cle_actions
+
+let clip_events_length l =
+	(if !swf_version >= 6 then 10 else 6) + sum clip_event_length l
+
+let export_length e =
+	2 + string_length e.exp_name
+
+let import_length i =
+	2 + string_length i.imp_name
+
+let sound_length s =
+	2 + 1 + 4 + String.length s.so_data
+
+let shape_fill_style_length s =
+	1 + match s with
+	| SFSSolid _ -> rgb_length
+	| SFSSolid3 _ -> rgba_length
+	| SFSLinearGradient (m,g)
+	| SFSRadialGradient (m,g,None) -> matrix_length m + gradient_length g
+	| SFSRadialGradient (m,g,Some _) -> matrix_length m + gradient_length g + 2
+	| SFSBitmap b -> 2 + matrix_length b.sfb_mpos
+
+let shape_line_style_length s =
+	2 + match s.sls_flags with
+		| None -> color_length s.sls_color
+		| Some _ ->
+			2 + (match s.sls_fill with None -> color_length s.sls_color | Some f -> shape_fill_style_length f)
+			  + opt_len (const 2) s.sls_miter
+
+let shape_array_length f s =
+	let n = List.length s in
+	(if n < 0xFF then 1 else 3) + sum f s
+
+let shape_new_styles_length s =
+	shape_array_length shape_fill_style_length s.sns_fill_styles +
+	shape_array_length shape_line_style_length s.sns_line_styles +
+	1
+
+let font_shape_records_length records =
+	let nbits = ref 8 in
+	let nfbits = ref records.srs_nfbits in
+	let nlbits = ref records.srs_nlbits in
+	List.iter (fun r ->
+		nbits := !nbits + 6;
+		match r with
+		| SRStyleChange s ->
+			nbits := !nbits +
+				opt_len (fun (n,_,_) -> 5 + n * 2) s.scsr_move +
+				opt_len (const !nfbits) s.scsr_fs0 +
+				opt_len (const !nfbits) s.scsr_fs1 +
+				opt_len (const !nlbits) s.scsr_ls;
+		| SRCurvedEdge s ->
+			nbits := !nbits + s.scer_nbits * 4
+		| SRStraightEdge s ->
+			nbits := !nbits + 1 + (match s.sser_line with
+								| None , None -> assert false
+								| Some _ , None
+								| None, Some _ -> 1 + s.sser_nbits
+								| Some _ , Some _ -> 2 * s.sser_nbits)
+	) records.srs_records;
+	(* nbits := !nbits + 6; *)
+	(!nbits + 7) / 8
+
+let shape_records_length records =
+	let nbits = ref 8 in
+	let nfbits = ref records.srs_nfbits in
+	let nlbits = ref records.srs_nlbits in
+	List.iter (fun r ->
+		nbits := !nbits + 6;
+		match r with
+		| SRStyleChange s ->
+			nbits := !nbits +
+				opt_len (fun (n,_,_) -> 5 + n * 2) s.scsr_move +
+				opt_len (const !nfbits) s.scsr_fs0 +
+				opt_len (const !nfbits) s.scsr_fs1 +
+				opt_len (const !nlbits) s.scsr_ls;
+			(match s.scsr_new_styles with
+			| None -> ()
+			| Some s ->
+				nbits := (((!nbits + 7) / 8) + shape_new_styles_length s) * 8;
+				nfbits := s.sns_nfbits;
+				nlbits := s.sns_nlbits)
+		| SRCurvedEdge s ->
+			nbits := !nbits + s.scer_nbits * 4
+		| SRStraightEdge s ->
+			nbits := !nbits + 1 + (match s.sser_line with
+								| None , None -> assert false
+								| Some _ , None
+								| None, Some _ -> 1 + s.sser_nbits
+								| Some _ , Some _ -> 2 * s.sser_nbits)
+	) records.srs_records;
+	nbits := !nbits + 6;
+	(!nbits + 7) / 8
+
+let shape_with_style_length s =
+	shape_array_length shape_fill_style_length s.sws_fill_styles +
+	shape_array_length shape_line_style_length s.sws_line_styles +
+	shape_records_length s.sws_records
+
+let shape_length s =
+	2 + rect_length s.sh_bounds + opt_len (fun (r,_) -> rect_length r + 1) s.sh_bounds2 + shape_with_style_length s.sh_style
+
+let bitmap_lossless_length b =
+	2 + 1 + 2 + 2 + String.length b.bll_data
+
+let morph_shape_length s =
+	2 + rect_length s.msh_start_bounds + rect_length s.msh_end_bounds + String.length s.msh_data
+
+let text_record_length t r =
+	1 + opt_len (const 4) r.txr_font +
+		opt_len color_length r.txr_color +
+		opt_len (const 2) r.txr_dx +
+		opt_len (const 2) r.txr_dy +
+		1 + ((((t.txt_ngbits + t.txt_nabits) * List.length r.txr_glyphs) + 7) / 8)
+
+let text_length t =
+	2 + big_rect_length t.txt_bounds + matrix_length t.txt_matrix + 2 + sum (text_record_length t) t.txt_records + 1
+
+let filters_length l =
+	1 + sum (fun f ->
+		1 + match f with
+		| FDropShadow s
+		| FBlur s
+		| FGlow s
+		| FBevel s
+		| FAdjustColor s ->
+			String.length s
+		| FGradientGlow fg
+		| FGradientBevel fg ->
+			1 + ((rgba_length + 1) * List.length fg.fgr_colors) + String.length fg.fgr_data
+	) l
+
+let button_record_length r =
+	1 + 2 + 2 + matrix_length r.btr_mpos + (match r.btr_color with None -> 0 | Some c -> cxa_length c)
+	+ opt_len filters_length r.btr_filters
+	+ (match r.btr_blendmode with None -> 0 | Some c -> 1)
+
+let button_action_length r =
+	2 + 2 + actions_length r.bta_actions
+
+let button2_length b =
+	2 + 1 + 2 +
+		1 + sum button_record_length b.bt2_records +
+		sum button_action_length b.bt2_actions
+
+let cid_data_length c =
+	2 + String.length c.cd_data
+
+let edit_text_layout_length = 9
+
+let header_length h =
+	3 + 1 + rect_length h.h_size + 2 + 4
+
+let edit_text_length t =
+	2 + rect_length t.edt_bounds + 2 +
+		opt_len (const 4) t.edt_font +
+		opt_len (const rgba_length) t.edt_color +
+		opt_len (const 2) t.edt_maxlen +
+		opt_len (const edit_text_layout_length) t.edt_layout +
+		string_length t.edt_variable +
+		opt_len string_length t.edt_text
+
+let place_object_length p v3 =
+	3
+	+ (if v3 then 1 else 0)
+	+ 0 (* po_move *)
+	+ opt_len (const 2) p.po_cid
+	+ opt_len matrix_length p.po_matrix
+	+ opt_len cxa_length p.po_color
+	+ opt_len (const 2) p.po_ratio
+	+ opt_len string_length p.po_inst_name
+	+ opt_len (const 2) p.po_clip_depth
+	+ opt_len clip_events_length p.po_events
+	+ (if v3 then
+		opt_len filters_length p.po_filters
+		+ opt_len (const 1) p.po_blend
+		+ opt_len (const 1) p.po_bcache
+	else
+		0)
+
+let rec tag_data_length = function
+	| TEnd ->
+		0
+	| TShowFrame ->
+		0
+	| TShape s ->
+		shape_length s
+	| TRemoveObject _ ->
+		4
+	| TBitsJPEG b ->
+		2 + String.length b.jpg_data
+	| TJPEGTables tab ->
+		String.length tab
+	| TSetBgColor _ ->
+		rgb_length
+	| TFont c ->
+		cid_data_length c
+	| TText t ->
+		text_length t
+	| TDoAction acts ->
+		actions_length acts
+	| TFontInfo c ->
+		cid_data_length c
+	| TSound s ->
+		sound_length s
+	| TStartSound s ->
+		2 + String.length s.sts_data
+	| TBitsLossless b ->
+		bitmap_lossless_length b
+	| TBitsJPEG2 b ->
+		2 + opt_len String.length b.bd_table + String.length b.bd_data
+	| TShape2 s ->
+		shape_length s
+	| TProtect ->
+		0
+	| TPlaceObject2 p ->
+		place_object_length p false
+	| TRemoveObject2 _ ->
+		2
+	| TShape3 s ->
+		shape_length s
+	| TText2 t ->
+		text_length t
+	| TButton2 b ->
+		button2_length b
+	| TBitsJPEG3 b ->
+		2 + 4 + opt_len String.length b.bd_table + String.length b.bd_data + opt_len String.length b.bd_alpha
+	| TBitsLossless2 b ->
+		bitmap_lossless_length b
+	| TEditText t ->
+		edit_text_length t
+	| TClip c ->
+		4 + sum tag_length (tag_end :: c.c_tags)
+	| TProductInfo s ->
+		String.length s
+	| TFrameLabel (label,id) ->
+		string_length label + (match id with None -> 0 | Some _ -> 1)
+	| TSoundStreamHead2 data ->
+		String.length data
+	| TMorphShape s | TMorphShape2 s ->
+		morph_shape_length s
+	| TFont2 c | TFont3 c | TFontAlignZones c ->
+		cid_data_length c
+	| TExport el ->
+		2 + sum export_length el
+	| TImport (url,il) ->
+		string_length url + 2 + sum import_length il
+	| TDoInitAction i ->
+		2 + actions_length i.dia_actions
+	| TVideoStream c ->
+		cid_data_length c
+	| TVideoFrame c ->
+		cid_data_length c
+	| TFontInfo2 c ->
+		cid_data_length c
+	| TDebugID s ->
+		String.length s
+	| TEnableDebugger2 (_,pass) ->
+		2 + string_length pass
+	| TScriptLimits _ ->
+		4
+	| TFilesAttributes _ ->
+		4
+	| TPlaceObject3 p ->
+		place_object_length p true
+	| TImport2 (url,il) ->
+		string_length url + 1 + 1 + 2 + sum import_length il
+	| TCSMSettings c ->
+		cid_data_length c
+	| TF9Classes l ->
+		2 + sum (fun c -> string_length c.f9_classname + 2) l
+	| TMetaData meta ->
+		string_length meta
+	| TScale9 (_,r) ->
+		2 + rect_length r
+	| TActionScript3 (id,a) ->
+		(match id with None -> 0 | Some (id,f) -> 4 + string_length f) + As3parse.as3_length a
+	| TShape4 s ->
+		shape_length s
+	| TScenes (sl,fl) ->
+		As3parse.int_length (List.length sl) + sum (fun(n,s) -> As3parse.int_length n + string_length s) sl +
+		As3parse.int_length (List.length fl) + sum (fun(n,s) -> As3parse.int_length n + string_length s) fl
+	| TBinaryData (_,data) ->
+		2 + 4 + String.length data
+	| TBigBinaryData (_,data) ->
+		2 + 4 + (List.fold_left (fun acc s -> acc + String.length s) 0 data)
+	| TFontName c ->
+		cid_data_length c
+	| TBitsJPEG4 b ->
+		2 + 2 + 4 + opt_len String.length b.bd_table + String.length b.bd_data + opt_len String.length b.bd_alpha
+	| TFont4 c ->
+		cid_data_length c
+	| TUnknown (_,data) ->
+		String.length data
+
+and tag_length t =
+	let dlen = tag_data_length t.tdata in
+	dlen + 2 + (if t.textended || dlen >= 63 then 4 else 0)
+
+(* ************************************************************************ *)
+(* READ PRIMS *)
+
+let skip ch n =
+	seek_in ch ((Pervasives.pos_in ch) + n)
+
+let read_rgba ch =
+	let r = read_byte ch in
+	let g = read_byte ch in
+	let b = read_byte ch in
+	let a = read_byte ch in
+	{
+		r = r;
+		g = g;
+		b = b;
+		a = a;
+	}
+
+let read_rgb ch =
+	let r = read_byte ch in
+	let g = read_byte ch in
+	let b = read_byte ch in
+	{
+		cr = r;
+		cg = g;
+		cb = b;
+	}
+
+let read_gradient ch is_rgba =
+	let grad_rgb() =
+		let r = read_byte ch in
+		let c = read_rgb ch in
+		(r, c)
+	in
+	let grad_rgba() =
+		let r = read_byte ch in
+		let c = read_rgba ch in
+		(r, c)
+	in
+	let n = read_byte ch in
+	let n , flags = n land 0xF , n lsr 4 in
+	if is_rgba then
+		GradientRGBA (read_count n grad_rgba (),flags)
+	else
+		GradientRGB (read_count n grad_rgb (),flags)
+
+let read_rect ch =
+	let b = input_bits ch in
+	let nbits = read_bits b 5 in
+	let left = read_bits b nbits in
+	let right = read_bits b nbits in
+	let top = read_bits b nbits in
+	let bottom = read_bits b nbits in
+	{
+		rect_nbits = nbits;
+		left = left;
+		right = right;
+		top = top;
+		bottom = bottom;
+	}
+
+let rec read_multi_bits b n =
+	if n <= 30 then
+		[read_bits b n]
+	else
+		let d = read_bits b 30 in
+		d :: read_multi_bits b (n - 30)
+
+let read_big_rect ch =
+	let b = input_bits ch in
+	let nbits = read_bits b 5 in
+	let left = read_multi_bits b nbits in
+	let right = read_multi_bits b nbits in
+	let top = read_multi_bits b nbits in
+	let bottom = read_multi_bits b nbits in
+	{
+		brect_nbits = nbits;
+		bleft = left;
+		bright = right;
+		btop = top;
+		bbottom = bottom;
+	}
+
+let read_matrix ch =
+	let b = input_bits ch in
+	let read_matrix_part() =
+		let nbits = read_bits b 5 in
+		let x = read_bits b nbits in
+		let y = read_bits b nbits in
+		{
+			m_nbits = nbits;
+			mx = x;
+			my = y;
+		}
+	in
+	let has_scale = (read_bits b 1 = 1) in
+	let scale = (if has_scale then Some (read_matrix_part()) else None) in
+	let has_rotate = (read_bits b 1 = 1) in
+	let rotate = (if has_rotate then Some (read_matrix_part()) else None) in
+	let trans = read_matrix_part() in
+	{
+		scale = scale;
+		rotate = rotate;
+		trans = trans;
+	}
+
+let read_cxa ch =
+	let b = input_bits ch in
+	let has_add = (read_bits b 1 = 1) in
+	let has_mult = (read_bits b 1 = 1) in
+	let nbits = read_bits b 4 in
+	let read_cxa_color() =
+		let r = read_bits b nbits in
+		let g = read_bits b nbits in
+		let bl = read_bits b nbits in
+		let a = read_bits b nbits in
+		{
+			r = r;
+			g = g;
+			b = bl;
+			a = a;
+		}
+	in
+	let mult = (if has_mult then Some (read_cxa_color()) else None) in
+	let add = (if has_add then Some (read_cxa_color()) else None) in
+	{
+		cxa_nbits = nbits;
+		cxa_add = add;
+		cxa_mult = mult;
+	}
+
+let read_event ch =
+	(if !swf_version >= 6 then read_i32 else read_ui16) ch
+
+(* ************************************************************************ *)
+(* WRITE PRIMS *)
+
+let write_rgb ch c =
+	write_byte ch c.cr;
+	write_byte ch c.cg;
+	write_byte ch c.cb
+
+let write_rgba ch c =
+	write_byte ch c.r;
+	write_byte ch c.g;
+	write_byte ch c.b;
+	write_byte ch c.a
+
+let write_color ch = function
+	| ColorRGB c -> write_rgb ch c
+	| ColorRGBA c -> write_rgba ch c
+
+let write_gradient ch = function
+	| GradientRGB (l,flags) ->
+		let n = List.length l in
+		write_byte ch (n lor (flags lsl 4));
+		List.iter (fun (ratio,c) -> write_byte ch ratio; write_rgb ch c) l
+	| GradientRGBA (l,flags) ->
+		let n = List.length l in
+		write_byte ch (n lor (flags lsl 4));
+		List.iter (fun (ratio,c) -> write_byte ch ratio; write_rgba ch c) l
+
+let write_rect ch r =
+	let b = output_bits ch in
+	let nbits = rect_nbits r in
+	write_bits b 5 nbits;
+	write_bits b nbits r.left;
+	write_bits b nbits r.right;
+	write_bits b nbits r.top;
+	write_bits b nbits r.bottom;
+	flush_bits b
+
+let rec write_multi_bits b n l =
+	if n <= 30 then
+		match l with
+		| [] -> write_bits b n 0
+		| [x] -> write_bits b n x
+		| _ -> assert false
+	else
+		match l with
+		| [] -> write_bits b 30 0; write_multi_bits b (n - 30) []
+		| x :: l -> write_bits b 30 x; write_multi_bits b (n - 30) l
+
+let write_big_rect ch r =
+	let b = output_bits ch in
+	let nbits = bigrect_nbits r in
+	write_bits b 5 nbits;
+	write_multi_bits b nbits r.bleft;
+	write_multi_bits b nbits r.bright;
+	write_multi_bits b nbits r.btop;
+	write_multi_bits b nbits r.bbottom;
+	flush_bits b
+
+let write_matrix ch m =
+	let b = output_bits ch in
+	let write_matrix_part m =
+		let nbits = matrix_part_nbits m in
+		write_bits b 5 nbits;
+		write_bits b nbits m.mx;
+		write_bits b nbits m.my;
+	in
+	(match m.scale with
+	| None ->
+		write_bits b 1 0
+	| Some s ->
+		write_bits b 1 1;
+		write_matrix_part s
+	);
+	(match m.rotate with
+	| None ->
+		write_bits b 1 0
+	| Some r ->
+		write_bits b 1 1;
+		write_matrix_part r);
+	write_matrix_part m.trans;
+	flush_bits b
+
+let write_cxa ch c =
+	let b = output_bits ch in
+	let nbits = cxa_nbits c in
+	(match c.cxa_add , c.cxa_mult with
+	| None , None ->
+		write_bits b 2 0;
+		write_bits b 4 1; (* some strange MM thing... *)
+	| Some c , None ->
+		write_bits b 2 2;
+		write_bits b 4 nbits;
+		List.iter (write_bits b ~nbits) [c.r;c.g;c.b;c.a];
+	| None , Some c ->
+		write_bits b 2 1;
+		write_bits b 4 nbits;
+		List.iter (write_bits b ~nbits) [c.r;c.g;c.b;c.a];
+	| Some c1 , Some c2 ->
+		write_bits b 2 3;
+		write_bits b 4 nbits;
+		List.iter (write_bits b ~nbits) [c2.r;c2.g;c2.b;c2.a;c1.r;c1.g;c1.b;c1.a]
+	);
+	flush_bits b
+
+let write_event ch evt =
+	(if !swf_version >= 6 then write_i32 else write_ui16) ch evt
+
+(* ************************************************************************ *)
+(* PARSING *)
+
+let parse_clip_events ch =
+	ignore(read_ui16 ch); (* reserved *)
+	ignore(read_event ch); (* all_events *)
+	let rec loop() =
+		let events = read_event ch in
+		if events = 0 then
+			[]
+		else begin
+			ignore(read_i32 ch); (* len *)
+			let key = (if events land (1 lsl 17) <> 0 then Some (read ch) else None) in
+			let e = {
+				cle_events = events;
+				cle_key = key;
+				cle_actions = parse_actions ch
+			} in
+			e :: (loop())
+		end;
+	in
+	loop()
+
+let parse_shape_fill_style ch vshape =
+	let t = read_byte ch in
+	match t with
+	| 0x00 when vshape >= 3 -> SFSSolid3 (read_rgba ch)
+	| 0x00 -> SFSSolid (read_rgb ch)
+	| 0x10 ->
+		let m = read_matrix ch in
+		let g = read_gradient ch (vshape >= 3) in
+		SFSLinearGradient (m,g)
+	| 0x12 ->
+		let m = read_matrix ch in
+		let g = read_gradient ch (vshape >= 3) in
+		SFSRadialGradient (m,g,None)
+	| 0x13 ->
+		let m = read_matrix ch in
+		let g = read_gradient ch (vshape >= 3) in
+		let i = read_i16 ch in
+		SFSRadialGradient (m,g,Some i)
+	| 0x40
+	| 0x41
+	| 0x42
+	| 0x43 ->
+		let id = read_ui16 ch in
+		let m = read_matrix ch in
+		SFSBitmap {
+			sfb_repeat = (t = 0x40 || t = 0x42);
+			sfb_smooth = (t = 0x42 || t = 0x43);
+			sfb_cid = id;
+			sfb_mpos = m;
+		}
+	| _ ->
+		assert false
+
+let parse_shape_line_style ch vshape =
+	let width = read_ui16 ch in
+	if vshape >= 4 then begin
+		let flags = read_ui16 ch in
+		let fill = (flags land 8 <> 0) in
+		let miterjoin = (flags land 0x20 <> 0) in
+		let miter = (if miterjoin then Some (IO.read_ui16 ch) else None) in
+		let color = (if fill then { r = 0; g = 0; b = 0; a = 0 } else read_rgba ch) in
+		(*
+			let noVscale = (flags land 0x02 <> 0) in
+			let noHscale = (flags land 0x04 <> 0) in
+			let beveljoin = (flags land 0x10 <> 0) in
+			let nocap = (flags land 0x40 <> 0) in
+			let squarecap = (flags land 0x80 <> 0) in
+		*)
+		{
+			sls_width = width;
+			sls_color = ColorRGBA color;
+			sls_fill = if fill then Some (parse_shape_fill_style ch vshape) else None;
+			sls_flags = Some flags;
+			sls_miter = miter;
+		}
+	end else
+		{
+			sls_width = width;
+			sls_color = if vshape = 3 then ColorRGBA (read_rgba ch) else ColorRGB (read_rgb ch);
+			sls_fill = None;
+			sls_flags = None;
+			sls_miter = None;
+		}
+
+let parse_shape_array f ch vshape =
+	let n = (match read_byte ch with 0xFF -> read_ui16 ch | n -> n) in
+	read_count n (f ch) vshape
+
+let parse_shape_style_change_record ch b flags nlbits nfbits vshape =
+	let move = (if flags land 1 <> 0 then begin
+		let mbits = read_bits b 5 in
+		let dx = read_bits b mbits in
+		let dy = read_bits b mbits in
+		Some (mbits,dx,dy)
+	end else
+		None)
+	in
+	let fs0 = (if flags land 2 <> 0 then Some (read_bits b !nfbits) else None) in
+	let fs1 = (if flags land 4 <> 0 then Some (read_bits b !nfbits) else None) in
+	let ls = (if flags land 8 <> 0 then Some (read_bits b !nlbits) else None) in
+	let styles = (if flags land 16 <> 0 then begin
+		IO.drop_bits b;
+		let fstyles = parse_shape_array parse_shape_fill_style ch vshape in
+		let lstyles = parse_shape_array parse_shape_line_style ch vshape in
+		let bits = read_byte ch in
+		nlbits := bits land 15;
+		nfbits := bits lsr 4;
+		Some {
+			sns_fill_styles = fstyles;
+			sns_line_styles = lstyles;
+			sns_nlbits = !nlbits;
+			sns_nfbits = !nfbits;
+		}
+	end else
+		None
+	) in
+	{
+		scsr_move = move;
+		scsr_fs0 = fs0;
+		scsr_fs1 = fs1;
+		scsr_ls = ls;
+		scsr_new_styles = styles;
+	}
+
+let parse_shape_curved_edge_record b flags =
+	let nbits = (flags land 15) + 2 in
+	let cx = read_bits b nbits in
+	let cy = read_bits b nbits in
+	let ax = read_bits b nbits in
+	let ay = read_bits b nbits in
+	{
+		scer_nbits = nbits;
+		scer_cx = cx;
+		scer_cy = cy;
+		scer_ax = ax;
+		scer_ay = ay;
+	}
+
+let parse_shape_straight_edge_record b flags =
+	let nbits = (flags land 15) + 2 in
+	let is_general = (read_bits b 1 = 1) in
+	let l = (if is_general then
+		let dx = read_bits b nbits in
+		let dy = read_bits b nbits in
+		Some dx, Some dy
+	else
+		let is_vertical = (read_bits b 1 = 1) in
+		let p = read_bits b nbits in
+		if is_vertical then
+			None, Some p
+		else
+			Some p, None)
+	in
+	{
+		sser_nbits = nbits;
+		sser_line = l;
+	}
+
+let parse_shape_records ch nlbits nfbits vshape =
+	let b = input_bits ch in
+	let nlbits = ref nlbits in
+	let nfbits = ref nfbits in
+	let rec loop() =
+		let flags = read_bits b 6 in
+		if flags = 0 then
+			[]
+		else
+			let r =
+				(if (flags land 32) = 0 then
+					SRStyleChange (parse_shape_style_change_record ch b flags nlbits nfbits vshape)
+				else if (flags land 48) = 32 then
+					SRCurvedEdge (parse_shape_curved_edge_record b flags)
+				else
+					SRStraightEdge (parse_shape_straight_edge_record b flags))
+			in
+			r :: loop()
+	in
+	loop()
+
+let parse_shape_with_style ch vshape =
+	let fstyles = parse_shape_array parse_shape_fill_style ch vshape in
+	let lstyles = parse_shape_array parse_shape_line_style ch vshape in
+	let bits = read_byte ch in
+	let nlbits = bits land 15 in
+	let nfbits = bits lsr 4 in
+	let records = parse_shape_records ch nlbits nfbits vshape in
+	{
+		sws_fill_styles = fstyles;
+		sws_line_styles = lstyles;
+		sws_records = {
+			srs_nlbits = nlbits;
+			srs_nfbits = nfbits;
+			srs_records = records;
+		}
+	}
+
+
+let parse_shape ch len vshape =
+	let id = read_ui16 ch in
+	let bounds = read_rect ch in
+	let bounds2 = (if vshape = 4 then
+		let r = read_rect ch in
+		let b = read_byte ch in
+		Some (r, b)
+	else
+		None
+	) in
+	let style = parse_shape_with_style ch vshape in
+	{
+		sh_id = id;
+		sh_bounds = bounds;
+		sh_bounds2 = bounds2;
+		sh_style = style;
+	}
+
+let extract_jpg_table data =
+	match data.[0], data.[1] with
+	| '\xFF', '\xD8' ->
+		let ch = IO.input_string data in
+		let b = Buffer.create 0 in
+		let rec loop flag =
+			let c = IO.read ch in
+			Buffer.add_char b c;
+			match int_of_char c with
+			| 0xFF -> loop true
+			| 0xD9 when flag -> ()
+			| _ -> loop false
+		in
+		loop false;
+		let t = Buffer.contents b in
+		let l = String.length t in
+		String.sub data l (String.length data - l), Some t
+	| _ ->
+		data, None
+
+let parse_bitmap_lossless ch len =
+	let id = read_ui16 ch in
+	let format = read_byte ch in
+	let width = read_ui16 ch in
+	let height = read_ui16 ch in
+	let data = nread_string ch (len - 7) in
+	{
+		bll_id = id;
+		bll_format = format;
+		bll_width = width;
+		bll_height = height;
+		bll_data = data;
+	}
+
+let parse_text ch is_txt2 =
+	let id = read_ui16 ch in
+	let bounds = read_big_rect ch in
+	let matrix = read_matrix ch in
+	let ngbits = read_byte ch in
+	let nabits = read_byte ch in
+	let read_glyph bits =
+		let indx = read_bits bits ngbits in
+		let adv = read_bits bits nabits in
+		{
+			txg_index = indx;
+			txg_advanced = adv;
+		}
+	in
+	let rec loop() =
+		let flags = read_byte ch in
+		if flags = 0 then
+			[]
+		else
+			let font_id = (if flags land 8 <> 0 then read_ui16 ch else 0) in
+			let color = (if flags land 4 <> 0 then Some (if is_txt2 then ColorRGBA (read_rgba ch) else ColorRGB (read_rgb ch)) else None) in
+			let dx = (if flags land 1 <> 0 then Some (read_i16 ch) else None) in
+			let dy = (if flags land 2 <> 0 then Some (read_i16 ch) else None) in
+			let font = (if flags land 8 <> 0 then Some (font_id,read_ui16 ch) else None) in
+			let nglyphs = read_byte ch in
+			let r = {
+				txr_font = font;
+				txr_color = color;
+				txr_dx = dx;
+				txr_dy = dy;
+				txr_glyphs = read_count nglyphs read_glyph (input_bits ch);
+			} in
+			r :: loop()
+	in
+	{
+		txt_id = id;
+		txt_bounds = bounds;
+		txt_matrix = matrix;
+		txt_ngbits = ngbits;
+		txt_nabits = nabits;
+		txt_records = loop();
+	}
+
+let parse_edit_text_layout ch =
+	let align = read_byte ch in
+	let ml = read_ui16 ch in
+	let rl = read_ui16 ch in
+	let ident = read_ui16 ch in
+	let lead = read_ui16 ch in
+	{
+		edtl_align = align;
+		edtl_left_margin = ml;
+		edtl_right_margin = rl;
+		edtl_indent = ident;
+		edtl_leading = lead;
+	}
+
+let parse_edit_text ch =
+	let id = read_ui16 ch in
+	let bounds = read_rect ch in
+	let flags = read_ui16 ch in
+	let font = (if flags land 1 <> 0 then
+			let fid = read_ui16 ch in
+			let height = read_ui16 ch in
+			Some (fid, height)
+		else
+			None) in
+	let color = (if flags land 4 <> 0 then Some (read_rgba ch) else None) in
+	let maxlen = (if flags land 2 <> 0 then Some (read_ui16 ch) else None) in
+	let layout = (if flags land (1 lsl 13) <> 0 then Some (parse_edit_text_layout ch) else None) in
+	let variable = read_string ch in
+	let text = (if flags land 128 <> 0 then Some (read_string ch) else None) in
+	{
+		edt_id = id;
+		edt_bounds = bounds;
+		edt_font = font;
+		edt_color = color;
+		edt_maxlen = maxlen;
+		edt_layout = layout;
+		edt_variable = variable;
+		edt_text = text;
+		edt_wordwrap = (flags land 64) <> 0;
+		edt_multiline = (flags land 32) <> 0;
+		edt_password = (flags land 16) <> 0;
+		edt_readonly = (flags land 8) <> 0;
+		edt_autosize = (flags land (1 lsl 14)) <> 0;
+		edt_noselect = (flags land 4096) <> 0;
+		edt_border = (flags land 2048) <> 0;
+		edt_html = (flags land 512) <> 0;
+		edt_outlines = (flags land 256) <> 0;
+	}
+
+let parse_cid_data ch len =
+	let id = read_ui16 ch in
+	let data = nread_string ch (len - 2) in
+	{
+		cd_id = id;
+		cd_data = data;
+	}
+
+let parse_morph_shape ch len =
+	let id = read_ui16 ch in
+	let sbounds = read_rect ch in
+	let ebounds = read_rect ch in
+	let data = nread_string ch (len - 2 - rect_length sbounds - rect_length ebounds) in
+	{
+		msh_id = id;
+		msh_start_bounds = sbounds;
+		msh_end_bounds = ebounds;
+		msh_data = data;
+	}
+
+let parse_filter_gradient ch =
+	let ncolors = read_byte ch in
+	let colors = read_count ncolors read_rgba ch in
+	let cvals = read_count ncolors read_byte ch in
+	let data = nread_string ch 19 in
+	{
+		fgr_colors = List.combine colors cvals;
+		fgr_data = data;
+	}
+
+let parse_filter ch =
+	match read_byte ch with
+	| 0 -> FDropShadow (nread_string ch 23)
+	| 1 -> FBlur (nread_string ch 9)
+	| 2 -> FGlow (nread_string ch 15)
+	| 3 -> FBevel (nread_string ch 27)
+	| 4 -> FGradientGlow (parse_filter_gradient ch)
+	| 6 -> FAdjustColor (nread_string ch 80)
+	| 7 -> FGradientBevel (parse_filter_gradient ch)
+	| _ -> assert false
+
+let parse_filters ch =
+	let nf = read_byte ch in
+	read_count nf parse_filter ch
+
+let rec parse_button_records ch color =
+	let flags = read_byte ch in
+	if flags = 0 then
+		[]
+	else
+		let cid = read_ui16 ch in
+		let depth = read_ui16 ch in
+		let mpos = read_matrix ch in
+		let cxa = (if color then Some (read_cxa ch) else None) in
+		let filters = (if flags land 16 = 0 then None else Some (parse_filters ch)) in
+		let blendmode = (if flags land 32 = 0 then None else Some (read_byte ch)) in
+		let r = {
+			btr_flags = flags;
+			btr_cid = cid;
+			btr_depth = depth;
+			btr_mpos = mpos;
+			btr_color = cxa;
+			btr_filters = filters;
+			btr_blendmode = blendmode;
+		} in
+		r :: parse_button_records ch color
+
+let rec parse_button_actions ch =
+	let size = read_ui16 ch in
+	let flags = read_ui16 ch in
+	let actions = parse_actions ch in
+	let bta = {
+		bta_flags = flags;
+		bta_actions = actions;
+	} in
+	if size = 0 then
+		[bta]
+	else
+		bta :: parse_button_actions ch
+
+let parse_button2 ch len =
+	let id = read_ui16 ch in
+	let flags = read_byte ch in
+	let track = (match flags with 0 -> false | 1 -> true | _ -> assert false) in
+	let offset = read_ui16 ch in
+	let records = parse_button_records ch true in
+	let actions = (if offset = 0 then [] else parse_button_actions ch) in
+	{
+		bt2_id = id;
+		bt2_track_as_menu = track;
+		bt2_records = records;
+		bt2_actions = actions;
+	}
+
+let parse_place_object ch v3 =
+	let f = read_byte ch in
+	let fext = (if v3 then read_byte ch else 0) in
+	let depth = read_ui16 ch in
+	let move = (f land 1) <> 0 in
+	let cid = opt_flag f 2 read_ui16 ch in
+	let matrix = opt_flag f 4 read_matrix ch in
+	let color = opt_flag f 8 read_cxa ch in
+	let ratio = opt_flag f 16 read_ui16 ch in
+	let name = opt_flag f 32 read_string ch in
+	let clip_depth = opt_flag f 64 read_ui16 ch in
+	let clip_events = opt_flag f 128 parse_clip_events ch in
+	let filters = opt_flag fext 1 parse_filters ch in
+	let blend = opt_flag fext 2 read_byte ch in
+	let bcache = opt_flag fext 4 read_byte ch in
+	{
+		po_depth = depth;
+		po_move = move;
+		po_cid = cid;
+		po_matrix = matrix;
+		po_color = color;
+		po_ratio = ratio;
+		po_inst_name = name;
+		po_clip_depth = clip_depth;
+		po_events = clip_events;
+		po_filters = filters;
+		po_blend = blend;
+		po_bcache = bcache;
+	}
+
+let parse_import ch =
+	let cid = read_ui16 ch in
+	let name = read_string ch in
+	{
+		imp_id = cid;
+		imp_name = name
+	}
+
+let rec parse_tag ch h =
+	let id = h lsr 6 in
+	let len = h land 63 in
+	let len , extended = (
+		if len = 63 then
+			let len = read_i32 ch in
+			len , len < 63
+		else
+			len , false
+	) in
+	let t = (
+		match id with
+		| 0x00 ->
+			TEnd
+		| 0x01 ->
+			TShowFrame
+		| 0x02 when !full_parsing ->
+			TShape (parse_shape ch len 1)
+		(* 0x03 invalid *)
+		(*//0x04 TPlaceObject *)
+		| 0x05 ->
+			let cid = read_ui16 ch in
+			let depth = read_ui16 ch in
+			TRemoveObject {
+				rmo_id = cid;
+				rmo_depth = depth;
+			}
+		| 0x06 ->
+			let id = read_ui16 ch in
+			let data = nread_string ch (len - 2) in
+			TBitsJPEG {
+				jpg_id = id;
+				jpg_data = data;
+			}
+		(*//0x07 TButton *)
+		| 0x08 ->
+			TJPEGTables (nread_string ch len)
+		| 0x09 ->
+			TSetBgColor (read_rgb ch)
+		| 0x0A ->
+			TFont (parse_cid_data ch len)
+		| 0x0B when !full_parsing ->
+			TText (parse_text ch false)
+		| 0x0C ->
+			TDoAction (parse_actions ch)
+		| 0x0D ->
+			TFontInfo (parse_cid_data ch len)
+		| 0x0E ->
+			let sid = read_ui16 ch in
+			let flags = read_byte ch in
+			let samples = read_i32 ch in
+			let data = nread_string ch (len - 7) in
+			TSound {
+				so_id = sid;
+				so_flags = flags;
+				so_samples = samples;
+				so_data = data;
+			}
+		| 0x0F ->
+			let sid = read_ui16 ch in
+			let data = nread_string ch (len - 2) in
+			TStartSound {
+				sts_id = sid;
+				sts_data = data;
+			}
+		(* 0x10 invalid *)
+		(*//0x11 TButtonSound *)
+		(*//0x12 TSoundStreamHead *)
+		(*//0x13 TSoundStreamBlock *)
+		| 0x14 ->
+			TBitsLossless (parse_bitmap_lossless ch len)
+		| 0x15 ->
+			let id = read_ui16 ch in
+			let data = nread_string ch (len - 2) in
+			let data, table = extract_jpg_table data in
+			TBitsJPEG2 {
+				bd_id = id;
+				bd_table = table;
+				bd_data = data;
+				bd_alpha = None;
+				bd_deblock = None;
+			}
+		| 0x16 when !full_parsing ->
+			TShape2 (parse_shape ch len 2)
+		(*//0x17 TButtonCXForm *)
+		| 0x18 ->
+			TProtect
+		(* 0x19 invalid *)
+		| 0x1A when !full_parsing ->
+			TPlaceObject2 (parse_place_object ch false)
+		(* 0x1B invalid *)
+		| 0x1C ->
+			let depth = read_ui16 ch in
+			TRemoveObject2 depth
+		(* 0x1D-1F invalid *)
+		| 0x20 when !full_parsing ->
+			TShape3 (parse_shape ch len 3)
+		| 0x21 when !full_parsing ->
+			TText2 (parse_text ch true)
+		| 0x22 when !full_parsing ->
+			TButton2 (parse_button2 ch len)
+		| 0x23 ->
+			let id = read_ui16 ch in
+			let size = read_i32 ch in
+			let data = nread_string ch size in
+			let data, table = extract_jpg_table data in
+			let alpha = nread_string ch (len - 6 - size) in
+			TBitsJPEG3 {
+				bd_id = id;
+				bd_table = table;
+				bd_data = data;
+				bd_alpha = Some alpha;
+				bd_deblock = None;
+			}
+		| 0x24 ->
+			TBitsLossless2 (parse_bitmap_lossless ch len)
+		| 0x25 when !full_parsing ->
+			TEditText (parse_edit_text ch)
+		(* 0x26 invalid *)
+		| 0x27 ->
+			let cid = read_ui16 ch in
+			let fcount = read_ui16 ch in
+			let tags = parse_tag_list ch in
+			TClip {
+				c_id = cid;
+				c_frame_count = fcount;
+				c_tags = tags;
+			}
+		(* 0x28 invalid *)
+		| 0x29 ->
+			(* undocumented ? *)
+			TProductInfo (nread_string ch len)
+		(* 0x2A invalid *)
+		| 0x2B ->
+			let label = read_string ch in
+			let id = (if len = String.length label + 2 then Some (read ch) else None) in
+			TFrameLabel (label,id)
+		(* 0x2C invalid *)
+		| 0x2D ->
+			TSoundStreamHead2 (nread_string ch len)
+		| 0x2E when !full_parsing ->
+			TMorphShape (parse_morph_shape ch len)
+		(* 0x2F invalid *)
+		| 0x30 when !full_parsing ->
+			TFont2 (parse_cid_data ch len)
+		(* 0x31-37 invalid *)
+		| 0x38 ->
+			let read_export() =
+				let cid = read_ui16 ch in
+				let name = read_string ch in
+				{
+					exp_id = cid;
+					exp_name = name
+				}
+			in
+			TExport (read_count (read_ui16 ch) read_export ())
+		| 0x39 ->
+			let url = read_string ch in
+			TImport (url, read_count (read_ui16 ch) parse_import ch)
+		(*// 0x3A TEnableDebugger *)
+		| 0x3B ->
+			let cid = read_ui16 ch in
+			let actions = parse_actions ch in
+			TDoInitAction {
+				dia_id = cid;
+				dia_actions = actions;
+			}
+		| 0x3C ->
+			TVideoStream (parse_cid_data ch len)
+		| 0x3D ->
+			TVideoFrame (parse_cid_data ch len)
+		| 0x3E ->
+			TFontInfo2 (parse_cid_data ch len)
+		| 0x3F ->
+			(* undocumented ? *)
+			TDebugID (nread_string ch len)
+		| 0x40 ->
+			let tag = read_ui16 ch in
+			(* 0 in general, 6517 for some swfs *)
+			let pass_md5 = read_string ch in
+			TEnableDebugger2 (tag,pass_md5)
+		| 0x41 ->
+			let recursion_depth = read_ui16 ch in
+			let script_timeout = read_ui16 ch in
+			TScriptLimits (recursion_depth, script_timeout)
+		(*// 0x42 TSetTabIndex *)
+		(* 0x43-0x44 invalid *)
+		| 0x45 ->
+			let flags = IO.read_i32 ch in
+			let mask = 1 lor 8 lor 16 lor 32 lor 64 in
+			if (flags lor mask) <> mask then failwith ("Invalid file attributes " ^ string_of_int flags);
+			TFilesAttributes {
+				fa_network = (flags land 1) <> 0;
+				(* flags 2,4 : reserved *)
+				fa_as3 = (flags land 8) <> 0;
+				fa_metadata = (flags land 16) <> 0;
+				fa_gpu = (flags land 32) <> 0;
+				fa_direct_blt = (flags land 64) <> 0;
+			}
+		| 0x46 when !full_parsing ->
+			TPlaceObject3 (parse_place_object ch true)
+		| 0x47 ->
+			let url = read_string ch in
+			if IO.read_byte ch <> 1 then assert false;
+			if IO.read_byte ch <> 0 then assert false;
+			TImport2 (url, read_count (read_ui16 ch) parse_import ch)
+		| 0x48 when !full_parsing || !force_as3_parsing ->
+			TActionScript3 (None , As3parse.parse ch len)
+		| 0x49 when !full_parsing ->
+			TFontAlignZones (parse_cid_data ch len)
+		| 0x4A ->
+			TCSMSettings (parse_cid_data ch len)
+		| 0x4B when !full_parsing ->
+			TFont3 (parse_cid_data ch len)
+		| 0x4C ->
+			let i = read_ui16 ch in
+			let rec loop i =
+				if i = 0 then
+					[]
+				else
+					let a = read_ui16 ch in
+					let s = read_string ch in
+					{
+						f9_cid = if a = 0 then None else Some a;
+						f9_classname = s;
+					} :: loop (i - 1)
+			in
+			TF9Classes (loop i)
+		| 0x4D ->
+			TMetaData (read_string ch)
+		| 0x4E ->
+			let cid = read_ui16 ch in
+			let rect = read_rect ch in
+			TScale9 (cid,rect)
+		(* 0x4F-0x51 invalid *)
+		| 0x52 when !full_parsing || !force_as3_parsing ->
+			let id = read_i32 ch in
+			let frame = read_string ch in
+			let len = len - (4 + String.length frame + 1) in
+			TActionScript3 (Some (id,frame), As3parse.parse ch len)
+		| 0x53 when !full_parsing ->
+			TShape4 (parse_shape ch len 4)
+		| 0x54 when !full_parsing ->
+			TMorphShape2 (parse_morph_shape ch len)
+		(* 0x55 invalid *)
+		| 0x56 ->
+			let scenes = read_count (As3parse.read_int ch) (fun() ->
+				let offset = As3parse.read_int ch in
+				let name = read_string ch in
+				(offset, name)
+			) () in
+			let frames = read_count (As3parse.read_int ch) (fun() ->
+				let f = As3parse.read_int ch in
+				let name = read_string ch in
+				(f, name)
+			) () in
+			TScenes (scenes,frames)
+		| 0x57 ->
+			let cid = read_ui16 ch in
+			if read_i32 ch <> 0 then assert false;
+			let rec loop len =
+				if len > Sys.max_string_length then
+					let s = nread_string ch Sys.max_string_length in
+					s :: loop (len - Sys.max_string_length)
+				else
+					[nread_string ch len]
+			in
+			(match loop (len - 6) with
+			| [data] -> TBinaryData (cid,data)
+			| data -> TBigBinaryData (cid,data))
+		| 0x58 ->
+			TFontName (parse_cid_data ch len)
+		(* // 0x59 TStartSound2 *)
+		| 0x5A ->
+			let id = read_ui16 ch in
+			let size = read_i32 ch in
+			let deblock = read_ui16 ch in
+			let data = nread_string ch size in
+			let data, table = extract_jpg_table data in
+			let alpha = nread_string ch (len - 6 - size) in
+			TBitsJPEG4 {
+				bd_id = id;
+				bd_table = table;
+				bd_data = data;
+				bd_alpha = Some alpha;
+				bd_deblock = Some deblock;
+			}
+		| 0x5B ->
+			TFont4 (parse_cid_data ch len)
+		| _ ->
+			(*if !Swf.warnings then Printf.printf "Unknown tag 0x%.2X\n" id;*)
+			TUnknown (id,nread_string ch len)
+	) in
+(*	let len2 = tag_data_length t in
+	if len <> len2 then error (Printf.sprintf "Datalen mismatch for tag 0x%.2X (%d != %d)" id len len2);
+*)	{
+		tid = gen_id();
+		tdata = t;
+		textended = extended;
+	}
+
+and parse_tag_list ch =
+	let rec loop acc =
+		let h = (try read_ui16 ch with IO.No_more_input -> 0) in
+		match parse_tag ch h with
+		| { tdata = TEnd } -> List.rev acc
+		| t -> loop (t :: acc)
+	in
+	loop []
+
+let parse ch =
+	let sign = nread_string ch 3 in
+	if sign <> "FWS" && sign <> "CWS" then error "Invalid SWF signature";
+	let ver = read_byte ch in
+	swf_version := ver;
+	ignore(read_i32 ch); (* file length *)
+	let compressed, ch = (if sign = "CWS" then true , inflate ch else false, ch) in
+	let size = read_rect ch in
+	let fps = read_ui16 ch in
+	let frame_count = read_ui16 ch in
+	let h = {
+		h_version = ver;
+		h_size = size;
+		h_fps = fps;
+		h_frame_count = frame_count;
+		h_compressed = compressed;
+	} in
+	let data = h , parse_tag_list ch in
+	if compressed then IO.close_in ch;
+	data
+
+(* ************************************************************************ *)
+(* WRITING *)
+
+let rec tag_id = function
+	| TEnd -> 0x00
+	| TShowFrame -> 0x01
+	| TShape _ -> 0x02
+	| TRemoveObject _ -> 0x05
+	| TBitsJPEG _ -> 0x06
+	| TJPEGTables _ -> 0x08
+	| TSetBgColor _ -> 0x09
+	| TFont _ -> 0x0A
+	| TText _ -> 0x0B
+	| TDoAction _ -> 0x0C
+	| TFontInfo _ -> 0x0D
+	| TSound _ -> 0x0E
+	| TStartSound _ -> 0x0F
+	| TBitsLossless _ -> 0x14
+	| TBitsJPEG2 _ -> 0x15
+	| TShape2 _ -> 0x16
+	| TProtect -> 0x18
+	| TPlaceObject2 _ -> 0x1A
+	| TRemoveObject2 _ -> 0x1C
+	| TShape3 _ -> 0x20
+	| TText2 _ -> 0x21
+	| TButton2 _ -> 0x22
+	| TBitsJPEG3 _ -> 0x23
+	| TBitsLossless2 _ -> 0x24
+	| TEditText _ -> 0x25
+	| TClip _ -> 0x27
+	| TProductInfo _ -> 0x29
+	| TFrameLabel _ -> 0x2B
+	| TSoundStreamHead2 _ -> 0x2D
+	| TMorphShape _ -> 0x2E
+	| TFont2 _ -> 0x30
+	| TExport _ -> 0x38
+	| TImport _ -> 0x39
+	| TDoInitAction _ -> 0x3B
+	| TVideoStream _ -> 0x3C
+	| TVideoFrame _ -> 0x3D
+	| TFontInfo2 _ -> 0x3E
+	| TDebugID _ -> 0x3F
+	| TEnableDebugger2 _ -> 0x40
+	| TScriptLimits _ -> 0x41
+	| TFilesAttributes _ -> 0x45
+	| TPlaceObject3 _ -> 0x46
+	| TImport2 _ -> 0x47
+	| TFontAlignZones _ -> 0x49
+	| TCSMSettings _ -> 0x4A
+	| TFont3 _ -> 0x4B
+	| TF9Classes _ -> 0x4C
+	| TMetaData _ -> 0x4D
+	| TScale9 _ -> 0x4E
+	| TActionScript3 (None,_) -> 0x48
+	| TActionScript3 _ -> 0x52
+	| TShape4 _ -> 0x53
+	| TMorphShape2 _ -> 0x54
+	| TScenes _ -> 0x56
+	| TBinaryData _ | TBigBinaryData _ -> 0x57
+	| TFontName _ -> 0x58
+	| TBitsJPEG4 _ -> 0x5A
+	| TFont4 _ -> 0x5B
+	| TUnknown (id,_) -> id
+
+let write_clip_event ch c =
+	write_event ch c.cle_events;
+	write_i32 ch (actions_length c.cle_actions + opt_len (const 1) c.cle_key);
+	opt (write ch) c.cle_key;
+	write_actions ch c.cle_actions
+
+let write_clip_events ch event_list =
+ 	write_ui16 ch 0;
+	let all_events = List.fold_left (fun acc c -> acc lor c.cle_events) 0 event_list in
+	write_event ch all_events;
+	List.iter (write_clip_event ch) event_list;
+	write_event ch 0
+
+let write_shape_fill_style ch s =
+	match s with
+	| SFSSolid c ->
+		write_byte ch 0x00;
+		write_rgb ch c
+	| SFSSolid3 c ->
+		write_byte ch 0x00;
+		write_rgba ch c
+	| SFSLinearGradient (m,g) ->
+		write_byte ch 0x10;
+		write_matrix ch m;
+		write_gradient ch g
+	| SFSRadialGradient (m,g,None) ->
+		write_byte ch 0x12;
+		write_matrix ch m;
+		write_gradient ch g
+	| SFSRadialGradient (m,g,Some i) ->
+		write_byte ch 0x13;
+		write_matrix ch m;
+		write_gradient ch g;
+		write_i16 ch i;
+	| SFSBitmap b ->
+		write_byte ch (match b.sfb_repeat , b.sfb_smooth with
+			| true, false -> 0x40
+			| false , false -> 0x41
+			| true , true -> 0x42
+			| false, true -> 0x43);
+		write_ui16 ch b.sfb_cid;
+		write_matrix ch b.sfb_mpos
+
+let write_shape_line_style ch l =
+	write_ui16 ch l.sls_width;
+	opt (write_ui16 ch) l.sls_flags;
+	opt (write_ui16 ch) l.sls_miter;
+	match l.sls_fill with
+	| None ->
+		write_color ch l.sls_color;
+	| Some fill ->
+		write_shape_fill_style ch fill
+
+let write_shape_array ch f sl =
+	let n = List.length sl in
+	if n >= 0xFF then begin
+		write_byte ch 0xFF;
+		write_ui16 ch n;
+	end else
+		write_byte ch n;
+	List.iter (f ch) sl
+
+let write_shape_style_change_record ch b nlbits nfbits s =
+	let flags = make_flags [flag s.scsr_move; flag s.scsr_fs0; flag s.scsr_fs1; flag s.scsr_ls; flag s.scsr_new_styles] in
+	write_bits b 6 flags;
+	opt (fun (n,dx,dy) ->
+		write_bits b 5 n;
+		write_bits b n dx;
+		write_bits b n dy;
+	) s.scsr_move;
+	opt (write_bits b ~nbits:!nfbits) s.scsr_fs0;
+	opt (write_bits b ~nbits:!nfbits) s.scsr_fs1;
+	opt (write_bits b ~nbits:!nlbits) s.scsr_ls;
+	match s.scsr_new_styles with
+	| None -> ()
+	| Some s ->
+		flush_bits b;
+		write_shape_array ch write_shape_fill_style s.sns_fill_styles;
+		write_shape_array ch write_shape_line_style s.sns_line_styles;
+		nfbits := s.sns_nfbits;
+		nlbits := s.sns_nlbits;
+		write_bits b 4 !nfbits;
+		write_bits b 4 !nlbits
+
+let write_shape_record ch b nlbits nfbits = function
+	| SRStyleChange s ->
+		write_shape_style_change_record ch b nlbits nfbits s
+	| SRCurvedEdge s ->
+		write_bits b 2 2;
+		write_bits b 4 (s.scer_nbits - 2);
+		write_bits b s.scer_nbits s.scer_cx;
+		write_bits b s.scer_nbits s.scer_cy;
+		write_bits b s.scer_nbits s.scer_ax;
+		write_bits b s.scer_nbits s.scer_ay;
+	| SRStraightEdge s ->
+		write_bits b 2 3;
+		write_bits b 4 (s.sser_nbits - 2);
+		match s.sser_line with
+		| None , None -> assert false
+		| None , Some p
+		| Some p , None ->
+			write_bits b 1 0;
+			write_bits b 1 (if (fst s.sser_line) = None then 1 else 0);
+			write_bits b s.sser_nbits p;
+		| Some dx, Some dy ->
+			write_bits b 1 1;
+			write_bits b s.sser_nbits dx;
+			write_bits b s.sser_nbits dy
+
+let write_shape_without_style ch s =
+	(* write_shape_array ch write_shape_fill_style s.sws_fill_styles; *)
+	(* write_shape_array ch write_shape_line_style s.sws_line_styles; *)
+	let r = s in (* s.sws_records in *)
+	let b = output_bits ch in
+	write_bits b 4 r.srs_nfbits;
+	write_bits b 4 r.srs_nlbits;
+	let nlbits = ref r.srs_nlbits in
+	let nfbits = ref r.srs_nfbits in
+	List.iter (write_shape_record ch b nlbits nfbits) r.srs_records;
+	(* write_bits b 6 0; *)
+	flush_bits b
+
+let write_shape_with_style ch s =
+	write_shape_array ch write_shape_fill_style s.sws_fill_styles;
+	write_shape_array ch write_shape_line_style s.sws_line_styles;
+	let r = s.sws_records in
+	let b = output_bits ch in
+	write_bits b 4 r.srs_nfbits;
+	write_bits b 4 r.srs_nlbits;
+	let nlbits = ref r.srs_nlbits in
+	let nfbits = ref r.srs_nfbits in
+	List.iter (write_shape_record ch b nlbits nfbits) r.srs_records;
+	write_bits b 6 0;
+	flush_bits b
+
+let write_shape ch s =
+	write_ui16 ch s.sh_id;
+	write_rect ch s.sh_bounds;
+	(match s.sh_bounds2 with
+	| None -> ()
+	| Some (r,b) ->
+		write_rect ch r;
+		write_byte ch b);
+	write_shape_with_style ch s.sh_style
+
+let write_bitmap_lossless ch b =
+	write_ui16 ch b.bll_id;
+	write_byte ch b.bll_format;
+	write_ui16 ch b.bll_width;
+	write_ui16 ch b.bll_height;
+	nwrite_string ch b.bll_data
+
+let write_morph_shape ch s =
+	write_ui16 ch s.msh_id;
+	write_rect ch s.msh_start_bounds;
+	write_rect ch s.msh_end_bounds;
+	nwrite_string ch s.msh_data
+
+let write_text_record ch t r =
+	write_byte ch (make_flags [flag r.txr_dx; flag r.txr_dy; flag r.txr_color; flag r.txr_font; false; false; false; true]);
+	opt (fun (id,_) -> write_ui16 ch id) r.txr_font;
+	opt (write_color ch) r.txr_color;
+	opt (write_i16 ch) r.txr_dx;
+	opt (write_i16 ch) r.txr_dy;
+	opt (fun (_,id) -> write_ui16 ch id) r.txr_font;
+	write_byte ch (List.length r.txr_glyphs);
+	let bits = output_bits ch in
+	List.iter (fun g ->
+		write_bits bits t.txt_ngbits g.txg_index;
+		write_bits bits t.txt_nabits g.txg_advanced;
+	) r.txr_glyphs;
+	flush_bits bits
+
+let write_text ch t =
+	write_ui16 ch t.txt_id;
+	write_big_rect ch t.txt_bounds;
+	write_matrix ch t.txt_matrix;
+	write_byte ch t.txt_ngbits;
+	write_byte ch t.txt_nabits;
+	List.iter (write_text_record ch t) t.txt_records;
+	write_byte ch 0
+
+let write_edit_text_layout ch l =
+	write_byte ch l.edtl_align;
+	write_ui16 ch l.edtl_left_margin;
+	write_ui16 ch l.edtl_right_margin;
+	write_ui16 ch l.edtl_indent;
+	write_ui16 ch l.edtl_leading
+
+let write_edit_text ch t =
+	write_ui16 ch t.edt_id;
+	write_rect ch t.edt_bounds;
+	write_ui16 ch (make_flags [
+		flag t.edt_font; flag t.edt_maxlen; flag t.edt_color; t.edt_readonly;
+		t.edt_password; t.edt_multiline; t.edt_wordwrap; flag t.edt_text;
+		t.edt_outlines; t.edt_html; false; t.edt_border;
+		t.edt_noselect; flag t.edt_layout; t.edt_autosize; false
+	]);
+	opt (fun (id,h) -> write_ui16 ch id; write_ui16 ch h) t.edt_font;
+	opt (write_rgba ch) t.edt_color;
+	opt (write_ui16 ch) t.edt_maxlen;
+	opt (write_edit_text_layout ch) t.edt_layout;
+	write_string ch t.edt_variable;
+	opt (write_string ch) t.edt_text
+
+let write_cid_data ch c =
+	write_ui16 ch c.cd_id;
+	nwrite_string ch c.cd_data
+
+let write_filter_gradient ch fg =
+	write_byte ch (List.length fg.fgr_colors);
+	List.iter (fun (c,_) -> write_rgba ch c) fg.fgr_colors;
+	List.iter (fun (_,n) -> write_byte ch n) fg.fgr_colors;
+	nwrite_string ch fg.fgr_data
+
+let write_filter ch = function
+	| FDropShadow s ->
+		write_byte ch 0;
+		nwrite_string ch s
+	| FBlur s ->
+		write_byte ch 1;
+		nwrite_string ch s
+	| FGlow s ->
+		write_byte ch 2;
+		nwrite_string ch s
+	| FBevel s ->
+		write_byte ch 3;
+		nwrite_string ch s
+	| FGradientGlow fg ->
+		write_byte ch 4;
+		write_filter_gradient ch fg
+	| FAdjustColor s ->
+		write_byte ch 6;
+		nwrite_string ch s
+	| FGradientBevel fg ->
+		write_byte ch 7;
+		write_filter_gradient ch fg
+
+let write_button_record ch r =
+	write_byte ch r.btr_flags;
+	write_ui16 ch r.btr_cid;
+	write_ui16 ch r.btr_depth;
+	write_matrix ch r.btr_mpos;
+	(match r.btr_color with
+	| None -> ()
+	| Some c ->
+		write_cxa ch c);
+	opt (fun l ->
+		write_byte ch (List.length l);
+		List.iter (write_filter ch) l
+	) r.btr_filters;
+	(match r.btr_blendmode with
+	| None -> ()
+	| Some c ->
+		write_byte ch c)
+
+let rec write_button_actions ch = function
+	| [] -> assert false
+	| [a] ->
+		write_ui16 ch 0;
+		write_ui16 ch a.bta_flags;
+		write_actions ch a.bta_actions
+	| a :: l ->
+		let size = button_action_length a in
+		write_ui16 ch size;
+		write_ui16 ch a.bta_flags;
+		write_actions ch a.bta_actions;
+		write_button_actions ch l
+
+let write_button2 ch b =
+	write_ui16 ch b.bt2_id;
+	write_byte ch (if b.bt2_track_as_menu then 1 else 0);
+	if b.bt2_actions <> [] then write_ui16 ch (3 + sum button_record_length b.bt2_records) else write_ui16 ch 0;
+	List.iter (write_button_record ch) b.bt2_records;
+	write_byte ch 0;
+	if b.bt2_actions <> [] then write_button_actions ch b.bt2_actions
+
+let write_place_object ch p v3 =
+	write_byte ch (make_flags [
+		p.po_move;
+		flag p.po_cid;
+		flag p.po_matrix;
+		flag p.po_color;
+		flag p.po_ratio;
+		flag p.po_inst_name;
+		flag p.po_clip_depth;
+		flag p.po_events
+	]);
+	if v3 then write_byte ch (make_flags [flag p.po_filters; flag p.po_blend; flag p.po_bcache]);
+	write_ui16 ch p.po_depth;
+	opt (write_ui16 ch) p.po_cid;
+	opt (write_matrix ch) p.po_matrix;
+	opt (write_cxa ch) p.po_color;
+	opt (write_ui16 ch) p.po_ratio;
+	opt (write_string ch) p.po_inst_name;
+	opt (write_ui16 ch) p.po_clip_depth;
+	opt (write_clip_events ch) p.po_events;
+	if v3 then begin
+		opt (fun l ->
+			write_byte ch (List.length l);
+			List.iter (write_filter ch) l
+		) p.po_filters;
+		opt (write_byte ch) p.po_blend;
+		opt (write_byte ch) p.po_bcache;
+	end
+
+let rec write_tag_data ch = function
+	| TEnd ->
+		()
+	| TShowFrame ->
+		()
+	| TShape s ->
+		write_shape ch s
+	| TRemoveObject r ->
+		write_ui16 ch r.rmo_id;
+		write_ui16 ch r.rmo_depth;
+	| TBitsJPEG b ->
+		write_ui16 ch b.jpg_id;
+		nwrite_string ch b.jpg_data
+	| TJPEGTables tab ->
+		nwrite_string ch tab
+	| TSetBgColor c ->
+		write_rgb ch c
+	| TFont c ->
+		write_cid_data ch c
+	| TText t ->
+		write_text ch t
+	| TDoAction acts ->
+		write_actions ch acts
+	| TFontInfo c ->
+		write_cid_data ch c
+	| TSound s ->
+		write_ui16 ch s.so_id;
+		write_byte ch s.so_flags;
+		write_i32 ch s.so_samples;
+		nwrite_string ch s.so_data
+	| TStartSound s ->
+		write_ui16 ch s.sts_id;
+		nwrite_string ch s.sts_data
+	| TBitsLossless b ->
+		write_bitmap_lossless ch b
+	| TBitsJPEG2 b ->
+		write_ui16 ch b.bd_id;
+		opt (nwrite_string ch) b.bd_table;
+		nwrite_string ch b.bd_data;
+	| TShape2 s ->
+		write_shape ch s
+	| TProtect ->
+		()
+	| TPlaceObject2 p ->
+		write_place_object ch p false;
+	| TRemoveObject2 depth ->
+		write_ui16 ch depth;
+	| TShape3 s ->
+		write_shape ch s
+	| TText2 t ->
+		write_text ch t
+	| TButton2 b ->
+		write_button2 ch b
+	| TBitsJPEG3 b ->
+		write_ui16 ch b.bd_id;
+		write_i32 ch (String.length b.bd_data + opt_len String.length b.bd_table);
+		opt (nwrite_string ch) b.bd_table;
+		nwrite_string ch b.bd_data;
+		opt (nwrite_string ch) b.bd_alpha;
+	| TBitsLossless2 b ->
+		write_bitmap_lossless ch b
+	| TEditText t ->
+		write_edit_text ch t
+	| TClip c ->
+		write_ui16 ch c.c_id;
+		write_ui16 ch c.c_frame_count;
+		List.iter (write_tag ch) c.c_tags;
+		write_tag ch tag_end;
+	| TProductInfo s ->
+		nwrite_string ch s
+	| TFrameLabel (label,id) ->
+		write_string ch label;
+		opt (write ch) id;
+	| TSoundStreamHead2 data ->
+		nwrite_string ch data
+	| TMorphShape s ->
+		write_morph_shape ch s
+	| TFont2 c ->
+		write_cid_data ch c
+	| TExport el ->
+		write_ui16 ch (List.length el);
+		List.iter (fun e ->
+			write_ui16 ch e.exp_id;
+			write_string ch e.exp_name
+		) el
+	| TImport (url,il) ->
+		write_string ch url;
+		write_ui16 ch (List.length il);
+		List.iter (fun i ->
+			write_ui16 ch i.imp_id;
+			write_string ch i.imp_name
+		) il
+	| TDoInitAction i ->
+		write_ui16 ch i.dia_id;
+		write_actions ch i.dia_actions;
+	| TVideoStream c ->
+		write_cid_data ch c
+	| TVideoFrame c ->
+		write_cid_data ch c
+	| TFontInfo2 c ->
+		write_cid_data ch c
+	| TDebugID s ->
+		nwrite_string ch s
+	| TEnableDebugger2 (tag,pass) ->
+		write_ui16 ch tag;
+		write_string ch pass
+	| TScriptLimits (recursion_depth, script_timeout) ->
+		write_ui16 ch recursion_depth;
+		write_ui16 ch script_timeout;
+	| TFilesAttributes f ->
+		let flags = make_flags [f.fa_network;false;false;f.fa_as3;f.fa_metadata;f.fa_gpu;f.fa_direct_blt] in
+		write_i32 ch flags
+	| TPlaceObject3 p ->
+		write_place_object ch p true;
+	| TImport2 (url,il) ->
+		write_string ch url;
+		write_byte ch 1;
+		write_byte ch 0;
+		write_ui16 ch (List.length il);
+		List.iter (fun i ->
+			write_ui16 ch i.imp_id;
+			write_string ch i.imp_name
+		) il
+	| TFontAlignZones c ->
+		write_cid_data ch c
+	| TCSMSettings c ->
+		write_cid_data ch c
+	| TFont3 c ->
+		write_cid_data ch c
+	| TF9Classes l ->
+		write_ui16 ch (List.length l);
+		List.iter (fun c ->
+			write_ui16 ch (match c.f9_cid with None -> 0 | Some id -> id);
+			write_string ch c.f9_classname
+		) l
+	| TMetaData meta ->
+		write_string ch meta
+	| TScale9 (cid,r) ->
+		write_ui16 ch cid;
+		write_rect ch r;
+	| TActionScript3 (id,a) ->
+		(match id with
+		| None -> ()
+		| Some (id,frame) ->
+			write_i32 ch id;
+			write_string ch frame;
+		);
+		As3parse.write ch a
+	| TShape4 s ->
+		write_shape ch s
+	| TMorphShape2 m ->
+		write_morph_shape ch m
+	| TScenes (sl,fl) ->
+		As3parse.write_int ch (List.length sl);
+		List.iter (fun (n,s) ->
+			As3parse.write_int ch n;
+			write_string ch s;
+		) sl;
+		As3parse.write_int ch (List.length fl);
+		List.iter (fun (n,s) ->
+			As3parse.write_int ch n;
+			write_string ch s;
+		) fl;
+	| TBinaryData (id,data) ->
+		write_ui16 ch id;
+		write_i32 ch 0;
+		nwrite_string ch data
+	| TBigBinaryData (id,data) ->
+		write_ui16 ch id;
+		write_i32 ch 0;
+		List.iter (nwrite_string ch) data
+	| TFontName c ->
+		write_cid_data ch c
+	| TBitsJPEG4 b ->
+		write_ui16 ch b.bd_id;
+		write_i32 ch (String.length b.bd_data + opt_len String.length b.bd_table);
+		opt (write_ui16 ch) b.bd_deblock;
+		opt (nwrite_string ch) b.bd_table;
+		nwrite_string ch b.bd_data;
+		opt (nwrite_string ch) b.bd_alpha;
+	| TFont4 c ->
+		write_cid_data ch c
+	| TUnknown (_,data) ->
+		nwrite_string ch data
+
+and write_tag ch t =
+	let id = tag_id t.tdata in
+	let dlen = tag_data_length t.tdata in
+	if t.textended || dlen >= 63 then begin
+		write_ui16 ch ((id lsl 6) lor 63);
+		write_i32 ch dlen;
+	end else begin
+		write_ui16 ch ((id lsl 6) lor dlen);
+	end;
+	write_tag_data ch t.tdata
+
+let write ch (h,tags) =
+	swf_version := h.h_version;
+	nwrite_string ch (if h.h_compressed then "CWS" else "FWS");
+	write ch (char_of_int h.h_version);
+	let rec calc_len = function
+		| [] -> tag_length tag_end
+		| t :: l ->
+			tag_length t + calc_len l
+	in
+	let len = calc_len tags in
+	let len = len + 4 + 4 + rect_length h.h_size + 2 + 2 in
+	write_i32 ch len;
+	let ch = (if h.h_compressed then deflate ch else ch) in
+	write_rect ch h.h_size;
+	write_ui16 ch h.h_fps;
+	write_ui16 ch h.h_frame_count;
+	List.iter (write_tag ch) tags;
+	write_tag ch tag_end;
+	if h.h_compressed then IO.close_out ch
+
+(* ************************************************************************ *)
+(* EXTRA *)
+
+let scan fid f t =
+	match t.tdata with
+	| TEnd
+	| TShowFrame
+	| TJPEGTables _
+	| TSetBgColor _
+	| TDoAction _
+	| TActionScript3 _
+	| TProtect
+	| TRemoveObject2 _
+	| TFrameLabel _
+	| TSoundStreamHead2 _
+	| TScenes _
+	| TEnableDebugger2 _
+	| TMetaData _
+	| TScriptLimits _
+	| TDebugID _
+	| TFilesAttributes _
+	| TProductInfo _
+		-> ()
+	| TF9Classes l ->
+		List.iter (fun c ->
+			match c.f9_cid with
+			| None -> ()
+			| Some id -> c.f9_cid <- Some (f id)
+		) l
+	| TShape s
+	| TShape2 s
+	| TShape3 s
+	| TShape4 s ->
+		s.sh_id <- fid s.sh_id;
+		let loop fs =
+			List.iter (fun s -> match s with
+				| SFSBitmap b ->
+					if b.sfb_cid <> 0xFFFF then b.sfb_cid <- f b.sfb_cid;
+				| _ ->
+					()
+			) fs
+		in
+		loop s.sh_style.sws_fill_styles;
+		List.iter (fun s -> match s with
+			| SRStyleChange { scsr_new_styles = Some s } ->
+				loop s.sns_fill_styles
+			| _ ->
+				()
+		) s.sh_style.sws_records.srs_records;
+	| TRemoveObject r ->
+		r.rmo_id <- f r.rmo_id
+	| TBitsJPEG b ->
+		b.jpg_id <- fid b.jpg_id
+	| TBitsJPEG2 b ->
+		b.bd_id <- fid b.bd_id
+	| TText t
+	| TText2 t ->
+		t.txt_id <- fid t.txt_id;
+		List.iter (fun r -> match r.txr_font with None -> () | Some (id,id2) -> r.txr_font <- Some (f id,id2)) t.txt_records
+	| TEditText t ->
+		t.edt_id <- fid t.edt_id;
+		(match t.edt_font with None -> () | Some (id,h) -> t.edt_font <- Some (f id,h))
+	| TSound s ->
+		s.so_id <- fid s.so_id
+	| TStartSound s ->
+		s.sts_id <- f s.sts_id
+	| TBitsLossless b
+	| TBitsLossless2 b ->
+		b.bll_id <- fid b.bll_id
+	| TPlaceObject2 p ->
+		p.po_cid <- (match p.po_cid with None -> None | Some id -> Some (f id))
+	| TButton2 b ->
+		b.bt2_id <- fid b.bt2_id;
+		List.iter (fun r ->
+			r.btr_cid <- f r.btr_cid
+		) b.bt2_records;
+	| TBitsJPEG3 j ->
+		j.bd_id <- fid j.bd_id
+	| TClip c ->
+		c.c_id <- fid c.c_id
+	| TMorphShape s | TMorphShape2 s ->
+		s.msh_id <- fid s.msh_id
+	| TFont c | TFont2 c | TFont3 c | TFont4 c ->
+		c.cd_id <- fid c.cd_id
+	| TExport el ->
+		List.iter (fun e -> e.exp_id <- f e.exp_id) el
+	| TImport (_,il) | TImport2 (_,il) ->
+		List.iter (fun i -> i.imp_id <- fid i.imp_id) il
+	| TDoInitAction a ->
+		a.dia_id <- f a.dia_id
+	| TVideoStream c ->
+		c.cd_id <- fid c.cd_id
+	| TVideoFrame c ->
+		c.cd_id <- f c.cd_id
+	| TPlaceObject3 p ->
+		p.po_cid <- (match p.po_cid with None -> None | Some id -> Some (f id))
+	| TCSMSettings c ->
+		c.cd_id <- f c.cd_id
+	| TBinaryData (id,data) ->
+		t.tdata <- TBinaryData (fid id,data)
+	| TBigBinaryData (id,data) ->
+		t.tdata <- TBigBinaryData (fid id,data)
+	| TFontAlignZones c | TFontInfo c | TFontInfo2 c | TFontName c ->
+		c.cd_id <- f c.cd_id
+	| TScale9 (id,r) ->
+		t.tdata <- TScale9 (f id,r)
+	| TBitsJPEG4 j ->
+		j.bd_id <- fid j.bd_id
+	| TUnknown _ ->
+		()
+
+let tag_name = function
+	| TEnd -> "End"
+	| TShowFrame -> "ShowFrame"
+	| TShape _ -> "Shape"
+	| TRemoveObject _ -> "RemoveObject"
+	| TBitsJPEG _ -> "BitsJPEG"
+	| TJPEGTables _ -> "JPGETables"
+	| TSetBgColor _ -> "SetBgColor"
+	| TFont _ -> "Font"
+	| TText _ -> "Text"
+	| TDoAction _ -> "DoAction"
+	| TFontInfo _ -> "FontInfo"
+	| TSound _ -> "Sound"
+	| TStartSound _ -> "StartSound"
+	| TBitsLossless _ -> "BitsLossless"
+	| TBitsJPEG2 _ -> "BitsJPEG2"
+	| TShape2 _ -> "Shape2"
+	| TProtect -> "Protect"
+	| TPlaceObject2 _ -> "PlaceObject2"
+	| TRemoveObject2 _ -> "RemoveObject2"
+	| TShape3 _ -> "Shape3"
+	| TText2 _ -> "Text2"
+	| TButton2 _ -> "Button2"
+	| TBitsJPEG3 _ -> "BitsJPEG3"
+	| TBitsLossless2 _ -> "Lossless2"
+	| TEditText _ -> "EditText"
+	| TClip _ -> "Clip"
+	| TProductInfo _ -> "ProductInfo"
+	| TFrameLabel _ -> "FrameLabel"
+	| TSoundStreamHead2 _ -> "SoundStreamHead2"
+	| TMorphShape _ -> "MorphShape"
+	| TFont2 _ -> "Font2"
+	| TExport _ -> "Export"
+	| TImport _ -> "Import"
+	| TDoInitAction _ -> "DoInitAction"
+	| TVideoStream _ -> "VideoStream"
+	| TVideoFrame _ -> "VideoFrame"
+	| TFontInfo2 _ -> "FontInfo2"
+	| TDebugID _ -> "DebugID"
+	| TEnableDebugger2 _ -> "EnableDebugger2"
+	| TScriptLimits _ -> "ScriptLimits"
+	| TFilesAttributes _ -> "FilesAttributes"
+	| TPlaceObject3 _ -> "PlaceObject3"
+	| TImport2 _ -> "Import2"
+	| TFontAlignZones _ -> "FontAlignZones"
+	| TCSMSettings _ -> "TCSMSettings"
+	| TFont3 _ -> "Font3"
+	| TF9Classes _ -> "F9Classes"
+	| TMetaData _ -> "MetaData"
+	| TScale9 _ -> "Scale9"
+	| TActionScript3 _ -> "ActionScript3"
+	| TShape4 _ -> "Shape4"
+	| TMorphShape2 _ -> "MorphShape2"
+	| TScenes _ -> "Scenes"
+	| TBinaryData _ -> "BinaryData"
+	| TBigBinaryData _ -> "BigBinaryData"
+	| TFontName _ -> "FontName"
+	| TBitsJPEG4 _ -> "BitsJPEG4"
+	| TFont4 _ -> "Font4"
+	| TUnknown (n,_) -> Printf.sprintf "Unknown 0x%.2X" n
+
+let init inflate deflate =
+	Swf.__parser := parse;
+	Swf.__printer := write;
+	Swf.__inflate := inflate;
+	Swf.__deflate := deflate;
+
+;;
+Swf.__parser := parse;
+Swf.__printer := write

libs/swflib/swfPic.ml

@@ -0,0 +1,230 @@
+(*
+ *  This file is part of SwfLib
+ *  Copyright (c)2005 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+ *)
+
+open Png
+open Swf
+open ExtList
+
+type error_msg =
+	| PngError of Png.error_msg
+	| Interlaced
+	| UnsupportedColorModel
+	| UnsupportedExtension
+	| UnzipFailed
+
+exception Error of error_msg
+exception File_not_found of string
+
+type picture = {
+	pwidth : int;
+	pheight : int;
+	pid : int;
+	pdata : tag_data;
+	pframe : string option;
+}
+
+let error_msg = function
+	| PngError m -> Png.error_msg m
+	| Interlaced -> "Interlaced mode is not supported"
+	| UnsupportedColorModel -> "Unsupported color model"
+	| UnsupportedExtension -> "Unsupported file extension"
+	| UnzipFailed -> "Decompression failed"
+
+let error msg = raise (Error msg)
+
+let unsigned v n =
+	if v < 0 then
+		(- ( v + 1 )) lxor (1 lsl n - 1)
+	else
+		v
+
+let load_picture file id =
+	let ch = IO.input_channel (try open_in_bin file with _ -> raise (File_not_found file)) in
+	let len = String.length file in
+	let p = (try String.rindex file '.' with Not_found -> len) in
+	let ext = String.sub file (p + 1) (len - (p + 1)) in
+	match String.uppercase ext with
+	| "PNG" ->
+		let png , header, data = (try
+			let p = Png.parse ch in
+			p , Png.header p, Png.data p
+		with Png.Error msg ->
+			IO.close_in ch; error (PngError msg)
+		) in
+		IO.close_in ch;
+		if header.png_interlace then error Interlaced;
+		let data = (try Extc.unzip data with _ -> error UnzipFailed) in
+		let w = header.png_width in
+		let h = header.png_height in
+		let data = (try Png.filter png data with Png.Error msg -> error (PngError msg)) in
+		let data = Bytes.unsafe_of_string data in
+		{
+			pwidth = w;
+			pheight = h;
+			pid = id;
+			pframe = None;
+			pdata = (match header.png_color with
+				| ClTrueColor (TBits8,NoAlpha) ->
+					(* set alpha to 0 *)
+					for p = 0 to w * h - 1 do
+						Bytes.unsafe_set data (p * 4) '\000';
+					done;
+					TBitsLossless {
+						bll_id = id;
+						bll_format = 5;
+						bll_width = w;
+						bll_height = h;
+						bll_data = Extc.zip (Bytes.unsafe_to_string data);
+					}
+				| ClTrueColor (TBits8,HaveAlpha) ->
+					(* premultiply rgb by alpha *)
+					for p = 0 to w * h - 1 do
+						let k = p * 4 in
+						let a = int_of_char (Bytes.unsafe_get data k) in
+						Bytes.unsafe_set data (k + 1) (Char.unsafe_chr ((int_of_char (Bytes.unsafe_get data (k + 1)) * a) / 0xFF));
+						Bytes.unsafe_set data (k + 2) (Char.unsafe_chr ((int_of_char (Bytes.unsafe_get data (k + 2)) * a) / 0xFF));
+						Bytes.unsafe_set data (k + 3) (Char.unsafe_chr ((int_of_char (Bytes.unsafe_get data (k + 3)) * a) / 0xFF));
+					done;
+					TBitsLossless2 {
+						bll_id = id;
+						bll_format = 5;
+						bll_width = w;
+						bll_height = h;
+						bll_data = Extc.zip (Bytes.unsafe_to_string data);
+					}
+				| _ -> error UnsupportedColorModel);
+		}
+	| _ ->
+		IO.close_in ch;
+		error UnsupportedExtension
+
+let make_clip name pics baseid =
+	let npics = List.length pics in
+	let ids = Array.of_list (List.map (fun p -> p.pid) pics) in
+	let rec loop i p =
+		let w = p.pwidth in
+		let h = p.pheight in
+		let rb = if 20 * max w h >= 1 lsl 14 then 15 else 14 in
+		let nbits = rb in
+		TShape {
+			sh_id = baseid + i;
+			sh_bounds = {
+				rect_nbits = rb;
+				left = 0;
+				top = 0;
+				right = w * 20;
+				bottom = h * 20;
+			};
+			sh_bounds2 = None;
+			sh_style = {
+				sws_fill_styles = [
+					SFSBitmap {
+						sfb_repeat = true;
+						sfb_smooth = true;
+						sfb_cid = ids.(i);
+						sfb_mpos = {
+							scale = Some {
+								m_nbits = 22;
+								mx = 20 lsl 16;
+								my = 20 lsl 16;
+							};
+							rotate = None;
+							trans = {
+								m_nbits = 0;
+								mx = 0;
+								my = 0;
+							};
+						};
+					};
+				];
+				sws_line_styles = [];
+				sws_records = {
+					srs_nlbits = 0;
+					srs_nfbits = 1;
+					srs_records = [
+						SRStyleChange {
+							scsr_move = None;
+							scsr_fs0 = None;
+							scsr_fs1 = Some 1;
+							scsr_ls = None;
+							scsr_new_styles = None;
+						};
+						SRStraightEdge {
+							sser_nbits = nbits;
+							sser_line = Some (w * 20) , None;
+						};
+						SRStraightEdge {
+							sser_nbits = nbits;
+							sser_line = None , Some (h * 20);
+						};
+						SRStraightEdge {
+							sser_nbits = nbits;
+							sser_line = Some (unsigned (-w * 20) nbits), None;
+						};
+						SRStraightEdge {
+							sser_nbits = nbits;
+							sser_line = None , Some (unsigned (-h * 20) nbits);
+						};
+					];
+				};
+			};
+		}
+	in
+	let shapes = List.mapi loop pics in
+	let rec loop i =
+		if i = npics then
+			[]
+		else
+			TPlaceObject2 {
+				po_depth = 0;
+				po_move = (i > 0);
+				po_cid = Some (baseid+i);
+				po_color = None;
+				po_matrix = None;
+				po_ratio = None;
+				po_inst_name = None;
+				po_clip_depth = None;
+				po_events = None;
+				po_filters = None;
+				po_blend = None;
+				po_bcache = None;
+			} :: TShowFrame :: loop (i+1)
+	in
+	let tid = ref 0 in
+	let make_tag t =
+		incr tid;
+		{
+			tid = - !tid;
+			textended = false;
+			tdata = t;
+		}
+	in
+	let pics = List.map (fun p -> make_tag p.pdata) pics in
+	let shapes = List.map make_tag shapes in
+	pics @ shapes @ List.map make_tag [
+		TClip {
+			c_id = baseid + npics;
+			c_frame_count = npics;
+			c_tags = List.map make_tag (loop 0);
+		};
+		TExport [{
+			exp_id = baseid + npics;
+			exp_name = name;
+		}];
+	]

libs/swflib/swflib.sln

@@ -0,0 +1,21 @@
+Microsoft Visual Studio Solution File, Format Version 8.00
+Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "swflib", "swflib.vcproj", "{A9DD9D90-85E1-4FCF-8C09-42BF78942849}"
+	ProjectSection(ProjectDependencies) = postProject
+	EndProjectSection
+EndProject
+Global
+	GlobalSection(SolutionConfiguration) = preSolution
+		Bytecode = Bytecode
+		Native code = Native code
+	EndGlobalSection
+	GlobalSection(ProjectConfiguration) = postSolution
+		{A9DD9D90-85E1-4FCF-8C09-42BF78942849}.Bytecode.ActiveCfg = Bytecode|Win32
+		{A9DD9D90-85E1-4FCF-8C09-42BF78942849}.Bytecode.Build.0 = Bytecode|Win32
+		{A9DD9D90-85E1-4FCF-8C09-42BF78942849}.Native code.ActiveCfg = Native code|Win32
+		{A9DD9D90-85E1-4FCF-8C09-42BF78942849}.Native code.Build.0 = Native code|Win32
+	EndGlobalSection
+	GlobalSection(ExtensibilityGlobals) = postSolution
+	EndGlobalSection
+	GlobalSection(ExtensibilityAddIns) = postSolution
+	EndGlobalSection
+EndGlobal

libs/swflib/swflib.vcproj

@@ -0,0 +1,80 @@
+<?xml version="1.0" encoding="Windows-1252"?>
+<VisualStudioProject
+	ProjectType="Visual C++"
+	Version="7.10"
+	Name="swflib"
+	SccProjectName=""
+	SccLocalPath=""
+	Keyword="MakeFileProj">
+	<Platforms>
+		<Platform
+			Name="Win32"/>
+	</Platforms>
+	<Configurations>
+		<Configuration
+			Name="Native code|Win32"
+			OutputDirectory="."
+			IntermediateDirectory="."
+			ConfigurationType="0"
+			UseOfMFC="0"
+			ATLMinimizesCRunTimeLibraryUsage="FALSE">
+			<Tool
+				Name="VCNMakeTool"
+				BuildCommandLine="ocamake -opt swfLib.vcproj -a -g"
+				ReBuildCommandLine="ocamake -opt swfLib.vcproj -a -g -all"
+				Output="swflib.exe"/>
+		</Configuration>
+		<Configuration
+			Name="Bytecode|Win32"
+			OutputDirectory="."
+			IntermediateDirectory="."
+			ConfigurationType="0"
+			UseOfMFC="0"
+			ATLMinimizesCRunTimeLibraryUsage="FALSE">
+			<Tool
+				Name="VCNMakeTool"
+				BuildCommandLine="ocamake -a swfLib.vcproj"
+				ReBuildCommandLine="ocamake -a swfLib.vcproj -all"
+				Output="swflib.exe"/>
+		</Configuration>
+	</Configurations>
+	<References>
+	</References>
+	<Files>
+		<File
+			RelativePath=".\actionScript.ml">
+		</File>
+		<File
+			RelativePath=".\as3.mli">
+		</File>
+		<File
+			RelativePath=".\as3code.ml">
+		</File>
+		<File
+			RelativePath=".\as3hl.mli">
+		</File>
+		<File
+			RelativePath=".\as3hlparse.ml">
+		</File>
+		<File
+			RelativePath=".\as3parse.ml">
+		</File>
+		<File
+			RelativePath=".\png.ml">
+		</File>
+		<File
+			RelativePath=".\png.mli">
+		</File>
+		<File
+			RelativePath=".\swf.ml">
+		</File>
+		<File
+			RelativePath=".\swfParser.ml">
+		</File>
+		<File
+			RelativePath=".\swfPic.ml">
+		</File>
+	</Files>
+	<Globals>
+	</Globals>
+</VisualStudioProject>

libs/ttflib/Makefile

@@ -0,0 +1,31 @@
+OCAMLOPT=ocamlopt
+OCAMLC=ocamlc
+
+FLAGS=-package extlib -safe-string -I ../extlib-leftovers -I ../swflib
+FILES=tTFData tTFParser tTFTools tTFSwfWriter tTFCanvasWriter tTFJsonWriter
+LIBS=extLib swflib unix
+
+OUTPUT=ttf
+
+all: native bytecode
+
+native: ttflib.cmxa
+
+bytecode: ttflib.cma
+
+ttflib.cmxa: $(FILES:=.ml)
+	ocamlfind $(OCAMLOPT) $(FLAGS) $(FILES:=.ml) -g -a -o ttflib.cmxa
+
+ttflib.cma: $(FILES:=.ml)
+	ocamlfind $(OCAMLC) $(FLAGS) $(FILES:=.ml) -g -a -o ttflib.cma
+
+exec:
+	ocamlfind $(OCAMLOPT) $(FLAGS) $(LIBS:=.cmxa) $(FILES:=.ml) main.ml -g -o $(OUTPUT)
+
+clean:
+	rm -rf ttflib.cmxa ttflib.cma ttflib.lib ttflib.a $(wildcard *.cmx) $(wildcard *.obj) $(wildcard *.o) $(wildcard *.cmi) $(wildcard *.cmo)
+
+.PHONY: all native bytecode clean exec
+
+Makefile: ;
+$(FILES:=.ml): ;

libs/ttflib/main.ml

@@ -0,0 +1,137 @@
+open TTFData
+
+exception Abort
+
+let gen_hxswfml_debug fontname =
+	let xml = "<?xml version=\"1.0\" ?>
+	<swf>
+		<FileAttributes/>
+		<Custom tagId=\"75\" file=\"" ^ fontname ^ ".dat\" comment=\"DefineFont3\"/>
+		<SymbolClass id=\"1\" class=\"TestFont\" base=\"flash.text.Font\"/>
+		<DefineABC file=\"Main.swf\" isBoot=\"true\"/>
+		<ShowFrame/>
+	</swf>"
+	in
+	Std.output_file (fontname ^ ".fxml") xml;
+	if Sys.command "haxe -main Main -swf main.swf" <> 0 then failwith "Error while executing haxe";
+	if Sys.command ("hxswfml xml2swf \"" ^ fontname ^ ".fxml\" \"" ^ fontname ^ ".swf\" -no-strict") <> 0 then failwith "Error while executing hxswfml";
+	Unix.unlink (fontname ^ ".fxml");
+	Unix.unlink "main.swf"
+
+let normalize_path p =
+	let l = String.length p in
+	if l = 0 then
+		"./"
+	else begin
+		let p = String.concat "/" (ExtString.String.nsplit p "\\") in
+		match p.[l-1] with
+		| '/' -> p
+		| _ -> p ^ "/"
+	end
+
+let mk_dir_rec dir =
+	let dir = normalize_path dir in
+	let parts = ExtString.String.nsplit dir "/" in
+	let rec create acc = function
+		| [] -> ()
+		| "" :: [] -> ()
+		| d :: l ->
+			let dir = String.concat "/" (List.rev (d :: acc)) in
+			if not (Sys.file_exists dir) then Unix.mkdir dir 0o755;
+			create (d :: acc) l
+	in
+	create [] parts
+
+let exit msg =
+	prerr_endline msg;
+	raise Abort
+
+let process args =
+	let fonts = ref [] in
+	let range_str = ref "" in
+	let targets = ref [] in
+	let debug_hxswfml = ref false in
+	let args_callback s = fonts := s :: !fonts in
+	let usage = Printf.sprintf
+		"Ttf <font paths> (-swf|-canvas)"
+	in
+	let basic_args = [
+		("-range",Arg.String (fun str ->
+			range_str := str;
+		),"<str> : specifies the character range");
+		("-swf",Arg.String (fun dir ->
+			mk_dir_rec dir;
+ 			let f ttf range_str =
+ 				let config = {
+ 					ttfc_range_str = range_str;
+ 					ttfc_font_name = None;
+ 				} in
+				let f2 = TTFSwfWriter.to_swf ttf config in
+				let ch = IO.output_channel (open_out_bin (dir ^ "/" ^ ttf.ttf_font_name ^ ".dat")) in
+				let b = IO.output_bits ch in
+				IO.write_i16 ch 1;
+				TTFSwfWriter.write_font2 ch b f2;
+				IO.close_out ch;
+				if !debug_hxswfml then begin
+					if not (Sys.file_exists "Main.hx") then failwith "Could not find Main.hx required for -hxswfml-debug";
+					let main = Std.input_file "Main.hx" in
+					let old = Sys.getcwd () in
+					Sys.chdir dir;
+					Std.output_file ~filename:"Main.hx" ~text:main;
+					gen_hxswfml_debug ttf.ttf_font_name;
+					Unix.unlink "Main.hx";
+					Sys.chdir old;
+				end
+			in
+			targets := f :: !targets;
+		),"<dir> : generate swf tag data to <dir>");
+		("-canvas", Arg.String (fun dir ->
+			mk_dir_rec dir;
+ 			let f ttf range_str =
+ 				let glyphs = TTFCanvasWriter.to_canvas ttf range_str in
+				let ch = IO.output_channel (open_out_bin (dir ^ "/" ^ ttf.ttf_font_name ^ ".js")) in
+				TTFCanvasWriter.write_font ch ttf glyphs;
+				IO.close_out ch;
+			in
+			targets := f :: !targets;
+		),"<dir> : generate canvas draw commands to <dir>");
+		("-json", Arg.String (fun dir ->
+			mk_dir_rec dir;
+ 			let f ttf range_str =
+ 				let glyphs = TTFJsonWriter.to_json ttf range_str in
+				let ch = IO.output_channel (open_out_bin (dir ^ "/" ^ ttf.ttf_font_name ^ ".js")) in
+				TTFJsonWriter.write_font ch ttf glyphs;
+				IO.close_out ch;
+			in
+			targets := f :: !targets;
+		),"<dir> : generate json-encoded glyph information to <dir>");
+		("-hxswfml-debug", Arg.Unit (fun () ->
+			debug_hxswfml := true;
+		),": generate debug swf with hxswfml")
+	] in
+	if Array.length Sys.argv = 1 then
+		Arg.usage basic_args usage
+	else begin
+		Arg.parse basic_args args_callback usage;
+		match !fonts,!targets with
+		| [],_ ->
+			prerr_endline "Missing font argument";
+			Arg.usage basic_args usage
+		| _,[] ->
+			prerr_endline "No targets specified (-swf|-canvas|-json)";
+			Arg.usage basic_args usage
+		| fonts,targets ->
+			List.iter (fun font ->
+				let ch = try open_in_bin font with _ -> exit ("No such file: " ^ font) in
+				let ttf = TTFParser.parse ch in
+				List.iter (fun target ->
+					target ttf !range_str
+				) targets;
+				close_in ch;
+			) fonts;
+	end
+;;
+try
+	process Sys.argv;
+with Abort ->
+	()

libs/ttflib/tTFCanvasWriter.ml

@@ -0,0 +1,50 @@
+(*
+ * Copyright (C)2005-2014 Haxe Foundation
+ *
+ * Permission is hereby granted, free of charge, to any person obtaining a
+ * copy of this software and associated documentation files (the "Software"),
+ * to deal in the Software without restriction, including without limitation
+ * the rights to use, copy, modify, merge, publish, distribute, sublicense,
+ * and/or sell copies of the Software, and to permit persons to whom the
+ * Software is furnished to do so, subject to the following conditions:
+ *
+ * The above copyright notice and this permission notice shall be included in
+ * all copies or substantial portions of the Software.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+ * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+ * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+ * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+ * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+ * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+ * DEALINGS IN THE SOFTWARE.
+ *)
+
+open TTFData
+open TTFTools
+
+let rec write_glyph ttf key glyf =
+	key,TTFTools.build_glyph_paths ttf false glyf
+
+let write_font ch ttf glyphs =
+	let scale = 1024. /. (float_of_int ttf.ttf_head.hd_units_per_em) in
+	List.iter (fun (key,paths) ->
+		IO.nwrite_string ch (Printf.sprintf "\tfunction key%i(ctx) {\n" key);
+		IO.nwrite_string ch "\t\tctx.beginPath();\n";
+		List.iter (fun path ->
+			IO.nwrite_string ch (match path.gp_type with
+			| 0 -> Printf.sprintf "\t\tctx.moveTo(%.2f,%.2f);\n" (path.gp_x *. scale) (path.gp_y *. scale *. (-1.))
+			| 1 -> Printf.sprintf "\t\tctx.lineTo(%.2f,%.2f);\n" (path.gp_x *. scale) (path.gp_y *. scale *. (-1.))
+			| 2 -> Printf.sprintf "\t\tctx.quadraticCurveTo(%.2f,%.2f,%.2f,%.2f);\n" (path.gp_cx *. scale) (path.gp_cy *. scale *. (-1.)) (path.gp_x *. scale) (path.gp_y *. scale *. (-1.))
+			| _ -> assert false)
+		) paths;
+		IO.nwrite_string ch "\t\tctx.fill();\n";
+		IO.nwrite_string ch "\t}\n";
+	) glyphs;
+	()
+
+let to_canvas ttf range_str =
+	let lut = TTFTools.build_lut ttf range_str in
+	let glyfs = Hashtbl.fold (fun k v acc -> (k,ttf.ttf_glyfs.(v)) :: acc) lut [] in
+	let glyfs = List.stable_sort (fun a b -> compare (fst a) (fst b)) glyfs in
+	List.map (fun (k,g) -> write_glyph ttf k g) glyfs

libs/ttflib/tTFData.ml

@@ -0,0 +1,350 @@
+(*
+ * Copyright (C)2005-2014 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.
+ *)
+
+type header = {
+	hd_major_version : int;
+	hd_minor_version : int;
+	hd_num_tables : int;
+	hd_search_range : int;
+	hd_entry_selector : int;
+	hd_range_shift : int;
+}
+
+type entry = {
+	entry_table_name : string;
+	entry_checksum : int32;
+	entry_offset : int32;
+	entry_length: int32;
+}
+
+(* GLYF *)
+
+type glyf_header = {
+	gh_num_contours : int;
+	gh_xmin : int;
+	gh_ymin : int;
+	gh_xmax : int;
+	gh_ymax : int;
+}
+
+type glyf_simple = {
+	gs_end_pts_of_contours : int array;
+	gs_instruction_length : int;
+	gs_instructions : char array;
+	gs_flags : int array;
+	gs_x_coordinates : int array;
+	gs_y_coordinates : int array;
+}
+
+type transformation_option =
+	| NoScale
+	| Scale of float
+	| ScaleXY of float * float
+	| ScaleMatrix of float * float * float * float
+
+type glyf_component = {
+	gc_flags : int;
+	gc_glyf_index : int;
+	gc_arg1 : int;
+	gc_arg2 : int;
+	gc_transformation : transformation_option;
+}
+
+type glyf =
+	| TGlyfSimple of glyf_header * glyf_simple
+	| TGlyfComposite of glyf_header * glyf_component list
+	| TGlyfNull
+
+(* HMTX *)
+
+type hmtx = {
+	advance_width : int;
+	left_side_bearing : int;
+}
+
+(* CMAP *)
+
+type cmap_subtable_header = {
+	csh_platform_id : int;
+	csh_platform_specific_id : int;
+	csh_offset : int32;
+}
+
+type cmap_format_0 = {
+	c0_format : int;
+	c0_length : int;
+	c0_language : int;
+	c0_glyph_index_array : char array;
+}
+
+type cmap_format_4 = {
+	c4_format : int;
+	c4_length : int;
+	c4_language : int;
+	c4_seg_count_x2 : int;
+	c4_search_range : int;
+	c4_entry_selector : int;
+	c4_range_shift : int;
+	c4_end_code : int array;
+	c4_reserved_pad : int;
+	c4_start_code : int array;
+	c4_id_delta : int array;
+	c4_id_range_offset : int array;
+	c4_glyph_index_array : int array;
+}
+
+type cmap_format_6 = {
+	c6_format : int;
+	c6_length : int;
+	c6_language : int;
+	c6_first_code : int;
+	c6_entry_count : int;
+	c6_glyph_index_array : int array;
+}
+
+type cmap_format_12_group = {
+	c12g_start_char_code : int32;
+	c12g_end_char_code : int32;
+	c12g_start_glyph_code : int32;
+}
+
+type cmap_format_12 = {
+	c12_format : int32;
+	c12_length : int32;
+	c12_language : int32;
+	c12_num_groups : int32;
+	c12_groups : cmap_format_12_group list;
+}
+
+type cmap_subtable_def =
+	| Cmap0 of cmap_format_0
+	| Cmap4 of cmap_format_4
+	| Cmap6 of cmap_format_6
+	| Cmap12 of cmap_format_12
+	| CmapUnk of string
+
+type cmap_subtable = {
+	cs_header : cmap_subtable_header;
+	cs_def : cmap_subtable_def;
+}
+
+type cmap = {
+	cmap_version : int;
+	cmap_num_subtables : int;
+	cmap_subtables : cmap_subtable list;
+}
+
+(* KERN *)
+
+type kern_subtable_header = {
+	ksh_length : int32;
+	ksh_coverage : int;
+	ksh_tuple_index : int;
+}
+
+type kern_pair = {
+	kern_left : int;
+	kern_right : int;
+	kern_value : int;
+}
+
+type kern_format_0 = {
+	k0_num_pairs : int;
+	k0_search_range : int;
+	k0_entry_selector : int;
+	k0_range_shift : int;
+	k0_pairs : kern_pair list;
+}
+
+type kern_format_2 = {
+	k2_row_width : int;
+	k2_left_offset_table : int;
+	k2_right_offset_table : int;
+	k2_array : int;
+	k2_first_glyph : int;
+	k2_num_glyphs : int;
+	k2_offsets : int list;
+}
+
+type kern_subtable_def =
+	| Kern0 of kern_format_0
+	| Kern2 of kern_format_2
+
+type kern_subtable = {
+	ks_header : kern_subtable_header;
+	ks_def : kern_subtable_def;
+}
+
+type kern = {
+	kern_version : int32;
+	kern_num_tables : int32;
+	kern_subtables : kern_subtable list;
+}
+
+(* NAME *)
+
+type name_record = {
+	nr_platform_id : int;
+	nr_platform_specific_id : int;
+	nr_language_id : int;
+	nr_name_id : int;
+	nr_length : int;
+	nr_offset : int;
+	mutable nr_value : string;
+}
+
+type name = {
+	name_format : int;
+	name_num_records : int;
+	name_offset : int;
+	name_records : name_record array;
+}
+
+(* HEAD *)
+
+type head = {
+	hd_version : int32;
+	hd_font_revision : int32;
+	hd_checksum_adjustment : int32;
+	hd_magic_number : int32;
+	hd_flags : int;
+	hd_units_per_em : int;
+	hd_created : float;
+	hd_modified : float;
+	hd_xmin : int;
+	hd_ymin : int;
+	hd_xmax : int;
+	hd_ymax : int;
+	hd_mac_style : int;
+	hd_lowest_rec_ppem : int;
+	hd_font_direction_hint : int;
+	hd_index_to_loc_format : int;
+	hd_glyph_data_format : int;
+}
+
+(* HHEA *)
+
+type hhea = {
+	hhea_version : int32;
+	hhea_ascent : int;
+	hhea_descent : int;
+	hhea_line_gap : int;
+	hhea_advance_width_max : int;
+	hhea_min_left_side_bearing : int;
+	hhea_min_right_side_bearing : int;
+	hhea_x_max_extent : int;
+	hhea_caret_slope_rise : int;
+	hhea_caret_slope_run : int;
+	hhea_caret_offset : int;
+	hhea_reserved : string;
+	hhea_metric_data_format : int;
+	hhea_number_of_hmetrics :int;
+}
+
+(* LOCA *)
+
+type loca = int32 array
+
+(* MAXP *)
+
+type maxp = {
+	maxp_version_number : int32;
+	maxp_num_glyphs : int;
+	maxp_max_points : int;
+	maxp_max_contours : int;
+	maxp_max_component_points : int;
+	maxp_max_component_contours : int;
+	maxp_max_zones : int;
+	maxp_max_twilight_points : int;
+	maxp_max_storage : int;
+	maxp_max_function_defs : int;
+	maxp_max_instruction_defs :int;
+	maxp_max_stack_elements : int;
+	maxp_max_size_of_instructions :int;
+	maxp_max_component_elements :int;
+	maxp_max_component_depth :int;
+}
+
+(* OS2 *)
+
+type os2 = {
+	os2_version : int;
+	os2_x_avg_char_width : int;
+	os2_us_weight_class : int;
+	os2_us_width_class : int;
+	os2_fs_type : int;
+	os2_y_subscript_x_size : int;
+	os2_y_subscript_y_size : int;
+	os2_y_subscript_x_offset : int;
+	os2_y_subscript_y_offset : int;
+	os2_y_superscript_x_size : int;
+	os2_y_superscript_y_size : int;
+	os2_y_superscript_x_offset : int;
+	os2_y_superscript_y_offset : int;
+	os2_y_strikeout_size : int;
+	os2_y_strikeout_position : int;
+	os2_s_family_class : int;
+	os2_b_family_type : int;
+	os2_b_serif_style : int;
+	os2_b_weight : int;
+	os2_b_proportion : int;
+	os2_b_contrast : int;
+	os2_b_stroke_variation : int;
+	os2_b_arm_style : int;
+	os2_b_letterform : int;
+	os2_b_midline : int;
+	os2_b_x_height : int;
+	os2_ul_unicode_range_1 : int32;
+	os2_ul_unicode_range_2 : int32;
+	os2_ul_unicode_range_3 : int32;
+	os2_ul_unicode_range_4 : int32;
+	os2_ach_vendor_id : int32;
+	os2_fs_selection : int;
+	os2_us_first_char_index : int;
+	os2_us_last_char_index : int;
+	os2_s_typo_ascender : int;
+	os2_s_typo_descender : int;
+	os2_s_typo_line_gap : int;
+	os2_us_win_ascent : int;
+	os2_us_win_descent : int;
+}
+
+type ttf = {
+	ttf_header : header;
+	ttf_font_name : string;
+	ttf_directory: (string,entry) Hashtbl.t;
+	ttf_glyfs : glyf array;
+	ttf_hmtx : hmtx array;
+	ttf_cmap : cmap;
+	ttf_head : head;
+	ttf_loca : loca;
+	ttf_hhea : hhea;
+	ttf_maxp : maxp;
+	ttf_name : name;
+	ttf_os2 : os2;
+	ttf_kern : kern option;
+}
+
+type ttf_config = {
+	mutable ttfc_range_str : string;
+	mutable ttfc_font_name : string option;
+}

libs/ttflib/tTFJsonWriter.ml

@@ -0,0 +1,49 @@
+(*
+ * Copyright (C)2005-2014 Haxe Foundation
+ *
+ * Permission is hereby granted, free of charge, to any person obtaining a
+ * copy of this software and associated documentation files (the "Software"),
+ * to deal in the Software without restriction, including without limitation
+ * the rights to use, copy, modify, merge, publish, distribute, sublicense,
+ * and/or sell copies of the Software, and to permit persons to whom the
+ * Software is furnished to do so, subject to the following conditions:
+ *
+ * The above copyright notice and this permission notice shall be included in
+ * all copies or substantial portions of the Software.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+ * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+ * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+ * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+ * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+ * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+ * DEALINGS IN THE SOFTWARE.
+ *)
+
+open TTFData
+open TTFTools
+
+let rec write_glyph ttf key glyf =
+	key,TTFTools.build_glyph_paths ttf false glyf
+
+let write_font ch ttf glyphs =
+	let scale = 1024. /. (float_of_int ttf.ttf_head.hd_units_per_em) in
+	IO.nwrite_string ch "{\n\t";
+	IO.nwrite_string ch (String.concat ",\n\t" (List.map (fun (key,paths) ->
+		(Printf.sprintf "\"g%i\":[" key)
+		^ (String.concat "," (List.map (fun path ->
+			match path.gp_type with
+			| 0 -> Printf.sprintf "[0,%.2f,%.2f]" (path.gp_x *. scale) (path.gp_y *. scale *. (-1.))
+			| 1 -> Printf.sprintf "[1,%.2f,%.2f]" (path.gp_x *. scale) (path.gp_y *. scale *. (-1.))
+			| 2 -> Printf.sprintf "[2,%.2f,%.2f,%.2f,%.2f]" (path.gp_cx *. scale) (path.gp_cy *. scale *. (-1.)) (path.gp_x *. scale) (path.gp_y *. scale *. (-1.))
+			| _ -> assert false
+		) paths))
+		^ "]";
+	) glyphs));
+	IO.nwrite_string ch "\n}"
+
+let to_json ttf range_str =
+	let lut = TTFTools.build_lut ttf range_str in
+	let glyfs = Hashtbl.fold (fun k v acc -> (k,ttf.ttf_glyfs.(v)) :: acc) lut [] in
+	let glyfs = List.stable_sort (fun a b -> compare (fst a) (fst b)) glyfs in
+	List.map (fun (k,g) -> write_glyph ttf k g) glyfs

libs/ttflib/tTFParser.ml

@@ -0,0 +1,688 @@
+(*
+ * Copyright (C)2005-2014 Haxe Foundation
+ *
+ * Permission is hereby granted, free of charge, to any person obtaining a
+ * copy of this software and associated documentation files (the "Software"),
+ * to deal in the Software without restriction, including without limitation
+ * the rights to use, copy, modify, merge, publish, distribute, sublicense,
+ * and/or sell copies of the Software, and to permit persons to whom the
+ * Software is furnished to do so, subject to the following conditions:
+ *
+ * The above copyright notice and this permission notice shall be included in
+ * all copies or substantial portions of the Software.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+ * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+ * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+ * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+ * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+ * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+ * DEALINGS IN THE SOFTWARE.
+ *)
+
+open TTFData
+open IO
+
+type ctx = {
+	file : Pervasives.in_channel;
+	ch : input;
+	mutable entry : entry;
+}
+
+let rd16 = BigEndian.read_i16
+let rdu16 = BigEndian.read_ui16
+let rd32 = BigEndian.read_i32
+let rd32r = BigEndian.read_real_i32
+
+let parse_header ctx =
+	let ch = ctx.ch in
+	let major_version = rdu16 ch in
+	let minor_version = rdu16 ch in
+	let num_tables = rdu16 ch in
+	let search_range = rdu16 ch in
+	let entry_selector = rdu16 ch in
+	let range_shift = rdu16 ch in
+	{
+		hd_major_version = major_version;
+		hd_minor_version = minor_version;
+		hd_num_tables = num_tables;
+		hd_search_range = search_range;
+		hd_entry_selector = entry_selector;
+		hd_range_shift = range_shift;
+	}
+
+let parse_directory ctx header =
+	let ch = ctx.ch in
+	let directory = Hashtbl.create 0 in
+	for i = 0 to header.hd_num_tables - 1 do
+		let name = nread_string ch 4 in
+		let cs = rd32r ch in
+		let off = rd32r ch in
+		let length = rd32r ch in
+		Hashtbl.add directory name {
+			entry_table_name = name;
+			entry_checksum = cs;
+			entry_offset = off;
+			entry_length = length;
+		}
+	done;
+	directory
+
+let parse_head_table ctx =
+	let ch = ctx.ch in
+	let version = rd32r ch in
+	let font_revision = rd32r ch in
+	let checksum_adjustment = rd32r ch in
+	let magic_number = rd32r ch in
+	let flags = rdu16 ch in
+	let units_per_em = rdu16 ch in
+	let created = BigEndian.read_double ch in
+	let modified = BigEndian.read_double ch in
+	let xmin = rd16 ch in
+	let ymin = rd16 ch in
+	let xmax = rd16 ch in
+	let ymax = rd16 ch in
+	let mac_style = rdu16 ch in
+	let lowest_rec_ppem = rdu16 ch in
+	let font_direction_hint = rd16 ch in
+	let index_to_loc_format = rd16 ch in
+	let glyph_data_format = rd16 ch in
+	{
+		hd_version = version;
+		hd_font_revision = font_revision;
+		hd_checksum_adjustment = checksum_adjustment;
+		hd_magic_number = magic_number;
+		hd_flags = flags;
+		hd_units_per_em = units_per_em;
+		hd_created = created;
+		hd_modified = modified;
+		hd_xmin = xmin;
+		hd_ymin = ymin;
+		hd_xmax = xmax;
+		hd_ymax = ymax;
+		hd_mac_style = mac_style;
+		hd_lowest_rec_ppem = lowest_rec_ppem;
+		hd_font_direction_hint = font_direction_hint;
+		hd_index_to_loc_format = index_to_loc_format;
+		hd_glyph_data_format = glyph_data_format;
+	}
+
+let parse_hhea_table ctx =
+	let ch = ctx.ch in
+	let version = rd32r ch in
+	let ascender = rd16 ch in
+	let descender = rd16 ch in
+	let line_gap = rd16 ch in
+	let advance_width_max = rdu16 ch in
+	let min_left_side_bearing = rd16 ch in
+	let min_right_side_bearing = rd16 ch in
+	let x_max_extent = rd16 ch in
+	let caret_slope_rise = rd16 ch in
+	let caret_slope_run = rd16 ch in
+	let caret_offset = rd16 ch in
+	let reserved = nread_string ch 8 in
+	let metric_data_format = rd16 ch in
+	let number_of_hmetrics = rdu16 ch in
+	{
+		hhea_version = version;
+		hhea_ascent = ascender;
+		hhea_descent = descender;
+		hhea_line_gap = line_gap;
+		hhea_advance_width_max = advance_width_max;
+		hhea_min_left_side_bearing = min_left_side_bearing;
+		hhea_min_right_side_bearing = min_right_side_bearing;
+		hhea_x_max_extent = x_max_extent;
+		hhea_caret_slope_rise = caret_slope_rise;
+		hhea_caret_slope_run = caret_slope_run;
+		hhea_caret_offset = caret_offset;
+		hhea_reserved = reserved;
+		hhea_metric_data_format = metric_data_format;
+		hhea_number_of_hmetrics = number_of_hmetrics;
+	}
+
+let parse_maxp_table ctx =
+	let ch = ctx.ch in
+	let version_number = rd32r ch in
+	let num_glyphs = rdu16 ch in
+	let max_points = rdu16 ch in
+	let max_contours = rdu16 ch in
+	let max_component_points = rdu16 ch in
+	let max_component_contours = rdu16 ch in
+	let max_zones = rdu16 ch in
+	let max_twilight_points = rdu16 ch in
+	let max_storage = rdu16 ch in
+	let max_function_defs = rdu16 ch in
+	let max_instruction_defs = rdu16 ch in
+	let max_stack_elements = rdu16 ch in
+	let max_size_of_instructions = rdu16 ch in
+	let max_component_elements = rdu16 ch in
+	let max_component_depth = rdu16 ch in
+	{
+		maxp_version_number = version_number;
+		maxp_num_glyphs = num_glyphs;
+		maxp_max_points = max_points;
+		maxp_max_contours = max_contours;
+		maxp_max_component_points = max_component_points;
+		maxp_max_component_contours = max_component_contours;
+		maxp_max_zones = max_zones;
+		maxp_max_twilight_points = max_twilight_points;
+		maxp_max_storage = max_storage;
+		maxp_max_function_defs = max_function_defs;
+		maxp_max_instruction_defs = max_instruction_defs;
+		maxp_max_stack_elements = max_stack_elements;
+		maxp_max_size_of_instructions = max_size_of_instructions;
+		maxp_max_component_elements = max_component_elements;
+		maxp_max_component_depth = max_component_depth;
+	}
+
+let parse_loca_table head maxp ctx =
+	let ch = ctx.ch in
+	if head.hd_index_to_loc_format = 0 then
+		Array.init (maxp.maxp_num_glyphs + 1) (fun _ -> Int32.of_int ((rdu16 ch) * 2))
+	else
+		Array.init (maxp.maxp_num_glyphs + 1) (fun _ -> rd32r ch)
+
+let parse_hmtx_table maxp hhea ctx =
+	let ch = ctx.ch in
+	let last_advance_width = ref 0 in (* check me 1/2*)
+	Array.init maxp.maxp_num_glyphs (fun i ->
+		let advance_width = if i > hhea.hhea_number_of_hmetrics-1 then (* check me 2/2*)
+			!last_advance_width
+		else
+			rdu16 ch
+		in
+		last_advance_width := advance_width;
+		let left_side_bearing = rd16 ch in
+		{
+			advance_width = advance_width;
+			left_side_bearing = left_side_bearing;
+		}
+	)
+
+let parse_cmap_table ctx =
+	let ch = ctx.ch in
+	let version = rdu16 ch in
+	let num_subtables = rdu16 ch in
+	let dir = ExtList.List.init num_subtables (fun _ ->
+		let platform_id = rdu16 ch in
+		let platform_specific_id = rdu16 ch in
+		let offset = rd32r ch in
+		{
+			csh_platform_id = platform_id;
+			csh_platform_specific_id = platform_specific_id;
+			csh_offset = offset;
+		}
+	) in
+	let dir = List.stable_sort (fun csh1 csh2 ->
+		if csh1.csh_platform_id < csh2.csh_platform_id then -1
+		else if csh1.csh_platform_id > csh2.csh_platform_id then 1
+		else compare csh1.csh_platform_specific_id csh2.csh_platform_specific_id
+	) dir in
+	let parse_sub entry =
+		seek_in ctx.file ((Int32.to_int ctx.entry.entry_offset) + (Int32.to_int entry.csh_offset));
+		let format = rdu16 ch in
+		let def = match format with
+			| 0 ->
+				let length = rdu16 ch in
+				let language = rdu16 ch in
+				let glyph_index = Array.init 256 (fun _ -> read ch) in
+				Cmap0 {
+					c0_format = 0;
+					c0_length = length;
+					c0_language = language;
+					c0_glyph_index_array = glyph_index;
+				}
+			| 4 ->
+				let length = rdu16 ch in
+				let language = rdu16 ch in
+				let seg_count_x2 = rdu16 ch in
+				let seg_count = seg_count_x2 / 2 in
+				let search_range = rdu16 ch in
+				let entry_selector = rdu16 ch in
+				let range_shift = rdu16 ch in
+				let end_code = Array.init seg_count (fun _ -> rdu16 ch) in
+				let reserved = rdu16 ch in
+				assert (reserved = 0);
+				let start_code = Array.init seg_count (fun _ -> rdu16 ch) in
+				let id_delta = Array.init seg_count (fun _ -> rdu16 ch) in
+				let id_range_offset = Array.init seg_count (fun _ -> rdu16 ch) in
+				let count = (length - (8 * seg_count + 16)) / 2 in
+				let glyph_index = Array.init count (fun _ -> rdu16 ch) in
+				Cmap4 {
+					c4_format = format;
+					c4_length = length;
+					c4_language = language;
+					c4_seg_count_x2 = seg_count_x2;
+					c4_search_range = search_range;
+					c4_entry_selector = entry_selector;
+					c4_range_shift = range_shift;
+					c4_end_code = end_code;
+					c4_reserved_pad = reserved;
+					c4_start_code = start_code;
+					c4_id_delta = id_delta;
+					c4_id_range_offset = id_range_offset;
+					c4_glyph_index_array = glyph_index;
+				}
+			| 6 ->
+				let length = rdu16 ch in
+				let language = rdu16 ch in
+				let first_code = rdu16 ch in
+				let entry_count = rdu16 ch in
+				let glyph_index = Array.init entry_count (fun _ -> rdu16 ch) in
+				Cmap6 {
+					c6_format = format;
+					c6_length = length;
+					c6_language = language;
+					c6_first_code = first_code;
+					c6_entry_count = entry_count;
+					c6_glyph_index_array = glyph_index;
+				}
+  			| 12 ->
+				ignore (rd16 ch);
+				let length = rd32r ch in
+				let language = rd32r ch in
+				let num_groups = rd32r ch in
+				let groups = ExtList.List.init (Int32.to_int num_groups) (fun _ ->
+					let start = rd32r ch in
+					let stop = rd32r ch in
+					let start_glyph = rd32r ch in
+					{
+						c12g_start_char_code = start;
+						c12g_end_char_code = stop;
+						c12g_start_glyph_code = start_glyph;
+					}
+				) in
+				Cmap12 {
+					c12_format = Int32.of_int 12;
+					c12_length = length;
+					c12_language = language;
+					c12_num_groups = num_groups;
+					c12_groups = groups;
+				}
+			| x ->
+				failwith ("Not implemented format: " ^ (string_of_int x));
+		in
+		{
+			cs_def = def;
+			cs_header = entry;
+		}
+
+	in
+	{
+		cmap_version = version;
+		cmap_num_subtables = num_subtables;
+		cmap_subtables = List.map parse_sub dir;
+	}
+
+let parse_glyf_table maxp loca cmap hmtx ctx =
+	let ch = ctx.ch in
+	let parse_glyf i =
+		seek_in ctx.file ((Int32.to_int ctx.entry.entry_offset) + (Int32.to_int loca.(i)));
+		let num_contours = rd16 ch in
+		let xmin = rd16 ch in
+		let ymin = rd16 ch in
+		let xmax = rd16 ch in
+		let ymax = rd16 ch in
+		let header = {
+			gh_num_contours = num_contours;
+			gh_xmin = xmin;
+			gh_ymin = ymin;
+			gh_xmax = xmax;
+			gh_ymax = ymax;
+		} in
+		if num_contours >= 0 then begin
+			let num_points = ref 0 in
+			let end_pts_of_contours = Array.init num_contours (fun i ->
+				let v = rdu16 ch in
+				if i = num_contours - 1 then num_points := v + 1;
+				v
+			) in
+			let instruction_length = rdu16 ch in
+			let instructions = Array.init instruction_length (fun _ ->
+				read ch
+			) in
+			let flags = DynArray.create () in
+			let rec loop index =
+				if index >= !num_points then () else begin
+					let v = read_byte ch in
+					let incr = if (v land 8) == 0 then begin
+						DynArray.add flags v;
+						1
+					end else begin
+						let r = (int_of_char (read ch)) in
+						for i = 0 to r do DynArray.add flags v done;
+						r + 1
+					end in
+					loop (index + incr)
+				end
+			in
+			loop 0;
+			assert (DynArray.length flags = !num_points);
+			let x_coordinates = Array.init !num_points (fun i ->
+				let flag = DynArray.get flags i in
+				if flag land 0x10 <> 0 then begin
+					if flag land 0x02 <> 0 then read_byte ch
+					else 0
+				end else begin
+					if flag land 0x02 <> 0 then -read_byte ch
+					else rd16 ch
+				end
+			) in
+			let y_coordinates = Array.init !num_points (fun i ->
+				let flag = DynArray.get flags i in
+				if flag land 0x20 <> 0 then begin
+					if flag land 0x04 <> 0 then read_byte ch
+					else 0
+				end else begin
+					if flag land 0x04 <> 0 then -read_byte ch
+					else rd16 ch
+				end;
+			) in
+			TGlyfSimple (header, {
+				gs_end_pts_of_contours = end_pts_of_contours;
+				gs_instruction_length = instruction_length;
+				gs_instructions = instructions;
+				gs_flags = DynArray.to_array flags;
+				gs_x_coordinates = x_coordinates;
+				gs_y_coordinates = y_coordinates;
+			})
+		end else if num_contours = -1 then begin
+			let acc = DynArray.create () in
+			let rec loop () =
+				let flags = rdu16 ch in
+				let glyph_index = rdu16 ch in
+				let arg1,arg2 = if flags land 1 <> 0 then begin
+					let arg1 = rd16 ch in
+					let arg2 = rd16 ch in
+					arg1,arg2
+				end else begin
+					let arg1 = read_byte ch in
+					let arg2 = read_byte ch in
+					arg1,arg2
+				end in
+				let fmt214 i = (float_of_int i) /. (float_of_int 0x4000) in
+				let fmode =	if flags land 8 <> 0 then
+					Scale (fmt214 (rd16 ch))
+				else if flags land 64 <> 0 then begin
+					let s1 = fmt214 (rd16 ch) in
+					let s2 = fmt214 (rd16 ch) in
+					ScaleXY (s1,s2)
+				end else if flags land 128 <> 0 then begin
+					let a = fmt214 (rd16 ch) in
+					let b = fmt214 (rd16 ch) in
+					let c = fmt214 (rd16 ch) in
+					let d = fmt214 (rd16 ch) in
+					ScaleMatrix (a,b,c,d)
+				end else
+					NoScale
+				in
+				DynArray.add acc {
+					gc_flags = flags;
+					gc_glyf_index = glyph_index;
+					gc_arg1 = if flags land 2 <> 0 then arg1 else 0;
+					gc_arg2 = if flags land 2 <> 0 then arg2 else 0;
+					gc_transformation = fmode;
+				};
+				if flags land 0x20 <> 0 then loop ();
+			in
+			loop ();
+			TGlyfComposite (header,(DynArray.to_list acc))
+		end else
+			failwith "Unknown Glyf"
+	in
+	Array.init maxp.maxp_num_glyphs (fun i ->
+		let len = (Int32.to_int loca.(i + 1)) - (Int32.to_int loca.(i)) in
+		if len > 0 then parse_glyf i else TGlyfNull
+	)
+
+let parse_kern_table ctx =
+	let ch = ctx.ch in
+	let version = Int32.of_int (rd16 ch) in
+	let num_tables = Int32.of_int (rd16 ch) in
+	let tables = ExtList.List.init (Int32.to_int num_tables) (fun _ ->
+		let length = Int32.of_int (rdu16 ch) in
+		let tuple_index = rdu16 ch in
+		let coverage = rdu16 ch in
+		let def = match coverage lsr 8 with
+		| 0 ->
+			let num_pairs = rdu16 ch in
+			let search_range = rdu16 ch in
+			let entry_selector = rdu16 ch in
+			let range_shift = rdu16 ch in
+			let kerning_pairs = ExtList.List.init num_pairs (fun _ ->
+				let left = rdu16 ch in
+				let right = rdu16 ch in
+				let value = rd16 ch in
+				{
+					kern_left = left;
+					kern_right = right;
+					kern_value = value;
+				}
+			) in
+			Kern0 {
+				k0_num_pairs = num_pairs;
+				k0_search_range = search_range;
+				k0_entry_selector = entry_selector;
+				k0_range_shift = range_shift;
+				k0_pairs = kerning_pairs;
+			}
+		| 2 ->
+			let row_width = rdu16 ch in
+			let left_offset_table = rdu16 ch in
+			let right_offset_table = rdu16 ch in
+			let array_offset = rdu16 ch in
+			let first_glyph = rdu16 ch in
+			let num_glyphs = rdu16 ch in
+			let offsets = ExtList.List.init num_glyphs (fun _ ->
+				rdu16 ch
+			) in
+			Kern2 {
+				k2_row_width = row_width;
+				k2_left_offset_table = left_offset_table;
+				k2_right_offset_table = right_offset_table;
+				k2_array = array_offset;
+				k2_first_glyph = first_glyph;
+				k2_num_glyphs = num_glyphs;
+				k2_offsets = offsets;
+			}
+		| i ->
+			failwith ("Unknown kerning: " ^ (string_of_int i));
+		in
+		{
+			ks_def = def;
+			ks_header = {
+				ksh_length = length;
+				ksh_coverage = coverage;
+				ksh_tuple_index = tuple_index;
+			}
+		}
+	) in
+	{
+		kern_version = version;
+		kern_num_tables = num_tables;
+		kern_subtables = tables;
+	}
+
+let parse_name_table ctx =
+	let ch = ctx.ch in
+	let format = rdu16 ch in
+	let num_records = rdu16 ch in
+	let offset = rdu16 ch in
+	let records = Array.init num_records (fun _ ->
+		let platform_id = rdu16 ch in
+		let platform_specific_id = rdu16 ch in
+		let language_id = rdu16 ch in
+		let name_id = rdu16 ch in
+		let length = rdu16 ch in
+		let offset = rdu16 ch in
+		{
+			nr_platform_id = platform_id;
+			nr_platform_specific_id = platform_specific_id;
+			nr_language_id = language_id;
+			nr_name_id = name_id;
+			nr_length = length;
+			nr_offset = offset;
+			nr_value = "";
+		}
+	) in
+	let ttf_name = ref "" in
+	(* TODO: use real utf16 conversion *)
+	let set_name n =
+		let l = ExtList.List.init (String.length n / 2) (fun i -> String.make 1 n.[i * 2 + 1]) in
+		ttf_name := String.concat "" l
+	in
+	let records = Array.map (fun r ->
+		seek_in ctx.file ((Int32.to_int ctx.entry.entry_offset) + offset + r.nr_offset);
+		r.nr_value <- nread_string ch r.nr_length;
+		if r.nr_name_id = 4 && r.nr_platform_id = 3 || r.nr_platform_id = 0 then set_name r.nr_value;
+		r
+	) records in
+	{
+		name_format = format;
+		name_num_records = num_records;
+		name_offset = offset;
+		name_records = records;
+	},!ttf_name
+
+let parse_os2_table ctx =
+	let ch = ctx.ch in
+	let version = rdu16 ch in
+	let x_avg_char_width = rd16 ch in
+	let us_weight_class = rdu16 ch in
+	let us_width_class = rdu16 ch in
+	let fs_type = rd16 ch in
+	let y_subscript_x_size = rd16 ch in
+	let y_subscript_y_size = rd16 ch in
+	let y_subscript_x_offset = rd16 ch in
+	let y_subscript_y_offset = rd16 ch in
+	let y_superscript_x_size = rd16 ch in
+	let y_superscript_y_size = rd16 ch in
+	let y_superscript_x_offset = rd16 ch in
+	let y_superscript_y_offset = rd16 ch in
+	let y_strikeout_size = rd16 ch in
+	let y_strikeout_position = rd16 ch in
+	let s_family_class = rd16 ch in
+
+	let b_family_type = read_byte ch in
+	let b_serif_style = read_byte ch in
+	let b_weight = read_byte ch in
+	let b_proportion = read_byte ch in
+	let b_contrast = read_byte ch in
+	let b_stroke_variation = read_byte ch in
+	let b_arm_style = read_byte ch in
+	let b_letterform = read_byte ch in
+	let b_midline = read_byte ch in
+	let b_x_height = read_byte ch in
+
+	let ul_unicode_range_1 = rd32r ch in
+	let ul_unicode_range_2 = rd32r ch in
+	let ul_unicode_range_3 = rd32r ch in
+	let ul_unicode_range_4 = rd32r ch in
+	let ach_vendor_id = rd32r ch in
+	let fs_selection = rd16 ch in
+	let us_first_char_index = rdu16 ch in
+	let us_last_char_index = rdu16 ch in
+	let s_typo_ascender = rd16 ch in
+	let s_typo_descender = rd16 ch in
+	let s_typo_line_gap = rd16 ch in
+	let us_win_ascent = rdu16 ch in
+	let us_win_descent = rdu16 ch in
+	{
+		os2_version = version;
+		os2_x_avg_char_width = x_avg_char_width;
+		os2_us_weight_class = us_weight_class;
+		os2_us_width_class = us_width_class;
+		os2_fs_type = fs_type;
+		os2_y_subscript_x_size = y_subscript_x_size;
+		os2_y_subscript_y_size = y_subscript_y_size;
+		os2_y_subscript_x_offset = y_subscript_x_offset;
+		os2_y_subscript_y_offset = y_subscript_y_offset;
+		os2_y_superscript_x_size = y_superscript_x_size;
+		os2_y_superscript_y_size = y_superscript_y_size;
+		os2_y_superscript_x_offset = y_superscript_x_offset;
+		os2_y_superscript_y_offset = y_superscript_y_offset;
+		os2_y_strikeout_size = y_strikeout_size;
+		os2_y_strikeout_position = y_strikeout_position;
+		os2_s_family_class = s_family_class;
+		os2_b_family_type = b_family_type;
+		os2_b_serif_style = b_serif_style;
+		os2_b_weight = b_weight;
+		os2_b_proportion = b_proportion;
+		os2_b_contrast = b_contrast;
+		os2_b_stroke_variation = b_stroke_variation;
+		os2_b_arm_style = b_arm_style;
+		os2_b_letterform = b_letterform;
+		os2_b_midline = b_midline;
+		os2_b_x_height = b_x_height;
+		os2_ul_unicode_range_1 = ul_unicode_range_1;
+		os2_ul_unicode_range_2 = ul_unicode_range_2;
+		os2_ul_unicode_range_3 = ul_unicode_range_3;
+		os2_ul_unicode_range_4 = ul_unicode_range_4;
+		os2_ach_vendor_id = ach_vendor_id;
+		os2_fs_selection = fs_selection;
+		os2_us_first_char_index = us_first_char_index;
+		os2_us_last_char_index = us_last_char_index;
+		os2_s_typo_ascender = s_typo_ascender;
+		os2_s_typo_descender = s_typo_descender;
+		os2_s_typo_line_gap = s_typo_line_gap;
+		os2_us_win_ascent = us_win_ascent;
+		os2_us_win_descent = us_win_descent;
+	}
+
+let parse file : ttf =
+	let ctx = {
+		file = file;
+		ch = input_channel file;
+		entry = {
+			entry_table_name = "";
+			entry_offset = Int32.of_int 0;
+			entry_length = Int32.of_int 0;
+			entry_checksum = Int32.of_int 0;
+		}
+	} in
+	let header = parse_header ctx in
+	let directory = parse_directory ctx header in
+	let parse_table entry f =
+		seek_in file (Int32.to_int entry.entry_offset);
+		ctx.entry <- entry;
+		f ctx
+	in
+	let parse_req_table name f =
+		try
+			let entry = Hashtbl.find directory name in
+			parse_table entry f
+		with Not_found ->
+			failwith (Printf.sprintf "Required table %s could not be found" name)
+	in
+	let parse_opt_table name f =
+		try
+			let entry = Hashtbl.find directory name in
+			Some (parse_table entry f)
+		with Not_found ->
+			None
+	in
+	let head = parse_req_table "head" parse_head_table in
+	let hhea = parse_req_table "hhea" parse_hhea_table in
+	let maxp = parse_req_table "maxp" parse_maxp_table in
+	let loca = parse_req_table "loca" (parse_loca_table head maxp) in
+	let hmtx = parse_req_table "hmtx" (parse_hmtx_table maxp hhea) in
+	let cmap = parse_req_table "cmap" (parse_cmap_table) in
+	let glyfs = parse_req_table "glyf" (parse_glyf_table maxp loca cmap hmtx) in
+	let kern = parse_opt_table "kern" (parse_kern_table) in
+	let name,ttf_name = parse_req_table "name" (parse_name_table) in
+	let os2 = parse_req_table "OS/2" (parse_os2_table) in
+	{
+		ttf_header = header;
+		ttf_font_name = ttf_name;
+		ttf_directory = directory;
+		ttf_head = head;
+		ttf_hhea = hhea;
+		ttf_maxp = maxp;
+		ttf_loca = loca;
+		ttf_hmtx = hmtx;
+		ttf_cmap = cmap;
+		ttf_glyfs = glyfs;
+		ttf_name = name;
+		ttf_os2 = os2;
+		ttf_kern = kern;
+	}

libs/ttflib/tTFSwfWriter.ml

@@ -0,0 +1,210 @@
+(*
+ * Copyright (C)2005-2014 Haxe Foundation
+ *
+ * Permission is hereby granted, free of charge, to any person obtaining a
+ * copy of this software and associated documentation files (the "Software"),
+ * to deal in the Software without restriction, including without limitation
+ * the rights to use, copy, modify, merge, publish, distribute, sublicense,
+ * and/or sell copies of the Software, and to permit persons to whom the
+ * Software is furnished to do so, subject to the following conditions:
+ *
+ * The above copyright notice and this permission notice shall be included in
+ * all copies or substantial portions of the Software.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+ * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+ * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+ * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+ * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+ * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+ * DEALINGS IN THE SOFTWARE.
+ *)
+
+open TTFData
+open Swf
+
+let num_bits x =
+	if x = 0 then
+		0
+	else
+		let rec loop n v =
+			if v = 0 then n else loop (n + 1) (v lsr 1)
+		in
+		loop 1 (abs x)
+
+let round x = int_of_float (floor (x +. 0.5))
+
+let to_twips v = round (v *. 20.)
+
+type ctx = {
+	ttf : ttf;
+}
+
+let begin_fill =
+	SRStyleChange {
+		scsr_move = None;
+		scsr_fs0 = Some(1);
+		scsr_fs1 = None;
+		scsr_ls = None;
+		scsr_new_styles = None;
+	}
+
+let end_fill =
+	SRStyleChange {
+		scsr_move = None;
+		scsr_fs0 = None;
+		scsr_fs1 = None;
+		scsr_ls = None;
+		scsr_new_styles = None;
+	}
+
+let align_bits x nbits = x land ((1 lsl nbits ) - 1)
+
+let move_to ctx x y =
+	let x = to_twips x in
+	let y = to_twips y in
+	let nbits = max (num_bits x) (num_bits y) in
+	SRStyleChange {
+		scsr_move = Some (nbits, align_bits x nbits, align_bits y nbits);
+		scsr_fs0 = Some(1);
+		scsr_fs1 = None;
+		scsr_ls = None;
+		scsr_new_styles = None;
+	}
+
+let line_to ctx x y =
+	let x = to_twips x in
+	let y = to_twips y in
+	if x = 0 && y = 0 then raise Exit;
+	let nbits = max (num_bits x) (num_bits y) in
+	SRStraightEdge {
+		sser_nbits = nbits;
+		sser_line = (if x = 0 then None else Some(align_bits x nbits)), (if y = 0 then None else Some(align_bits y nbits));
+	}
+
+let curve_to ctx cx cy ax ay =
+	let cx = to_twips cx in
+	let cy = to_twips cy in
+	let ax = to_twips ax in
+	let ay = to_twips ay in
+	let nbits = max (max (num_bits cx) (num_bits cy)) (max (num_bits ax) (num_bits ay)) in
+	SRCurvedEdge {
+		scer_nbits = nbits;
+		scer_cx = align_bits cx nbits;
+		scer_cy = align_bits cy nbits;
+		scer_ax = align_bits ax nbits;
+		scer_ay = align_bits ay nbits;
+	}
+
+open TTFTools
+
+let write_paths ctx paths =
+	let scale = 1024. /. (float_of_int ctx.ttf.ttf_head.hd_units_per_em) in
+	let srl = DynArray.create () in
+	List.iter (fun path ->
+		try
+			DynArray.add srl (match path.gp_type with
+			| 0 -> move_to ctx (path.gp_x *. scale) ((-1.) *. path.gp_y *. scale);
+			| 1 -> line_to ctx (path.gp_x *. scale) ((-1.) *. path.gp_y *. scale);
+			| 2 -> curve_to ctx (path.gp_cx *. scale) ((-1.) *. path.gp_cy *. scale) (path.gp_x *. scale) ((-1.) *. path.gp_y *. scale);
+			| _ -> assert false)
+		with Exit ->
+			()
+	) paths;
+	DynArray.add srl (end_fill);
+	{
+		srs_nfbits = 1;
+		srs_nlbits = 0;
+		srs_records = DynArray.to_list srl;
+	}
+
+let rec write_glyph ctx key glyf =
+	{
+		font_char_code = key;
+		font_shape = write_paths ctx (TTFTools.build_glyph_paths ctx.ttf true glyf);
+	}
+
+let write_font_layout ctx lut =
+	let scale = 1024. /. (float_of_int ctx.ttf.ttf_head.hd_units_per_em) in
+	let hmtx = Hashtbl.fold (fun k v acc -> (k,ctx.ttf.ttf_hmtx.(v)) :: acc) lut [] in
+	let hmtx = List.stable_sort (fun a b -> compare (fst a) (fst b)) hmtx in
+	let hmtx = List.map (fun (k,g) -> g) hmtx in
+	{
+			font_ascent = round((float_of_int ctx.ttf.ttf_os2.os2_us_win_ascent) *. scale *. 20.);
+			font_descent = round((float_of_int ctx.ttf.ttf_os2.os2_us_win_descent) *. scale *. 20.);
+			font_leading = round(((float_of_int(ctx.ttf.ttf_os2.os2_us_win_ascent + ctx.ttf.ttf_os2.os2_us_win_descent - ctx.ttf.ttf_head.hd_units_per_em)) *. scale) *. 20.);
+			font_glyphs_layout = Array.of_list( ExtList.List.mapi (fun i h ->
+			{
+				font_advance = round((float_of_int h.advance_width) *. scale *. 20.);
+				font_bounds = {rect_nbits=0; left=0; right=0; top=0; bottom=0};
+			}) hmtx );
+			font_kerning = [];
+	}
+
+let bi v = if v then 1 else 0
+
+let int_from_langcode lc =
+	match lc with
+	| LCNone -> 0
+	| LCLatin -> 1
+	| LCJapanese -> 2
+	| LCKorean -> 3
+	| LCSimplifiedChinese -> 4
+	| LCTraditionalChinese -> 5
+
+let write_font2 ch b f2 =
+	IO.write_bits b 1 (bi true);
+	IO.write_bits b 1 (bi f2.font_shift_jis);
+	IO.write_bits b 1 (bi f2.font_is_small);
+	IO.write_bits b 1 (bi f2.font_is_ansi);
+	IO.write_bits b 1 (bi f2.font_wide_offsets);
+	IO.write_bits b 1 (bi f2.font_wide_codes);
+	IO.write_bits b 1 (bi f2.font_is_italic);
+	IO.write_bits b 1 (bi f2.font_is_bold);
+	IO.write_byte ch (int_from_langcode f2.font_language);
+	IO.write_byte ch (String.length f2.font_name);
+	IO.nwrite_string ch f2.font_name;
+	IO.write_ui16 ch (Array.length f2.font_glyphs);
+	let glyph_offset = ref (((Array.length f2.font_glyphs) * 4)+4) in
+	Array.iter (fun g ->
+		IO.write_i32 ch !glyph_offset;
+		glyph_offset := !glyph_offset + SwfParser.font_shape_records_length g.font_shape;
+	)f2.font_glyphs;
+	IO.write_i32 ch !glyph_offset;
+	Array.iter (fun g -> SwfParser.write_shape_without_style ch g.font_shape;) f2.font_glyphs;
+	Array.iter (fun g -> IO.write_ui16 ch g.font_char_code; )f2.font_glyphs;
+	IO.write_i16 ch f2.font_layout.font_ascent;
+	IO.write_i16 ch f2.font_layout.font_descent;
+	IO.write_i16 ch f2.font_layout.font_leading;
+	Array.iter (fun g ->
+		let fa = ref g.font_advance in
+		if (!fa) <  -32767 then fa := -32768;(* fix or check *)
+		if (!fa) > 32766 then fa := 32767;
+		IO.write_i16 ch !fa;) f2.font_layout.font_glyphs_layout;
+	Array.iter (fun g -> SwfParser.write_rect ch g.font_bounds;) f2.font_layout.font_glyphs_layout;
+	IO.write_ui16 ch 0 (* TODO: optional FontKerningTable *)
+
+let to_swf ttf config =
+	let ctx = {
+		ttf = ttf;
+	} in
+	let lut = TTFTools.build_lut ttf config.ttfc_range_str in
+	let glyfs = Hashtbl.fold (fun k v acc -> (k,ctx.ttf.ttf_glyfs.(v)) :: acc) lut [] in
+	let glyfs = List.stable_sort (fun a b -> compare (fst a) (fst b)) glyfs in
+	let glyfs = List.map (fun (k,g) -> write_glyph ctx k g) glyfs in
+	let glyfs_font_layout = write_font_layout ctx lut in
+	let glyfs = Array.of_list glyfs in
+	{
+		font_shift_jis = false;
+		font_is_small = false;
+		font_is_ansi = false;
+		font_wide_offsets = true;
+		font_wide_codes = true;
+		font_is_italic = false;
+		font_is_bold = false;
+		font_language = LCNone;
+		font_name = (match config.ttfc_font_name with Some s -> s | None -> ttf.ttf_font_name);
+		font_glyphs = glyfs;
+		font_layout = glyfs_font_layout;
+	}
+;;

libs/ttflib/tTFTools.ml

@@ -0,0 +1,275 @@
+(*
+ * Copyright (C)2005-2014 Haxe Foundation
+ *
+ * Permission is hereby granted, free of charge, to any person obtaining a
+ * copy of this software and associated documentation files (the "Software"),
+ * to deal in the Software without restriction, including without limitation
+ * the rights to use, copy, modify, merge, publish, distribute, sublicense,
+ * and/or sell copies of the Software, and to permit persons to whom the
+ * Software is furnished to do so, subject to the following conditions:
+ *
+ * The above copyright notice and this permission notice shall be included in
+ * all copies or substantial portions of the Software.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+ * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+ * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+ * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+ * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+ * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+ * DEALINGS IN THE SOFTWARE.
+ *)
+
+open TTFData
+
+type glyf_transformation_matrix = {
+	mutable a : float;
+	mutable b : float;
+	mutable c : float;
+	mutable d : float;
+	mutable tx : float;
+	mutable ty : float;
+}
+
+type glyf_path = {
+	gp_type : int;
+	gp_x : float;
+	gp_y : float;
+	gp_cx : float;
+	gp_cy : float;
+}
+
+type simple_point = {
+	x : float;
+	y : float;
+}
+
+let mk_path t x y cx cy = {
+	gp_type = t;
+	gp_x = x;
+	gp_y = y;
+	gp_cx = cx;
+	gp_cy = cy;
+}
+
+let identity () = {
+	a = 1.0;
+	b = 0.0;
+	c = 0.0;
+	d = 1.0;
+	tx = 0.0;
+	ty = 0.0;
+}
+
+let multiply m x y =
+	x *. m.a +. y *. m.b +. m.tx,
+	x *. m.c +. y *. m.d +. m.ty
+
+(* TODO: check if this can be done in the parser directly *)
+let matrix_from_composite gc =
+	let a,b,c,d = match gc.gc_transformation with
+		| NoScale -> 1.0,0.0,0.0,1.0
+		| Scale f -> f,0.0,0.0,f
+		| ScaleXY(fx,fy) -> fx,0.0,0.0,fy
+		| ScaleMatrix (a,b,c,d) -> a,b,c,d
+	in
+	let arg1 = float_of_int gc.gc_arg1 in
+	let arg2 = float_of_int gc.gc_arg2 in
+	{
+		a = a;
+		b = b;
+		c = c;
+		d = d;
+		(* TODO: point offsets *)
+		tx = arg1 *. a +. arg2 *. b;
+		ty = arg1 *. c +. arg2 *. d;
+	}
+
+let relative_matrix m = {m with tx = 0.0; ty = 0.0}
+
+let make_coords relative mo g = match mo with
+	| None ->
+		Array.init (Array.length g.gs_x_coordinates) (fun i -> float_of_int g.gs_x_coordinates.(i),float_of_int g.gs_y_coordinates.(i))
+	| Some m ->
+		let m = if relative then relative_matrix m else m in
+		Array.init (Array.length g.gs_x_coordinates) (fun i ->
+			let x,y = float_of_int g.gs_x_coordinates.(i),float_of_int g.gs_y_coordinates.(i) in
+			multiply m x y
+		)
+
+let build_paths relative mo g =
+	let len = Array.length g.gs_x_coordinates in
+	let current_end = ref 0 in
+	let end_pts = Array.init len (fun i ->
+		if g.gs_end_pts_of_contours.(!current_end) = i then begin
+			incr current_end;
+			true
+		end else
+			false
+	) in
+	let is_on i = g.gs_flags.(i) land 0x01 <> 0 in
+	let is_end i = end_pts.(i) in
+	let arr = DynArray.create () in
+	let tx,ty = match mo with None -> 0.0,0.0 | Some m -> m.tx,m.ty in
+	let last_added = ref {
+		x = 0.0;
+		y = 0.0;
+	} in
+	let add_rel t x y cx cy =
+		let p = match t with
+			| 0 ->
+				mk_path t (x +. tx) (y +. ty) cx cy
+			| 1 ->
+				mk_path t (x -. !last_added.x) (y -. !last_added.y) cx cy
+			| 2 ->
+				mk_path t (x -. cx) (y -. cy) (cx -. !last_added.x) (cy -. !last_added.y)
+			| _ ->
+				assert false
+		in
+		last_added := { x = x; y = y; };
+		DynArray.add arr p
+	in
+	let add_abs t x y cx cy = DynArray.add arr (mk_path t x y cx cy) in
+	let add = if relative then add_rel else add_abs in
+	let coords = make_coords relative mo g in
+
+	let left = ref [] in
+	let right = ref [] in
+	let new_contour = ref true in
+	let p = ref { x = 0.0; y = 0.0 } in
+	for i = 0 to len - 1 do
+		p := {
+			x = !p.x +. fst coords.(i);
+			y = !p.y +. snd coords.(i);
+		};
+		let p = !p in
+		let is_on = is_on i in
+		let is_end = is_end i in
+		let rec flush pl = match pl with
+			| c :: a :: [] -> add 2 a.x a.y c.x c.y
+			| a :: [] -> add 1 a.x a.y 0.0 0.0
+			| c1 :: c2 :: pl ->
+				add 2 (c1.x +. (c2.x -. c1.x) /. 2.0) (c1.y +. (c2.y -. c1.y) /. 2.0) c1.x c1.y;
+				flush (c2 :: pl)
+			| _ ->
+				Printf.printf "Fail, len: %i\n" (List.length pl);
+		in
+		if !new_contour then begin
+			if is_on then begin
+				new_contour := false;
+				add 0 p.x p.y 0.0 0.0;
+			end;
+			left := p :: !left
+		end else if is_on || is_end then begin
+			right := p :: !right;
+			if is_on then begin
+				flush (List.rev !right);
+				right := []
+			end;
+			if is_end then begin
+				new_contour := true;
+				flush ((List.rev !right) @ (List.rev !left));
+				left := [];
+				right := [];
+			end
+		end else
+			right := p :: !right
+	done;
+	DynArray.to_list arr
+
+let rec build_glyph_paths ttf relative ?(transformation=None) glyf =
+	match glyf with
+	| TGlyfSimple (h,g) ->
+		build_paths relative transformation g
+	| TGlyfComposite (h,gl) ->
+		List.concat (List.map (fun g ->
+			let t = Some (matrix_from_composite g) in
+			build_glyph_paths ttf relative ~transformation:t (ttf.ttf_glyfs.(g.gc_glyf_index))
+		) gl)
+	| TGlyfNull ->
+		[]
+
+let map_char_code cc c4 =
+	let index = ref 0 in
+	let seg_count = c4.c4_seg_count_x2 / 2 in
+	if cc >= 0xFFFF then 0 else begin
+		for i = 0 to seg_count - 1 do
+			if c4.c4_end_code.(i) >= cc && c4.c4_start_code.(i) <= cc then begin
+				if c4.c4_id_range_offset.(i) > 0 then
+					let v = c4.c4_id_range_offset.(i)/2 + cc - c4.c4_start_code.(i) - seg_count + i in
+					index := c4.c4_glyph_index_array.(v)
+				else
+					index := (c4.c4_id_delta.(i) + cc) mod 65536
+			end
+		done;
+		!index
+	end
+
+let parse_range_str str =
+	let last = ref (Char.code '\\') in
+	let range = ref false in
+	let lut = Hashtbl.create 0 in
+	UTF8.iter (fun code ->
+		let code = UChar.code code in
+		if code = Char.code '-' && !last <> Char.code '\\' then
+			range := true
+		else if !range then begin
+			range := false;
+			for i = !last to code do
+				Hashtbl.replace lut i true;
+			done;
+		end else begin
+			Hashtbl.replace lut code true;
+			last := code;
+		end
+	) str;
+	if !range then Hashtbl.replace lut (Char.code '-') true;
+	lut
+
+let build_lut ttf range_str =
+	let lut = Hashtbl.create 0 in
+	Hashtbl.add lut 0 0;
+	Hashtbl.add lut 1 1;
+	Hashtbl.add lut 2 2;
+	let add_character = if range_str = "" then
+			fun k v -> Hashtbl.replace lut k v
+		else begin
+			let range = parse_range_str range_str in
+			fun k v -> if Hashtbl.mem range k then Hashtbl.replace lut k v
+		end
+	in
+	let make_cmap4_map c4 =
+		let seg_count = c4.c4_seg_count_x2 / 2 in
+		for i = 0 to seg_count - 1 do
+			for j = c4.c4_start_code.(i) to c4.c4_end_code.(i) do
+				let index = map_char_code j c4 in
+				add_character j index;
+			done;
+		done
+	in
+(*  	let make_cmap12_map c12 =
+		List.iter (fun group ->
+			let rec loop cc gi =
+				add_character cc gi;
+				if cc < (Int32.to_int group.c12g_end_char_code) then loop (cc + 1) (gi + 1)
+			in
+			loop (Int32.to_int group.c12g_start_char_code) (Int32.to_int group.c12g_start_glyph_code)
+		) c12.c12_groups
+	in *)
+	List.iter (fun st -> match st.cs_def with
+		| Cmap0 c0 ->
+			Array.iteri (fun i c -> add_character i (int_of_char c)) c0.c0_glyph_index_array;
+		| Cmap4 c4 ->
+			make_cmap4_map c4;
+		| Cmap12 c12 ->
+			(*
+				TODO: this causes an exception with some fonts:
+				Fatal error: exception IO.Overflow("write_ui16")
+			*)
+			(* make_cmap12_map ctx lut c12; *)
+			()
+		| _ ->
+			(* TODO *)
+			()
+	) ttf.ttf_cmap.cmap_subtables;
+	lut

libs/ziplib/Makefile

@@ -0,0 +1,22 @@
+OCAMLOPT=ocamlopt
+OCAMLC=ocamlc
+SRC=zlib.mli zlib.ml zip.mli zip.ml
+
+all: native bytecode
+
+native: ziplib.cmxa
+ziplib.cmxa: $(SRC)
+	ocamlfind $(OCAMLOPT) -safe-string -g -I ../extlib -I ../extc -a -o ziplib.cmxa $(SRC)
+
+bytecode: ziplib.cma
+ziplib.cma: $(SRC)
+	ocamlfind $(OCAMLC) -safe-string -g -I ../extlib -I ../extc -a -o ziplib.cma $(SRC)
+
+clean:
+	rm -rf ziplib.cmxa ziplib.cma ziplib.lib ziplib.a $(wildcard *.cmx) $(wildcard *.obj) $(wildcard *.o) $(wildcard *.cmi) $(wildcard *.cmo)
+
+.PHONY: all native bytecode clean
+
+Makefile: ;
+
+$(SRC): ;

libs/ziplib/test/Makefile

@@ -0,0 +1,7 @@
+OCAMLOPT=ocamlopt
+
+all: ../zip.cmxa minizip.ml
+	$(OCAMLOPT) -g -g -I .. -I ../../extc -o minizip -cclib ../../extc/extc_stubs.o -cclib -lz unix.cmxa ../zip.cmxa minizip.ml
+
+clean:
+	rm -rf minizip $(wildcard *.cmx) $(wildcard *.obj) $(wildcard *.o) $(wildcard *.cmi)

libs/ziplib/test/minizip.ml

@@ -0,0 +1,93 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                         The CamlZip library                         *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file LICENSE.        *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: minizip.ml,v 1.2 2006/04/04 08:29:07 xleroy Exp $ *)
+
+open Printf
+
+let list_entry e =
+  let t = Unix.localtime e.Zip.mtime in
+  printf "%6d  %6d  %c  %04d-%02d-%02d %02d:%02d  %c  %s\n"
+    e.Zip.uncompressed_size
+    e.Zip.compressed_size
+    (match e.Zip.methd with Zip.Stored -> 's' | Zip.Deflated -> 'd')
+    (t.Unix.tm_year + 1900) (t.Unix.tm_mon + 1) t.Unix.tm_mday
+    t.Unix.tm_hour t.Unix.tm_min
+    (if e.Zip.is_directory then 'd' else ' ')
+    e.Zip.filename;
+  if e.Zip.comment <> "" then
+    printf "        %s\n" e.Zip.comment
+
+let list zipfile =
+  let ic = Zip.open_in zipfile in
+  if Zip.comment ic <> "" then printf "%s\n" (Zip.comment ic);
+  List.iter list_entry (Zip.entries ic);
+  Zip.close_in ic
+
+let extract_entry ifile e =
+  print_string e.Zip.filename; print_newline();
+  if e.Zip.is_directory then begin
+    try
+      Unix.mkdir e.Zip.filename 0o777
+    with Unix.Unix_error(Unix.EEXIST, _, _) -> ()
+  end else begin
+    Zip.copy_entry_to_file ifile e e.Zip.filename
+  end
+
+let extract zipfile =
+  let ic = Zip.open_in zipfile in
+  List.iter (extract_entry ic) (Zip.entries ic);
+  Zip.close_in ic
+
+let rec add_entry oc file =
+  let s = Unix.stat file in
+  match s.Unix.st_kind with
+    Unix.S_REG ->
+      printf "Adding file %s\n" file; flush stdout;
+      Zip.copy_file_to_entry file oc ~mtime:s.Unix.st_mtime file
+  | Unix.S_DIR ->
+      printf "Adding directory %s\n" file; flush stdout;
+      Zip.add_entry "" oc ~mtime:s.Unix.st_mtime
+        (if Filename.check_suffix file "/" then file else file ^ "/");
+      let d = Unix.opendir file in
+      begin try
+        while true do
+          let e = Unix.readdir d in
+          if e <> "." && e <> ".." then add_entry oc (Filename.concat file e)
+        done
+      with End_of_file -> ()
+      end;
+      Unix.closedir d
+  | _ -> ()  
+
+let create zipfile files =
+  let oc = Zip.open_out zipfile in
+  Array.iter (add_entry oc) files;
+  Zip.close_out oc
+
+let usage() =
+  prerr_string
+"Usage: 
+  minizip t <zipfile>           show contents of <zipfile>
+  minizip x <zipfile>           extract files from <zipfile>
+  minizip c <zipfile> <file> .. create a <zipfile> with the given files";
+  exit 2
+
+let _ =
+  if Array.length Sys.argv < 3 then usage();
+  match Sys.argv.(1) with
+    "t" -> list Sys.argv.(2)
+  | "x" -> extract Sys.argv.(2)
+  | "c" -> create Sys.argv.(2)
+                  (Array.sub Sys.argv 3 (Array.length Sys.argv - 3))
+  | _ -> usage()

libs/ziplib/zip.ml

@@ -0,0 +1,614 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                         The CamlZip library                         *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                  adapted to Extc lib by Caue Waneck                 *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Lesser General Public License, with     *)
+(*  the special exception on linking described in file LICENSE.        *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: zip.ml,v 1.5 2008/12/07 09:23:08 xleroy Exp $ *)
+
+(* Module [Zip]: reading and writing ZIP archives *)
+
+exception Error of string * string * string
+
+let read1 = input_byte
+let read2 ic =
+  let lb = read1 ic in let hb = read1 ic in lb lor (hb lsl 8)
+let read4 ic =
+  let lw = read2 ic in let hw = read2 ic in
+  Int32.logor (Int32.of_int lw) (Int32.shift_left (Int32.of_int hw) 16)
+let read4_int ic =
+  let lw = read2 ic in let hw = read2 ic in
+  if hw > max_int lsr 16 then raise (Error("", "", "32-bit data too large"));
+  lw lor (hw lsl 16)
+let readstring ic n =
+  let s = Bytes.create n in
+  really_input ic s 0 n; Bytes.to_string s
+
+let write1 = output_byte
+let write2 oc n =
+  write1 oc n; write1 oc (n lsr 8)
+let write4 oc n =
+  write2 oc (Int32.to_int n);
+  write2 oc (Int32.to_int (Int32.shift_right_logical n 16))
+let write4_int oc n =
+  write2 oc n;
+  write2 oc (n lsr 16)
+let writestring oc s =
+  output oc (Bytes.of_string s) 0 (String.length s)
+let writebytes oc s =
+  output oc s 0 (Bytes.length s)
+
+type compression_method = Stored | Deflated
+
+type entry =
+  { filename: string;
+    extra: string;
+    comment: string;
+    methd: compression_method;
+    mtime: float;
+    crc: int32;
+    uncompressed_size: int;
+    compressed_size: int;
+    is_directory: bool;
+    file_offset: int64 }
+
+type in_file =
+  { if_filename: string;
+    if_channel: Pervasives.in_channel;
+    if_entries: entry list;
+    if_directory: (string, entry) Hashtbl.t;
+    if_comment: string }
+
+let entries ifile = ifile.if_entries
+let comment ifile = ifile.if_comment
+
+type out_file =
+  { of_filename: string;
+    of_channel: Pervasives.out_channel;
+    mutable of_entries: entry list;
+    of_comment: string }
+
+(* Return the position of the last occurrence of s1 in s2, or -1 if not
+   found. *)
+
+let strrstr pattern buf ofs len =
+  let rec search i j =
+    if i < ofs then -1
+    else if j >= String.length pattern then i
+    else if pattern.[j] = buf.[i + j] then search i (j+1)
+    else search (i-1) 0
+  in search (ofs + len - String.length pattern) 0
+
+(* Determine if a file name is a directory (ends with /) *)
+
+let filename_is_directory name =
+  String.length name > 0 && name.[String.length name - 1] = '/'
+
+(* Convert between Unix dates and DOS dates *)
+
+let unixtime_of_dostime time date =
+  fst(Unix.mktime
+        { Unix.tm_sec = (time lsl 1) land 0x3e;
+          Unix.tm_min = (time lsr 5) land 0x3f;
+          Unix.tm_hour = (time lsr 11) land 0x1f;
+          Unix.tm_mday = date land 0x1f;
+          Unix.tm_mon = ((date lsr 5) land 0xf) - 1;
+          Unix.tm_year = ((date lsr 9) land 0x7f) + 80;
+          Unix.tm_wday = 0;
+          Unix.tm_yday = 0;
+          Unix.tm_isdst = false })
+
+let dostime_of_unixtime t =
+  let tm = Unix.localtime t in
+  (tm.Unix.tm_sec lsr 1
+     + (tm.Unix.tm_min lsl 5)
+     + (tm.Unix.tm_hour lsl 11),
+   tm.Unix.tm_mday
+     + (tm.Unix.tm_mon + 1) lsl 5
+     + (tm.Unix.tm_year - 80) lsl 9)
+
+(* Read end of central directory record *)
+
+let read_ecd filename ic =
+  let buf = Bytes.create 256 in
+  let filelen = in_channel_length ic in
+  let rec find_ecd pos len =
+    (* On input, bytes 0 ... len - 1 of buf reflect what is at pos in ic *)
+    if pos <= 0 || filelen - pos >= 0x10000 then
+      raise (Error(filename, "",
+                   "end of central directory not found, not a ZIP file"));
+    let toread = min pos 128 in
+    (* Make room for "toread" extra bytes, and read them *)
+    Bytes.blit buf 0 buf toread (256 - toread);
+    let newpos = pos - toread in
+    seek_in ic newpos;
+    really_input ic buf 0 toread;
+    let newlen = min (toread + len) 256 in
+    (* Search for magic number *)
+    let ofs = strrstr "PK\005\006" (Bytes.to_string buf) 0 newlen in
+    if ofs < 0 || newlen < 22 ||
+       (let comment_len =
+          Char.code (Bytes.get buf (ofs + 20)) lor (Char.code (Bytes.get buf (ofs + 21)) lsl 8) in
+        newpos + ofs + 22 + comment_len <> filelen) then
+      find_ecd newpos newlen
+    else
+      newpos + ofs in
+  seek_in ic (find_ecd filelen 0);
+  let magic = read4 ic in
+  let disk_no = read2 ic in
+  let cd_disk_no = read2 ic in
+  let _disk_entries = read2 ic in
+  let cd_entries = read2 ic in
+  let cd_size = read4 ic in
+  let cd_offset = read4 ic in
+  let comment_len = read2 ic in
+  let comment = readstring ic comment_len in
+  assert (magic = Int32.of_int 0x06054b50);
+  if disk_no <> 0 || cd_disk_no <> 0 then
+    raise (Error(filename, "", "multi-disk ZIP files not supported"));
+  (cd_entries, cd_size, cd_offset, comment)
+
+(* Read central directory *)
+
+let read_cd filename ic cd_entries cd_offset cd_bound =
+  let cd_bound = Int64.of_int32 cd_bound in
+  try
+    LargeFile.seek_in ic (Int64.of_int32 cd_offset);
+    let e = ref [] in
+    let entrycnt = ref 0 in
+    while (LargeFile.pos_in ic < cd_bound) do
+      incr entrycnt;
+      let magic = read4 ic in
+      let _version_made_by = read2 ic in
+      let _version_needed = read2 ic in
+      let flags = read2 ic in
+      let methd = read2 ic in
+      let lastmod_time = read2 ic in
+      let lastmod_date = read2 ic in
+      let crc = read4 ic in
+      let compr_size = read4_int ic in
+      let uncompr_size = read4_int ic in
+      let name_len = read2 ic in
+      let extra_len = read2 ic in
+      let comment_len = read2 ic in
+      let _disk_number = read2 ic in
+      let _internal_attr = read2 ic in
+      let _external_attr = read4 ic in
+      let header_offset = Int64.of_int32(read4 ic) in
+      let name = readstring ic name_len in
+      let extra = readstring ic extra_len in
+      let comment = readstring ic comment_len in
+      if magic <> Int32.of_int 0x02014b50 then
+        raise (Error(filename, name,
+                     "wrong file header in central directory"));
+      if flags land 1 <> 0 then
+        raise (Error(filename, name, "encrypted entries not supported"));
+
+      e := { filename = name;
+             extra = extra;
+             comment = comment;
+             methd = (match methd with
+                         0 -> Stored
+                       | 8 -> Deflated
+                       | _ -> raise (Error(filename, name,
+                                           "unknown compression method")));
+             mtime = unixtime_of_dostime lastmod_time lastmod_date;
+             crc = crc;
+             uncompressed_size = uncompr_size;
+             compressed_size = compr_size;
+             is_directory = filename_is_directory name;
+             file_offset = header_offset
+           } :: !e
+    done;
+    assert((cd_bound = (LargeFile.pos_in ic)) &&
+           (cd_entries = 65535 || !entrycnt = cd_entries));
+    List.rev !e
+  with End_of_file ->
+    raise (Error(filename, "", "end-of-file while reading central directory"))
+
+(* Open a ZIP file for reading *)
+
+let open_in filename =
+  let ic = Pervasives.open_in_bin filename in
+  let (cd_entries, cd_size, cd_offset, cd_comment) = read_ecd filename ic in
+  let entries =
+    read_cd filename ic cd_entries cd_offset (Int32.add cd_offset cd_size) in
+  let dir = Hashtbl.create (cd_entries / 3) in
+  List.iter (fun e -> Hashtbl.add dir e.filename e) entries;
+  { if_filename = filename;
+    if_channel = ic;
+    if_entries = entries;
+    if_directory = dir;
+    if_comment = cd_comment }
+
+(* Close a ZIP file opened for reading *)
+
+let close_in ifile =
+  Pervasives.close_in ifile.if_channel
+
+(* Return the info associated with an entry *)
+
+let find_entry ifile name =
+  Hashtbl.find ifile.if_directory name
+
+(* Position on an entry *)
+
+let goto_entry ifile e =
+  try
+    let ic = ifile.if_channel in
+    LargeFile.seek_in ic e.file_offset;
+    let magic = read4 ic in
+    let _version_needed = read2 ic in
+    let _flags = read2 ic in
+    let _methd = read2 ic in
+    let _lastmod_time = read2 ic in
+    let _lastmod_date = read2 ic in
+    let _crc = read4 ic in
+    let _compr_size = read4_int ic in
+    let _uncompr_size = read4_int ic in
+    let filename_len = read2 ic in
+    let extra_len = read2 ic in
+    if magic <> Int32.of_int 0x04034b50 then
+       raise (Error(ifile.if_filename, e.filename, "wrong local file header"));
+    (* Could validate information read against directory entry, but
+       what the heck *)
+    LargeFile.seek_in ifile.if_channel
+      (Int64.add e.file_offset (Int64.of_int (30 + filename_len + extra_len)))
+  with End_of_file ->
+    raise (Error(ifile.if_filename, e.filename, "truncated local file header"))
+
+(* Read the contents of an entry as a string *)
+
+let read_entry ifile e =
+  try
+    goto_entry ifile e;
+    let res = Bytes.create e.uncompressed_size in
+    match e.methd with
+      Stored ->
+        if e.compressed_size <> e.uncompressed_size then
+          raise (Error(ifile.if_filename, e.filename,
+                       "wrong size for stored entry"));
+        really_input ifile.if_channel res 0 e.uncompressed_size;
+        Bytes.to_string res
+    | Deflated ->
+        let in_avail = ref e.compressed_size in
+        let out_pos = ref 0 in
+        begin try
+
+          Zlib.uncompress ~header:false
+            (fun buf ->
+              let read = input ifile.if_channel buf 0
+                               (min !in_avail (Bytes.length buf)) in
+              in_avail := !in_avail - read;
+              read)
+            (fun buf len ->
+              if !out_pos + len > Bytes.length res then
+                raise (Error(ifile.if_filename, e.filename,
+                             "wrong size for deflated entry (too much data)"));
+              Bytes.blit buf 0 res !out_pos len;
+              out_pos := !out_pos + len)
+        with Failure(_) ->
+          raise (Error(ifile.if_filename, e.filename, "decompression error"))
+        end;
+        if !out_pos <> Bytes.length res then
+          raise (Error(ifile.if_filename, e.filename,
+                       "wrong size for deflated entry (not enough data)"));
+        let crc = Zlib.update_crc Int32.zero res 0 (Bytes.length res) in
+        if crc <> e.crc then
+          raise (Error(ifile.if_filename, e.filename, "CRC mismatch"));
+        Bytes.to_string res
+  with End_of_file ->
+    raise (Error(ifile.if_filename, e.filename, "truncated data"))
+
+(* Write the contents of an entry into an out channel *)
+
+let copy_entry_to_channel ifile e oc =
+  try
+    goto_entry ifile e;
+    match e.methd with
+      Stored ->
+        if e.compressed_size <> e.uncompressed_size then
+          raise (Error(ifile.if_filename, e.filename,
+                       "wrong size for stored entry"));
+        let buf = Bytes.create 4096 in
+        let rec copy n =
+          if n > 0 then begin
+            let r = input ifile.if_channel buf 0 (min n (Bytes.length buf)) in
+            output oc buf 0 r;
+            copy (n - r)
+          end in
+        copy e.uncompressed_size
+    | Deflated ->
+        let in_avail = ref e.compressed_size in
+        let crc = ref Int32.zero in
+        begin try
+          Zlib.uncompress ~header:false
+            (fun buf ->
+              let read = input ifile.if_channel buf 0
+                               (min !in_avail (Bytes.length buf)) in
+              in_avail := !in_avail - read;
+              read)
+            (fun buf len ->
+              output oc buf 0 len;
+              crc := Zlib.update_crc !crc buf 0 len)
+        with Failure _ ->
+          raise (Error(ifile.if_filename, e.filename, "decompression error"))
+        end;
+        if !crc <> e.crc then
+          raise (Error(ifile.if_filename, e.filename, "CRC mismatch"))
+  with End_of_file ->
+    raise (Error(ifile.if_filename, e.filename, "truncated data"))
+
+(* Write the contents of an entry to a file *)
+
+let copy_entry_to_file ifile e outfilename =
+  let oc = open_out_bin outfilename in
+  try
+    copy_entry_to_channel ifile e oc;
+    close_out oc;
+    begin try
+      Unix.utimes outfilename e.mtime e.mtime
+    with Unix.Unix_error(_, _, _) | Invalid_argument _ -> ()
+    end
+  with x ->
+    close_out oc;
+    Sys.remove outfilename;
+    raise x
+
+(* Open a ZIP file for writing *)
+
+let open_out ?(comment = "") filename =
+  if String.length comment >= 0x10000 then
+    raise(Error(filename, "", "comment too long"));
+  { of_filename = filename;
+    of_channel = Pervasives.open_out_bin filename;
+    of_entries = [];
+    of_comment = comment }
+
+(* Close a ZIP file for writing.  Add central directory. *)
+
+let write_directory_entry oc e =
+  write4 oc (Int32.of_int 0x02014b50);  (* signature *)
+  let version = match e.methd with Stored -> 10 | Deflated -> 20 in
+  write2 oc version;                    (* version made by *)
+  write2 oc version;                    (* version needed to extract *)
+  write2 oc 8;                          (* flags *)
+  write2 oc (match e.methd with Stored -> 0 | Deflated -> 8); (* method *)
+  let (time, date) = dostime_of_unixtime e.mtime in
+  write2 oc time;                       (* last mod time *)
+  write2 oc date;                       (* last mod date *)
+  write4 oc e.crc;                      (* CRC32 *)
+  write4_int oc e.compressed_size;      (* compressed size *)
+  write4_int oc e.uncompressed_size;    (* uncompressed size *)
+  write2 oc (String.length e.filename); (* filename length *)
+  write2 oc (String.length e.extra);    (* extra length *)
+  write2 oc (String.length e.comment);  (* comment length *)
+  write2 oc 0;                          (* disk number start *)
+  write2 oc 0;                          (* internal attributes *)
+  write4_int oc 0;                      (* external attributes *)
+  write4 oc (Int64.to_int32 e.file_offset); (* offset of local header *)
+  writestring oc e.filename;            (* filename *)
+  writestring oc e.extra;               (* extra info *)
+  writestring oc e.comment              (* file comment *)
+
+let close_out ofile =
+  let oc = ofile.of_channel in
+  let start_cd = pos_out oc in
+  List.iter (write_directory_entry oc) (List.rev ofile.of_entries);
+  let cd_size = pos_out oc - start_cd in
+  let num_entries = List.length ofile.of_entries in
+  if num_entries >= 0x10000 then
+    raise(Error(ofile.of_filename, "", "too many entries"));
+  write4 oc (Int32.of_int 0x06054b50);  (* signature *)
+  write2 oc 0;                          (* disk number *)
+  write2 oc 0;                          (* number of disk with central dir *)
+  write2 oc num_entries;                (* # entries in this disk *)
+  write2 oc num_entries;                (* # entries in central dir *)
+  write4_int oc cd_size;                (* size of central dir *)
+  write4_int oc start_cd;               (* offset of central dir *)
+  write2 oc (String.length ofile.of_comment); (* length of comment *)
+  writestring oc ofile.of_comment;         (* comment *)
+  Pervasives.close_out oc
+
+(* Write a local file header and return the corresponding entry *)
+
+let add_entry_header ofile extra comment level mtime filename =
+  if level < 0 || level > 9 then
+    raise(Error(ofile.of_filename, filename, "wrong compression level"));
+  if String.length filename >= 0x10000 then
+    raise(Error(ofile.of_filename, filename, "filename too long"));
+  if String.length extra >= 0x10000 then
+    raise(Error(ofile.of_filename, filename, "extra data too long"));
+  if String.length comment >= 0x10000 then
+    raise(Error(ofile.of_filename, filename, "comment too long"));
+  let oc = ofile.of_channel in
+  let pos = LargeFile.pos_out oc in
+  write4 oc (Int32.of_int 0x04034b50);  (* signature *)
+  let version = if level = 0 then 10 else 20 in
+  write2 oc version;                    (* version needed to extract *)
+  write2 oc 8;                          (* flags *)
+  write2 oc (if level = 0 then 0 else 8); (* method *)
+  let (time, date) = dostime_of_unixtime mtime in
+  write2 oc time;                       (* last mod time *)
+  write2 oc date;                       (* last mod date *)
+  write4 oc Int32.zero;                 (* CRC32 - to be filled later *)
+  write4_int oc 0;                      (* compressed size - later *)
+  write4_int oc 0;                      (* uncompressed size - later *)
+  write2 oc (String.length filename);   (* filename length *)
+  write2 oc (String.length extra);      (* extra length *)
+  writestring oc filename;              (* filename *)
+  writestring oc extra;                 (* extra info *)
+  { filename = filename;
+    extra = extra;
+    comment = comment;
+    methd = (if level = 0 then Stored else Deflated);
+    mtime = mtime;
+    crc = Int32.zero;
+    uncompressed_size = 0;
+    compressed_size = 0;
+    is_directory = filename_is_directory filename;
+    file_offset = pos }
+
+(* Write a data descriptor and update the entry *)
+
+let add_data_descriptor ofile crc compr_size uncompr_size entry =
+  let oc = ofile.of_channel in
+  write4 oc (Int32.of_int 0x08074b50);  (* signature *)
+  write4 oc crc;                        (* CRC *)
+  write4_int oc compr_size;             (* compressed size *)
+  write4_int oc uncompr_size;           (* uncompressed size *)
+  { entry with crc = crc;
+               uncompressed_size = uncompr_size;
+               compressed_size = compr_size }
+
+(* Add an entry with the contents of a string *)
+
+let add_entry data ofile ?(extra = "") ?(comment = "")
+                         ?(level = 6) ?(mtime = Unix.time()) name =
+  let data = Bytes.of_string data in
+  let e = add_entry_header ofile extra comment level mtime name in
+  let crc = Zlib.update_crc Int32.zero data 0 (Bytes.length data) in
+  let compr_size =
+    match level with
+      0 ->
+        output ofile.of_channel data 0 (Bytes.length data);
+        Bytes.length data
+    | _ ->
+        let in_pos = ref 0 in
+        let out_pos = ref 0 in
+        try
+          Zlib.compress ~level ~header:false
+            (fun buf ->
+               let n = min (Bytes.length data - !in_pos)
+                           (Bytes.length buf) in
+               Bytes.blit data !in_pos buf 0 n;
+               in_pos := !in_pos + n;
+               n)
+            (fun buf n ->
+                output ofile.of_channel buf 0 n;
+                out_pos := !out_pos + n);
+          !out_pos
+        with Failure _ ->
+          raise (Error(ofile.of_filename, name, "compression error")) in
+  let e' = add_data_descriptor ofile crc compr_size (Bytes.length data) e in
+  ofile.of_entries <- e' :: ofile.of_entries
+
+(* Add an entry with the contents of an in channel *)
+
+let copy_channel_to_entry ic ofile ?(extra = "") ?(comment = "")
+                                   ?(level = 6) ?(mtime = Unix.time()) name =
+  let e = add_entry_header ofile extra comment level mtime name in
+  let crc = ref Int32.zero in
+  let (compr_size, uncompr_size) =
+    match level with
+      0 ->
+        let buf = Bytes.create 4096 in
+        let rec copy sz =
+          let r = input ic buf 0 (Bytes.length buf) in
+          if r = 0 then sz else begin
+            crc := Zlib.update_crc !crc buf 0 r;
+            output ofile.of_channel buf 0 r;
+            copy (sz + r)
+          end in
+        let size = copy 0 in
+        (size, size)
+    | _ ->
+        let in_pos = ref 0 in
+        let out_pos = ref 0 in
+        try
+          Zlib.compress ~level ~header:false
+            (fun buf ->
+               let r = input ic buf 0 (Bytes.length buf) in
+               crc := Zlib.update_crc !crc buf 0 r;
+               in_pos := !in_pos + r;
+               r)
+            (fun buf n ->
+               output ofile.of_channel buf 0 n;
+               out_pos := !out_pos + n);
+          (!out_pos, !in_pos)
+        with Failure( _) ->
+          raise (Error(ofile.of_filename, name, "compression error")) in
+  let e' = add_data_descriptor ofile !crc compr_size uncompr_size e in
+  ofile.of_entries <- e' :: ofile.of_entries
+
+(* Add an entry with the contents of a file *)
+
+let copy_file_to_entry infilename ofile ?(extra = "") ?(comment = "")
+                                        ?(level = 6) ?mtime name =
+  let ic = open_in_bin infilename in
+  let mtime' =
+    match mtime with
+      Some t -> mtime
+    | None ->
+        try Some((Unix.stat infilename).Unix.st_mtime)
+        with Unix.Unix_error(_,_,_) -> None in
+  try
+    copy_channel_to_entry ic ofile ~extra ~comment ~level ?mtime:mtime' name;
+    Pervasives.close_in ic
+  with x ->
+    Pervasives.close_in ic; raise x
+
+
+(* Add an entry whose content will be produced by the caller *)
+
+let add_entry_generator ofile ?(extra = "") ?(comment = "")
+                         ?(level = 6) ?(mtime = Unix.time()) name =
+  let e = add_entry_header ofile extra comment level mtime name in
+  let crc = ref Int32.zero in
+  let compr_size = ref 0 in
+  let uncompr_size = ref 0 in
+  let finished = ref false in
+  let check () =
+    if !finished then
+      raise (Error(ofile.of_filename, name, "entry already finished"))
+  in
+  let finish () =
+    finished := true;
+    let e' = add_data_descriptor ofile !crc !compr_size !uncompr_size e in
+    ofile.of_entries <- e' :: ofile.of_entries
+  in
+  match level with
+  | 0 ->
+      (fun buf pos len ->
+        let buf = Bytes.of_string buf in
+        check ();
+        output ofile.of_channel buf pos len;
+        compr_size := !compr_size + len;
+        uncompr_size := !uncompr_size + len
+      ),
+      (fun () ->
+        check ();
+        finish ()
+      )
+  | _ ->
+      let (send, flush) = Zlib.compress_direct ~level ~header:false
+          (fun buf n ->
+            output ofile.of_channel buf 0 n;
+            compr_size := !compr_size + n)
+      in
+      (fun buf pos len ->
+        let buf = Bytes.of_string buf in
+        check ();
+        try
+          send buf pos len;
+          uncompr_size := !uncompr_size + len;
+          crc := Zlib.update_crc !crc buf pos len
+        with Failure(_) ->
+          raise (Error(ofile.of_filename, name, "compression error"))
+      ),
+      (fun () ->
+        check ();
+        try
+          flush ();
+          finish ()
+        with Failure(_) ->
+          raise (Error(ofile.of_filename, name, "compression error"))
+      )

libs/ziplib/zip.mli

@@ -0,0 +1,176 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                         The CamlZip library                         *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                  adapted to Extc lib by Caue Waneck                 *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Lesser General Public License, with     *)
+(*  the special exception on linking described in file LICENSE.        *)
+(*                                                                     *)
+(***********************************************************************)
+(* $Id: zip.mli,v 1.7 2008/12/07 09:23:08 xleroy Exp $ *)
+
+(** Reading and writing ZIP archives
+
+    This module provides functions for reading and writing ZIP archive
+    files.  ZIP archives package one or more compressed files into
+    a single ``ZIP file'' along with information about the files,
+    including file name, date and time of last modification, user-provided
+    comments, and a checksum to verify the integrity of each entry.
+    The entries of a ZIP file are not necessarily actual files, and can
+    actually consist of arbitrary data.
+
+    The ZIP file format used in this module is identical to that
+    implemented by the popular [pkzip] archiver under Windows,
+    and by the Info-ZIP [zip] and [unzip] commands under Unix and Windows.
+    This format is also identical to the JAR file format used by Java. *)
+
+(** {6 Information on ZIP entries} *)
+
+type compression_method =
+    Stored                     (** data is stored without compression *)
+  | Deflated                   (** data is compressed with the ``deflate'' algorithm *)
+        (** Indicate whether the data in the entry is compressed or not. *)
+
+type entry =
+  { filename: string;          (** file name for entry *)
+    extra: string;             (** extra information attached to entry *)
+    comment: string;           (** comment attached to entry *)
+    methd: compression_method; (** compression method *)
+    mtime: float;              (** last modification time (seconds since epoch) *)
+    crc: int32;                (** cyclic redundancy check for data *)
+    uncompressed_size: int;    (** size of original data in bytes *)
+    compressed_size: int;      (** size of compressed data *)
+    is_directory: bool;        (** whether this entry represents a directory *)
+    file_offset: int64         (** for internal use *)
+  }
+          (** Description of an entry in a ZIP file. *)
+
+(** {6 Reading from ZIP files} *)
+
+type in_file
+          (** Abstract type representing a handle opened for reading from
+              a ZIP file. *)
+val open_in: string -> in_file
+          (** Open the ZIP file with the given filename.  Return a
+              handle opened for reading from this file. *)
+val entries: in_file -> entry list
+          (** Return a list of all entries in the given ZIP file. *)
+val comment: in_file -> string
+          (** Return the comment attached to the given ZIP file, or the
+              empty string if none. *)
+val find_entry: in_file -> string -> entry
+          (** [Zip.find_entry zf filename] returns the description of the
+              entry having name [filename] in the ZIP file [zf].
+              Raises [Not_found] if no such entry exists.
+              The file name must match exactly; in particular, case is
+              significant.  File names must use [/] (slash) as the directory
+              separator.  The name of a directory must end with a trailing 
+              [/] (slash). *)
+val read_entry: in_file -> entry -> string
+          (** [Zip.read_entry zf e] reads and uncompresses the data
+              (file contents) associated with entry [e] of ZIP file [zf].
+              The data is returned as a character string. *)
+val copy_entry_to_channel: in_file -> entry -> out_channel -> unit
+          (** [Zip.copy_entry_to_channel zf e oc] reads and uncompresses
+              the data associated with entry [e] of ZIP file [zf].
+              It then writes this data to the output channel [oc]. *)
+val copy_entry_to_file: in_file -> entry -> string -> unit
+          (** [Zip.copy_entry_to_file zf e destfile] reads and uncompresses
+              the data associated with entry [e] of ZIP file [zf].
+              It then writes this data to the file named [destfile].
+              The file [destfile] is created if it does not exist,
+              and overwritten otherwise.  The last modification date of
+              the file is set to that indicated in the ZIP entry [e],
+              if possible. *)
+val close_in: in_file -> unit
+          (** Close the given ZIP file handle.  If the ZIP file handle was
+              created by [open_in_channel], the underlying input channel
+              is closed. *)
+
+(** {6 Writing to ZIP files} *)
+
+type out_file
+          (** Abstract type representing a handle opened for writing to
+              a ZIP file. *)
+val open_out: ?comment: string -> string -> out_file
+          (** Create (or truncate to zero length) the ZIP file with
+              the given filename.  Return a handle opened for writing
+              to this file.  The optional argument [comment] is a
+              comment string that is attached to the ZIP file as a whole
+              (as opposed to the comments that can be attached to individual
+              ZIP entries). *) 
+val add_entry:
+  string -> out_file -> 
+    ?extra: string -> ?comment: string -> ?level: int ->
+    ?mtime: float -> string -> unit
+          (** [Zip.add_entry data zf name] adds a new entry to the 
+              ZIP file [zf].  The data (file contents) associated with
+              the entry is taken from the string [data].  It is compressed
+              and written to the ZIP file [zf].  [name] is the file name
+              stored along with this entry.  Several optional arguments
+              can be provided to control the format and attached information 
+              of the entry:
+              @param extra  extra data attached to the entry (a string).
+                Default: empty.
+              @param comment  attached to the entry (a string).
+                Default: empty.
+              @param level  compression level for the entry.  This is an
+                integer between 0 and 9, with 0 meaning no compression (store
+                as is), 1 lowest compression, 9 highest compression.  Higher
+                levels result in smaller compressed data, but longer
+                compression times.
+                Default: 6 (moderate compression).
+              @param mtime  last modification time (in seconds since the
+                epoch).
+                Default: the current time. *)
+val copy_channel_to_entry:
+  in_channel -> out_file -> 
+    ?extra: string -> ?comment: string -> ?level: int ->
+    ?mtime: float -> string -> unit
+          (** Same as [Zip.add_entry], but the data associated with the
+              entry is read from the input channel given as first argument.
+              The channel is read up to end of file. *)
+val copy_file_to_entry:
+  string -> out_file -> 
+    ?extra: string -> ?comment: string -> ?level: int ->
+    ?mtime: float -> string -> unit
+          (** Same as [Zip.add_entry], but the data associated with the
+              entry is read from the file whose name is given as first
+              argument.  Also, the default value for the [mtime]
+              optional parameter is the time of last modification of the
+              file. *)
+val add_entry_generator:
+  out_file ->
+    ?extra: string -> ?comment: string -> ?level: int ->
+    ?mtime: float -> string -> (string -> int -> int -> unit) * (unit -> unit)
+          (** [Zip.add_entry_generator zf name] returns a pair of functions
+              [(add, finish)].  It adds a new entry to the 
+              ZIP file [zf].  The file name stored along with this entry
+              is [name].  Initially, no data is stored in this entry.
+              To store data in this entry, the program must repeatedly call
+              the [add] function returned by [Zip.add_entry_generator].
+              An invocation [add s ofs len] stores [len] characters of
+              string [s] starting at offset [ofs] in the ZIP entry.
+              When all the data forming the entry has been sent, the
+              program must call the [finish] function returned by
+              [Zip.add_entry_generator].  [finish] must be called exactly once.
+              The optional arguments to [Zip.add_entry_generator]
+              are as described in {!Zip.add_entry}. *)
+val close_out: out_file -> unit
+          (** Finish writing the ZIP archive by adding the table of
+              contents, and close it. *)
+
+(** {6 Error reporting} *)
+
+exception Error of string * string * string
+          (** Exception raised when an ill-formed ZIP archive is encountered,
+              or illegal parameters are given to the functions in this
+              module.  The exception is of the form
+              [Error(ZIP_name, entry_name, message)] where [ZIP_name]
+              is the name of the ZIP file, [entry_name] the name of
+              the offending entry, and [message] an explanation of the
+              error. *)

libs/ziplib/zlib.ml

@@ -0,0 +1,111 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                         The CamlZip library                         *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                  adapted to Extc lib by Caue Waneck                 *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Lesser General Public License, with     *)
+(*  the special exception on linking described in file LICENSE.        *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: zlib.ml,v 1.4 2008/12/07 09:23:08 xleroy Exp $ *)
+
+open Extc;;
+
+let buffer_size = 1024
+
+let polynom = 0xedb88320l
+
+let crc_table = Array.init 256 (fun n ->
+  let crc = ref (Int32.of_int n) in
+  for j = 0 to 7 do
+    crc := if Int32.to_int (Int32.logand (!crc) 1l) <> 0 then
+      Int32.logxor (Int32.shift_right_logical (!crc) 1) polynom
+    else
+      Int32.shift_right_logical (!crc) 1;
+  done;
+  !crc) 
+
+let max_wbits = 15
+
+let compress ?(level = 6) ?(header = true) refill flush =
+  let inbuf = Bytes.create buffer_size
+  and outbuf = Bytes.create buffer_size in
+  let zs = Extc.zlib_deflate_init2 level (if header then max_wbits else -max_wbits) in
+  let rec compr inpos inavail =
+    if inavail = 0 then begin
+      let incount = refill inbuf in
+      if incount = 0 then compr_finish() else compr 0 incount
+    end else begin
+      let res = Extc.zlib_deflate zs ~src:(Bytes.to_string inbuf) ~spos:inpos ~slen:inavail ~dst:outbuf ~dpos:0 ~dlen:buffer_size Z_NO_FLUSH in
+      let used_in, used_out = res.z_read, res.z_wrote in
+      flush outbuf used_out;
+      compr (inpos + used_in) (inavail - used_in)
+    end
+  and compr_finish () =
+    let ret = Extc.zlib_deflate zs ~src:(Bytes.to_string inbuf) ~spos:0 ~slen:0 ~dst:outbuf ~dpos:0 ~dlen:buffer_size Z_FINISH in
+    let (finished, _, used_out) = ret.z_finish, ret.z_read, ret.z_wrote in
+    flush outbuf used_out;
+    if not finished then compr_finish()
+  in
+    compr 0 0;
+    Extc.zlib_deflate_end zs
+
+let compress_direct  ?(level = 6) ?(header = true) flush =
+  let outbuf = Bytes.create buffer_size in
+  let zs = Extc.zlib_deflate_init2 level (if header then max_wbits else -max_wbits) in
+  let rec compr inbuf inpos inavail =
+    if inavail = 0 then ()
+    else begin
+      let res = Extc.zlib_deflate zs ~src:(Bytes.to_string inbuf) ~spos:inpos ~slen:inavail ~dst:outbuf ~dpos:0 ~dlen:buffer_size Z_NO_FLUSH in
+      let used_in, used_out = res.z_read, res.z_wrote in
+      flush outbuf used_out;
+      compr inbuf (inpos + used_in) (inavail - used_in)
+    end
+  and compr_finish () =
+    let ret = Extc.zlib_deflate zs ~src:"" ~spos:0 ~slen:0 ~dst:outbuf ~dpos:0 ~dlen:buffer_size Z_FINISH in
+    let (finished, _, used_out) = ret.z_finish, (), ret.z_wrote in
+    flush outbuf used_out;
+    if not finished then compr_finish()
+  in
+  compr, compr_finish
+
+let uncompress ?(header = true) refill flush =
+  let inbuf = Bytes.create buffer_size
+  and outbuf = Bytes.create buffer_size in
+  let zs = Extc.zlib_inflate_init2 (if header then max_wbits else -max_wbits) in
+  let rec uncompr inpos inavail =
+    if inavail = 0 then begin
+      let incount = refill inbuf in
+      if incount = 0 then uncompr_finish true else uncompr 0 incount
+    end else begin
+      let ret = Extc.zlib_inflate zs ~src:(Bytes.to_string inbuf) ~spos: inpos ~slen:inavail ~dst:outbuf ~dpos:0 ~dlen:buffer_size Z_SYNC_FLUSH in
+      let (finished, used_in, used_out) = ret.z_finish, ret.z_read, ret.z_wrote in
+      flush outbuf used_out;
+      if not finished then uncompr (inpos + used_in) (inavail - used_in)
+    end
+  and uncompr_finish first_finish =
+    (* Gotcha: if there is no header, inflate requires an extra "dummy" byte
+       after the compressed stream in order to complete decompression
+       and return finished = true. *)
+    let dummy_byte = if first_finish && not header then 1 else 0 in
+    let ret = Extc.zlib_inflate zs ~src:(Bytes.to_string inbuf) ~spos:0 ~slen:dummy_byte ~dst:outbuf ~dpos:0 ~dlen:buffer_size Z_SYNC_FLUSH in
+    let (finished, _, used_out) = ret.z_finish, ret.z_read, ret.z_wrote in
+    flush outbuf used_out;
+    if not finished then uncompr_finish false
+  in
+    uncompr 0 0;
+    Extc.zlib_inflate_end zs
+
+let update_crc crc buf pos len =
+  let c = ref (Int32.lognot crc) in
+  for i = pos to (len + pos - 1) do
+    let b = Int32.of_int (int_of_char (Bytes.get buf i)) in
+    c := Int32.logxor (Array.get crc_table (Int32.to_int (Int32.logand (Int32.logxor !c b) 0xFFl))) (Int32.shift_right_logical !c 8);
+  done;
+  let ret = Int32.lognot !c in
+  ret

libs/ziplib/zlib.mli

@@ -0,0 +1,29 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                         The CamlZip library                         *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                  adapted to Extc lib by Caue Waneck                 *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Lesser General Public License, with     *)
+(*  the special exception on linking described in file LICENSE.        *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: zlib.mli,v 1.2 2008/12/07 09:23:08 xleroy Exp $ *)
+
+val compress:
+  ?level: int -> ?header: bool -> 
+  (bytes -> int) -> (bytes -> int -> unit) -> unit
+
+val compress_direct:
+  ?level: int -> ?header: bool -> (bytes -> int -> unit) ->
+  (bytes -> int -> int -> unit) * (unit -> unit)
+
+val uncompress:
+  ?header: bool -> (bytes -> int) -> (bytes -> int -> unit) -> unit
+
+val update_crc: 
+  int32 -> bytes -> int -> int -> int32