haxe local copy of ocamllibs

libs/extc/LICENSE

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

libs/extc/Makefile

@@ -0,0 +1,17 @@
+CFLAGS = -I zlib
+LIBS = -I ../extlib
+
+all: bytecode native
+
+bytecode: extc_stubs.obj
+	ocamlc -a -o extc.cma $(LIBS) extc.ml
+
+native: extc_stubs.obj
+	ocamlopt -a -o extc.cmxa $(LIBS) extc.ml
+
+extc_stubs.obj: extc_stubs.c
+	ocamlc $(CFLAGS) extc_stubs.c
+
+clean:
+	rm -f extc.cma extc.cmi extc.cmx extc.cmxa extc.o extc.obj extc.lib extc_stubs.obj extc_stubs.o
+	rm -f extc.a libextc.a libextc.lib extc.cmo

libs/extc/extc.ml

@@ -0,0 +1,206 @@
+(*
+ *  Extc : C common OCaml bindings
+ *  Copyright (c)2004 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+type zstream
+
+type zflush =
+	| Z_NO_FLUSH
+	| Z_PARTIAL_FLUSH
+	| Z_SYNC_FLUSH
+	| Z_FULL_FLUSH
+	| Z_FINISH
+
+
+type zresult = {
+	z_finish : bool;
+	z_read : int;
+	z_wrote : int;
+}
+
+external zlib_deflate_init2 : int -> int -> zstream = "zlib_deflate_init2"
+external zlib_deflate : zstream -> src:string -> spos:int -> slen:int -> dst:string -> dpos:int -> dlen:int -> zflush -> zresult = "zlib_deflate_bytecode" "zlib_deflate"
+external zlib_deflate_end : zstream -> unit = "zlib_deflate_end"
+
+external zlib_inflate_init2 : int -> zstream = "zlib_inflate_init"
+external zlib_inflate : zstream -> src:string -> spos:int -> slen:int -> dst:string -> dpos:int -> dlen:int -> zflush -> zresult = "zlib_inflate_bytecode" "zlib_inflate"
+external zlib_inflate_end : zstream -> unit = "zlib_inflate_end"
+
+external _executable_path : string -> string = "executable_path"
+external get_full_path : string -> string = "get_full_path"
+external get_real_path : string -> string = "get_real_path"
+
+external zlib_deflate_bound : zstream -> int -> int = "zlib_deflate_bound"
+
+external time : unit -> float = "sys_time"
+
+type library
+type sym
+type value
+
+external dlopen : string -> library = "sys_dlopen"
+external dlsym : library -> string -> sym = "sys_dlsym"
+external dlcall0 : sym -> value = "sys_dlcall0"
+external dlcall1 : sym -> value -> value = "sys_dlcall1"
+external dlcall2 : sym -> value -> value -> value = "sys_dlcall2"
+external dlcall3 : sym -> value -> value -> value -> value = "sys_dlcall3"
+external dlcall4 : sym -> value -> value -> value -> value -> value = "sys_dlcall4"
+external dlcall5 : sym -> value -> value -> value -> value -> value -> value = "sys_dlcall5_bc" "sys_dlcall5"
+external dlint : int -> value = "sys_dlint"
+external dltoint : value -> int = "sys_dltoint"
+external dlstring : string -> value = "%identity"
+external dladdr : value -> int -> value = "sys_dladdr"
+external dlptr : value -> value = "sys_dlptr"
+external dlsetptr : value -> value -> unit = "sys_dlsetptr"
+external dlalloc_string : value -> string = "sys_dlalloc_string"
+external dlmemcpy : value -> value -> int -> unit = "sys_dlmemcpy"
+external dlcallback : int -> value = "sys_dlcallback"
+external dlcaml_callback : int -> value = "sys_dlcaml_callback"
+external dlint32 : int32 -> value = "sys_dlint32"
+
+(* support for backward compatibility *)
+let zlib_deflate_init lvl = zlib_deflate_init2 lvl 15
+let zlib_inflate_init() = zlib_inflate_init2 15
+
+let executable_path() =
+	let p = _executable_path Sys.argv.(0) in
+	let p1 = (try String.rindex p '/' with Not_found -> String.length p + 1) in
+	let p2 = (try String.rindex p '\\' with Not_found -> String.length p + 1) in
+	match min p1 p2 with
+	| x when x = String.length p + 1 -> ""
+	| pos ->
+		String.sub p 0 pos ^ "/"
+
+let zlib_op op z str =
+	let bufsize = 1 lsl 14 in
+	let tmp = String.create bufsize in
+	let total = ref 0 in
+	let rec loop pos len acc =
+		let r = op z ~src:str ~spos:pos ~slen:len ~dst:tmp ~dpos:0 ~dlen:bufsize (if len = 0 then Z_FINISH else Z_SYNC_FLUSH) in
+		total := !total + r.z_wrote;
+		let acc = String.sub tmp 0 r.z_wrote :: acc in
+		if r.z_finish then
+			acc
+		else
+			loop (pos + r.z_read) (len - r.z_read) acc
+	in
+	let strings = loop 0 (String.length str) [] in
+	let big = String.create !total in
+	ignore(List.fold_left (fun p s ->
+		let l = String.length s in
+		let p = p - l in
+		String.unsafe_blit s 0 big p l;
+		p
+	) !total strings);
+	big
+
+let zip str =
+	let z = zlib_deflate_init 9 in
+	let s = zlib_op zlib_deflate z str in
+	zlib_deflate_end z;
+	s
+
+let unzip str =
+	let z = zlib_inflate_init()  in
+	let s = zlib_op zlib_inflate z str in
+	zlib_inflate_end z;
+	s
+
+let input_zip ?(bufsize=65536) ch =
+	let tmp_out = String.create bufsize in
+	let tmp_in = String.create bufsize in
+	let tmp_buf = Buffer.create bufsize in
+	let buf = ref "" in
+	let p = ref 0 in
+	let z = zlib_inflate_init() in
+	let rec fill_buffer() =
+		let rec loop pos len =
+			if len > 0 || pos = 0 then begin
+				let r = zlib_inflate z tmp_in pos len tmp_out 0 bufsize (if pos = 0 && len = 0 then Z_FINISH else Z_SYNC_FLUSH) in
+				Buffer.add_substring tmp_buf tmp_out 0 r.z_wrote;
+				loop (pos + r.z_read) (len - r.z_read);
+			end
+		in
+		loop 0 (IO.input ch tmp_in 0 bufsize);
+		p := 0;
+		buf := Buffer.contents tmp_buf;
+		Buffer.clear tmp_buf;
+	in
+	let read() =
+		if !p = String.length !buf then fill_buffer();
+		let c = String.unsafe_get !buf !p in
+		incr p;
+		c
+	in
+	let rec input str pos len =
+		let b = String.length !buf - !p in
+		if b >= len then begin
+			String.blit !buf !p str pos len;
+			p := !p + len;
+			len;
+		end else begin
+			String.blit !buf !p str pos b;
+			fill_buffer();
+			if !p = String.length !buf then
+				b
+			else
+				b + input str (pos + b) (len - b)
+		end;
+	in
+	let close() =
+		zlib_inflate_end z
+	in
+	IO.create_in ~read ~input ~close
+
+let output_zip ?(bufsize=65536) ?(level=9) ch =
+	let z = zlib_deflate_init level in
+	let out = String.create bufsize in
+	let tmp_out = String.create bufsize in
+	let p = ref 0 in
+	let rec flush finish =
+		let r = zlib_deflate z out 0 !p tmp_out 0 bufsize (if finish then Z_FINISH else Z_SYNC_FLUSH) in
+		ignore(IO.really_output ch tmp_out 0 r.z_wrote);
+		let remain = !p - r.z_read in
+		String.blit out r.z_read out 0 remain;
+		p := remain;
+		if finish && not r.z_finish then flush true
+	in
+	let write c =
+		if !p = bufsize then flush false;
+		String.unsafe_set out !p c;
+		incr p
+	in
+	let rec output str pos len =
+		let b = bufsize - !p in
+		if len <= b then begin
+			String.blit str pos out !p len;
+			p := !p + len;
+			len
+		end else begin
+			String.blit str pos out !p b;
+			p := !p + b;
+			flush false;
+			b + output str (pos + b) (len - b);
+		end;
+	in
+	let close() =
+		flush true;
+		zlib_deflate_end z
+	in
+	IO.create_out ~write ~output ~flush:(fun() -> flush false; IO.flush ch) ~close
+

libs/extc/extc_stubs.c

@@ -0,0 +1,415 @@
+/*
+ *  Extc : C common OCaml bindings
+ *  Copyright (c)2004 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ */
+
+#include <caml/alloc.h>
+#include <caml/callback.h>
+#include <caml/mlvalues.h>
+#include <caml/fail.h>
+#include <zlib.h>
+#ifdef _WIN32
+#	include <windows.h>
+#else
+#	include <dlfcn.h>
+#	include <limits.h>
+#	include <unistd.h>
+#	include <string.h>
+#	include <sys/time.h>
+#	include <sys/times.h>
+#	include <caml/memory.h>
+#endif
+#ifdef __APPLE__
+#	include <sys/param.h>
+#	include <sys/syslimits.h>
+#	include <mach-o/dyld.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
+
+
+#define zval(z)		((z_streamp)(z))
+
+value zlib_new_stream() {
+	value z = alloc((sizeof(z_stream) + sizeof(value) - 1) / sizeof(value),Abstract_tag);
+	z_stream *s = zval(z);
+	s->zalloc = NULL;
+	s->zfree = NULL;
+	s->opaque = NULL;
+	s->next_in = NULL;
+	s->next_out = NULL;
+	return z;
+}
+
+CAMLprim value zlib_deflate_init2(value lvl,value wbits) {
+	value z = zlib_new_stream();
+	if( deflateInit2(zval(z),Int_val(lvl),Z_DEFLATED,Int_val(wbits),8,Z_DEFAULT_STRATEGY) != Z_OK )
+		failwith("zlib_deflate_init");
+	return z;
+}
+
+CAMLprim value zlib_deflate( value zv, value src, value spos, value slen, value dst, value dpos, value dlen, value flush ) {
+	z_streamp z = zval(zv);
+	value res;
+	int r;
+
+	z->next_in = (Bytef*)(String_val(src) + Int_val(spos));
+	z->next_out = (Bytef*)(String_val(dst) + Int_val(dpos));
+	z->avail_in = Int_val(slen);
+	z->avail_out = Int_val(dlen);
+	if( (r = deflate(z,Int_val(flush))) < 0 )
+		failwith("zlib_deflate");
+
+	z->next_in = NULL;
+	z->next_out = NULL;
+
+	res = alloc_small(3, 0);
+	Field(res, 0) = Val_bool(r == Z_STREAM_END);
+	Field(res, 1) = Val_int(Int_val(slen) - z->avail_in);
+	Field(res, 2) = Val_int(Int_val(dlen) - z->avail_out);
+	return res;
+}
+
+CAMLprim value zlib_deflate_bytecode(value * arg, int nargs) {
+	return zlib_deflate(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],arg[7]);
+}
+
+CAMLprim value zlib_deflate_end(value zv) {
+	if( deflateEnd(zval(zv)) != 0 )
+		failwith("zlib_deflate_end");
+	return Val_unit;
+}
+
+CAMLprim value zlib_inflate_init(value wbits) {
+	value z = zlib_new_stream();
+	if( inflateInit2(zval(z),Int_val(wbits)) != Z_OK )
+		failwith("zlib_inflate_init");
+	return z;
+}
+
+CAMLprim value zlib_inflate( value zv, value src, value spos, value slen, value dst, value dpos, value dlen, value flush ) {
+	z_streamp z = zval(zv);
+	value res;
+	int r;
+
+	z->next_in = (Bytef*)(String_val(src) + Int_val(spos));
+	z->next_out = (Bytef*)(String_val(dst) + Int_val(dpos));
+	z->avail_in = Int_val(slen);
+	z->avail_out = Int_val(dlen);
+	if( (r = inflate(z,Int_val(flush))) < 0 )
+		failwith("zlib_inflate");
+
+	z->next_in = NULL;
+	z->next_out = NULL;
+
+	res = alloc_small(3, 0);
+	Field(res, 0) = Val_bool(r == Z_STREAM_END);
+	Field(res, 1) = Val_int(Int_val(slen) - z->avail_in);
+	Field(res, 2) = Val_int(Int_val(dlen) - z->avail_out);
+	return res;
+}
+
+CAMLprim value zlib_inflate_bytecode(value * arg, int nargs) {
+	return zlib_inflate(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],arg[7]);
+}
+
+CAMLprim value zlib_inflate_end(value zv) {
+	if( inflateEnd(zval(zv)) != 0 )
+		failwith("zlib_inflate_end");
+	return Val_unit;
+}
+
+CAMLprim value zlib_deflate_bound(value zv,value len) {
+	return Val_int(deflateBound(zval(zv),Int_val(len)));
+}
+
+CAMLprim value executable_path(value u) {
+#ifdef _WIN32
+	char path[MAX_PATH];
+	if( GetModuleFileName(NULL,path,MAX_PATH) == 0 )
+		failwith("executable_path");
+	return caml_copy_string(path);
+#elif __APPLE__
+	char path[MAXPATHLEN+1];
+	uint32_t path_len = MAXPATHLEN;
+	if ( _NSGetExecutablePath(path, &path_len) )
+		failwith("executable_path");
+	return caml_copy_string(path);
+#elif __FreeBSD__
+	char path[PATH_MAX];
+	int error, name[4];
+	size_t len;
+	name[0] = CTL_KERN;
+	name[1] = KERN_PROC;
+	name[2] = KERN_PROC_PATHNAME;
+	name[3] = (int)getpid();
+	len = sizeof(path);
+	error = sysctl(name, 4, path, &len, NULL, 0);
+	if( error < 0 )
+		failwith("executable_path");
+	return caml_copy_string(path);
+#else
+	const char *p = getenv("_");
+	if( p != NULL )
+		return caml_copy_string(p);
+	{
+		char path[200];
+		int length = readlink("/proc/self/exe", path, sizeof(path));
+		if( length < 0 || length >= 200 )
+			failwith("executable_path");
+	    path[length] = '\0';
+		return caml_copy_string(path);
+	}
+#endif
+}
+
+CAMLprim value get_full_path( value f ) {
+#ifdef _WIN32
+	char path[MAX_PATH];
+	if( GetFullPathName(String_val(f),MAX_PATH,path,NULL) == 0 )
+		failwith("get_full_path");
+	return caml_copy_string(path);
+#else
+	char path[4096];
+	if( realpath(String_val(f),path) == NULL )
+		failwith("get_full_path");
+	return caml_copy_string(path);
+#endif
+}
+
+#ifdef _WIN32
+static void copyAscii( char *to, const char *from, int len ) {
+	while( len-- > 0 ) {
+		unsigned char c = *from;
+		if( c < 128 )
+			*to = c;
+		to++;
+		from++;
+	}
+}
+#endif
+
+CAMLprim value get_real_path( value path ) {
+#ifdef _WIN32
+	value path2 = caml_copy_string(String_val(path));
+	char *cur = String_val(path2);
+	if( cur[0] == '\\' && cur[1] == '\\' ) {
+		cur = strchr(cur,'\\');
+		if( cur != NULL ) cur++;
+	} else if( cur[0] != 0 && cur[1] == ':' ) {
+		char c = cur[0];
+		if( c >= 'a' && c <= 'z' )
+			cur[0] = c - 'a' + 'A';
+		cur += 2;
+		if( cur[0] == '\\' )
+			cur++;
+	}
+	while( cur ) {
+		char *next = strchr(cur,'\\');
+		SHFILEINFOA infos;
+		if( next != NULL )
+			*next = 0;
+		else if( *cur == 0 )
+			break;
+		if( SHGetFileInfoA( String_val(path2), 0, &infos, sizeof(infos), SHGFI_DISPLAYNAME ) != 0 ) {
+			// some special names might be expended to their localized name, so make sure we only
+			// change the casing and not the whole content
+			if( strcmpi(infos.szDisplayName,cur) == 0 )
+				copyAscii(cur,infos.szDisplayName,strlen(infos.szDisplayName)+1);
+		}
+		if( next != NULL ) {
+			*next = '\\';
+			cur = next + 1;
+		} else
+			cur = NULL;
+	}
+	return path2;
+#else
+	return path;
+#endif
+}
+
+CAMLprim value sys_time() {
+#ifdef _WIN32
+#define EPOCH_DIFF	(134774*24*60*60.0)
+	static LARGE_INTEGER freq;
+	static int freq_init = -1;
+	LARGE_INTEGER counter;
+	if( freq_init == -1 )
+		freq_init = QueryPerformanceFrequency(&freq);
+	if( !freq_init || !QueryPerformanceCounter(&counter) ) {
+		SYSTEMTIME t;
+		FILETIME ft;
+		ULARGE_INTEGER ui;
+		GetSystemTime(&t);
+		if( !SystemTimeToFileTime(&t,&ft) )
+			failwith("sys_cpu_time");
+		ui.LowPart = ft.dwLowDateTime;
+		ui.HighPart = ft.dwHighDateTime;
+		return caml_copy_double( ((double)ui.QuadPart) / 10000000.0 - EPOCH_DIFF );
+	}
+	return caml_copy_double( ((double)counter.QuadPart) / ((double)freq.QuadPart) );
+#else
+	struct tms t;
+	times(&t);
+	return caml_copy_double( ((double)(t.tms_utime + t.tms_stime)) / CLK_TCK );
+#endif
+}
+
+CAMLprim value sys_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/test.ml

@@ -0,0 +1,23 @@
+(*
+ *  Extc : C common OCaml bindings
+ *  Copyright (c)2004 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+prerr_endline (Extc.executable_path());
+let contents = Std.input_file "test.ml" in
+let s = Extc.unzip (Extc.zip contents) in
+if s <> contents then failwith "zip + unzip failed";

libs/extc/zlib/README.txt

@@ -0,0 +1 @@
+1.2.3 static LIBCMT

libs/extc/zlib/zconf.h

@@ -0,0 +1,332 @@
+/* zconf.h -- configuration of the zlib compression library
+ * Copyright (C) 1995-2005 Jean-loup Gailly.
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* @(#) $Id: zconf.h,v 1.1 2007-02-15 14:41:38 ncannasse Exp $ */
+
+#ifndef ZCONF_H
+#define ZCONF_H
+
+/*
+ * If you *really* need a unique prefix for all types and library functions,
+ * compile with -DZ_PREFIX. The "standard" zlib should be compiled without it.
+ */
+#ifdef Z_PREFIX
+#  define deflateInit_          z_deflateInit_
+#  define deflate               z_deflate
+#  define deflateEnd            z_deflateEnd
+#  define inflateInit_          z_inflateInit_
+#  define inflate               z_inflate
+#  define inflateEnd            z_inflateEnd
+#  define deflateInit2_         z_deflateInit2_
+#  define deflateSetDictionary  z_deflateSetDictionary
+#  define deflateCopy           z_deflateCopy
+#  define deflateReset          z_deflateReset
+#  define deflateParams         z_deflateParams
+#  define deflateBound          z_deflateBound
+#  define deflatePrime          z_deflatePrime
+#  define inflateInit2_         z_inflateInit2_
+#  define inflateSetDictionary  z_inflateSetDictionary
+#  define inflateSync           z_inflateSync
+#  define inflateSyncPoint      z_inflateSyncPoint
+#  define inflateCopy           z_inflateCopy
+#  define inflateReset          z_inflateReset
+#  define inflateBack           z_inflateBack
+#  define inflateBackEnd        z_inflateBackEnd
+#  define compress              z_compress
+#  define compress2             z_compress2
+#  define compressBound         z_compressBound
+#  define uncompress            z_uncompress
+#  define adler32               z_adler32
+#  define crc32                 z_crc32
+#  define get_crc_table         z_get_crc_table
+#  define zError                z_zError
+
+#  define alloc_func            z_alloc_func
+#  define free_func             z_free_func
+#  define in_func               z_in_func
+#  define out_func              z_out_func
+#  define Byte                  z_Byte
+#  define uInt                  z_uInt
+#  define uLong                 z_uLong
+#  define Bytef                 z_Bytef
+#  define charf                 z_charf
+#  define intf                  z_intf
+#  define uIntf                 z_uIntf
+#  define uLongf                z_uLongf
+#  define voidpf                z_voidpf
+#  define voidp                 z_voidp
+#endif
+
+#if defined(__MSDOS__) && !defined(MSDOS)
+#  define MSDOS
+#endif
+#if (defined(OS_2) || defined(__OS2__)) && !defined(OS2)
+#  define OS2
+#endif
+#if defined(_WINDOWS) && !defined(WINDOWS)
+#  define WINDOWS
+#endif
+#if defined(_WIN32) || defined(_WIN32_WCE) || defined(__WIN32__)
+#  ifndef WIN32
+#    define WIN32
+#  endif
+#endif
+#if (defined(MSDOS) || defined(OS2) || defined(WINDOWS)) && !defined(WIN32)
+#  if !defined(__GNUC__) && !defined(__FLAT__) && !defined(__386__)
+#    ifndef SYS16BIT
+#      define SYS16BIT
+#    endif
+#  endif
+#endif
+
+/*
+ * Compile with -DMAXSEG_64K if the alloc function cannot allocate more
+ * than 64k bytes at a time (needed on systems with 16-bit int).
+ */
+#ifdef SYS16BIT
+#  define MAXSEG_64K
+#endif
+#ifdef MSDOS
+#  define UNALIGNED_OK
+#endif
+
+#ifdef __STDC_VERSION__
+#  ifndef STDC
+#    define STDC
+#  endif
+#  if __STDC_VERSION__ >= 199901L
+#    ifndef STDC99
+#      define STDC99
+#    endif
+#  endif
+#endif
+#if !defined(STDC) && (defined(__STDC__) || defined(__cplusplus))
+#  define STDC
+#endif
+#if !defined(STDC) && (defined(__GNUC__) || defined(__BORLANDC__))
+#  define STDC
+#endif
+#if !defined(STDC) && (defined(MSDOS) || defined(WINDOWS) || defined(WIN32))
+#  define STDC
+#endif
+#if !defined(STDC) && (defined(OS2) || defined(__HOS_AIX__))
+#  define STDC
+#endif
+
+#if defined(__OS400__) && !defined(STDC)    /* iSeries (formerly AS/400). */
+#  define STDC
+#endif
+
+#ifndef STDC
+#  ifndef const /* cannot use !defined(STDC) && !defined(const) on Mac */
+#    define const       /* note: need a more gentle solution here */
+#  endif
+#endif
+
+/* Some Mac compilers merge all .h files incorrectly: */
+#if defined(__MWERKS__)||defined(applec)||defined(THINK_C)||defined(__SC__)
+#  define NO_DUMMY_DECL
+#endif
+
+/* Maximum value for memLevel in deflateInit2 */
+#ifndef MAX_MEM_LEVEL
+#  ifdef MAXSEG_64K
+#    define MAX_MEM_LEVEL 8
+#  else
+#    define MAX_MEM_LEVEL 9
+#  endif
+#endif
+
+/* Maximum value for windowBits in deflateInit2 and inflateInit2.
+ * WARNING: reducing MAX_WBITS makes minigzip unable to extract .gz files
+ * created by gzip. (Files created by minigzip can still be extracted by
+ * gzip.)
+ */
+#ifndef MAX_WBITS
+#  define MAX_WBITS   15 /* 32K LZ77 window */
+#endif
+
+/* The memory requirements for deflate are (in bytes):
+            (1 << (windowBits+2)) +  (1 << (memLevel+9))
+ that is: 128K for windowBits=15  +  128K for memLevel = 8  (default values)
+ plus a few kilobytes for small objects. For example, if you want to reduce
+ the default memory requirements from 256K to 128K, compile with
+     make CFLAGS="-O -DMAX_WBITS=14 -DMAX_MEM_LEVEL=7"
+ Of course this will generally degrade compression (there's no free lunch).
+
+   The memory requirements for inflate are (in bytes) 1 << windowBits
+ that is, 32K for windowBits=15 (default value) plus a few kilobytes
+ for small objects.
+*/
+
+                        /* Type declarations */
+
+#ifndef OF /* function prototypes */
+#  ifdef STDC
+#    define OF(args)  args
+#  else
+#    define OF(args)  ()
+#  endif
+#endif
+
+/* The following definitions for FAR are needed only for MSDOS mixed
+ * model programming (small or medium model with some far allocations).
+ * This was tested only with MSC; for other MSDOS compilers you may have
+ * to define NO_MEMCPY in zutil.h.  If you don't need the mixed model,
+ * just define FAR to be empty.
+ */
+#ifdef SYS16BIT
+#  if defined(M_I86SM) || defined(M_I86MM)
+     /* MSC small or medium model */
+#    define SMALL_MEDIUM
+#    ifdef _MSC_VER
+#      define FAR _far
+#    else
+#      define FAR far
+#    endif
+#  endif
+#  if (defined(__SMALL__) || defined(__MEDIUM__))
+     /* Turbo C small or medium model */
+#    define SMALL_MEDIUM
+#    ifdef __BORLANDC__
+#      define FAR _far
+#    else
+#      define FAR far
+#    endif
+#  endif
+#endif
+
+#if defined(WINDOWS) || defined(WIN32)
+   /* If building or using zlib as a DLL, define ZLIB_DLL.
+    * This is not mandatory, but it offers a little performance increase.
+    */
+#  ifdef ZLIB_DLL
+#    if defined(WIN32) && (!defined(__BORLANDC__) || (__BORLANDC__ >= 0x500))
+#      ifdef ZLIB_INTERNAL
+#        define ZEXTERN extern __declspec(dllexport)
+#      else
+#        define ZEXTERN extern __declspec(dllimport)
+#      endif
+#    endif
+#  endif  /* ZLIB_DLL */
+   /* If building or using zlib with the WINAPI/WINAPIV calling convention,
+    * define ZLIB_WINAPI.
+    * Caution: the standard ZLIB1.DLL is NOT compiled using ZLIB_WINAPI.
+    */
+#  ifdef ZLIB_WINAPI
+#    ifdef FAR
+#      undef FAR
+#    endif
+#    include <windows.h>
+     /* No need for _export, use ZLIB.DEF instead. */
+     /* For complete Windows compatibility, use WINAPI, not __stdcall. */
+#    define ZEXPORT WINAPI
+#    ifdef WIN32
+#      define ZEXPORTVA WINAPIV
+#    else
+#      define ZEXPORTVA FAR CDECL
+#    endif
+#  endif
+#endif
+
+#if defined (__BEOS__)
+#  ifdef ZLIB_DLL
+#    ifdef ZLIB_INTERNAL
+#      define ZEXPORT   __declspec(dllexport)
+#      define ZEXPORTVA __declspec(dllexport)
+#    else
+#      define ZEXPORT   __declspec(dllimport)
+#      define ZEXPORTVA __declspec(dllimport)
+#    endif
+#  endif
+#endif
+
+#ifndef ZEXTERN
+#  define ZEXTERN extern
+#endif
+#ifndef ZEXPORT
+#  define ZEXPORT
+#endif
+#ifndef ZEXPORTVA
+#  define ZEXPORTVA
+#endif
+
+#ifndef FAR
+#  define FAR
+#endif
+
+#if !defined(__MACTYPES__)
+typedef unsigned char  Byte;  /* 8 bits */
+#endif
+typedef unsigned int   uInt;  /* 16 bits or more */
+typedef unsigned long  uLong; /* 32 bits or more */
+
+#ifdef SMALL_MEDIUM
+   /* Borland C/C++ and some old MSC versions ignore FAR inside typedef */
+#  define Bytef Byte FAR
+#else
+   typedef Byte  FAR Bytef;
+#endif
+typedef char  FAR charf;
+typedef int   FAR intf;
+typedef uInt  FAR uIntf;
+typedef uLong FAR uLongf;
+
+#ifdef STDC
+   typedef void const *voidpc;
+   typedef void FAR   *voidpf;
+   typedef void       *voidp;
+#else
+   typedef Byte const *voidpc;
+   typedef Byte FAR   *voidpf;
+   typedef Byte       *voidp;
+#endif
+
+#if 0           /* HAVE_UNISTD_H -- this line is updated by ./configure */
+#  include <sys/types.h> /* for off_t */
+#  include <unistd.h>    /* for SEEK_* and off_t */
+#  ifdef VMS
+#    include <unixio.h>   /* for off_t */
+#  endif
+#  define z_off_t off_t
+#endif
+#ifndef SEEK_SET
+#  define SEEK_SET        0       /* Seek from beginning of file.  */
+#  define SEEK_CUR        1       /* Seek from current position.  */
+#  define SEEK_END        2       /* Set file pointer to EOF plus "offset" */
+#endif
+#ifndef z_off_t
+#  define z_off_t long
+#endif
+
+#if defined(__OS400__)
+#  define NO_vsnprintf
+#endif
+
+#if defined(__MVS__)
+#  define NO_vsnprintf
+#  ifdef FAR
+#    undef FAR
+#  endif
+#endif
+
+/* MVS linker does not support external names larger than 8 bytes */
+#if defined(__MVS__)
+#   pragma map(deflateInit_,"DEIN")
+#   pragma map(deflateInit2_,"DEIN2")
+#   pragma map(deflateEnd,"DEEND")
+#   pragma map(deflateBound,"DEBND")
+#   pragma map(inflateInit_,"ININ")
+#   pragma map(inflateInit2_,"ININ2")
+#   pragma map(inflateEnd,"INEND")
+#   pragma map(inflateSync,"INSY")
+#   pragma map(inflateSetDictionary,"INSEDI")
+#   pragma map(compressBound,"CMBND")
+#   pragma map(inflate_table,"INTABL")
+#   pragma map(inflate_fast,"INFA")
+#   pragma map(inflate_copyright,"INCOPY")
+#endif
+
+#endif /* ZCONF_H */

libs/extc/zlib/zlib.h

@@ -0,0 +1,1357 @@
+/* zlib.h -- interface of the 'zlib' general purpose compression library
+  version 1.2.3, July 18th, 2005
+
+  Copyright (C) 1995-2005 Jean-loup Gailly and Mark Adler
+
+  This software is provided 'as-is', without any express or implied
+  warranty.  In no event will the authors be held liable for any damages
+  arising from the use of this software.
+
+  Permission is granted to anyone to use this software for any purpose,
+  including commercial applications, and to alter it and redistribute it
+  freely, subject to the following restrictions:
+
+  1. The origin of this software must not be misrepresented; you must not
+     claim that you wrote the original software. If you use this software
+     in a product, an acknowledgment in the product documentation would be
+     appreciated but is not required.
+  2. Altered source versions must be plainly marked as such, and must not be
+     misrepresented as being the original software.
+  3. This notice may not be removed or altered from any source distribution.
+
+  Jean-loup Gailly        Mark Adler
+  [email protected]          [email protected]
+
+
+  The data format used by the zlib library is described by RFCs (Request for
+  Comments) 1950 to 1952 in the files http://www.ietf.org/rfc/rfc1950.txt
+  (zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format).
+*/
+
+#ifndef ZLIB_H
+#define ZLIB_H
+
+#include "zconf.h"
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#define ZLIB_VERSION "1.2.3"
+#define ZLIB_VERNUM 0x1230
+
+/*
+     The 'zlib' compression library provides in-memory compression and
+  decompression functions, including integrity checks of the uncompressed
+  data.  This version of the library supports only one compression method
+  (deflation) but other algorithms will be added later and will have the same
+  stream interface.
+
+     Compression can be done in a single step if the buffers are large
+  enough (for example if an input file is mmap'ed), or can be done by
+  repeated calls of the compression function.  In the latter case, the
+  application must provide more input and/or consume the output
+  (providing more output space) before each call.
+
+     The compressed data format used by default by the in-memory functions is
+  the zlib format, which is a zlib wrapper documented in RFC 1950, wrapped
+  around a deflate stream, which is itself documented in RFC 1951.
+
+     The library also supports reading and writing files in gzip (.gz) format
+  with an interface similar to that of stdio using the functions that start
+  with "gz".  The gzip format is different from the zlib format.  gzip is a
+  gzip wrapper, documented in RFC 1952, wrapped around a deflate stream.
+
+     This library can optionally read and write gzip streams in memory as well.
+
+     The zlib format was designed to be compact and fast for use in memory
+  and on communications channels.  The gzip format was designed for single-
+  file compression on file systems, has a larger header than zlib to maintain
+  directory information, and uses a different, slower check method than zlib.
+
+     The library does not install any signal handler. The decoder checks
+  the consistency of the compressed data, so the library should never
+  crash even in case of corrupted input.
+*/
+
+typedef voidpf (*alloc_func) OF((voidpf opaque, uInt items, uInt size));
+typedef void   (*free_func)  OF((voidpf opaque, voidpf address));
+
+struct internal_state;
+
+typedef struct z_stream_s {
+    Bytef    *next_in;  /* next input byte */
+    uInt     avail_in;  /* number of bytes available at next_in */
+    uLong    total_in;  /* total nb of input bytes read so far */
+
+    Bytef    *next_out; /* next output byte should be put there */
+    uInt     avail_out; /* remaining free space at next_out */
+    uLong    total_out; /* total nb of bytes output so far */
+
+    char     *msg;      /* last error message, NULL if no error */
+    struct internal_state FAR *state; /* not visible by applications */
+
+    alloc_func zalloc;  /* used to allocate the internal state */
+    free_func  zfree;   /* used to free the internal state */
+    voidpf     opaque;  /* private data object passed to zalloc and zfree */
+
+    int     data_type;  /* best guess about the data type: binary or text */
+    uLong   adler;      /* adler32 value of the uncompressed data */
+    uLong   reserved;   /* reserved for future use */
+} z_stream;
+
+typedef z_stream FAR *z_streamp;
+
+/*
+     gzip header information passed to and from zlib routines.  See RFC 1952
+  for more details on the meanings of these fields.
+*/
+typedef struct gz_header_s {
+    int     text;       /* true if compressed data believed to be text */
+    uLong   time;       /* modification time */
+    int     xflags;     /* extra flags (not used when writing a gzip file) */
+    int     os;         /* operating system */
+    Bytef   *extra;     /* pointer to extra field or Z_NULL if none */
+    uInt    extra_len;  /* extra field length (valid if extra != Z_NULL) */
+    uInt    extra_max;  /* space at extra (only when reading header) */
+    Bytef   *name;      /* pointer to zero-terminated file name or Z_NULL */
+    uInt    name_max;   /* space at name (only when reading header) */
+    Bytef   *comment;   /* pointer to zero-terminated comment or Z_NULL */
+    uInt    comm_max;   /* space at comment (only when reading header) */
+    int     hcrc;       /* true if there was or will be a header crc */
+    int     done;       /* true when done reading gzip header (not used
+                           when writing a gzip file) */
+} gz_header;
+
+typedef gz_header FAR *gz_headerp;
+
+/*
+   The application must update next_in and avail_in when avail_in has
+   dropped to zero. It must update next_out and avail_out when avail_out
+   has dropped to zero. The application must initialize zalloc, zfree and
+   opaque before calling the init function. All other fields are set by the
+   compression library and must not be updated by the application.
+
+   The opaque value provided by the application will be passed as the first
+   parameter for calls of zalloc and zfree. This can be useful for custom
+   memory management. The compression library attaches no meaning to the
+   opaque value.
+
+   zalloc must return Z_NULL if there is not enough memory for the object.
+   If zlib is used in a multi-threaded application, zalloc and zfree must be
+   thread safe.
+
+   On 16-bit systems, the functions zalloc and zfree must be able to allocate
+   exactly 65536 bytes, but will not be required to allocate more than this
+   if the symbol MAXSEG_64K is defined (see zconf.h). WARNING: On MSDOS,
+   pointers returned by zalloc for objects of exactly 65536 bytes *must*
+   have their offset normalized to zero. The default allocation function
+   provided by this library ensures this (see zutil.c). To reduce memory
+   requirements and avoid any allocation of 64K objects, at the expense of
+   compression ratio, compile the library with -DMAX_WBITS=14 (see zconf.h).
+
+   The fields total_in and total_out can be used for statistics or
+   progress reports. After compression, total_in holds the total size of
+   the uncompressed data and may be saved for use in the decompressor
+   (particularly if the decompressor wants to decompress everything in
+   a single step).
+*/
+
+                        /* constants */
+
+#define Z_NO_FLUSH      0
+#define Z_PARTIAL_FLUSH 1 /* will be removed, use Z_SYNC_FLUSH instead */
+#define Z_SYNC_FLUSH    2
+#define Z_FULL_FLUSH    3
+#define Z_FINISH        4
+#define Z_BLOCK         5
+/* Allowed flush values; see deflate() and inflate() below for details */
+
+#define Z_OK            0
+#define Z_STREAM_END    1
+#define Z_NEED_DICT     2
+#define Z_ERRNO        (-1)
+#define Z_STREAM_ERROR (-2)
+#define Z_DATA_ERROR   (-3)
+#define Z_MEM_ERROR    (-4)
+#define Z_BUF_ERROR    (-5)
+#define Z_VERSION_ERROR (-6)
+/* Return codes for the compression/decompression functions. Negative
+ * values are errors, positive values are used for special but normal events.
+ */
+
+#define Z_NO_COMPRESSION         0
+#define Z_BEST_SPEED             1
+#define Z_BEST_COMPRESSION       9
+#define Z_DEFAULT_COMPRESSION  (-1)
+/* compression levels */
+
+#define Z_FILTERED            1
+#define Z_HUFFMAN_ONLY        2
+#define Z_RLE                 3
+#define Z_FIXED               4
+#define Z_DEFAULT_STRATEGY    0
+/* compression strategy; see deflateInit2() below for details */
+
+#define Z_BINARY   0
+#define Z_TEXT     1
+#define Z_ASCII    Z_TEXT   /* for compatibility with 1.2.2 and earlier */
+#define Z_UNKNOWN  2
+/* Possible values of the data_type field (though see inflate()) */
+
+#define Z_DEFLATED   8
+/* The deflate compression method (the only one supported in this version) */
+
+#define Z_NULL  0  /* for initializing zalloc, zfree, opaque */
+
+#define zlib_version zlibVersion()
+/* for compatibility with versions < 1.0.2 */
+
+                        /* basic functions */
+
+ZEXTERN const char * ZEXPORT zlibVersion OF((void));
+/* The application can compare zlibVersion and ZLIB_VERSION for consistency.
+   If the first character differs, the library code actually used is
+   not compatible with the zlib.h header file used by the application.
+   This check is automatically made by deflateInit and inflateInit.
+ */
+
+/*
+ZEXTERN int ZEXPORT deflateInit OF((z_streamp strm, int level));
+
+     Initializes the internal stream state for compression. The fields
+   zalloc, zfree and opaque must be initialized before by the caller.
+   If zalloc and zfree are set to Z_NULL, deflateInit updates them to
+   use default allocation functions.
+
+     The compression level must be Z_DEFAULT_COMPRESSION, or between 0 and 9:
+   1 gives best speed, 9 gives best compression, 0 gives no compression at
+   all (the input data is simply copied a block at a time).
+   Z_DEFAULT_COMPRESSION requests a default compromise between speed and
+   compression (currently equivalent to level 6).
+
+     deflateInit returns Z_OK if success, Z_MEM_ERROR if there was not
+   enough memory, Z_STREAM_ERROR if level is not a valid compression level,
+   Z_VERSION_ERROR if the zlib library version (zlib_version) is incompatible
+   with the version assumed by the caller (ZLIB_VERSION).
+   msg is set to null if there is no error message.  deflateInit does not
+   perform any compression: this will be done by deflate().
+*/
+
+
+ZEXTERN int ZEXPORT deflate OF((z_streamp strm, int flush));
+/*
+    deflate compresses as much data as possible, and stops when the input
+  buffer becomes empty or the output buffer becomes full. It may introduce some
+  output latency (reading input without producing any output) except when
+  forced to flush.
+
+    The detailed semantics are as follows. deflate performs one or both of the
+  following actions:
+
+  - Compress more input starting at next_in and update next_in and avail_in
+    accordingly. If not all input can be processed (because there is not
+    enough room in the output buffer), next_in and avail_in are updated and
+    processing will resume at this point for the next call of deflate().
+
+  - Provide more output starting at next_out and update next_out and avail_out
+    accordingly. This action is forced if the parameter flush is non zero.
+    Forcing flush frequently degrades the compression ratio, so this parameter
+    should be set only when necessary (in interactive applications).
+    Some output may be provided even if flush is not set.
+
+  Before the call of deflate(), the application should ensure that at least
+  one of the actions is possible, by providing more input and/or consuming
+  more output, and updating avail_in or avail_out accordingly; avail_out
+  should never be zero before the call. The application can consume the
+  compressed output when it wants, for example when the output buffer is full
+  (avail_out == 0), or after each call of deflate(). If deflate returns Z_OK
+  and with zero avail_out, it must be called again after making room in the
+  output buffer because there might be more output pending.
+
+    Normally the parameter flush is set to Z_NO_FLUSH, which allows deflate to
+  decide how much data to accumualte before producing output, in order to
+  maximize compression.
+
+    If the parameter flush is set to Z_SYNC_FLUSH, all pending output is
+  flushed to the output buffer and the output is aligned on a byte boundary, so
+  that the decompressor can get all input data available so far. (In particular
+  avail_in is zero after the call if enough output space has been provided
+  before the call.)  Flushing may degrade compression for some compression
+  algorithms and so it should be used only when necessary.
+
+    If flush is set to Z_FULL_FLUSH, all output is flushed as with
+  Z_SYNC_FLUSH, and the compression state is reset so that decompression can
+  restart from this point if previous compressed data has been damaged or if
+  random access is desired. Using Z_FULL_FLUSH too often can seriously degrade
+  compression.
+
+    If deflate returns with avail_out == 0, this function must be called again
+  with the same value of the flush parameter and more output space (updated
+  avail_out), until the flush is complete (deflate returns with non-zero
+  avail_out). In the case of a Z_FULL_FLUSH or Z_SYNC_FLUSH, make sure that
+  avail_out is greater than six to avoid repeated flush markers due to
+  avail_out == 0 on return.
+
+    If the parameter flush is set to Z_FINISH, pending input is processed,
+  pending output is flushed and deflate returns with Z_STREAM_END if there
+  was enough output space; if deflate returns with Z_OK, this function must be
+  called again with Z_FINISH and more output space (updated avail_out) but no
+  more input data, until it returns with Z_STREAM_END or an error. After
+  deflate has returned Z_STREAM_END, the only possible operations on the
+  stream are deflateReset or deflateEnd.
+
+    Z_FINISH can be used immediately after deflateInit if all the compression
+  is to be done in a single step. In this case, avail_out must be at least
+  the value returned by deflateBound (see below). If deflate does not return
+  Z_STREAM_END, then it must be called again as described above.
+
+    deflate() sets strm->adler to the adler32 checksum of all input read
+  so far (that is, total_in bytes).
+
+    deflate() may update strm->data_type if it can make a good guess about
+  the input data type (Z_BINARY or Z_TEXT). In doubt, the data is considered
+  binary. This field is only for information purposes and does not affect
+  the compression algorithm in any manner.
+
+    deflate() returns Z_OK if some progress has been made (more input
+  processed or more output produced), Z_STREAM_END if all input has been
+  consumed and all output has been produced (only when flush is set to
+  Z_FINISH), Z_STREAM_ERROR if the stream state was inconsistent (for example
+  if next_in or next_out was NULL), Z_BUF_ERROR if no progress is possible
+  (for example avail_in or avail_out was zero). Note that Z_BUF_ERROR is not
+  fatal, and deflate() can be called again with more input and more output
+  space to continue compressing.
+*/
+
+
+ZEXTERN int ZEXPORT deflateEnd OF((z_streamp strm));
+/*
+     All dynamically allocated data structures for this stream are freed.
+   This function discards any unprocessed input and does not flush any
+   pending output.
+
+     deflateEnd returns Z_OK if success, Z_STREAM_ERROR if the
+   stream state was inconsistent, Z_DATA_ERROR if the stream was freed
+   prematurely (some input or output was discarded). In the error case,
+   msg may be set but then points to a static string (which must not be
+   deallocated).
+*/
+
+
+/*
+ZEXTERN int ZEXPORT inflateInit OF((z_streamp strm));
+
+     Initializes the internal stream state for decompression. The fields
+   next_in, avail_in, zalloc, zfree and opaque must be initialized before by
+   the caller. If next_in is not Z_NULL and avail_in is large enough (the exact
+   value depends on the compression method), inflateInit determines the
+   compression method from the zlib header and allocates all data structures
+   accordingly; otherwise the allocation will be deferred to the first call of
+   inflate.  If zalloc and zfree are set to Z_NULL, inflateInit updates them to
+   use default allocation functions.
+
+     inflateInit returns Z_OK if success, Z_MEM_ERROR if there was not enough
+   memory, Z_VERSION_ERROR if the zlib library version is incompatible with the
+   version assumed by the caller.  msg is set to null if there is no error
+   message. inflateInit does not perform any decompression apart from reading
+   the zlib header if present: this will be done by inflate().  (So next_in and
+   avail_in may be modified, but next_out and avail_out are unchanged.)
+*/
+
+
+ZEXTERN int ZEXPORT inflate OF((z_streamp strm, int flush));
+/*
+    inflate decompresses as much data as possible, and stops when the input
+  buffer becomes empty or the output buffer becomes full. It may introduce
+  some output latency (reading input without producing any output) except when
+  forced to flush.
+
+  The detailed semantics are as follows. inflate performs one or both of the
+  following actions:
+
+  - Decompress more input starting at next_in and update next_in and avail_in
+    accordingly. If not all input can be processed (because there is not
+    enough room in the output buffer), next_in is updated and processing
+    will resume at this point for the next call of inflate().
+
+  - Provide more output starting at next_out and update next_out and avail_out
+    accordingly.  inflate() provides as much output as possible, until there
+    is no more input data or no more space in the output buffer (see below
+    about the flush parameter).
+
+  Before the call of inflate(), the application should ensure that at least
+  one of the actions is possible, by providing more input and/or consuming
+  more output, and updating the next_* and avail_* values accordingly.
+  The application can consume the uncompressed output when it wants, for
+  example when the output buffer is full (avail_out == 0), or after each
+  call of inflate(). If inflate returns Z_OK and with zero avail_out, it
+  must be called again after making room in the output buffer because there
+  might be more output pending.
+
+    The flush parameter of inflate() can be Z_NO_FLUSH, Z_SYNC_FLUSH,
+  Z_FINISH, or Z_BLOCK. Z_SYNC_FLUSH requests that inflate() flush as much
+  output as possible to the output buffer. Z_BLOCK requests that inflate() stop
+  if and when it gets to the next deflate block boundary. When decoding the
+  zlib or gzip format, this will cause inflate() to return immediately after
+  the header and before the first block. When doing a raw inflate, inflate()
+  will go ahead and process the first block, and will return when it gets to
+  the end of that block, or when it runs out of data.
+
+    The Z_BLOCK option assists in appending to or combining deflate streams.
+  Also to assist in this, on return inflate() will set strm->data_type to the
+  number of unused bits in the last byte taken from strm->next_in, plus 64
+  if inflate() is currently decoding the last block in the deflate stream,
+  plus 128 if inflate() returned immediately after decoding an end-of-block
+  code or decoding the complete header up to just before the first byte of the
+  deflate stream. The end-of-block will not be indicated until all of the
+  uncompressed data from that block has been written to strm->next_out.  The
+  number of unused bits may in general be greater than seven, except when
+  bit 7 of data_type is set, in which case the number of unused bits will be
+  less than eight.
+
+    inflate() should normally be called until it returns Z_STREAM_END or an
+  error. However if all decompression is to be performed in a single step
+  (a single call of inflate), the parameter flush should be set to
+  Z_FINISH. In this case all pending input is processed and all pending
+  output is flushed; avail_out must be large enough to hold all the
+  uncompressed data. (The size of the uncompressed data may have been saved
+  by the compressor for this purpose.) The next operation on this stream must
+  be inflateEnd to deallocate the decompression state. The use of Z_FINISH
+  is never required, but can be used to inform inflate that a faster approach
+  may be used for the single inflate() call.
+
+     In this implementation, inflate() always flushes as much output as
+  possible to the output buffer, and always uses the faster approach on the
+  first call. So the only effect of the flush parameter in this implementation
+  is on the return value of inflate(), as noted below, or when it returns early
+  because Z_BLOCK is used.
+
+     If a preset dictionary is needed after this call (see inflateSetDictionary
+  below), inflate sets strm->adler to the adler32 checksum of the dictionary
+  chosen by the compressor and returns Z_NEED_DICT; otherwise it sets
+  strm->adler to the adler32 checksum of all output produced so far (that is,
+  total_out bytes) and returns Z_OK, Z_STREAM_END or an error code as described
+  below. At the end of the stream, inflate() checks that its computed adler32
+  checksum is equal to that saved by the compressor and returns Z_STREAM_END
+  only if the checksum is correct.
+
+    inflate() will decompress and check either zlib-wrapped or gzip-wrapped
+  deflate data.  The header type is detected automatically.  Any information
+  contained in the gzip header is not retained, so applications that need that
+  information should instead use raw inflate, see inflateInit2() below, or
+  inflateBack() and perform their own processing of the gzip header and
+  trailer.
+
+    inflate() returns Z_OK if some progress has been made (more input processed
+  or more output produced), Z_STREAM_END if the end of the compressed data has
+  been reached and all uncompressed output has been produced, Z_NEED_DICT if a
+  preset dictionary is needed at this point, Z_DATA_ERROR if the input data was
+  corrupted (input stream not conforming to the zlib format or incorrect check
+  value), Z_STREAM_ERROR if the stream structure was inconsistent (for example
+  if next_in or next_out was NULL), Z_MEM_ERROR if there was not enough memory,
+  Z_BUF_ERROR if no progress is possible or if there was not enough room in the
+  output buffer when Z_FINISH is used. Note that Z_BUF_ERROR is not fatal, and
+  inflate() can be called again with more input and more output space to
+  continue decompressing. If Z_DATA_ERROR is returned, the application may then
+  call inflateSync() to look for a good compression block if a partial recovery
+  of the data is desired.
+*/
+
+
+ZEXTERN int ZEXPORT inflateEnd OF((z_streamp strm));
+/*
+     All dynamically allocated data structures for this stream are freed.
+   This function discards any unprocessed input and does not flush any
+   pending output.
+
+     inflateEnd returns Z_OK if success, Z_STREAM_ERROR if the stream state
+   was inconsistent. In the error case, msg may be set but then points to a
+   static string (which must not be deallocated).
+*/
+
+                        /* Advanced functions */
+
+/*
+    The following functions are needed only in some special applications.
+*/
+
+/*
+ZEXTERN int ZEXPORT deflateInit2 OF((z_streamp strm,
+                                     int  level,
+                                     int  method,
+                                     int  windowBits,
+                                     int  memLevel,
+                                     int  strategy));
+
+     This is another version of deflateInit with more compression options. The
+   fields next_in, zalloc, zfree and opaque must be initialized before by
+   the caller.
+
+     The method parameter is the compression method. It must be Z_DEFLATED in
+   this version of the library.
+
+     The windowBits parameter is the base two logarithm of the window size
+   (the size of the history buffer). It should be in the range 8..15 for this
+   version of the library. Larger values of this parameter result in better
+   compression at the expense of memory usage. The default value is 15 if
+   deflateInit is used instead.
+
+     windowBits can also be -8..-15 for raw deflate. In this case, -windowBits
+   determines the window size. deflate() will then generate raw deflate data
+   with no zlib header or trailer, and will not compute an adler32 check value.
+
+     windowBits can also be greater than 15 for optional gzip encoding. Add
+   16 to windowBits to write a simple gzip header and trailer around the
+   compressed data instead of a zlib wrapper. The gzip header will have no
+   file name, no extra data, no comment, no modification time (set to zero),
+   no header crc, and the operating system will be set to 255 (unknown).  If a
+   gzip stream is being written, strm->adler is a crc32 instead of an adler32.
+
+     The memLevel parameter specifies how much memory should be allocated
+   for the internal compression state. memLevel=1 uses minimum memory but
+   is slow and reduces compression ratio; memLevel=9 uses maximum memory
+   for optimal speed. The default value is 8. See zconf.h for total memory
+   usage as a function of windowBits and memLevel.
+
+     The strategy parameter is used to tune the compression algorithm. Use the
+   value Z_DEFAULT_STRATEGY for normal data, Z_FILTERED for data produced by a
+   filter (or predictor), Z_HUFFMAN_ONLY to force Huffman encoding only (no
+   string match), or Z_RLE to limit match distances to one (run-length
+   encoding). Filtered data consists mostly of small values with a somewhat
+   random distribution. In this case, the compression algorithm is tuned to
+   compress them better. The effect of Z_FILTERED is to force more Huffman
+   coding and less string matching; it is somewhat intermediate between
+   Z_DEFAULT and Z_HUFFMAN_ONLY. Z_RLE is designed to be almost as fast as
+   Z_HUFFMAN_ONLY, but give better compression for PNG image data. The strategy
+   parameter only affects the compression ratio but not the correctness of the
+   compressed output even if it is not set appropriately.  Z_FIXED prevents the
+   use of dynamic Huffman codes, allowing for a simpler decoder for special
+   applications.
+
+      deflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough
+   memory, Z_STREAM_ERROR if a parameter is invalid (such as an invalid
+   method). msg is set to null if there is no error message.  deflateInit2 does
+   not perform any compression: this will be done by deflate().
+*/
+
+ZEXTERN int ZEXPORT deflateSetDictionary OF((z_streamp strm,
+                                             const Bytef *dictionary,
+                                             uInt  dictLength));
+/*
+     Initializes the compression dictionary from the given byte sequence
+   without producing any compressed output. This function must be called
+   immediately after deflateInit, deflateInit2 or deflateReset, before any
+   call of deflate. The compressor and decompressor must use exactly the same
+   dictionary (see inflateSetDictionary).
+
+     The dictionary should consist of strings (byte sequences) that are likely
+   to be encountered later in the data to be compressed, with the most commonly
+   used strings preferably put towards the end of the dictionary. Using a
+   dictionary is most useful when the data to be compressed is short and can be
+   predicted with good accuracy; the data can then be compressed better than
+   with the default empty dictionary.
+
+     Depending on the size of the compression data structures selected by
+   deflateInit or deflateInit2, a part of the dictionary may in effect be
+   discarded, for example if the dictionary is larger than the window size in
+   deflate or deflate2. Thus the strings most likely to be useful should be
+   put at the end of the dictionary, not at the front. In addition, the
+   current implementation of deflate will use at most the window size minus
+   262 bytes of the provided dictionary.
+
+     Upon return of this function, strm->adler is set to the adler32 value
+   of the dictionary; the decompressor may later use this value to determine
+   which dictionary has been used by the compressor. (The adler32 value
+   applies to the whole dictionary even if only a subset of the dictionary is
+   actually used by the compressor.) If a raw deflate was requested, then the
+   adler32 value is not computed and strm->adler is not set.
+
+     deflateSetDictionary returns Z_OK if success, or Z_STREAM_ERROR if a
+   parameter is invalid (such as NULL dictionary) or the stream state is
+   inconsistent (for example if deflate has already been called for this stream
+   or if the compression method is bsort). deflateSetDictionary does not
+   perform any compression: this will be done by deflate().
+*/
+
+ZEXTERN int ZEXPORT deflateCopy OF((z_streamp dest,
+                                    z_streamp source));
+/*
+     Sets the destination stream as a complete copy of the source stream.
+
+     This function can be useful when several compression strategies will be
+   tried, for example when there are several ways of pre-processing the input
+   data with a filter. The streams that will be discarded should then be freed
+   by calling deflateEnd.  Note that deflateCopy duplicates the internal
+   compression state which can be quite large, so this strategy is slow and
+   can consume lots of memory.
+
+     deflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not
+   enough memory, Z_STREAM_ERROR if the source stream state was inconsistent
+   (such as zalloc being NULL). msg is left unchanged in both source and
+   destination.
+*/
+
+ZEXTERN int ZEXPORT deflateReset OF((z_streamp strm));
+/*
+     This function is equivalent to deflateEnd followed by deflateInit,
+   but does not free and reallocate all the internal compression state.
+   The stream will keep the same compression level and any other attributes
+   that may have been set by deflateInit2.
+
+      deflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source
+   stream state was inconsistent (such as zalloc or state being NULL).
+*/
+
+ZEXTERN int ZEXPORT deflateParams OF((z_streamp strm,
+                                      int level,
+                                      int strategy));
+/*
+     Dynamically update the compression level and compression strategy.  The
+   interpretation of level and strategy is as in deflateInit2.  This can be
+   used to switch between compression and straight copy of the input data, or
+   to switch to a different kind of input data requiring a different
+   strategy. If the compression level is changed, the input available so far
+   is compressed with the old level (and may be flushed); the new level will
+   take effect only at the next call of deflate().
+
+     Before the call of deflateParams, the stream state must be set as for
+   a call of deflate(), since the currently available input may have to
+   be compressed and flushed. In particular, strm->avail_out must be non-zero.
+
+     deflateParams returns Z_OK if success, Z_STREAM_ERROR if the source
+   stream state was inconsistent or if a parameter was invalid, Z_BUF_ERROR
+   if strm->avail_out was zero.
+*/
+
+ZEXTERN int ZEXPORT deflateTune OF((z_streamp strm,
+                                    int good_length,
+                                    int max_lazy,
+                                    int nice_length,
+                                    int max_chain));
+/*
+     Fine tune deflate's internal compression parameters.  This should only be
+   used by someone who understands the algorithm used by zlib's deflate for
+   searching for the best matching string, and even then only by the most
+   fanatic optimizer trying to squeeze out the last compressed bit for their
+   specific input data.  Read the deflate.c source code for the meaning of the
+   max_lazy, good_length, nice_length, and max_chain parameters.
+
+     deflateTune() can be called after deflateInit() or deflateInit2(), and
+   returns Z_OK on success, or Z_STREAM_ERROR for an invalid deflate stream.
+ */
+
+ZEXTERN uLong ZEXPORT deflateBound OF((z_streamp strm,
+                                       uLong sourceLen));
+/*
+     deflateBound() returns an upper bound on the compressed size after
+   deflation of sourceLen bytes.  It must be called after deflateInit()
+   or deflateInit2().  This would be used to allocate an output buffer
+   for deflation in a single pass, and so would be called before deflate().
+*/
+
+ZEXTERN int ZEXPORT deflatePrime OF((z_streamp strm,
+                                     int bits,
+                                     int value));
+/*
+     deflatePrime() inserts bits in the deflate output stream.  The intent
+  is that this function is used to start off the deflate output with the
+  bits leftover from a previous deflate stream when appending to it.  As such,
+  this function can only be used for raw deflate, and must be used before the
+  first deflate() call after a deflateInit2() or deflateReset().  bits must be
+  less than or equal to 16, and that many of the least significant bits of
+  value will be inserted in the output.
+
+      deflatePrime returns Z_OK if success, or Z_STREAM_ERROR if the source
+   stream state was inconsistent.
+*/
+
+ZEXTERN int ZEXPORT deflateSetHeader OF((z_streamp strm,
+                                         gz_headerp head));
+/*
+      deflateSetHeader() provides gzip header information for when a gzip
+   stream is requested by deflateInit2().  deflateSetHeader() may be called
+   after deflateInit2() or deflateReset() and before the first call of
+   deflate().  The text, time, os, extra field, name, and comment information
+   in the provided gz_header structure are written to the gzip header (xflag is
+   ignored -- the extra flags are set according to the compression level).  The
+   caller must assure that, if not Z_NULL, name and comment are terminated with
+   a zero byte, and that if extra is not Z_NULL, that extra_len bytes are
+   available there.  If hcrc is true, a gzip header crc is included.  Note that
+   the current versions of the command-line version of gzip (up through version
+   1.3.x) do not support header crc's, and will report that it is a "multi-part
+   gzip file" and give up.
+
+      If deflateSetHeader is not used, the default gzip header has text false,
+   the time set to zero, and os set to 255, with no extra, name, or comment
+   fields.  The gzip header is returned to the default state by deflateReset().
+
+      deflateSetHeader returns Z_OK if success, or Z_STREAM_ERROR if the source
+   stream state was inconsistent.
+*/
+
+/*
+ZEXTERN int ZEXPORT inflateInit2 OF((z_streamp strm,
+                                     int  windowBits));
+
+     This is another version of inflateInit with an extra parameter. The
+   fields next_in, avail_in, zalloc, zfree and opaque must be initialized
+   before by the caller.
+
+     The windowBits parameter is the base two logarithm of the maximum window
+   size (the size of the history buffer).  It should be in the range 8..15 for
+   this version of the library. The default value is 15 if inflateInit is used
+   instead. windowBits must be greater than or equal to the windowBits value
+   provided to deflateInit2() while compressing, or it must be equal to 15 if
+   deflateInit2() was not used. If a compressed stream with a larger window
+   size is given as input, inflate() will return with the error code
+   Z_DATA_ERROR instead of trying to allocate a larger window.
+
+     windowBits can also be -8..-15 for raw inflate. In this case, -windowBits
+   determines the window size. inflate() will then process raw deflate data,
+   not looking for a zlib or gzip header, not generating a check value, and not
+   looking for any check values for comparison at the end of the stream. This
+   is for use with other formats that use the deflate compressed data format
+   such as zip.  Those formats provide their own check values. If a custom
+   format is developed using the raw deflate format for compressed data, it is
+   recommended that a check value such as an adler32 or a crc32 be applied to
+   the uncompressed data as is done in the zlib, gzip, and zip formats.  For
+   most applications, the zlib format should be used as is. Note that comments
+   above on the use in deflateInit2() applies to the magnitude of windowBits.
+
+     windowBits can also be greater than 15 for optional gzip decoding. Add
+   32 to windowBits to enable zlib and gzip decoding with automatic header
+   detection, or add 16 to decode only the gzip format (the zlib format will
+   return a Z_DATA_ERROR).  If a gzip stream is being decoded, strm->adler is
+   a crc32 instead of an adler32.
+
+     inflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough
+   memory, Z_STREAM_ERROR if a parameter is invalid (such as a null strm). msg
+   is set to null if there is no error message.  inflateInit2 does not perform
+   any decompression apart from reading the zlib header if present: this will
+   be done by inflate(). (So next_in and avail_in may be modified, but next_out
+   and avail_out are unchanged.)
+*/
+
+ZEXTERN int ZEXPORT inflateSetDictionary OF((z_streamp strm,
+                                             const Bytef *dictionary,
+                                             uInt  dictLength));
+/*
+     Initializes the decompression dictionary from the given uncompressed byte
+   sequence. This function must be called immediately after a call of inflate,
+   if that call returned Z_NEED_DICT. The dictionary chosen by the compressor
+   can be determined from the adler32 value returned by that call of inflate.
+   The compressor and decompressor must use exactly the same dictionary (see
+   deflateSetDictionary).  For raw inflate, this function can be called
+   immediately after inflateInit2() or inflateReset() and before any call of
+   inflate() to set the dictionary.  The application must insure that the
+   dictionary that was used for compression is provided.
+
+     inflateSetDictionary returns Z_OK if success, Z_STREAM_ERROR if a
+   parameter is invalid (such as NULL dictionary) or the stream state is
+   inconsistent, Z_DATA_ERROR if the given dictionary doesn't match the
+   expected one (incorrect adler32 value). inflateSetDictionary does not
+   perform any decompression: this will be done by subsequent calls of
+   inflate().
+*/
+
+ZEXTERN int ZEXPORT inflateSync OF((z_streamp strm));
+/*
+    Skips invalid compressed data until a full flush point (see above the
+  description of deflate with Z_FULL_FLUSH) can be found, or until all
+  available input is skipped. No output is provided.
+
+    inflateSync returns Z_OK if a full flush point has been found, Z_BUF_ERROR
+  if no more input was provided, Z_DATA_ERROR if no flush point has been found,
+  or Z_STREAM_ERROR if the stream structure was inconsistent. In the success
+  case, the application may save the current current value of total_in which
+  indicates where valid compressed data was found. In the error case, the
+  application may repeatedly call inflateSync, providing more input each time,
+  until success or end of the input data.
+*/
+
+ZEXTERN int ZEXPORT inflateCopy OF((z_streamp dest,
+                                    z_streamp source));
+/*
+     Sets the destination stream as a complete copy of the source stream.
+
+     This function can be useful when randomly accessing a large stream.  The
+   first pass through the stream can periodically record the inflate state,
+   allowing restarting inflate at those points when randomly accessing the
+   stream.
+
+     inflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not
+   enough memory, Z_STREAM_ERROR if the source stream state was inconsistent
+   (such as zalloc being NULL). msg is left unchanged in both source and
+   destination.
+*/
+
+ZEXTERN int ZEXPORT inflateReset OF((z_streamp strm));
+/*
+     This function is equivalent to inflateEnd followed by inflateInit,
+   but does not free and reallocate all the internal decompression state.
+   The stream will keep attributes that may have been set by inflateInit2.
+
+      inflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source
+   stream state was inconsistent (such as zalloc or state being NULL).
+*/
+
+ZEXTERN int ZEXPORT inflatePrime OF((z_streamp strm,
+                                     int bits,
+                                     int value));
+/*
+     This function inserts bits in the inflate input stream.  The intent is
+  that this function is used to start inflating at a bit position in the
+  middle of a byte.  The provided bits will be used before any bytes are used
+  from next_in.  This function should only be used with raw inflate, and
+  should be used before the first inflate() call after inflateInit2() or
+  inflateReset().  bits must be less than or equal to 16, and that many of the
+  least significant bits of value will be inserted in the input.
+
+      inflatePrime returns Z_OK if success, or Z_STREAM_ERROR if the source
+   stream state was inconsistent.
+*/
+
+ZEXTERN int ZEXPORT inflateGetHeader OF((z_streamp strm,
+                                         gz_headerp head));
+/*
+      inflateGetHeader() requests that gzip header information be stored in the
+   provided gz_header structure.  inflateGetHeader() may be called after
+   inflateInit2() or inflateReset(), and before the first call of inflate().
+   As inflate() processes the gzip stream, head->done is zero until the header
+   is completed, at which time head->done is set to one.  If a zlib stream is
+   being decoded, then head->done is set to -1 to indicate that there will be
+   no gzip header information forthcoming.  Note that Z_BLOCK can be used to
+   force inflate() to return immediately after header processing is complete
+   and before any actual data is decompressed.
+
+      The text, time, xflags, and os fields are filled in with the gzip header
+   contents.  hcrc is set to true if there is a header CRC.  (The header CRC
+   was valid if done is set to one.)  If extra is not Z_NULL, then extra_max
+   contains the maximum number of bytes to write to extra.  Once done is true,
+   extra_len contains the actual extra field length, and extra contains the
+   extra field, or that field truncated if extra_max is less than extra_len.
+   If name is not Z_NULL, then up to name_max characters are written there,
+   terminated with a zero unless the length is greater than name_max.  If
+   comment is not Z_NULL, then up to comm_max characters are written there,
+   terminated with a zero unless the length is greater than comm_max.  When
+   any of extra, name, or comment are not Z_NULL and the respective field is
+   not present in the header, then that field is set to Z_NULL to signal its
+   absence.  This allows the use of deflateSetHeader() with the returned
+   structure to duplicate the header.  However if those fields are set to
+   allocated memory, then the application will need to save those pointers
+   elsewhere so that they can be eventually freed.
+
+      If inflateGetHeader is not used, then the header information is simply
+   discarded.  The header is always checked for validity, including the header
+   CRC if present.  inflateReset() will reset the process to discard the header
+   information.  The application would need to call inflateGetHeader() again to
+   retrieve the header from the next gzip stream.
+
+      inflateGetHeader returns Z_OK if success, or Z_STREAM_ERROR if the source
+   stream state was inconsistent.
+*/
+
+/*
+ZEXTERN int ZEXPORT inflateBackInit OF((z_streamp strm, int windowBits,
+                                        unsigned char FAR *window));
+
+     Initialize the internal stream state for decompression using inflateBack()
+   calls.  The fields zalloc, zfree and opaque in strm must be initialized
+   before the call.  If zalloc and zfree are Z_NULL, then the default library-
+   derived memory allocation routines are used.  windowBits is the base two
+   logarithm of the window size, in the range 8..15.  window is a caller
+   supplied buffer of that size.  Except for special applications where it is
+   assured that deflate was used with small window sizes, windowBits must be 15
+   and a 32K byte window must be supplied to be able to decompress general
+   deflate streams.
+
+     See inflateBack() for the usage of these routines.
+
+     inflateBackInit will return Z_OK on success, Z_STREAM_ERROR if any of
+   the paramaters are invalid, Z_MEM_ERROR if the internal state could not
+   be allocated, or Z_VERSION_ERROR if the version of the library does not
+   match the version of the header file.
+*/
+
+typedef unsigned (*in_func) OF((void FAR *, unsigned char FAR * FAR *));
+typedef int (*out_func) OF((void FAR *, unsigned char FAR *, unsigned));
+
+ZEXTERN int ZEXPORT inflateBack OF((z_streamp strm,
+                                    in_func in, void FAR *in_desc,
+                                    out_func out, void FAR *out_desc));
+/*
+     inflateBack() does a raw inflate with a single call using a call-back
+   interface for input and output.  This is more efficient than inflate() for
+   file i/o applications in that it avoids copying between the output and the
+   sliding window by simply making the window itself the output buffer.  This
+   function trusts the application to not change the output buffer passed by
+   the output function, at least until inflateBack() returns.
+
+     inflateBackInit() must be called first to allocate the internal state
+   and to initialize the state with the user-provided window buffer.
+   inflateBack() may then be used multiple times to inflate a complete, raw
+   deflate stream with each call.  inflateBackEnd() is then called to free
+   the allocated state.
+
+     A raw deflate stream is one with no zlib or gzip header or trailer.
+   This routine would normally be used in a utility that reads zip or gzip
+   files and writes out uncompressed files.  The utility would decode the
+   header and process the trailer on its own, hence this routine expects
+   only the raw deflate stream to decompress.  This is different from the
+   normal behavior of inflate(), which expects either a zlib or gzip header and
+   trailer around the deflate stream.
+
+     inflateBack() uses two subroutines supplied by the caller that are then
+   called by inflateBack() for input and output.  inflateBack() calls those
+   routines until it reads a complete deflate stream and writes out all of the
+   uncompressed data, or until it encounters an error.  The function's
+   parameters and return types are defined above in the in_func and out_func
+   typedefs.  inflateBack() will call in(in_desc, &buf) which should return the
+   number of bytes of provided input, and a pointer to that input in buf.  If
+   there is no input available, in() must return zero--buf is ignored in that
+   case--and inflateBack() will return a buffer error.  inflateBack() will call
+   out(out_desc, buf, len) to write the uncompressed data buf[0..len-1].  out()
+   should return zero on success, or non-zero on failure.  If out() returns
+   non-zero, inflateBack() will return with an error.  Neither in() nor out()
+   are permitted to change the contents of the window provided to
+   inflateBackInit(), which is also the buffer that out() uses to write from.
+   The length written by out() will be at most the window size.  Any non-zero
+   amount of input may be provided by in().
+
+     For convenience, inflateBack() can be provided input on the first call by
+   setting strm->next_in and strm->avail_in.  If that input is exhausted, then
+   in() will be called.  Therefore strm->next_in must be initialized before
+   calling inflateBack().  If strm->next_in is Z_NULL, then in() will be called
+   immediately for input.  If strm->next_in is not Z_NULL, then strm->avail_in
+   must also be initialized, and then if strm->avail_in is not zero, input will
+   initially be taken from strm->next_in[0 .. strm->avail_in - 1].
+
+     The in_desc and out_desc parameters of inflateBack() is passed as the
+   first parameter of in() and out() respectively when they are called.  These
+   descriptors can be optionally used to pass any information that the caller-
+   supplied in() and out() functions need to do their job.
+
+     On return, inflateBack() will set strm->next_in and strm->avail_in to
+   pass back any unused input that was provided by the last in() call.  The
+   return values of inflateBack() can be Z_STREAM_END on success, Z_BUF_ERROR
+   if in() or out() returned an error, Z_DATA_ERROR if there was a format
+   error in the deflate stream (in which case strm->msg is set to indicate the
+   nature of the error), or Z_STREAM_ERROR if the stream was not properly
+   initialized.  In the case of Z_BUF_ERROR, an input or output error can be
+   distinguished using strm->next_in which will be Z_NULL only if in() returned
+   an error.  If strm->next is not Z_NULL, then the Z_BUF_ERROR was due to
+   out() returning non-zero.  (in() will always be called before out(), so
+   strm->next_in is assured to be defined if out() returns non-zero.)  Note
+   that inflateBack() cannot return Z_OK.
+*/
+
+ZEXTERN int ZEXPORT inflateBackEnd OF((z_streamp strm));
+/*
+     All memory allocated by inflateBackInit() is freed.
+
+     inflateBackEnd() returns Z_OK on success, or Z_STREAM_ERROR if the stream
+   state was inconsistent.
+*/
+
+ZEXTERN uLong ZEXPORT zlibCompileFlags OF((void));
+/* Return flags indicating compile-time options.
+
+    Type sizes, two bits each, 00 = 16 bits, 01 = 32, 10 = 64, 11 = other:
+     1.0: size of uInt
+     3.2: size of uLong
+     5.4: size of voidpf (pointer)
+     7.6: size of z_off_t
+
+    Compiler, assembler, and debug options:
+     8: DEBUG
+     9: ASMV or ASMINF -- use ASM code
+     10: ZLIB_WINAPI -- exported functions use the WINAPI calling convention
+     11: 0 (reserved)
+
+    One-time table building (smaller code, but not thread-safe if true):
+     12: BUILDFIXED -- build static block decoding tables when needed
+     13: DYNAMIC_CRC_TABLE -- build CRC calculation tables when needed
+     14,15: 0 (reserved)
+
+    Library content (indicates missing functionality):
+     16: NO_GZCOMPRESS -- gz* functions cannot compress (to avoid linking
+                          deflate code when not needed)
+     17: NO_GZIP -- deflate can't write gzip streams, and inflate can't detect
+                    and decode gzip streams (to avoid linking crc code)
+     18-19: 0 (reserved)
+
+    Operation variations (changes in library functionality):
+     20: PKZIP_BUG_WORKAROUND -- slightly more permissive inflate
+     21: FASTEST -- deflate algorithm with only one, lowest compression level
+     22,23: 0 (reserved)
+
+    The sprintf variant used by gzprintf (zero is best):
+     24: 0 = vs*, 1 = s* -- 1 means limited to 20 arguments after the format
+     25: 0 = *nprintf, 1 = *printf -- 1 means gzprintf() not secure!
+     26: 0 = returns value, 1 = void -- 1 means inferred string length returned
+
+    Remainder:
+     27-31: 0 (reserved)
+ */
+
+
+                        /* utility functions */
+
+/*
+     The following utility functions are implemented on top of the
+   basic stream-oriented functions. To simplify the interface, some
+   default options are assumed (compression level and memory usage,
+   standard memory allocation functions). The source code of these
+   utility functions can easily be modified if you need special options.
+*/
+
+ZEXTERN int ZEXPORT compress OF((Bytef *dest,   uLongf *destLen,
+                                 const Bytef *source, uLong sourceLen));
+/*
+     Compresses the source buffer into the destination buffer.  sourceLen is
+   the byte length of the source buffer. Upon entry, destLen is the total
+   size of the destination buffer, which must be at least the value returned
+   by compressBound(sourceLen). Upon exit, destLen is the actual size of the
+   compressed buffer.
+     This function can be used to compress a whole file at once if the
+   input file is mmap'ed.
+     compress returns Z_OK if success, Z_MEM_ERROR if there was not
+   enough memory, Z_BUF_ERROR if there was not enough room in the output
+   buffer.
+*/
+
+ZEXTERN int ZEXPORT compress2 OF((Bytef *dest,   uLongf *destLen,
+                                  const Bytef *source, uLong sourceLen,
+                                  int level));
+/*
+     Compresses the source buffer into the destination buffer. The level
+   parameter has the same meaning as in deflateInit.  sourceLen is the byte
+   length of the source buffer. Upon entry, destLen is the total size of the
+   destination buffer, which must be at least the value returned by
+   compressBound(sourceLen). Upon exit, destLen is the actual size of the
+   compressed buffer.
+
+     compress2 returns Z_OK if success, Z_MEM_ERROR if there was not enough
+   memory, Z_BUF_ERROR if there was not enough room in the output buffer,
+   Z_STREAM_ERROR if the level parameter is invalid.
+*/
+
+ZEXTERN uLong ZEXPORT compressBound OF((uLong sourceLen));
+/*
+     compressBound() returns an upper bound on the compressed size after
+   compress() or compress2() on sourceLen bytes.  It would be used before
+   a compress() or compress2() call to allocate the destination buffer.
+*/
+
+ZEXTERN int ZEXPORT uncompress OF((Bytef *dest,   uLongf *destLen,
+                                   const Bytef *source, uLong sourceLen));
+/*
+     Decompresses the source buffer into the destination buffer.  sourceLen is
+   the byte length of the source buffer. Upon entry, destLen is the total
+   size of the destination buffer, which must be large enough to hold the
+   entire uncompressed data. (The size of the uncompressed data must have
+   been saved previously by the compressor and transmitted to the decompressor
+   by some mechanism outside the scope of this compression library.)
+   Upon exit, destLen is the actual size of the compressed buffer.
+     This function can be used to decompress a whole file at once if the
+   input file is mmap'ed.
+
+     uncompress returns Z_OK if success, Z_MEM_ERROR if there was not
+   enough memory, Z_BUF_ERROR if there was not enough room in the output
+   buffer, or Z_DATA_ERROR if the input data was corrupted or incomplete.
+*/
+
+
+typedef voidp gzFile;
+
+ZEXTERN gzFile ZEXPORT gzopen  OF((const char *path, const char *mode));
+/*
+     Opens a gzip (.gz) file for reading or writing. The mode parameter
+   is as in fopen ("rb" or "wb") but can also include a compression level
+   ("wb9") or a strategy: 'f' for filtered data as in "wb6f", 'h' for
+   Huffman only compression as in "wb1h", or 'R' for run-length encoding
+   as in "wb1R". (See the description of deflateInit2 for more information
+   about the strategy parameter.)
+
+     gzopen can be used to read a file which is not in gzip format; in this
+   case gzread will directly read from the file without decompression.
+
+     gzopen returns NULL if the file could not be opened or if there was
+   insufficient memory to allocate the (de)compression state; errno
+   can be checked to distinguish the two cases (if errno is zero, the
+   zlib error is Z_MEM_ERROR).  */
+
+ZEXTERN gzFile ZEXPORT gzdopen  OF((int fd, const char *mode));
+/*
+     gzdopen() associates a gzFile with the file descriptor fd.  File
+   descriptors are obtained from calls like open, dup, creat, pipe or
+   fileno (in the file has been previously opened with fopen).
+   The mode parameter is as in gzopen.
+     The next call of gzclose on the returned gzFile will also close the
+   file descriptor fd, just like fclose(fdopen(fd), mode) closes the file
+   descriptor fd. If you want to keep fd open, use gzdopen(dup(fd), mode).
+     gzdopen returns NULL if there was insufficient memory to allocate
+   the (de)compression state.
+*/
+
+ZEXTERN int ZEXPORT gzsetparams OF((gzFile file, int level, int strategy));
+/*
+     Dynamically update the compression level or strategy. See the description
+   of deflateInit2 for the meaning of these parameters.
+     gzsetparams returns Z_OK if success, or Z_STREAM_ERROR if the file was not
+   opened for writing.
+*/
+
+ZEXTERN int ZEXPORT    gzread  OF((gzFile file, voidp buf, unsigned len));
+/*
+     Reads the given number of uncompressed bytes from the compressed file.
+   If the input file was not in gzip format, gzread copies the given number
+   of bytes into the buffer.
+     gzread returns the number of uncompressed bytes actually read (0 for
+   end of file, -1 for error). */
+
+ZEXTERN int ZEXPORT    gzwrite OF((gzFile file,
+                                   voidpc buf, unsigned len));
+/*
+     Writes the given number of uncompressed bytes into the compressed file.
+   gzwrite returns the number of uncompressed bytes actually written
+   (0 in case of error).
+*/
+
+ZEXTERN int ZEXPORTVA   gzprintf OF((gzFile file, const char *format, ...));
+/*
+     Converts, formats, and writes the args to the compressed file under
+   control of the format string, as in fprintf. gzprintf returns the number of
+   uncompressed bytes actually written (0 in case of error).  The number of
+   uncompressed bytes written is limited to 4095. The caller should assure that
+   this limit is not exceeded. If it is exceeded, then gzprintf() will return
+   return an error (0) with nothing written. In this case, there may also be a
+   buffer overflow with unpredictable consequences, which is possible only if
+   zlib was compiled with the insecure functions sprintf() or vsprintf()
+   because the secure snprintf() or vsnprintf() functions were not available.
+*/
+
+ZEXTERN int ZEXPORT gzputs OF((gzFile file, const char *s));
+/*
+      Writes the given null-terminated string to the compressed file, excluding
+   the terminating null character.
+      gzputs returns the number of characters written, or -1 in case of error.
+*/
+
+ZEXTERN char * ZEXPORT gzgets OF((gzFile file, char *buf, int len));
+/*
+      Reads bytes from the compressed file until len-1 characters are read, or
+   a newline character is read and transferred to buf, or an end-of-file
+   condition is encountered.  The string is then terminated with a null
+   character.
+      gzgets returns buf, or Z_NULL in case of error.
+*/
+
+ZEXTERN int ZEXPORT    gzputc OF((gzFile file, int c));
+/*
+      Writes c, converted to an unsigned char, into the compressed file.
+   gzputc returns the value that was written, or -1 in case of error.
+*/
+
+ZEXTERN int ZEXPORT    gzgetc OF((gzFile file));
+/*
+      Reads one byte from the compressed file. gzgetc returns this byte
+   or -1 in case of end of file or error.
+*/
+
+ZEXTERN int ZEXPORT    gzungetc OF((int c, gzFile file));
+/*
+      Push one character back onto the stream to be read again later.
+   Only one character of push-back is allowed.  gzungetc() returns the
+   character pushed, or -1 on failure.  gzungetc() will fail if a
+   character has been pushed but not read yet, or if c is -1. The pushed
+   character will be discarded if the stream is repositioned with gzseek()
+   or gzrewind().
+*/
+
+ZEXTERN int ZEXPORT    gzflush OF((gzFile file, int flush));
+/*
+     Flushes all pending output into the compressed file. The parameter
+   flush is as in the deflate() function. The return value is the zlib
+   error number (see function gzerror below). gzflush returns Z_OK if
+   the flush parameter is Z_FINISH and all output could be flushed.
+     gzflush should be called only when strictly necessary because it can
+   degrade compression.
+*/
+
+ZEXTERN z_off_t ZEXPORT    gzseek OF((gzFile file,
+                                      z_off_t offset, int whence));
+/*
+      Sets the starting position for the next gzread or gzwrite on the
+   given compressed file. The offset represents a number of bytes in the
+   uncompressed data stream. The whence parameter is defined as in lseek(2);
+   the value SEEK_END is not supported.
+     If the file is opened for reading, this function is emulated but can be
+   extremely slow. If the file is opened for writing, only forward seeks are
+   supported; gzseek then compresses a sequence of zeroes up to the new
+   starting position.
+
+      gzseek returns the resulting offset location as measured in bytes from
+   the beginning of the uncompressed stream, or -1 in case of error, in
+   particular if the file is opened for writing and the new starting position
+   would be before the current position.
+*/
+
+ZEXTERN int ZEXPORT    gzrewind OF((gzFile file));
+/*
+     Rewinds the given file. This function is supported only for reading.
+
+   gzrewind(file) is equivalent to (int)gzseek(file, 0L, SEEK_SET)
+*/
+
+ZEXTERN z_off_t ZEXPORT    gztell OF((gzFile file));
+/*
+     Returns the starting position for the next gzread or gzwrite on the
+   given compressed file. This position represents a number of bytes in the
+   uncompressed data stream.
+
+   gztell(file) is equivalent to gzseek(file, 0L, SEEK_CUR)
+*/
+
+ZEXTERN int ZEXPORT gzeof OF((gzFile file));
+/*
+     Returns 1 when EOF has previously been detected reading the given
+   input stream, otherwise zero.
+*/
+
+ZEXTERN int ZEXPORT gzdirect OF((gzFile file));
+/*
+     Returns 1 if file is being read directly without decompression, otherwise
+   zero.
+*/
+
+ZEXTERN int ZEXPORT    gzclose OF((gzFile file));
+/*
+     Flushes all pending output if necessary, closes the compressed file
+   and deallocates all the (de)compression state. The return value is the zlib
+   error number (see function gzerror below).
+*/
+
+ZEXTERN const char * ZEXPORT gzerror OF((gzFile file, int *errnum));
+/*
+     Returns the error message for the last error which occurred on the
+   given compressed file. errnum is set to zlib error number. If an
+   error occurred in the file system and not in the compression library,
+   errnum is set to Z_ERRNO and the application may consult errno
+   to get the exact error code.
+*/
+
+ZEXTERN void ZEXPORT gzclearerr OF((gzFile file));
+/*
+     Clears the error and end-of-file flags for file. This is analogous to the
+   clearerr() function in stdio. This is useful for continuing to read a gzip
+   file that is being written concurrently.
+*/
+
+                        /* checksum functions */
+
+/*
+     These functions are not related to compression but are exported
+   anyway because they might be useful in applications using the
+   compression library.
+*/
+
+ZEXTERN uLong ZEXPORT adler32 OF((uLong adler, const Bytef *buf, uInt len));
+/*
+     Update a running Adler-32 checksum with the bytes buf[0..len-1] and
+   return the updated checksum. If buf is NULL, this function returns
+   the required initial value for the checksum.
+   An Adler-32 checksum is almost as reliable as a CRC32 but can be computed
+   much faster. Usage example:
+
+     uLong adler = adler32(0L, Z_NULL, 0);
+
+     while (read_buffer(buffer, length) != EOF) {
+       adler = adler32(adler, buffer, length);
+     }
+     if (adler != original_adler) error();
+*/
+
+ZEXTERN uLong ZEXPORT adler32_combine OF((uLong adler1, uLong adler2,
+                                          z_off_t len2));
+/*
+     Combine two Adler-32 checksums into one.  For two sequences of bytes, seq1
+   and seq2 with lengths len1 and len2, Adler-32 checksums were calculated for
+   each, adler1 and adler2.  adler32_combine() returns the Adler-32 checksum of
+   seq1 and seq2 concatenated, requiring only adler1, adler2, and len2.
+*/
+
+ZEXTERN uLong ZEXPORT crc32   OF((uLong crc, const Bytef *buf, uInt len));
+/*
+     Update a running CRC-32 with the bytes buf[0..len-1] and return the
+   updated CRC-32. If buf is NULL, this function returns the required initial
+   value for the for the crc. Pre- and post-conditioning (one's complement) is
+   performed within this function so it shouldn't be done by the application.
+   Usage example:
+
+     uLong crc = crc32(0L, Z_NULL, 0);
+
+     while (read_buffer(buffer, length) != EOF) {
+       crc = crc32(crc, buffer, length);
+     }
+     if (crc != original_crc) error();
+*/
+
+ZEXTERN uLong ZEXPORT crc32_combine OF((uLong crc1, uLong crc2, z_off_t len2));
+
+/*
+     Combine two CRC-32 check values into one.  For two sequences of bytes,
+   seq1 and seq2 with lengths len1 and len2, CRC-32 check values were
+   calculated for each, crc1 and crc2.  crc32_combine() returns the CRC-32
+   check value of seq1 and seq2 concatenated, requiring only crc1, crc2, and
+   len2.
+*/
+
+
+                        /* various hacks, don't look :) */
+
+/* deflateInit and inflateInit are macros to allow checking the zlib version
+ * and the compiler's view of z_stream:
+ */
+ZEXTERN int ZEXPORT deflateInit_ OF((z_streamp strm, int level,
+                                     const char *version, int stream_size));
+ZEXTERN int ZEXPORT inflateInit_ OF((z_streamp strm,
+                                     const char *version, int stream_size));
+ZEXTERN int ZEXPORT deflateInit2_ OF((z_streamp strm, int  level, int  method,
+                                      int windowBits, int memLevel,
+                                      int strategy, const char *version,
+                                      int stream_size));
+ZEXTERN int ZEXPORT inflateInit2_ OF((z_streamp strm, int  windowBits,
+                                      const char *version, int stream_size));
+ZEXTERN int ZEXPORT inflateBackInit_ OF((z_streamp strm, int windowBits,
+                                         unsigned char FAR *window,
+                                         const char *version,
+                                         int stream_size));
+#define deflateInit(strm, level) \
+        deflateInit_((strm), (level),       ZLIB_VERSION, sizeof(z_stream))
+#define inflateInit(strm) \
+        inflateInit_((strm),                ZLIB_VERSION, sizeof(z_stream))
+#define deflateInit2(strm, level, method, windowBits, memLevel, strategy) \
+        deflateInit2_((strm),(level),(method),(windowBits),(memLevel),\
+                      (strategy),           ZLIB_VERSION, sizeof(z_stream))
+#define inflateInit2(strm, windowBits) \
+        inflateInit2_((strm), (windowBits), ZLIB_VERSION, sizeof(z_stream))
+#define inflateBackInit(strm, windowBits, window) \
+        inflateBackInit_((strm), (windowBits), (window), \
+        ZLIB_VERSION, sizeof(z_stream))
+
+
+#if !defined(ZUTIL_H) && !defined(NO_DUMMY_DECL)
+    struct internal_state {int dummy;}; /* hack for buggy compilers */
+#endif
+
+ZEXTERN const char   * ZEXPORT zError           OF((int));
+ZEXTERN int            ZEXPORT inflateSyncPoint OF((z_streamp z));
+ZEXTERN const uLongf * ZEXPORT get_crc_table    OF((void));
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* ZLIB_H */

libs/extlib/IO.ml

@@ -0,0 +1,796 @@
+(*
+ * IO - Abstract input/output
+ * Copyright (C) 2003 Nicolas Cannasse
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+type input = {
+	mutable in_read : unit -> char;
+	mutable in_input : string -> int -> int -> int;
+	mutable in_close : unit -> unit;
+}
+
+type 'a output = {
+	mutable out_write : char -> unit;
+	mutable out_output : string -> int -> int -> int;
+	mutable out_close : unit -> 'a;
+	mutable out_flush : unit -> unit;
+}
+
+exception No_more_input
+exception Input_closed
+exception Output_closed
+
+(* -------------------------------------------------------------- *)
+(* API *)
+
+let default_close = (fun () -> ())
+
+let create_in ~read ~input ~close =
+	{
+		in_read = read;
+		in_input = input;
+		in_close = close;
+	}
+
+let create_out ~write ~output ~flush ~close =
+	{
+		out_write = write;
+		out_output = output;
+		out_close = close;
+		out_flush = flush;
+	}
+
+let read i = i.in_read()
+
+let nread i n =
+	if n < 0 then invalid_arg "IO.nread";
+	if n = 0 then
+		""
+	else
+	let s = String.create n in
+	let l = ref n in
+	let p = ref 0 in
+	try
+		while !l > 0 do
+			let r = i.in_input s !p !l in
+			if r = 0 then raise No_more_input;
+			p := !p + r;
+			l := !l - r;
+		done;
+		s
+	with
+		No_more_input as e ->
+			if !p = 0 then raise e;
+			String.sub s 0 !p
+
+let really_output o s p l' =
+	let sl = String.length s in
+	if p + l' > sl || p < 0 || l' < 0 then invalid_arg "IO.really_output";
+   	let l = ref l' in
+	let p = ref p in
+	while !l > 0 do
+		let w = o.out_output s !p !l in
+		if w = 0 then raise Sys_blocked_io;
+		p := !p + w;
+		l := !l - w;
+	done;
+	l'
+
+let input i s p l =
+	let sl = String.length s in
+	if p + l > sl || p < 0 || l < 0 then invalid_arg "IO.input";
+	if l = 0 then
+		0
+	else
+		i.in_input s p l
+
+let really_input i s p l' =
+	let sl = String.length s in
+	if p + l' > sl || p < 0 || l' < 0 then invalid_arg "IO.really_input";
+	let l = ref l' in
+	let p = ref p in
+	while !l > 0 do
+		let r = i.in_input s !p !l in
+		if r = 0 then raise Sys_blocked_io;
+		p := !p + r;
+		l := !l - r;
+	done;
+	l'
+
+let really_nread i n =
+	if n < 0 then invalid_arg "IO.really_nread";
+	if n = 0 then ""
+	else
+	let s = String.create n
+	in
+	ignore(really_input i s 0 n);
+	s
+
+let close_in i =
+	let f _ = raise Input_closed in
+	i.in_close();
+	i.in_read <- f;
+	i.in_input <- f;
+	i.in_close <- f
+
+let write o x = o.out_write x
+
+let nwrite o s =
+	let p = ref 0 in
+	let l = ref (String.length s) in
+	while !l > 0 do
+		let w = o.out_output s !p !l in
+		if w = 0 then raise Sys_blocked_io;
+		p := !p + w;
+		l := !l - w;
+	done
+
+let output o s p l =
+	let sl = String.length s in
+	if p + l > sl || p < 0 || l < 0 then invalid_arg "IO.output";
+	o.out_output s p l
+
+let printf o fmt =
+	Printf.kprintf (fun s -> nwrite o s) fmt
+
+let flush o = o.out_flush()
+
+let close_out o =
+	let f _ = raise Output_closed in
+	let r = o.out_close() in
+	o.out_write <- f;
+	o.out_output <- f;
+	o.out_close <- f;
+	o.out_flush <- f;
+	r
+
+let read_all i =
+	let maxlen = 1024 in
+	let str = ref [] in
+	let pos = ref 0 in
+	let rec loop() =
+		let s = nread i maxlen in
+		str := (s,!pos) :: !str;
+		pos := !pos + String.length s;
+		loop()
+	in
+	try
+		loop()
+	with
+		No_more_input ->
+			let buf = String.create !pos in
+			List.iter (fun (s,p) ->
+				String.unsafe_blit s 0 buf p (String.length s)
+			) !str;
+			buf
+
+let pos_in i =
+	let p = ref 0 in
+	{
+		in_read = (fun () ->
+			let c = i.in_read() in
+			incr p;
+			c
+		);
+		in_input = (fun s sp l ->
+			let n = i.in_input s sp l in
+			p := !p + n;
+			n
+		);
+		in_close = i.in_close
+	} , (fun () -> !p)
+
+let pos_out o =
+	let p = ref 0 in
+	{
+		out_write = (fun c ->
+			o.out_write c;
+			incr p
+		);
+		out_output = (fun s sp l ->
+			let n = o.out_output s sp l in
+			p := !p + n;
+			n
+		);
+		out_close = o.out_close;
+		out_flush = o.out_flush;
+	} , (fun () -> !p)
+
+(* -------------------------------------------------------------- *)
+(* Standard IO *)
+
+let input_string s =
+	let pos = ref 0 in
+	let len = String.length s in
+	{
+		in_read = (fun () ->
+			if !pos >= len then raise No_more_input;
+			let c = String.unsafe_get s !pos in
+			incr pos;
+			c
+		);
+		in_input = (fun sout p l ->
+			if !pos >= len then raise No_more_input;
+			let n = (if !pos + l > len then len - !pos else l) in
+			String.unsafe_blit s !pos sout p n;
+			pos := !pos + n;
+			n
+		);
+		in_close = (fun () -> ());
+	}
+
+let output_string() =
+	let b = Buffer.create 0 in
+	{
+		out_write = (fun c ->
+			Buffer.add_char b c
+		);
+		out_output = (fun s p l ->
+			Buffer.add_substring b s p l;
+			l
+		);
+		out_close = (fun () -> Buffer.contents b);
+		out_flush = (fun () -> ());
+	}
+
+let output_strings() =
+	let sl = ref [] in
+	let size = ref 0 in
+	let b = Buffer.create 0 in
+	{
+		out_write = (fun c ->
+			if !size = Sys.max_string_length then begin
+				sl := Buffer.contents b :: !sl;
+				Buffer.clear b;
+				size := 0;
+			end else incr size;
+			Buffer.add_char b c
+		);
+		out_output = (fun s p l ->
+			if !size + l > Sys.max_string_length then begin
+				sl := Buffer.contents b :: !sl;
+				Buffer.clear b;
+				size := 0;
+			end else size := !size + l;
+			Buffer.add_substring b s p l;
+			l
+		);
+		out_close = (fun () -> sl := Buffer.contents b :: !sl; List.rev (!sl));
+		out_flush = (fun () -> ());
+	}
+
+
+let input_channel ch =
+	{
+		in_read = (fun () ->
+			try
+				input_char ch
+			with
+				End_of_file -> raise No_more_input
+		);
+		in_input = (fun s p l ->
+			let n = Pervasives.input ch s p l in
+			if n = 0 then raise No_more_input;
+			n
+		);
+		in_close = (fun () -> Pervasives.close_in ch);
+	}
+
+let output_channel ch =
+	{
+		out_write = (fun c -> output_char ch c);
+		out_output = (fun s p l -> Pervasives.output ch s p l; l);
+		out_close = (fun () -> Pervasives.close_out ch);
+		out_flush = (fun () -> Pervasives.flush ch);
+	}
+
+let input_enum e =
+	let pos = ref 0 in
+	{
+		in_read = (fun () ->
+			match Enum.get e with
+			| None -> raise No_more_input
+			| Some c ->
+				incr pos;
+				c
+		);
+		in_input = (fun s p l ->
+			let rec loop p l =
+				if l = 0 then
+					0
+				else
+					match Enum.get e with
+					| None -> l
+					| Some c ->
+						String.unsafe_set s p c;
+						loop (p + 1) (l - 1)
+			in
+			let k = loop p l in
+			if k = l then raise No_more_input;
+			l - k
+		);
+		in_close = (fun () -> ());
+	}
+
+let output_enum() =
+	let b = Buffer.create 0 in
+	{
+		out_write = (fun x ->
+			Buffer.add_char b x
+		);
+		out_output = (fun s p l ->
+			Buffer.add_substring b s p l;
+			l
+		);
+		out_close = (fun () ->
+			let s = Buffer.contents b in
+			ExtString.String.enum s
+		);
+		out_flush = (fun () -> ());
+	}
+
+let pipe() =
+	let input = ref "" in
+	let inpos = ref 0 in
+	let output = Buffer.create 0 in
+	let flush() =
+		input := Buffer.contents output;
+		inpos := 0;
+		Buffer.reset output;
+		if String.length !input = 0 then raise No_more_input
+	in
+	let read() =
+		if !inpos = String.length !input then flush();
+		let c = String.unsafe_get !input !inpos in
+		incr inpos;
+		c
+	in
+	let input s p l =
+		if !inpos = String.length !input then flush();
+		let r = (if !inpos + l > String.length !input then String.length !input - !inpos else l) in
+		String.unsafe_blit !input !inpos s p r;
+		inpos := !inpos + r;
+		r
+	in
+	let write c =
+		Buffer.add_char output c
+	in
+	let output s p l =
+		Buffer.add_substring output s p l;
+		l
+	in
+	let input = {
+		in_read = read;
+		in_input = input;
+		in_close = (fun () -> ());
+	} in
+	let output = {
+		out_write = write;
+		out_output = output;
+		out_close = (fun () -> ());
+		out_flush = (fun () -> ());
+	} in
+	input , output
+
+external cast_output : 'a output -> unit output = "%identity"
+
+(* -------------------------------------------------------------- *)
+(* BINARY APIs *)
+
+exception Overflow of string
+
+let read_byte i = int_of_char (i.in_read())
+
+let read_signed_byte i =
+	let c = int_of_char (i.in_read()) in
+	if c land 128 <> 0 then
+		c - 256
+	else
+		c
+
+let read_string i =
+	let b = Buffer.create 8 in
+	let rec loop() =
+		let c = i.in_read() in
+		if c <> '\000' then begin
+			Buffer.add_char b c;
+			loop();
+		end;
+	in
+	loop();
+	Buffer.contents b
+
+let read_line i =
+	let b = Buffer.create 8 in
+	let cr = ref false in
+	let rec loop() =
+		let c = i.in_read() in
+		match c with
+		| '\n' ->
+			()
+		| '\r' ->
+			cr := true;
+			loop()
+		| _ when !cr ->
+			cr := false;
+			Buffer.add_char b '\r';
+			Buffer.add_char b c;
+			loop();
+		| _ ->
+			Buffer.add_char b c;
+			loop();
+	in
+	try
+		loop();
+		Buffer.contents b
+	with
+		No_more_input ->
+			if !cr then Buffer.add_char b '\r';
+			if Buffer.length b > 0 then
+				Buffer.contents b
+			else
+				raise No_more_input
+
+let read_ui16 i =
+	let ch1 = read_byte i in
+	let ch2 = read_byte i in
+	ch1 lor (ch2 lsl 8)
+
+let read_i16 i =
+	let ch1 = read_byte i in
+	let ch2 = read_byte i in
+	let n = ch1 lor (ch2 lsl 8) in
+	if ch2 land 128 <> 0 then
+		n - 65536
+	else
+		n
+
+let read_i32 ch =
+	let ch1 = read_byte ch in
+	let ch2 = read_byte ch in
+	let ch3 = read_byte ch in
+	let ch4 = read_byte ch in
+	if ch4 land 128 <> 0 then begin
+		if ch4 land 64 = 0 then raise (Overflow "read_i32");
+		ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor ((ch4 land 127) lsl 24)
+	end else begin
+		if ch4 land 64 <> 0 then raise (Overflow "read_i32");
+		ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor (ch4 lsl 24)
+	end
+
+let read_real_i32 ch =
+	let ch1 = read_byte ch in
+	let ch2 = read_byte ch in
+	let ch3 = read_byte ch in
+	let base = Int32.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in
+	let big = Int32.shift_left (Int32.of_int (read_byte ch)) 24 in
+	Int32.logor base big
+
+let read_i64 ch =
+	let ch1 = read_byte ch in
+	let ch2 = read_byte ch in
+	let ch3 = read_byte ch in
+	let ch4 = read_byte ch in
+	let base = Int64.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in
+	let small = Int64.logor base (Int64.shift_left (Int64.of_int ch4) 24) in
+	let big = Int64.of_int32 (read_real_i32 ch) in
+	Int64.logor (Int64.shift_left big 32) small
+
+let read_double ch =
+	Int64.float_of_bits (read_i64 ch)
+
+let write_byte o n =
+	(* doesn't test bounds of n in order to keep semantics of Pervasives.output_byte *)
+	write o (Char.unsafe_chr (n land 0xFF))
+
+let write_string o s =
+	nwrite o s;
+	write o '\000'
+
+let write_line o s =
+	nwrite o s;
+	write o '\n'
+
+let write_ui16 ch n =
+	if n < 0 || n > 0xFFFF then raise (Overflow "write_ui16");
+	write_byte ch n;
+	write_byte ch (n lsr 8)
+
+let write_i16 ch n =
+	if n < -0x8000 || n > 0x7FFF then raise (Overflow "write_i16");
+	if n < 0 then
+		write_ui16 ch (65536 + n)
+	else
+		write_ui16 ch n
+
+let write_i32 ch n =
+	write_byte ch n;
+	write_byte ch (n lsr 8);
+	write_byte ch (n lsr 16);
+	write_byte ch (n asr 24)
+
+let write_real_i32 ch n =
+	let base = Int32.to_int n in
+	let big = Int32.to_int (Int32.shift_right_logical n 24) in
+	write_byte ch base;
+	write_byte ch (base lsr 8);
+	write_byte ch (base lsr 16);
+	write_byte ch big
+
+let write_i64 ch n =
+	write_real_i32 ch (Int64.to_int32 n);
+	write_real_i32 ch (Int64.to_int32 (Int64.shift_right_logical n 32))
+
+let write_double ch f =
+	write_i64 ch (Int64.bits_of_float f)
+
+(* -------------------------------------------------------------- *)
+(* Big Endians *)
+
+module BigEndian = struct
+
+let read_ui16 i =
+	let ch2 = read_byte i in
+	let ch1 = read_byte i in
+	ch1 lor (ch2 lsl 8)
+
+let read_i16 i =
+	let ch2 = read_byte i in
+	let ch1 = read_byte i in
+	let n = ch1 lor (ch2 lsl 8) in
+	if ch2 land 128 <> 0 then
+		n - 65536
+	else
+		n
+
+let read_i32 ch =
+	let ch4 = read_byte ch in
+	let ch3 = read_byte ch in
+	let ch2 = read_byte ch in
+	let ch1 = read_byte ch in
+	if ch4 land 128 <> 0 then begin
+		if ch4 land 64 = 0 then raise (Overflow "read_i32");
+		ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor ((ch4 land 127) lsl 24)
+	end else begin
+		if ch4 land 64 <> 0 then raise (Overflow "read_i32");
+		ch1 lor (ch2 lsl 8) lor (ch3 lsl 16) lor (ch4 lsl 24)
+	end
+
+let read_real_i32 ch =
+	let big = Int32.shift_left (Int32.of_int (read_byte ch)) 24 in
+	let ch3 = read_byte ch in
+	let ch2 = read_byte ch in
+	let ch1 = read_byte ch in
+	let base = Int32.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in
+	Int32.logor base big
+
+let read_i64 ch =
+	let big = Int64.of_int32 (read_real_i32 ch) in
+	let ch4 = read_byte ch in
+	let ch3 = read_byte ch in
+	let ch2 = read_byte ch in
+	let ch1 = read_byte ch in
+	let base = Int64.of_int (ch1 lor (ch2 lsl 8) lor (ch3 lsl 16)) in
+	let small = Int64.logor base (Int64.shift_left (Int64.of_int ch4) 24) in
+	Int64.logor (Int64.shift_left big 32) small
+
+let read_double ch =
+	Int64.float_of_bits (read_i64 ch)
+
+let write_ui16 ch n =
+	if n < 0 || n > 0xFFFF then raise (Overflow "write_ui16");
+	write_byte ch (n lsr 8);
+	write_byte ch n
+
+let write_i16 ch n =
+	if n < -0x8000 || n > 0x7FFF then raise (Overflow "write_i16");
+	if n < 0 then
+		write_ui16 ch (65536 + n)
+	else
+		write_ui16 ch n
+
+let write_i32 ch n =
+	write_byte ch (n asr 24);
+	write_byte ch (n lsr 16);
+	write_byte ch (n lsr 8);
+	write_byte ch n
+
+let write_real_i32 ch n =
+	let base = Int32.to_int n in
+	let big = Int32.to_int (Int32.shift_right_logical n 24) in
+	write_byte ch big;
+	write_byte ch (base lsr 16);
+	write_byte ch (base lsr 8);
+	write_byte ch base
+
+let write_i64 ch n =
+	write_real_i32 ch (Int64.to_int32 (Int64.shift_right_logical n 32));
+	write_real_i32 ch (Int64.to_int32 n)
+
+let write_double ch f =
+	write_i64 ch (Int64.bits_of_float f)
+
+end
+
+(* -------------------------------------------------------------- *)
+(* Bits API *)
+
+type 'a bc = {
+	ch : 'a;
+	mutable nbits : int;
+	mutable bits : int;
+}
+
+type in_bits = input bc
+type out_bits = unit output bc
+
+exception Bits_error
+
+let input_bits ch =
+	{
+		ch = ch;
+		nbits = 0;
+		bits = 0;
+	}
+
+let output_bits ch =
+	{
+		ch = cast_output ch;
+		nbits = 0;
+		bits = 0;
+	}
+
+let rec read_bits b n =
+	if b.nbits >= n then begin
+		let c = b.nbits - n in
+		let k = (b.bits asr c) land ((1 lsl n) - 1) in
+		b.nbits <- c;
+		k
+	end else begin
+		let k = read_byte b.ch in
+		if b.nbits >= 24 then begin
+			if n >= 31 then raise Bits_error;
+			let c = 8 + b.nbits - n in
+			let d = b.bits land ((1 lsl b.nbits) - 1) in
+			let d = (d lsl (8 - c)) lor (k lsr c) in
+			b.bits <- k;
+			b.nbits <- c;
+			d
+		end else begin
+			b.bits <- (b.bits lsl 8) lor k;
+			b.nbits <- b.nbits + 8;
+			read_bits b n;
+		end
+	end
+
+let drop_bits b =
+	b.nbits <- 0
+
+let rec write_bits b ~nbits x =
+	let n = nbits in
+	if n + b.nbits >= 32 then begin
+		if n > 31 then raise Bits_error;
+		let n2 = 32 - b.nbits - 1 in
+		let n3 = n - n2 in
+		write_bits b ~nbits:n2 (x asr n3);
+		write_bits b ~nbits:n3 (x land ((1 lsl n3) - 1));
+	end else begin
+		if n < 0 then raise Bits_error;
+		if (x < 0 || x > (1 lsl n - 1)) && n <> 31 then raise Bits_error;
+		b.bits <- (b.bits lsl n) lor x;
+		b.nbits <- b.nbits + n;
+		while b.nbits >= 8 do
+			b.nbits <- b.nbits - 8;
+			write_byte b.ch (b.bits asr b.nbits)
+		done
+	end
+
+let flush_bits b =
+	if b.nbits > 0 then write_bits b (8 - b.nbits) 0
+
+(* -------------------------------------------------------------- *)
+(* Generic IO *)
+
+class in_channel ch =
+  object
+	method input s pos len = input ch s pos len
+	method close_in() = close_in ch
+  end
+
+class out_channel ch =
+  object
+	method output s pos len = output ch s pos len
+	method flush() = flush ch
+	method close_out() = ignore(close_out ch)
+  end
+
+class in_chars ch =
+  object
+	method get() = try read ch with No_more_input -> raise End_of_file
+	method close_in() = close_in ch
+  end
+
+class out_chars ch =
+  object
+	method put t = write ch t
+	method flush() = flush ch
+	method close_out() = ignore(close_out ch)
+  end
+
+let from_in_channel ch =
+	let cbuf = String.create 1 in
+	let read() =
+		try
+			if ch#input cbuf 0 1 = 0 then raise Sys_blocked_io;
+			String.unsafe_get cbuf 0
+		with
+			End_of_file -> raise No_more_input
+	in
+	let input s p l =
+		ch#input s p l
+	in
+	create_in
+		~read
+		~input
+		~close:ch#close_in
+
+let from_out_channel ch =
+	let cbuf = String.create 1 in
+	let write c =
+		String.unsafe_set cbuf 0 c;
+		if ch#output cbuf 0 1 = 0 then raise Sys_blocked_io;
+	in
+	let output s p l =
+		ch#output s p l
+	in
+	create_out
+		~write
+		~output
+		~flush:ch#flush
+		~close:ch#close_out
+
+let from_in_chars ch =
+	let input s p l =
+		let i = ref 0 in
+		try
+			while !i < l do
+				String.unsafe_set s (p + !i) (ch#get());
+				incr i
+			done;
+			l
+		with
+			End_of_file when !i > 0 ->
+				!i
+	in
+	create_in
+		~read:ch#get
+		~input
+		~close:ch#close_in
+
+let from_out_chars ch =
+	let output s p l =
+		for i = p to p + l - 1 do
+			ch#put (String.unsafe_get s i)
+		done;
+		l
+	in
+	create_out
+		~write:ch#put
+		~output
+		~flush:ch#flush
+		~close:ch#close_out

libs/extlib/IO.mli

@@ -0,0 +1,327 @@
+(* 
+ * IO - Abstract input/output
+ * Copyright (C) 2003 Nicolas Cannasse
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** High-order abstract I/O.
+
+	IO module simply deals with abstract inputs/outputs. It provides a
+	set of methods for working with these IO as well as several
+	constructors that enable to write to an underlying channel, buffer,
+	or enum.
+*)
+
+type input
+(** The abstract input type. *)
+
+type 'a output
+(** The abstract output type, ['a] is the accumulator data, it is returned
+	when the [close_out] function is called. *)
+
+exception No_more_input
+(** This exception is raised when reading on an input with the [read] or
+  [nread] functions while there is no available token to read. *)
+
+exception Input_closed
+(** This exception is raised when reading on a closed input. *)
+
+exception Output_closed
+(** This exception is raised when reading on a closed output. *)
+
+(** {6 Standard API} *)
+
+val read : input -> char
+(** Read a single char from an input or raise [No_more_input] if
+  no input available. *)
+
+val nread : input -> int -> string
+(** [nread i n] reads a string of size up to [n] from an input.
+  The function will raise [No_more_input] if no input is available.
+  It will raise [Invalid_argument] if [n] < 0. *)
+
+val really_nread : input -> int -> string
+(** [really_nread i n] reads a string of exactly [n] characters
+  from the input. Raises [No_more_input] if at least [n] characters are
+  not available. Raises [Invalid_argument] if [n] < 0. *)
+
+val input : input -> string -> int -> int -> int
+(** [input i s p l] reads up to [l] characters from the given input, storing
+  them in string [s], starting at character number [p]. It returns the actual
+  number of characters read or raise [No_more_input] if no character can be
+  read. It will raise [Invalid_argument] if [p] and [l] do not designate a
+  valid substring of [s]. *)
+
+val really_input : input -> string -> int -> int -> int
+(** [really_input i s p l] reads exactly [l] characters from the given input,
+  storing them in the string [s], starting at position [p]. For consistency with
+  {!IO.input} it returns [l]. Raises [No_more_input] if at [l] characters are
+  not available. Raises [Invalid_argument] if [p] and [l] do not designate a
+  valid substring of [s]. *)
+
+val close_in : input -> unit
+(** Close the input. It can no longer be read from. *)
+
+val write : 'a output -> char -> unit
+(** Write a single char to an output. *)
+
+val nwrite : 'a output -> string -> unit
+(** Write a string to an output. *)
+
+val output : 'a output -> string -> int -> int -> int
+(** [output o s p l] writes up to [l] characters from string [s], starting at
+  offset [p]. It returns the number of characters written. It will raise
+  [Invalid_argument] if [p] and [l] do not designate a valid substring of [s]. *)
+
+val really_output : 'a output -> string -> int -> int -> int
+(** [really_output o s p l] writes exactly [l] characters from string [s] onto
+  the the output, starting with the character at offset [p]. For consistency with
+  {!IO.output} it returns [l]. Raises [Invalid_argument] if [p] and [l] do not
+  designate a valid substring of [s]. *)
+
+val flush : 'a output -> unit
+(** Flush an output. *)
+
+val close_out : 'a output -> 'a
+(** Close the output and return its accumulator data.
+  It can no longer be written. *)
+
+(** {6 Creation of IO Inputs/Outputs} *)
+
+val input_string : string -> input
+(** Create an input that will read from a string. *)
+
+val output_string : unit -> string output
+(** Create an output that will write into a string in an efficient way.
+  When closed, the output returns all the data written into it. *)
+
+val output_strings : unit -> string list output
+(** Create an output that will write into a string in an efficient way.
+  When closed, the output returns all the data written into it. 
+  Several strings are used in case the output size excess max_string_length
+*)
+
+val input_channel : in_channel -> input
+(** Create an input that will read from a channel. *)
+
+val output_channel : out_channel -> unit output
+(** Create an output that will write into a channel. *) 
+
+val input_enum : char Enum.t -> input
+(** Create an input that will read from an [enum]. *)
+
+val output_enum : unit -> char Enum.t output
+(** Create an output that will write into an [enum]. The 
+  final enum is returned when the output is closed. *)
+
+val create_in :
+  read:(unit -> char) ->
+  input:(string -> int -> int -> int) -> close:(unit -> unit) -> input
+(** Fully create an input by giving all the needed functions. *)
+
+val create_out :
+  write:(char -> unit) ->
+  output:(string -> int -> int -> int) ->   
+  flush:(unit -> unit) -> close:(unit -> 'a) -> 'a output
+(** Fully create an output by giving all the needed functions. *)
+
+(** {6 Utilities} *)
+
+val printf : 'a output -> ('b, unit, string, unit) format4 -> 'b
+(** The printf function works for any output. *)
+
+val read_all : input -> string
+(** read all the contents of the input until [No_more_input] is raised. *)
+
+val pipe : unit -> input * unit output
+(** Create a pipe between an input and an ouput. Data written from
+  the output can be read from the input. *)
+
+val pos_in : input -> input * (unit -> int)
+(** Create an input that provide a count function of the number of bytes
+  read from it. *)
+
+val pos_out : 'a output -> 'a output * (unit -> int)
+(** Create an output that provide a count function of the number of bytes
+  written through it. *)
+
+external cast_output : 'a output -> unit output = "%identity"
+(** You can safely transform any output to an unit output in a safe way 
+  by using this function. *)
+
+(** {6 Binary files API}
+
+	Here is some API useful for working with binary files, in particular
+	binary files generated by C applications. By default, encoding of
+	multibyte integers is low-endian. The BigEndian module provide multibyte
+	operations with other encoding.
+*)
+
+exception Overflow of string
+(** Exception raised when a read or write operation cannot be completed. *)
+
+val read_byte : input -> int
+(** Read an unsigned 8-bit integer. *)
+
+val read_signed_byte : input -> int
+(** Read an signed 8-bit integer. *)
+
+val read_ui16 : input -> int
+(** Read an unsigned 16-bit word. *)
+
+val read_i16 : input -> int
+(** Read a signed 16-bit word. *)
+
+val read_i32 : input -> int
+(** Read a signed 32-bit integer. Raise [Overflow] if the
+  read integer cannot be represented as a Caml 31-bit integer. *)
+
+val read_real_i32 : input -> int32
+(** Read a signed 32-bit integer as an OCaml int32. *)
+
+val read_i64 : input -> int64
+(** Read a signed 64-bit integer as an OCaml int64. *)
+
+val read_double : input -> float
+(** Read an IEEE double precision floating point value. *)
+
+val read_string : input -> string
+(** Read a null-terminated string. *)
+
+val read_line : input -> string
+(** Read a LF or CRLF terminated string. *)
+
+val write_byte : 'a output -> int -> unit
+(** Write an unsigned 8-bit byte. *)
+
+val write_ui16 : 'a output -> int -> unit
+(** Write an unsigned 16-bit word. *)
+
+val write_i16 : 'a output -> int -> unit
+(** Write a signed 16-bit word. *)
+
+val write_i32 : 'a output -> int -> unit
+(** Write a signed 32-bit integer. *) 
+
+val write_real_i32 : 'a output -> int32 -> unit
+(** Write an OCaml int32. *)
+
+val write_i64 : 'a output -> int64 -> unit
+(** Write an OCaml int64. *)
+
+val write_double : 'a output -> float -> unit
+(** Write an IEEE double precision floating point value. *)
+
+val write_string : 'a output -> string -> unit
+(** Write a string and append an null character. *)
+
+val write_line : 'a output -> string -> unit
+(** Write a line and append a LF (it might be converted
+	to CRLF on some systems depending on the underlying IO). *)
+
+(** Same as operations above, but use big-endian encoding *)
+module BigEndian :
+sig
+
+	val read_ui16 : input -> int
+	val read_i16 : input -> int
+	val read_i32 : input -> int
+	val read_real_i32 : input -> int32
+	val read_i64 : input -> int64
+	val read_double : input -> float
+	
+	val write_ui16 : 'a output -> int -> unit
+	val write_i16 : 'a output -> int -> unit
+	val write_i32 : 'a output -> int -> unit
+	val write_real_i32 : 'a output -> int32 -> unit
+	val write_i64 : 'a output -> int64 -> unit
+	val write_double : 'a output -> float -> unit
+
+end
+
+(** {6 Bits API}
+
+	This enable you to read and write from an IO bit-by-bit or several bits
+	at the same time.
+*)
+
+type in_bits
+type out_bits
+
+exception Bits_error
+
+val input_bits : input -> in_bits
+(** Read bits from an input *)
+
+val output_bits : 'a output -> out_bits
+(** Write bits to an output *)
+
+val read_bits : in_bits -> int -> int
+(** Read up to 31 bits, raise Bits_error if n < 0 or n > 31 *)
+
+val write_bits : out_bits -> nbits:int -> int -> unit
+(** Write up to 31 bits represented as a value, raise Bits_error if nbits < 0
+ or nbits > 31 or the value representation excess nbits. *)
+
+val flush_bits : out_bits -> unit
+(** Flush remaining unwritten bits, adding up to 7 bits which values 0. *)
+
+val drop_bits : in_bits -> unit
+(** Drop up to 7 buffered bits and restart to next input character. *)
+
+(** {6 Generic IO Object Wrappers}
+
+	Theses OO Wrappers have been written to provide easy support of ExtLib
+	IO by external librairies. If you want your library to support ExtLib
+	IO without actually requiring ExtLib to compile, you can should implement
+	the classes [in_channel], [out_channel], [poly_in_channel] and/or
+	[poly_out_channel] which are the common IO specifications established
+	for ExtLib, OCamlNet and Camomile.
+
+	(see http://www.ocaml-programming.de/tmp/IO-Classes.html for more details).
+*)
+
+class in_channel : input ->
+  object
+	method input : string -> int -> int -> int
+	method close_in : unit -> unit
+  end
+
+class out_channel : 'a output ->
+  object
+	method output : string -> int -> int -> int
+	method flush : unit -> unit
+	method close_out : unit -> unit
+  end
+
+class in_chars : input ->
+  object
+	method get : unit -> char
+	method close_in : unit -> unit
+  end
+
+class out_chars : 'a output ->
+  object
+	method put : char -> unit
+	method flush : unit -> unit
+	method close_out : unit -> unit
+  end
+
+val from_in_channel : #in_channel -> input
+val from_out_channel : #out_channel -> unit output
+val from_in_chars : #in_chars -> input
+val from_out_chars : #out_chars -> unit output

libs/extlib/LICENSE

@@ -0,0 +1,199 @@
+The Library is distributed under the terms of the GNU Library General
+Public License version 2 (included below).
+
+As a special exception to the GNU Library General Public License, you
+may link, statically or dynamically, a "work that uses the Library"
+with a publicly distributed version of the Library to produce an
+executable file containing portions of the Library, and distribute
+that executable file under terms of your choice, without any of the
+additional requirements listed in clause 6 of the GNU Library General
+Public License.  By "a publicly distributed version of the Library",
+we mean either the unmodified Library as distributed, or a
+modified version of the Library that is distributed under the
+conditions defined in clause 3 of the GNU Library General Public
+License.  This exception does not however invalidate any other reasons
+why the executable file might be covered by the GNU Library General
+Public License.
+
+------------
+
+GNU LESSER GENERAL PUBLIC LICENSE
+Version 2.1, February 1999 
+
+
+Copyright (C) 1991, 1999 Free Software Foundation, Inc.
+59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+Everyone is permitted to copy and distribute verbatim copies
+of this license document, but changing it is not allowed.
+
+[This is the first released version of the Lesser GPL.  It also counts
+ as the successor of the GNU Library Public License, version 2, hence
+ the version number 2.1.]
+
+Preamble
+The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. 
+
+This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. 
+
+When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. 
+
+To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. 
+
+For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. 
+
+We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. 
+
+To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. 
+
+Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. 
+
+Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. 
+
+When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. 
+
+We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. 
+
+For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. 
+
+In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. 
+
+Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. 
+
+The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. 
+
+
+TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". 
+
+A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. 
+
+The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) 
+
+"Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. 
+
+Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 
+
+1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. 
+
+You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 
+
+2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: 
+
+
+a) The modified work must itself be a software library. 
+b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. 
+c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. 
+d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. 
+(For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) 
+
+These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. 
+
+Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. 
+
+In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 
+
+3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. 
+
+Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. 
+
+This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 
+
+4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. 
+
+If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 
+
+5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. 
+
+However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. 
+
+When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. 
+
+If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) 
+
+Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 
+
+6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. 
+
+You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: 
+
+
+a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) 
+b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. 
+c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. 
+d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. 
+e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. 
+For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. 
+
+It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 
+
+7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: 
+
+
+a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. 
+b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 
+8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 
+
+9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 
+
+10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 
+
+11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. 
+
+If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. 
+
+It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. 
+
+This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 
+
+12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 
+
+13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. 
+
+Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 
+
+14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. 
+
+NO WARRANTY 
+
+15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 
+
+16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 
+
+
+END OF TERMS AND CONDITIONS
+How to Apply These Terms to Your New Libraries
+If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). 
+
+To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. 
+
+
+one line to give the library's name and an idea of what it does.
+Copyright (C) year  name of author
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 of the License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+Also add information on how to contact you by electronic and paper mail. 
+
+You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: 
+
+
+Yoyodyne, Inc., hereby disclaims all copyright interest in
+the library `Frob' (a library for tweaking knobs) written
+by James Random Hacker.
+
+signature of Ty Coon, 1 April 1990
+Ty Coon, President of Vice
+
+That's all there is to it! 

libs/extlib/META.txt

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

libs/extlib/Makefile

@@ -0,0 +1,34 @@
+# Makefile contributed by Alain Frisch
+
+MODULES = \
+ enum bitSet dynArray extArray extHashtbl extList extString global IO option \
+ pMap std uChar uTF8 base64 unzip refList optParse dllist
+
+# the list is topologically sorted
+
+MLI = $(MODULES:=.mli)
+SRC = $(MLI) $(MODULES:=.ml) extLib.ml
+
+all:
+	ocamlc -a -o extLib.cma $(SRC)
+opt:
+	ocamlopt -g -a -o extLib.cmxa $(SRC)
+doc:
+	ocamlc -c $(MODULES:=.mli)
+	mkdir -p doc/
+	ocamldoc -sort -html -d doc/ $(MODULES:=.mli)
+	cp odoc_style.css doc/style.css
+
+copy:
+	mv *.cmi *.cmx *.cma *.cmxa extLib.lib c:/ocaml/lib/
+
+install:
+	cp META.txt META
+	ocamlfind install extlib META *.cmi *.cma $(MLI) $(wildcard *.cmxa) $(wildcard *.a)
+
+uninstall:
+	ocamlfind remove extlib
+
+clean:
+	rm -f $(wildcard *.cmo) $(wildcard *.cmx) $(wildcard *.o) $(wildcard *.cmi) $(wildcard *.cma) $(wildcard *.cmxa) $(wildcard *.a) $(wildcard *.lib) $(wildcard *.obj)
+	rm -Rf doc

libs/extlib/README.txt

@@ -0,0 +1,56 @@
+OCaml Extended standard Library - ExtLib.
+=========================================
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+What is ExtLib ?
+----------------
+
+ExtLib is a set of additional useful functions and modules for OCaml.
+You can watch the SourceForge project page here :
+	http://sourceforge.net/projects/ocaml-lib/
+The web site is here :
+	http://ocaml-lib.sourceforge.net/
+and you can join the mailing list here :
+	http://lists.sourceforge.net/lists/listinfo/ocaml-lib-devel
+
+People are encouraged to contribute and to report any bug or problem
+they might have with ExtLib by using the mailing list.
+
+Installation :
+--------------
+
+Unzip or untar in any directory, then simply run
+
+> ocaml install.ml
+
+and follow the instructions.
+
+Usage :
+-------
+
+Generate and watch the documentation.
+
+Contributors :
+--------------
+
+Nicolas Cannasse ([email protected])
+Brian Hurt ([email protected])
+Yamagata Yoriyuki ([email protected])
+
+License :
+---------
+
+See LICENSE

libs/extlib/base64.ml

@@ -0,0 +1,119 @@
+(*
+ * Base64 - Base64 codec
+ * Copyright (C) 2003 Nicolas Cannasse
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+exception Invalid_char
+exception Invalid_table
+
+external unsafe_char_of_int : int -> char = "%identity"
+
+type encoding_table = char array
+type decoding_table = int array
+
+let chars = [|
+	'A';'B';'C';'D';'E';'F';'G';'H';'I';'J';'K';'L';'M';'N';'O';'P';
+	'Q';'R';'S';'T';'U';'V';'W';'X';'Y';'Z';'a';'b';'c';'d';'e';'f';
+	'g';'h';'i';'j';'k';'l';'m';'n';'o';'p';'q';'r';'s';'t';'u';'v';
+	'w';'x';'y';'z';'0';'1';'2';'3';'4';'5';'6';'7';'8';'9';'+';'/'
+|]
+
+let make_decoding_table tbl =
+	if Array.length tbl <> 64 then raise Invalid_table;
+	let d = Array.make 256 (-1) in
+	for i = 0 to 63 do
+		Array.unsafe_set d (int_of_char (Array.unsafe_get tbl i)) i;
+	done;
+	d
+
+let inv_chars = make_decoding_table chars
+
+let encode ?(tbl=chars) ch =
+	if Array.length tbl <> 64 then raise Invalid_table;
+	let data = ref 0 in
+	let count = ref 0 in
+	let flush() =
+		if !count > 0 then begin
+			let d = (!data lsl (6 - !count)) land 63 in
+			IO.write ch (Array.unsafe_get tbl d);
+		end;		
+	in
+	let write c =
+		let c = int_of_char c in
+		data := (!data lsl 8) lor c;
+		count := !count + 8;
+		while !count >= 6 do
+			count := !count - 6;
+			let d = (!data asr !count) land 63 in
+			IO.write ch (Array.unsafe_get tbl d)
+		done;
+	in
+	let output s p l =
+		for i = p to p + l - 1 do
+			write (String.unsafe_get s i)
+		done;
+		l
+	in
+	IO.create_out ~write ~output
+		~flush:(fun () -> flush(); IO.flush ch)
+		~close:(fun() -> flush(); IO.close_out ch)
+
+let decode ?(tbl=inv_chars) ch =
+	if Array.length tbl <> 256 then raise Invalid_table;
+	let data = ref 0 in
+	let count = ref 0 in
+	let rec fetch() =
+		if !count >= 8 then begin
+			count := !count - 8;
+			let d = (!data asr !count) land 0xFF in
+			unsafe_char_of_int d
+		end else
+			let c = int_of_char (IO.read ch) in
+			let c = Array.unsafe_get tbl c in
+			if c = -1 then raise Invalid_char;
+			data := (!data lsl 6) lor c;
+			count := !count + 6;
+			fetch()
+	in
+	let read = fetch in
+	let input s p l =
+		let i = ref 0 in
+		try
+			while !i < l do
+				String.unsafe_set s (p + !i) (fetch());
+				incr i;
+			done;
+			l
+		with
+			IO.No_more_input when !i > 0 ->
+				!i
+	in
+	let close() =
+		count := 0;
+		IO.close_in ch
+	in
+	IO.create_in ~read ~input ~close
+
+let str_encode ?(tbl=chars) s =
+	let ch = encode ~tbl (IO.output_string()) in
+	IO.nwrite ch s;
+	IO.close_out ch
+
+let str_decode ?(tbl=inv_chars) s =
+	let ch = decode ~tbl (IO.input_string s) in
+	IO.nread ch ((String.length s * 6) / 8)

libs/extlib/base64.mli

@@ -0,0 +1,57 @@
+(*
+ * Base64 - Base64 codec
+ * Copyright (C) 2003 Nicolas Cannasse
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** Base64 codec.
+
+	8-bit characters are encoded into 6-bit ones using ASCII lookup tables.
+	Default tables maps 0..63 values on characters A-Z, a-z, 0-9, '+' and '/'
+	(in that order). 
+*)
+
+(** This exception is raised when reading an invalid character
+	from a base64 input. *)
+exception Invalid_char
+
+(** This exception is raised if the encoding or decoding table
+	size is not correct. *)
+exception Invalid_table
+
+(** An encoding table maps integers 0..63 to the corresponding char. *)
+type encoding_table = char array
+
+(** A decoding table mais chars 0..255 to the corresponding 0..63 value
+ or -1 if the char is not accepted. *)
+type decoding_table = int array
+
+(** Encode a string into Base64. *)
+val str_encode : ?tbl:encoding_table -> string -> string
+
+(** Decode a string encoded into Base64, raise [Invalid_char] if a
+	character in the input string is not a valid one. *)
+val str_decode : ?tbl:decoding_table -> string -> string
+
+(** Generic base64 encoding over an output. *)
+val encode : ?tbl:encoding_table -> 'a IO.output -> 'a IO.output
+
+(** Generic base64 decoding over an input. *)
+val decode : ?tbl:decoding_table -> IO.input -> IO.input
+
+(** Create a valid decoding table from an encoding one. *)
+val make_decoding_table : encoding_table -> decoding_table

libs/extlib/bitSet.ml

@@ -0,0 +1,312 @@
+(*
+ * Bitset - Efficient bit sets
+ * Copyright (C) 2003 Nicolas Cannasse
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA	02111-1307	USA
+ *)
+
+type intern
+
+let bcreate : int -> intern = Obj.magic String.create
+external fast_get : intern -> int -> int = "%string_unsafe_get"
+external fast_set : intern -> int -> int -> unit = "%string_unsafe_set"
+external fast_bool : int -> bool = "%identity"
+let fast_blit : intern -> int -> intern -> int -> int -> unit = Obj.magic String.blit
+let fast_fill : intern -> int -> int -> int -> unit = Obj.magic String.fill
+let fast_length : intern -> int= Obj.magic String.length
+
+let bget s ndx =
+  assert (ndx >= 0 && ndx < fast_length s);
+  fast_get s ndx
+
+let bset s ndx v =
+  assert (ndx >= 0 && ndx < fast_length s);
+  fast_set s ndx v
+
+let bblit src srcoff dst dstoff len = 
+  assert (srcoff >= 0 && dstoff >= 0 && len >= 0);
+  fast_blit src srcoff dst dstoff len
+
+let bfill dst start len c = 
+  assert (start >= 0 && len >= 0);
+  fast_fill dst start len c
+
+exception Negative_index of string
+
+type t = {
+	mutable data : intern;
+	mutable len : int;
+}
+
+let error fname = raise (Negative_index fname)
+
+let empty() =
+	{
+		data = bcreate 0;
+		len = 0;
+	}
+
+let int_size = 7 (* value used to round up index *)
+let log_int_size = 3 (* number of shifts *)
+
+let create n =
+	if n < 0 then error "create";
+	let size = (n+int_size) lsr log_int_size in
+	let b = bcreate size in
+	bfill b 0 size 0;
+	{
+		data = b;
+		len = size;
+	}
+
+let copy t =
+	let b = bcreate t.len in
+	bblit t.data 0 b 0 t.len;
+	{
+		data = b;
+		len = t.len
+	}
+
+let clone = copy
+
+let set t x =
+	if x < 0 then error "set";
+	let pos = x lsr log_int_size and delta = x land int_size in
+	let size = t.len in
+	if pos >= size then begin
+		let b = bcreate (pos+1) in
+		bblit t.data 0 b 0 size;
+		bfill b size (pos - size + 1) 0;
+		t.len <- pos + 1;
+		t.data <- b;
+	end;
+	bset t.data pos ((bget t.data pos) lor (1 lsl delta))
+
+let unset t x =
+	if x < 0 then error "unset";
+	let pos = x lsr log_int_size and delta = x land int_size in
+	if pos < t.len then
+		bset t.data pos ((bget t.data pos) land (0xFF lxor (1 lsl delta)))
+
+let toggle t x =
+	if x < 0 then error "toggle";
+	let pos = x lsr log_int_size and delta = x land int_size in
+	let size = t.len in
+	if pos >= size then begin
+		let b = bcreate (pos+1) in
+		bblit t.data 0 b 0 size;
+		bfill b size (pos - size + 1) 0;
+		t.len <- pos + 1;
+		t.data <- b;
+	end;
+	bset t.data pos ((bget t.data pos) lxor (1 lsl delta))
+
+let put t = function
+	| true -> set t
+	| false -> unset t
+
+let is_set t x =
+  if x < 0 then error "is_set";
+  let pos = x lsr log_int_size and delta = x land int_size in
+  let size = t.len in
+  if pos < size then
+	fast_bool (((bget t.data pos) lsr delta) land 1)
+  else
+	false
+
+
+exception Break_int of int
+
+(* Find highest set element or raise Not_found *)
+let find_msb t =
+  (* Find highest set bit in a byte.  Does not work with zero. *)
+  let byte_msb b = 
+    assert (b <> 0);
+    let rec loop n = 
+      if b land (1 lsl n) = 0 then
+        loop (n-1)
+      else n in
+    loop 7 in
+  let n = t.len - 1
+  and buf = t.data in
+  try 
+    for i = n downto 0 do
+      let byte = bget buf i in
+      if byte <> 0 then raise (Break_int ((i lsl log_int_size)+(byte_msb byte)))
+    done;
+    raise Not_found
+  with 
+    Break_int n -> n
+  | _ -> raise Not_found
+
+let compare t1 t2 =
+  let some_msb b = try Some (find_msb b) with Not_found -> None in
+  match (some_msb t1, some_msb t2) with
+    (None, Some _) -> -1 (* 0-y -> -1 *)
+  | (Some _, None) -> 1  (* x-0 ->  1 *)
+  | (None, None) -> 0    (* 0-0 ->  0 *)
+  | (Some a, Some b) ->  (* x-y *)
+      if a < b then -1
+      else if a > b then 1
+      else
+        begin
+          (* MSBs differ, we need to scan arrays until we find a
+             difference *)
+          let ndx = a lsr log_int_size in 
+          assert (ndx < t1.len && ndx < t2.len);
+          try
+            for i = ndx downto 0 do
+              let b1 = bget t1.data i 
+              and b2 = bget t2.data i in
+              if b1 <> b2 then raise (Break_int (compare b1 b2))
+            done;
+            0
+          with
+            Break_int res -> res
+        end
+
+let equals t1 t2 =
+	compare t1 t2 = 0
+
+let partial_count t x =
+	let rec nbits x =
+		if x = 0 then
+			0
+		else if fast_bool (x land 1) then
+			1 + (nbits (x lsr 1))
+		else
+			nbits (x lsr 1)
+	in
+	let size = t.len in
+	let pos = x lsr log_int_size and delta = x land int_size in
+	let rec loop n acc =
+		if n = size then
+			acc
+		else
+			let x = bget t.data n in
+			loop (n+1) (acc + nbits x)
+	in
+	if pos >= size then
+		0
+	else
+		loop (pos+1) (nbits ((bget t.data pos) lsr delta))
+
+let count t =
+	partial_count t 0
+
+let enum t =
+	let rec make n =
+		let cur = ref n in
+		let rec next() =
+			let pos = !cur lsr log_int_size and delta = !cur land int_size in
+			if pos >= t.len then raise Enum.No_more_elements;
+			let x = bget t.data pos in
+			let rec loop i =
+	if i = 8 then
+		next()
+	else if x land (1 lsl i) = 0 then begin
+		incr cur;
+		loop (i+1)
+	end else
+		!cur
+			in
+			let b = loop delta in
+			incr cur;
+			b
+		in
+		Enum.make
+			~next
+			~count:(fun () -> partial_count t !cur)
+			~clone:(fun () -> make !cur)
+	in
+	make 0
+
+let raw_create size = 
+  let b = bcreate size in
+  bfill b 0 size 0;
+  { data = b; len = size }
+
+let inter a b =
+  let max_size = max a.len b.len in
+  let d = raw_create max_size in
+  let sl = min a.len b.len in
+  let abuf = a.data
+  and bbuf = b.data in
+  (* Note: rest of the array is set to zero automatically *)
+  for i = 0 to sl-1 do
+    bset d.data i ((bget abuf i) land (bget bbuf i))
+  done;
+  d
+
+(* Note: rest of the array is handled automatically correct, since we
+   took a copy of the bigger set. *)
+let union a b = 
+  let d = if a.len > b.len then copy a else copy b in
+  let sl = min a.len b.len in
+  let abuf = a.data
+  and bbuf = b.data in
+  for i = 0 to sl-1 do
+    bset d.data i ((bget abuf i) lor (bget bbuf i))
+  done;
+  d
+
+let diff a b = 
+  let maxlen = max a.len b.len in
+  let buf = bcreate maxlen in
+  bblit a.data 0 buf 0 a.len;
+  let sl = min a.len b.len in
+  let abuf = a.data
+  and bbuf = b.data in
+  for i = 0 to sl-1 do
+    bset buf i ((bget abuf i) land (lnot (bget bbuf i)))
+  done;
+  { data = buf; len = maxlen }
+
+let sym_diff a b = 
+  let maxlen = max a.len b.len in
+  let buf = bcreate maxlen in
+  (* Copy larger (assumes missing bits are zero) *)
+  bblit (if a.len > b.len then a.data else b.data) 0 buf 0 maxlen;
+  let sl = min a.len b.len in
+  let abuf = a.data
+  and bbuf = b.data in
+  for i = 0 to sl-1 do
+    bset buf i ((bget abuf i) lxor (bget bbuf i))
+  done;
+  { data = buf; len = maxlen }
+
+(* TODO the following set operations can be made faster if you do the
+   set operation in-place instead of taking a copy.  But be careful
+   when the sizes of the bitvector strings differ. *)
+let intersect t t' =
+  let d = inter t t' in
+  t.data <- d.data;
+  t.len <- d.len
+
+let differentiate t t' =
+  let d = diff t t' in
+  t.data <- d.data;
+  t.len <- d.len
+
+let unite t t' =
+  let d = union t t' in
+  t.data <- d.data;
+  t.len <- d.len
+
+let differentiate_sym t t' =
+  let d = sym_diff t t' in
+  t.data <- d.data;
+  t.len <- d.len

libs/extlib/bitSet.mli

@@ -0,0 +1,101 @@
+(*
+ * Bitset - Efficient bit sets
+ * Copyright (C) 2003 Nicolas Cannasse
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** Efficient bit sets.
+
+ A bitset is an array of boolean values that can be accessed with indexes
+ like an array but provides a better memory usage (divided by 8) for a
+ very small speed trade-off. *)
+
+type t
+
+exception Negative_index of string
+(** When a negative bit value is used for one of the BitSet functions,
+ this exception is raised with the name of the function. *)
+
+val empty : unit ->  t
+(** Create an empty bitset of size 0, the bitset will automatically expand
+ when needed. *)
+
+val create : int -> t
+(** Create an empty bitset with an initial size (in number of bits). *)
+
+val copy : t -> t
+(** Copy a bitset : further modifications of first one will not affect the
+ copy. *)
+
+val clone : t -> t
+(** Same as [copy] *)
+
+val set : t -> int -> unit
+(** [set s n] sets the nth-bit in the bitset [s] to true. *)
+
+val unset : t -> int -> unit
+(** [unset s n] sets the nth-bit in the bitset [s] to false. *)
+
+val put : t -> bool -> int -> unit
+(** [put s v n] sets the nth-bit in the bitset [s] to [v]. *)
+
+val toggle : t -> int -> unit
+(** [toggle s n] changes the nth-bit value in the bitset [s]. *)
+
+val is_set : t -> int -> bool
+(** [is_set s n] returns true if nth-bit in the bitset [s] is set,
+ or false otherwise. *)
+
+val compare : t -> t -> int
+(** [compare s1 s2] compares two bitsets. Highest bit indexes are
+ compared first. *)
+
+val equals : t -> t -> bool
+(** [equals s1 s2] returns true if, and only if, all bits values in s1 are
+  the same as in s2. *)
+
+val count : t -> int
+(** [count s] returns the number of bits set in the bitset [s]. *)
+
+val enum : t -> int Enum.t
+(** [enum s] returns an enumeration of bits which are set
+  in the bitset [s]. *)
+
+val intersect : t -> t -> unit
+(** [intersect s t] sets [s] to the intersection of the sets [s] and [t]. *)
+
+val unite : t -> t -> unit
+(** [unite s t] sets [s] to the union of the sets [s] and [t]. *)
+
+val differentiate : t -> t -> unit
+(** [differentiate s t] removes the elements of [t] from [s]. *)
+
+val differentiate_sym : t -> t -> unit
+(** [differentiate_sym s t] sets [s] to the symmetrical difference of the
+  sets [s] and [t]. *)
+
+val inter : t -> t -> t
+(** [inter s t] returns the intersection of sets [s] and [t]. *)
+
+val union : t -> t -> t
+(** [union s t] return the union of sets [s]  and [t]. *)
+
+val diff : t -> t -> t
+(** [diff s t] returns [s]-[t]. *)
+
+val sym_diff : t -> t -> t
+(** [sym_diff s t] returns the symmetrical difference of [s] and [t]. *)

libs/extlib/dllist.ml

@@ -0,0 +1,287 @@
+(*
+ * Dllist- a mutable, circular, doubly linked list library
+ * Copyright (C) 2004 Brian Hurt, Jesse Guardiani
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+type 'a node_t = {
+	mutable data : 'a;
+	mutable next : 'a node_t;
+	mutable prev : 'a node_t
+}
+
+type 'a enum_t = {
+	mutable curr : 'a node_t;
+	mutable valid : bool
+}
+
+exception Empty
+
+let create x = let rec nn = { data = x; next = nn; prev = nn} in nn
+
+let length node =
+	let rec loop cnt n =
+		if n == node then
+			cnt
+		else
+			loop (cnt + 1) n.next
+	in
+	loop 1 node.next
+
+let add node elem =
+	let nn = { data = elem; next = node.next; prev = node } in
+	node.next.prev <- nn;
+	node.next <- nn
+
+let append node elem =
+	let nn = { data = elem; next = node.next; prev = node } in
+	node.next.prev <- nn;
+	node.next <- nn;
+	nn
+
+let prepend node elem =
+	let nn = { data = elem; next = node; prev = node.prev } in
+	node.prev.next <- nn;
+	node.prev <- nn;
+	nn
+
+let promote node =
+	let next = node.next in
+	let prev = node.prev in
+	if next != prev then begin
+		next.next.prev <- node;
+		node.next <- next.next;
+		node.prev <- next;
+		next.next <- node;
+		next.prev <- prev;
+		prev.next <- next
+	end
+
+let demote node =
+	let next = node.next in
+	let prev = node.prev in
+	if next != prev then begin
+		prev.prev.next <- node;
+		node.prev <- prev.prev;
+		node.next <- prev;
+		prev.prev <- node;
+		prev.next <- next;
+		next.prev <- prev
+	end
+
+let remove node =
+	let next = node.next in
+	let prev = node.prev in
+	prev.next <- next;
+	next.prev <- prev;
+	node.next <- node;
+	node.prev <- node
+
+let drop node =
+	let next = node.next in
+	let prev = node.prev in
+	prev.next <- next;
+	next.prev <- prev;
+	node.next <- node;
+	node.prev <- node;
+	next
+
+let rev_drop node =
+	let next = node.next in
+	let prev = node.prev in
+	prev.next <- next;
+	next.prev <- prev;
+	node.next <- node;
+	node.prev <- node;
+	prev
+
+let splice node1 node2 =
+	let next = node1.next in
+	let prev = node2.prev in
+	node1.next <- node2;
+	node2.prev <- node1;
+	next.prev <- prev;
+	prev.next <- next
+
+let set node data = node.data <- data
+
+let get node = node.data
+
+let next node = node.next
+
+let prev node = node.prev
+
+let skip node idx =
+	let m = if idx > 0 then -1 else 1 in
+	let rec loop idx n =
+		if idx == 0 then
+			n
+		else
+			loop (idx + m) n.next
+	in
+	loop idx node
+
+let rev node =
+	let rec loop next n =
+		begin
+			let prev = n.prev in
+			n.next <- prev;
+			n.prev <- next;
+
+			if n != node then
+				loop n prev
+		end
+	in
+	loop node node.prev
+
+let iter f node =
+	let () = f node.data in
+	let rec loop n =
+		if n != node then
+			let () = f n.data in
+			loop n.next
+	in
+	loop node.next
+
+let fold_left f init node =
+	let rec loop accu n =
+		if n == node then
+			accu
+		else
+			loop (f accu n.data) n.next
+	in
+	loop (f init node.data) node.next
+
+let fold_right f node init =
+	let rec loop accu n =
+		if n == node then
+			f n.data accu
+		else
+			loop (f n.data accu) n.prev
+	in
+	loop init node.prev
+
+let map f node =
+	let first = create (f node.data) in
+	let rec loop last n =
+		if n == node then
+			begin
+				first.prev <- last;
+				first
+			end
+		else
+			begin
+				let nn = { data = f n.data; next = first; prev = last } in
+				last.next <- nn;
+				loop nn n.next
+			end
+	in
+	loop first node.next
+
+let copy node = map (fun x -> x) node
+
+let to_list node = fold_right (fun d l -> d::l) node []
+
+let of_list lst =
+	match lst with
+		| [] -> raise Empty
+		| h :: t ->
+			let first = create h in
+			let rec loop last = function
+				| [] ->
+					last.next <- first;
+					first.prev <- last;
+					first
+				| h :: t ->
+					let nn = { data = h; next = first; prev = last } in
+					last.next <- nn;
+					loop nn t
+			in
+			loop first t
+
+let enum node =
+	let next e () =
+		if e.valid == false then
+			raise Enum.No_more_elements
+		else
+			begin
+			let rval = e.curr.data in
+			e.curr <- e.curr.next;
+
+			if (e.curr == node) then
+				e.valid <- false;
+			rval
+			end
+	and count e () =
+		if e.valid == false then
+			0
+		else
+			let rec loop cnt n =
+				if n == node then
+					cnt
+				else
+					loop (cnt + 1) (n.next)
+			in
+			loop 1 (e.curr.next)
+	in
+	let rec clone e () =
+		let e' = { curr = e.curr; valid = e.valid } in
+		Enum.make ~next:(next e') ~count:(count e') ~clone:(clone e')
+	in
+	let e = { curr = node; valid = true } in
+	Enum.make ~next:(next e) ~count:(count e) ~clone:(clone e)
+
+let rev_enum node =
+	let prev e () =
+		if e.valid == false then
+			raise Enum.No_more_elements
+		else
+			begin
+			let rval = e.curr.data in
+			e.curr <- e.curr.prev;
+
+			if (e.curr == node) then
+				e.valid <- false;
+			rval
+			end
+	and count e () =
+		if e.valid == false then
+			0
+		else
+			let rec loop cnt n =
+				if n == node then
+					cnt
+				else
+					loop (cnt + 1) (n.prev)
+			in
+			loop 1 (e.curr.prev)
+	in
+	let rec clone e () =
+		let e' = { curr = e.curr; valid = e.valid } in
+		Enum.make ~next:(prev e') ~count:(count e') ~clone:(clone e')
+	in
+	let e = { curr = node; valid = true } in
+	Enum.make ~next:(prev e) ~count:(count e) ~clone:(clone e)
+
+let of_enum enm =
+	match Enum.get enm with
+		| None -> raise Empty
+		| Some(d) ->
+			let first = create d in
+			let f d n = append n d in
+			ignore(Enum.fold f first enm);
+			first

libs/extlib/dllist.mli

@@ -0,0 +1,182 @@
+(*
+ * Dllist- a mutable, circular, doubly linked list library
+ * Copyright (C) 2004 Brian Hurt, Jesse Guardiani
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** A mutable, imperative, circular, doubly linked list library
+
+    This module implements a doubly linked list in a mutable or imperitive
+    style (changes to the list are visible to all copies of the list).
+*)
+
+
+type 'a node_t (* abstract *)
+
+exception Empty
+
+(** {6 node functions } *)
+
+(** Creates a node.  This is an O(1) operation. *)
+val create : 'a -> 'a node_t
+
+(** Copy the list attached to the given node and return the copy of the given
+    node.  This is an O(N) operation.
+*)
+val copy : 'a node_t -> 'a node_t
+
+(** Returns the length of the list.  This is an O(N) operation. *)
+val length : 'a node_t -> int
+
+(** List reversal.  This is an O(N) operation.
+*)
+val rev : 'a node_t -> unit
+
+(** [add n a] Creates a new node containing data [a] and inserts it into
+    the list after node [n].  This is an O(1) operation.
+*)
+val add : 'a node_t -> 'a -> unit
+
+(** [append n a] Creates a new node containing data [a] and inserts it into
+    the list after node [n]. Returns new node.  This is an O(1) operation.
+*)
+val append : 'a node_t -> 'a -> 'a node_t
+
+(** [prepend n a] Creates a new node containing data [a] and inserts it into
+    the list before node [n]. Returns new node.  This is an O(1) operation.
+*)
+val prepend : 'a node_t -> 'a -> 'a node_t
+
+(** [promote n] Swaps [n] with [next n].  This is an O(1) operation.
+*)
+val promote : 'a node_t -> unit
+
+(** [demote n] Swaps [n] with [prev n].  This is an O(1) operation.
+*)
+val demote : 'a node_t -> unit
+
+(** Remove node from the list no matter where it is.  This is an O(1) operation.
+*)
+val remove : 'a node_t -> unit
+
+(** Remove node from the list no matter where it is. Return next node.  This is
+    an O(1) operation.
+*)
+val drop : 'a node_t -> 'a node_t
+
+(** Remove node from the list no matter where it is. Return previous node.  This
+    is an O(1) operation.
+*)
+val rev_drop : 'a node_t -> 'a node_t
+
+(** [splice n1 n2] Connects [n1] and [n2] so that
+    [next n1 == n2 && prev n2 == n1]. This can be used to connect two discrete
+    lists, or, if used on two nodes within the same list, it can be used to
+    separate the nodes between [n1] and [n2] from the rest of the list. In this
+    case, those nodes become a discrete list by themselves.  This is an O(1)
+    operation.
+*)   
+val splice : 'a node_t -> 'a node_t -> unit
+
+(** Given a node, get the data associated with that node.  This is an
+    O(1) operation.
+*)
+val get : 'a node_t -> 'a
+
+(** Given a node, set the data associated with that node.  This is an O(1)
+    operation.
+*)
+val set : 'a node_t -> 'a -> unit
+
+(** Given a node, get the next element in the list after the node.  
+
+    The list is circular, so the last node of the list returns the first 
+    node of the list as it's next node.
+    
+    This is an O(1) operation.
+*)
+val next : 'a node_t -> 'a node_t
+
+(** Given a node, get the previous element in the list before the node.
+ 
+    The list is circular, so the first node of the list returns the
+    last element of the list as it's previous node.
+
+    This is an O(1) operation.
+*)
+val prev : 'a node_t -> 'a node_t
+
+(** [skip n i] Return the node that is [i] nodes after node [n] in the list.
+    If [i] is negative then return the node that is [i] nodes before node [n]
+    in the list.  This is an O(N) operation.
+*)
+val skip : 'a node_t -> int -> 'a node_t
+
+(** [iter f n] Apply [f] to every element in the list, starting at [n].  This
+    is an O(N) operation.
+*)
+val iter : ('a -> unit) -> 'a node_t -> unit
+
+(** Accumulate a value over the entire list.  
+    This works like List.fold_left. This is an O(N) operation.
+*)
+val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b node_t -> 'a
+
+(** Accumulate a value over the entire list.
+    This works like List.fold_right, but since the list is bidirectional,
+    it doesn't suffer the performance problems of List.fold_right.
+    This is an O(N) operation.
+*)
+val fold_right : ('a -> 'b -> 'b) -> 'a node_t -> 'b -> 'b
+
+(** Allocate a new list, with entirely new nodes, whose values are
+    the transforms of the values of the original list.  Note that this
+    does not modify the given list.  This is an O(N) operation.
+*)
+val map : ('a -> 'b) -> 'a node_t -> 'b node_t
+
+
+(** {6 list conversion } *)
+
+(** Converts a dllist to a normal list.  This is an O(N) operation. *)
+val to_list : 'a node_t -> 'a list
+
+(** Converts from a normal list to a Dllist and returns the first node. Raises
+    [Empty] if given list is empty.  This is an O(N) operation.
+*)
+val of_list : 'a list -> 'a node_t
+
+
+(** {6 enums } *)
+
+(** Create an enum of the list.
+    Note that modifying the list while the enum exists will have undefined
+    effects.  This is an O(1) operation.
+*)
+val enum : 'a node_t -> 'a Enum.t
+
+(** Create a reverse enum of the list.
+    Note that modifying the list while the enum exists will have undefined
+    effects.  This is an O(1) operation.
+*)
+val rev_enum : 'a node_t -> 'a Enum.t
+
+(** Create a dllist from an enum.
+    This consumes the enum, and allocates a whole new dllist. Raises
+    [Empty] if given enum is empty.  This is an O(N) operation.
+*)
+val of_enum : 'a Enum.t -> 'a node_t

libs/extlib/dynArray.ml

@@ -0,0 +1,448 @@
+(*
+ * DynArray - Resizeable Ocaml arrays
+ * Copyright (C) 2003 Brian Hurt
+ * Copyright (C) 2003 Nicolas Cannasse
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+type resizer_t = currslots:int -> oldlength:int -> newlength:int -> int
+
+type 'a intern
+
+external ilen : 'a intern -> int = "%obj_size"
+let idup (x : 'a intern) = if ilen x = 0 then x else (Obj.magic (Obj.dup (Obj.repr x)) : 'a intern)
+let imake tag len = (Obj.magic (Obj.new_block tag len) : 'a intern)
+external iget : 'a intern -> int -> 'a = "%obj_field"
+external iset : 'a intern -> int -> 'a -> unit = "%obj_set_field"
+
+type 'a t = {
+	mutable arr : 'a intern;
+	mutable len : int;
+	mutable resize: resizer_t;
+}
+
+exception Invalid_arg of int * string * string
+
+let invalid_arg n f p = raise (Invalid_arg (n,f,p))
+
+let length d = d.len
+
+let exponential_resizer ~currslots ~oldlength ~newlength =
+	let rec doubler x = if x >= newlength then x else doubler (x * 2) in
+	let rec halfer x = if x / 2 < newlength then x else halfer (x / 2) in
+	if newlength = 1 then
+		1
+	else if currslots = 0 then
+		doubler 1
+	else if currslots < newlength then
+		doubler currslots
+	else
+		halfer currslots
+
+let step_resizer step =
+	if step <= 0 then invalid_arg step "step_resizer" "step";
+	(fun ~currslots ~oldlength ~newlength ->
+		if currslots < newlength || newlength < (currslots - step)
+		then
+		   (newlength + step - (newlength mod step))
+		else
+			currslots)
+
+let conservative_exponential_resizer ~currslots ~oldlength ~newlength =
+	let rec doubler x = if x >= newlength then x else doubler (x * 2) in
+	let rec halfer x = if x / 2 < newlength then x else halfer (x / 2) in
+	if currslots < newlength then begin
+		if newlength = 1 then
+			1
+		else if currslots = 0 then
+			doubler 1
+		else
+			doubler currslots
+	end else if oldlength < newlength then
+		halfer currslots
+	else
+		currslots
+
+let default_resizer = conservative_exponential_resizer
+
+let changelen (d : 'a t) newlen =
+	let oldsize = ilen d.arr in
+	let r = d.resize
+			~currslots:oldsize
+			~oldlength:d.len
+			~newlength:newlen
+	in
+	(* We require the size to be at least large enough to hold the number
+	 * of elements we know we need!
+	 *)
+	let newsize = if r < newlen then newlen else r in
+	if newsize <> oldsize then begin
+		let newarr = imake 0 newsize in
+		let cpylen = (if newlen < d.len then newlen else d.len) in
+		for i = 0 to cpylen - 1 do
+			iset newarr i (iget d.arr i);
+		done;
+		d.arr <- newarr;
+	end;
+	d.len <- newlen
+
+let compact d =
+	if d.len <> ilen d.arr then begin
+		let newarr = imake 0 d.len in
+		for i = 0 to d.len - 1 do
+			iset newarr i (iget d.arr i)
+		done;
+		d.arr <- newarr;
+	end
+
+let create() =
+	{
+		resize = default_resizer;
+		len = 0;
+		arr = imake 0 0;
+	}
+
+let make initsize =
+	if initsize < 0 then invalid_arg initsize "make" "size";
+	{
+		resize = default_resizer;
+		len = 0;
+		arr = imake 0 initsize;
+	}
+
+let init initlen f =
+	if initlen < 0 then invalid_arg initlen "init" "len";
+	let arr = imake 0 initlen in
+	for i = 0 to initlen-1 do
+		iset arr i (f i)
+	done;
+	{
+		resize = default_resizer;
+		len = initlen;
+		arr = arr;
+	}
+
+let set_resizer d resizer =
+	d.resize <- resizer
+
+let get_resizer d =
+	d.resize
+
+let empty d =
+	d.len = 0
+
+let get d idx =
+	if idx < 0 || idx >= d.len then invalid_arg idx "get" "index";
+	iget d.arr idx
+
+let last d =
+	if d.len = 0 then invalid_arg 0 "last" "<array len is 0>";
+	iget d.arr (d.len - 1)
+
+let set d idx v =
+	if idx < 0 || idx >= d.len then 	invalid_arg idx "set" "index";
+	iset d.arr idx v
+
+let insert d idx v =
+	if idx < 0 || idx > d.len then invalid_arg idx "insert" "index";
+	if d.len = ilen d.arr then changelen d (d.len + 1) else d.len <- d.len + 1;
+	if idx < d.len - 1 then begin
+		for i = d.len - 2 downto idx do
+			iset d.arr (i+1) (iget d.arr i)
+		done;
+	end;
+	iset d.arr idx v
+
+let add d v =
+	if d.len = ilen d.arr then changelen d (d.len + 1) else d.len <- d.len + 1;
+	iset d.arr (d.len - 1) v
+
+let delete d idx =
+	if idx < 0 || idx >= d.len then invalid_arg idx "delete" "index";
+	let oldsize = ilen d.arr in
+	(* we don't call changelen because we want to blit *)
+	let r = d.resize
+		~currslots:oldsize
+		~oldlength:d.len
+		~newlength:(d.len - 1)
+	in
+	let newsize = (if r < d.len - 1 then d.len - 1 else r) in
+	if oldsize <> newsize then begin
+		let newarr = imake 0 newsize in
+		for i = 0 to idx - 1 do
+			iset newarr i (iget d.arr i);
+		done;
+		for i = idx to d.len - 2 do
+			iset newarr i (iget d.arr (i+1));
+		done;
+		d.arr <- newarr;
+	end else begin
+		for i = idx to d.len - 2 do
+			iset d.arr i (iget d.arr (i+1));
+		done;
+		iset d.arr (d.len - 1) (Obj.magic 0)
+	end;
+	d.len <- d.len - 1
+
+
+let delete_range d idx len =
+	if len < 0 then invalid_arg len "delete_range" "length";
+	if idx < 0 || idx + len > d.len then invalid_arg idx "delete_range" "index";
+	let oldsize = ilen d.arr in
+	(* we don't call changelen because we want to blit *)
+	let r = d.resize
+		~currslots:oldsize
+		~oldlength:d.len
+		~newlength:(d.len - len)
+	in
+	let newsize = (if r < d.len - len then d.len - len else r) in
+	if oldsize <> newsize then begin
+		let newarr = imake 0 newsize in
+		for i = 0 to idx - 1 do
+			iset newarr i (iget d.arr i);
+		done;
+		for i = idx to d.len - len - 1 do
+			iset newarr i (iget d.arr (i+len));
+		done;
+		d.arr <- newarr;
+	end else begin
+		for i = idx to d.len - len - 1 do
+			iset d.arr i (iget d.arr (i+len));
+		done;
+		for i = d.len - len to d.len - 1 do
+			iset d.arr i (Obj.magic 0)
+		done;
+	end;
+	d.len <- d.len - len
+
+let clear d =
+	d.len <- 0;
+	d.arr <- imake 0 0
+
+let delete_last d =
+	if d.len <= 0 then invalid_arg 0 "delete_last" "<array len is 0>";
+	(* erase for GC, in case changelen don't resize our array *)
+	iset d.arr (d.len - 1) (Obj.magic 0);
+	changelen d (d.len - 1)
+
+let rec blit src srcidx dst dstidx len =
+	if len < 0 then invalid_arg len "blit" "len";
+	if srcidx < 0 || srcidx + len > src.len then invalid_arg srcidx "blit" "source index";
+	if dstidx < 0 || dstidx > dst.len then invalid_arg dstidx "blit" "dest index";
+	let newlen = dstidx + len in
+	if newlen > ilen dst.arr then begin
+		(* this case could be inlined so we don't blit on just-copied elements *)
+		changelen dst newlen
+	end else begin
+		if newlen > dst.len then dst.len <- newlen;
+	end;
+	(* same array ! we need to copy in reverse order *)
+	if src.arr == dst.arr && dstidx > srcidx then
+		for i = len - 1 downto 0 do
+			iset dst.arr (dstidx+i) (iget src.arr (srcidx+i));
+		done
+	else
+		for i = 0 to len - 1 do
+			iset dst.arr (dstidx+i) (iget src.arr (srcidx+i));
+		done
+
+let append src dst =
+	blit src 0 dst dst.len src.len
+
+let to_list d =
+	let rec loop idx accum =
+		if idx < 0 then accum else loop (idx - 1) (iget d.arr idx :: accum)
+	in
+	loop (d.len - 1) []
+
+let to_array d =
+	if d.len = 0 then begin
+		(* since the empty array is an atom, we don't care if float or not *)
+		[||]
+	end else begin
+		let arr = Array.make d.len (iget d.arr 0) in
+		for i = 1 to d.len - 1 do
+			Array.unsafe_set arr i (iget d.arr i)
+		done;
+		arr;
+	end
+
+let of_list lst =
+	let size = List.length lst in
+	let arr = imake 0 size in
+	let rec loop idx =  function
+		| h :: t -> iset arr idx h; loop (idx + 1) t
+		| [] -> ()
+	in
+	loop 0 lst;
+	{
+		resize = default_resizer;
+		len = size;
+		arr = arr;
+	}
+
+let of_array src =
+	let size = Array.length src in
+	let is_float = Obj.tag (Obj.repr src) = Obj.double_array_tag in
+	let arr = (if is_float then begin
+			let arr = imake 0 size in
+			for i = 0 to size - 1 do
+				iset arr i (Array.unsafe_get src i);
+			done;
+			arr
+		end else
+			(* copy the fields *)
+			idup (Obj.magic src : 'a intern))
+	in
+	{
+		resize = default_resizer;
+		len = size;
+		arr = arr;
+	}
+
+let copy src =
+	{
+		resize = src.resize;
+		len = src.len;
+		arr = idup src.arr;
+	}
+
+let sub src start len =
+	if len < 0 then invalid_arg len "sub" "len";
+	if start < 0 || start + len > src.len then invalid_arg start "sub" "start";
+	let arr = imake 0 len in
+	for i = 0 to len - 1 do
+		iset arr i (iget src.arr (i+start));
+	done;
+	{
+		resize = src.resize;
+		len = len;
+		arr = arr;
+	}
+
+let iter f d =
+	for i = 0 to d.len - 1 do
+		f (iget d.arr i)
+	done
+
+let iteri f d =
+	for i = 0 to d.len - 1 do
+		f i (iget d.arr i)
+	done
+
+let filter f d =
+	let l = d.len in
+	let a = imake 0 l in
+	let a2 = d.arr in
+	let p = ref 0 in
+	for i = 0 to l - 1 do
+		let x = iget a2 i in
+		if f x then begin
+			iset a !p x;
+			incr p;
+		end;
+	done;
+	d.len <- !p;
+	d.arr <- a
+
+let index_of f d =
+	let rec loop i =
+		if i >= d.len then
+			raise Not_found
+		else
+			if f (iget d.arr i) then
+				i
+			else
+				loop (i+1)
+	in
+	loop 0
+
+let map f src =
+	let arr = imake 0 src.len in
+	for i = 0 to src.len - 1 do
+		iset arr i (f (iget src.arr i))
+	done;
+	{
+		resize = src.resize;
+		len = src.len;
+		arr = arr;
+	}
+
+let mapi f src =
+	let arr = imake 0 src.len in
+	for i = 0 to src.len - 1 do
+		iset arr i (f i (iget src.arr i))
+	done;
+	{
+		resize = src.resize;
+		len = src.len;
+		arr = arr;
+	}
+
+let fold_left f x a =
+	let rec loop idx x =
+		if idx >= a.len then x else loop (idx + 1) (f x (iget a.arr idx))
+	in
+	loop 0 x
+
+let fold_right f a x =
+	let rec loop idx x =
+		if idx < 0 then x
+		else loop (idx - 1) (f (iget a.arr idx) x)
+	in
+	loop (a.len - 1) x
+
+let enum d =
+	let rec make start =
+		let idxref = ref 0 in
+		let next () =
+			if !idxref >= d.len then
+				raise Enum.No_more_elements
+			else
+				let retval = iget d.arr !idxref in
+				incr idxref;
+				retval
+		and count () =
+			if !idxref >= d.len then 0
+			else d.len - !idxref
+		and clone () =
+			make !idxref
+		in
+		Enum.make ~next:next ~count:count ~clone:clone
+	in
+	make 0
+
+let of_enum e =
+	if Enum.fast_count e then begin
+		let c = Enum.count e in
+		let arr = imake 0 c in
+		Enum.iteri (fun i x -> iset arr i x) e;
+		{
+			resize = default_resizer;
+			len = c;
+			arr = arr;
+		}
+	end else
+		let d = make 0 in
+		Enum.iter (add d) e;
+		d
+
+let unsafe_get a n =
+	iget a.arr n
+
+let unsafe_set a n x =
+	iset a.arr n x

libs/extlib/dynArray.mli

@@ -0,0 +1,281 @@
+(*
+ * DynArray - Resizeable Ocaml arrays
+ * Copyright (C) 2003 Brian Hurt
+ * Copyright (C) 2003 Nicolas Cannasse
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** Dynamic arrays.
+
+   A dynamic array is equivalent to a OCaml array that will resize itself
+   when elements are added or removed, except that floats are boxed and
+   that no initialization element is required.
+*)
+
+type 'a t
+
+exception Invalid_arg of int * string * string
+(** When an operation on an array fails, [Invalid_arg] is raised. The
+	integer is the value that made the operation fail, the first string
+	contains the function name that has been called and the second string
+	contains the parameter name that made the operation fail.
+*)
+
+(** {6 Array creation} *)
+
+val create : unit -> 'a t
+(** [create()] returns a new empty dynamic array. *)
+
+val make : int -> 'a t
+(** [make count] returns an array with some memory already allocated so
+	up to [count] elements can be stored into it without resizing. *)
+
+val init : int -> (int -> 'a) -> 'a t
+(** [init n f] returns an array of [n] elements filled with values
+	returned by [f 0 , f 1, ... f (n-1)]. *)
+
+(** {6 Array manipulation functions} *)
+
+val empty : 'a t -> bool
+(** Return true if the number of elements in the array is 0. *)
+
+val length : 'a t -> int
+(** Return the number of elements in the array. *)
+
+val get : 'a t -> int -> 'a
+(** [get darr idx] gets the element in [darr] at index [idx]. If [darr] has
+	[len] elements in it, then the valid indexes range from [0] to [len-1]. *)
+
+val last : 'a t -> 'a
+(** [last darr] returns the last element of [darr]. *)
+
+val set : 'a t -> int -> 'a -> unit
+(** [set darr idx v] sets the element of [darr] at index [idx] to value
+	[v].  The previous value is overwritten. *)
+
+val insert : 'a t -> int -> 'a -> unit
+(** [insert darr idx v] inserts [v] into [darr] at index [idx].  All elements
+	of [darr] with an index greater than or equal to [idx] have their
+	index incremented (are moved up one place) to make room for the new
+	element. *)
+
+val add : 'a t -> 'a -> unit
+(** [add darr v] appends [v] onto [darr].  [v] becomes the new
+	last element of [darr]. *)
+
+val append : 'a t -> 'a t -> unit
+(** [append src dst] adds all elements of [src] to the end of [dst]. *)
+
+val delete : 'a t -> int -> unit
+(** [delete darr idx] deletes the element of [darr] at [idx].  All elements
+	with an index greater than [idx] have their index decremented (are
+	moved down one place) to fill in the hole. *)
+
+val delete_last : 'a t -> unit
+(** [delete_last darr] deletes the last element of [darr]. This is equivalent
+	of doing [delete darr ((length darr) - 1)]. *)
+
+val delete_range : 'a t -> int -> int -> unit
+(** [delete_range darr p len] deletes [len] elements starting at index [p].
+	All elements with an index greater than [p+len] are moved to fill
+	in the hole. *)
+
+val clear : 'a t -> unit
+(** remove all elements from the array and resize it to 0. *)
+
+val blit : 'a t -> int -> 'a t -> int -> int -> unit
+(** [blit src srcidx dst dstidx len] copies [len] elements from [src]
+	starting with index [srcidx] to [dst] starting at [dstidx]. *)
+
+val compact : 'a t -> unit
+(** [compact darr] ensures that the space allocated by the array is minimal.*)
+
+(** {6 Array copy and conversion} *)
+
+val to_list : 'a t -> 'a list
+(** [to_list darr] returns the elements of [darr] in order as a list. *)
+
+val to_array : 'a t -> 'a array
+(** [to_array darr] returns the elements of [darr] in order as an array. *)
+
+val enum : 'a t -> 'a Enum.t
+(** [enum darr] returns the enumeration of [darr] elements. *)
+
+val of_list : 'a list -> 'a t
+(** [of_list lst] returns a dynamic array with the elements of [lst] in
+	it in order. *)
+
+val of_array : 'a array -> 'a t
+(** [of_array arr] returns an array with the elements of [arr] in it
+	in order. *)
+
+val of_enum : 'a Enum.t -> 'a t
+(** [of_enum e] returns an array that holds, in order, the elements of [e]. *)
+
+val copy : 'a t -> 'a t
+(** [copy src] returns a fresh copy of [src], such that no modification of
+	[src] affects the copy, or vice versa (all new memory is allocated for
+	the copy).   *)
+
+val sub : 'a t -> int -> int -> 'a t
+(** [sub darr start len] returns an array holding the subset of [len]
+	elements from [darr] starting with the element at index [idx]. *)
+
+(** {6 Array functional support} *)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** [iter f darr] calls the function [f] on every element of [darr].  It
+	is equivalent to [for i = 0 to length darr - 1 do f (get darr i) done;] *)
+
+val iteri : (int -> 'a -> unit) -> 'a t -> unit
+(** [iter f darr] calls the function [f] on every element of [darr].  It
+	is equivalent to [for i = 0 to length darr - 1 do f i (get darr i) done;]
+	*)
+
+val map : ('a -> 'b) -> 'a t -> 'b t
+(** [map f darr] applies the function [f] to every element of [darr]
+	and creates a dynamic array from the results - similar to [List.map] or
+	[Array.map]. *)
+
+val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t
+(** [mapi f darr] applies the function [f] to every element of [darr]
+	and creates a dynamic array from the results - similar to [List.mapi] or
+	[Array.mapi]. *)
+
+val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
+(** [fold_left f x darr] computes
+	[f ( ... ( f ( f (get darr 0) x) (get darr 1) ) ... ) (get darr n-1)],
+	similar to [Array.fold_left] or [List.fold_left]. *)
+
+val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+(** [fold_right f darr x] computes
+	[ f (get darr 0) (f (get darr 1) ( ... ( f (get darr n-1) x ) ... ) ) ]
+	similar to [Array.fold_right] or [List.fold_right]. *)
+
+val index_of : ('a -> bool) -> 'a t -> int
+(** [index_of f darr] returns the index of the first element [x] in darr such
+	as [f x] returns [true] or raise [Not_found] if not found. *)
+
+val filter : ('a -> bool) -> 'a t -> unit
+
+(** {6 Array resizers} *)
+
+type resizer_t = currslots:int -> oldlength:int -> newlength:int -> int
+(** The type of a resizer function.
+
+	Resizer functions are called whenever elements are added to
+	or removed from the dynamic array to determine what the current number of
+	storage spaces in the array should be.  The three named arguments
+	passed to a resizer are the current number of storage spaces in
+	the array, the length of the array before the elements are
+	added or removed, and the length the array will be after the
+	elements are added or removed.  If elements are being added, newlength
+	will be larger than oldlength, if elements are being removed,
+	newlength will be smaller than oldlength. If the resizer function
+	returns exactly oldlength, the size of the array is only changed when
+	adding an element while there is not enough space for it.
+
+	By default, all dynamic arrays are created with the [default_resizer].
+	When a dynamic array is created from another dynamic array (using [copy],
+	[map] , etc. ) the resizer of the copy will be the same as the original
+	dynamic array resizer. To change the resizer, use the [set_resizer]
+	function.
+*)
+
+val set_resizer : 'a t -> resizer_t -> unit
+(** Change the resizer for this array. *)
+
+val get_resizer : 'a t -> resizer_t
+(** Get the current resizer function for a given array *)
+
+val default_resizer : resizer_t
+(** The default resizer function the library is using - in this version
+	of DynArray, this is the [exponential_resizer] but should change in
+	next versions. *)
+
+val exponential_resizer : resizer_t
+(** The exponential resizer- The default resizer except when the resizer
+	is being copied from some other darray.
+
+	[exponential_resizer] works by doubling or halving the number of
+	slots until they "fit".  If the number of slots is less than the
+	new length, the number of slots is doubled until it is greater
+	than the new length (or Sys.max_array_size is reached).
+
+	If the number of slots is more than four times the new length,
+	the number of slots is halved until it is less than four times the
+	new length.
+
+	Allowing darrays to fall below 25% utilization before shrinking them
+	prevents "thrashing".  Consider the case where the caller is constantly
+	adding a few elements, and then removing a few elements, causing
+	the length to constantly cross above and below a power of two.
+	Shrinking the array when it falls below 50% would causing the
+	underlying array to be constantly allocated and deallocated.
+	A few elements would be added, causing the array to be reallocated
+	and have a usage of just above 50%.  Then a few elements would be
+	remove, and the array would fall below 50% utilization and be
+	reallocated yet again.  The bulk of the array, untouched, would be
+	copied and copied again.  By setting the threshold at 25% instead,
+	such "thrashing" only occurs with wild swings- adding and removing
+	huge numbers of elements (more than half of the elements in the array).
+
+	[exponential_resizer] is a good performing resizer for most
+	applications.  A list allocates 2 words for every element, while an
+	array (with large numbers of elements) allocates only 1 word per
+	element (ignoring unboxed floats).  On insert, [exponential_resizer]
+	keeps the amount of wasted "extra" array elements below 50%, meaning
+	that less than 2 words per element are used.  Even on removals
+	where the amount of wasted space is allowed to rise to 75%, that
+	only means that darray is using 4 words per element.  This is
+	generally not a significant overhead.
+
+	Furthermore, [exponential_resizer] minimizes the number of copies
+	needed- appending n elements into an empty darray with initial size
+	0 requires between n and 2n elements of the array be copied- O(n)
+	work, or O(1) work per element (on average).  A similar argument
+	can be made that deletes from the end of the array are O(1) as
+	well (obviously deletes from anywhere else are O(n) work- you
+	have to move the n or so elements above the deleted element down).
+
+*)
+
+val step_resizer : int -> resizer_t
+(** The stepwise resizer- another example of a resizer function, this
+	time of a parameterized resizer.
+
+	The resizer returned by [step_resizer step] returns the smallest
+	multiple of [step] larger than [newlength] if [currslots] is less
+	then [newlength]-[step] or greater than [newlength].
+
+	For example, to make an darray with a step of 10, a length
+	of len, and a null of null, you would do:
+	[make] ~resizer:([step_resizer] 10) len null
+*)
+
+val conservative_exponential_resizer : resizer_t
+(** [conservative_exponential_resizer] is an example resizer function
+	which uses the oldlength parameter.  It only shrinks the array
+	on inserts- no deletes shrink the array, only inserts.  It does
+	this by comparing the oldlength and newlength parameters.  Other
+	than that, it acts like [exponential_resizer].
+*)
+
+(** {6 Unsafe operations} **)
+
+val unsafe_get : 'a t -> int -> 'a
+val unsafe_set : 'a t -> int -> 'a -> unit

libs/extlib/enum.ml

@@ -0,0 +1,376 @@
+(* 
+ * Enum - Enumeration over abstract collection of elements.
+ * Copyright (C) 2003 Nicolas Cannasse
+ * 
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+type 'a t = {
+	mutable count : unit -> int;
+	mutable next : unit -> 'a;
+	mutable clone : unit -> 'a t;
+	mutable fast : bool;
+}
+
+(* raised by 'next' functions, should NOT go outside the API *)
+exception No_more_elements
+
+let _dummy () = assert false
+
+let make ~next ~count ~clone =
+	{
+		count = count;
+		next = next;
+		clone = clone;
+		fast = true;
+	}
+
+let rec init n f =
+	if n < 0 then invalid_arg "Enum.init";
+	let count = ref n in
+	{
+		count = (fun () -> !count);
+		next = (fun () ->
+			match !count with
+			| 0 -> raise No_more_elements
+			| _ ->
+				decr count;
+				f (n - 1 - !count));
+		clone = (fun () -> init !count f);
+		fast = true;
+	}			
+
+let rec empty () =
+	{
+		count = (fun () -> 0);
+		next = (fun () -> raise No_more_elements);
+		clone = (fun () -> empty());
+		fast = true;
+	}
+
+type 'a _mut_list = {
+	hd : 'a;
+	mutable tl : 'a _mut_list;
+}
+
+let force t =
+	let rec clone enum count =
+		let enum = ref !enum
+		and	count = ref !count in
+		{
+			count = (fun () -> !count);
+			next = (fun () ->
+				match !enum with
+				| [] -> raise No_more_elements
+				| h :: t -> decr count; enum := t; h);
+			clone = (fun () ->
+				let enum = ref !enum
+				and count = ref !count in
+				clone enum count);
+			fast = true;
+		}
+	in
+	let count = ref 0 in
+	let _empty = Obj.magic [] in
+	let rec loop dst =
+		let x = { hd = t.next(); tl = _empty } in
+		incr count;
+		dst.tl <- x;
+		loop x
+	in
+	let enum = ref _empty  in 
+	(try
+		enum := { hd = t.next(); tl = _empty };
+		incr count;
+		loop !enum;
+	with No_more_elements -> ());
+	let tc = clone (Obj.magic enum) count in
+	t.clone <- tc.clone;
+	t.next <- tc.next;
+	t.count <- tc.count;
+	t.fast <- true
+
+let from f =
+	let e = {
+		next = f;
+		count = _dummy;
+		clone = _dummy;
+		fast = false;
+	} in
+	e.count <- (fun () -> force e; e.count());
+	e.clone <- (fun () -> force e; e.clone());
+	e
+
+let from2 next clone =
+	let e = {
+		next = next;
+		count = _dummy;
+		clone = clone;
+		fast = false;
+	} in
+	e.count <- (fun () -> force e; e.count());
+	e
+
+let get t =
+	try
+		Some (t.next())
+	with
+		No_more_elements -> None
+
+let push t e =
+	let rec make t =
+		let fnext = t.next in
+		let fcount = t.count in
+		let fclone = t.clone in
+		let next_called = ref false in
+		t.next <- (fun () ->
+			next_called := true;
+			t.next <- fnext;
+			t.count <- fcount;
+			t.clone <- fclone;
+			e);
+		t.count <- (fun () ->
+			let n = fcount() in
+			if !next_called then n else n+1);
+		t.clone <- (fun () ->
+			let tc = fclone() in
+			if not !next_called then make tc;
+			tc);
+	in
+	make t
+
+let peek t =
+	match get t with
+	| None -> None
+	| Some x ->
+		push t x;
+		Some x
+
+let junk t =
+	try
+		ignore(t.next())
+	with
+		No_more_elements -> ()
+
+let is_empty t =
+	if t.fast then
+		t.count() = 0
+	else
+		peek t = None
+
+let count t =
+	t.count()
+
+let fast_count t =
+	t.fast
+
+let clone t =
+	t.clone()
+
+let iter f t =
+	let rec loop () =
+		f (t.next());
+		loop();
+	in
+	try
+		loop();
+	with
+		No_more_elements -> ()
+
+let iteri f t =
+	let rec loop idx =
+		f idx (t.next());
+		loop (idx+1);
+	in
+	try
+		loop 0;
+	with
+		No_more_elements -> ()
+
+let iter2 f t u =
+	let push_t = ref None in
+	let rec loop () =
+		push_t := None;
+		let e = t.next() in
+		push_t := Some e;
+		f e (u.next());
+		loop ()
+	in
+	try
+		loop ()
+	with
+		No_more_elements ->
+			match !push_t with
+			| None -> ()
+			| Some e ->
+				push t e
+
+let iter2i f t u =
+	let push_t = ref None in
+	let rec loop idx =
+		push_t := None;
+		let e = t.next() in
+		push_t := Some e;
+		f idx e (u.next());
+		loop (idx + 1)
+	in
+	try
+		loop 0
+	with
+		No_more_elements ->
+			match !push_t with
+			| None -> ()
+			| Some e -> push t e
+
+let fold f init t =
+	let acc = ref init in
+	let rec loop() =
+		acc := f (t.next()) !acc;
+		loop()
+	in
+	try
+		loop()
+	with
+		No_more_elements -> !acc
+
+let foldi f init t =
+	let acc = ref init in
+	let rec loop idx =
+		acc := f idx (t.next()) !acc;
+		loop (idx + 1)
+	in
+	try
+		loop 0
+	with
+		No_more_elements -> !acc
+
+let fold2 f init t u =
+	let acc = ref init in
+	let push_t = ref None in
+	let rec loop() =
+		push_t := None;
+		let e = t.next() in
+		push_t := Some e;
+		acc := f e (u.next()) !acc;
+		loop()
+	in
+	try
+		loop()
+	with
+		No_more_elements ->
+			match !push_t with
+			| None -> !acc
+			| Some e ->
+				push t e;
+				!acc
+
+let fold2i f init t u =
+	let acc = ref init in
+	let push_t = ref None in
+	let rec loop idx =
+		push_t := None;
+		let e = t.next() in
+		push_t := Some e;
+		acc := f idx e (u.next()) !acc;
+		loop (idx + 1)
+	in
+	try
+		loop 0
+	with
+		No_more_elements ->
+			match !push_t with
+			| None -> !acc
+			| Some e ->
+				push t e;
+				!acc
+
+let find f t =
+	let rec loop () =
+		let x = t.next() in
+		if f x then x else loop()
+	in
+	try
+		loop()
+	with
+		No_more_elements -> raise Not_found
+
+let rec map f t =
+	{
+		count = t.count;
+		next = (fun () -> f (t.next()));
+		clone = (fun () -> map f (t.clone()));
+		fast = t.fast;
+	}
+
+let rec mapi f t =
+	let idx = ref (-1) in
+	{
+		count = t.count;
+		next = (fun () -> incr idx; f !idx (t.next()));
+		clone = (fun () -> mapi f (t.clone()));
+		fast = t.fast;
+	}
+
+let rec filter f t =
+	let rec next() =
+		let x = t.next() in
+		if f x then x else next()
+	in
+	from2 next (fun () -> filter f (t.clone()))
+
+let rec filter_map f t =
+    let rec next () =
+        match f (t.next()) with
+        | None -> next()
+        | Some x -> x
+    in
+	from2 next (fun () -> filter_map f (t.clone()))
+
+let rec append ta tb = 
+	let t = {
+		count = (fun () -> ta.count() + tb.count());
+		next = _dummy;
+		clone = (fun () -> append (ta.clone()) (tb.clone()));
+		fast = ta.fast && tb.fast;
+	} in
+	t.next <- (fun () ->
+		try
+			ta.next()
+		with
+			No_more_elements ->
+				(* add one indirection because tb can mute *)
+				t.next <- (fun () -> tb.next());
+				t.count <- (fun () -> tb.count());
+				t.clone <- (fun () -> tb.clone());
+				t.fast <- tb.fast;
+				t.next()
+	);
+	t
+
+let rec concat t =
+	let concat_ref = ref _dummy in
+	let rec concat_next() =
+		let tn = t.next() in
+		concat_ref := (fun () ->
+			try
+				tn.next()
+			with
+				No_more_elements ->
+					concat_next());
+		!concat_ref ()
+	in
+	concat_ref := concat_next;
+	from2 (fun () -> !concat_ref ()) (fun () -> concat (t.clone()))

libs/extlib/enum.mli

@@ -0,0 +1,201 @@
+(* 
+ * Enum - enumeration over abstract collection of elements.
+ * Copyright (C) 2003 Nicolas Cannasse
+ * 
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** Enumeration over abstract collection of elements.
+
+ Enumerations are entirely functional and most of the operations do not
+ actually require the allocation of data structures. Using enumerations
+ to manipulate data is therefore efficient and simple. All data structures in
+ ExtLib such as lists, arrays, etc. have support to convert from and to
+ enumerations.
+*)
+
+
+type 'a t
+
+(** {6 Final functions}
+
+ These functions consume the enumeration until
+ it ends or an exception is raised by the first
+ argument function.
+*)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** [iter f e] calls the function [f] with each elements of [e] in turn. *)
+
+val iter2 : ('a -> 'b -> unit) -> 'a t -> 'b t -> unit
+(** [iter2 f e1 e2] calls the function [f] with the next elements of [e] and
+ [e2] repeatedly until one of the two enumerations ends. *)
+
+val fold : ('a -> 'b -> 'b) -> 'b -> 'a t -> 'b
+(** [fold f v e] returns v if e is empty,
+  otherwise [f (... (f (f v a1) a2) ...) aN] where a1..N are
+  the elements of [e]. 
+*)
+
+val fold2 : ('a -> 'b -> 'c -> 'c) -> 'c -> 'a t -> 'b t -> 'c
+(** [fold2] is similar to [fold] but will fold over two enumerations at the
+ same time until one of the two enumerations ends. *)
+
+(** Indexed functions : these functions are similar to previous ones
+ except that they call the function with one additional argument which
+ is an index starting at 0 and incremented after each call to the function. *)
+
+val iteri : (int -> 'a -> unit) -> 'a t -> unit
+
+val iter2i : ( int -> 'a -> 'b -> unit) -> 'a t -> 'b t -> unit
+
+val foldi : (int -> 'a -> 'b -> 'b) -> 'b -> 'a t -> 'b
+
+val fold2i : (int -> 'a -> 'b -> 'c -> 'c) -> 'c -> 'a t -> 'b t -> 'c
+
+(** {6 Useful functions} *)
+
+val find : ('a -> bool) -> 'a t -> 'a
+(** [find f e] returns the first element [x] of [e] such that [f x] returns
+ [true], consuming the enumeration up to and including the
+ found element, or, raises [Not_found] if no such element exists
+ in the enumeration, consuming the whole enumeration in the search.
+
+ Since [find] consumes a prefix of the enumeration, it can be used several 
+ times on the same enumeration to find the next element. *)
+
+val is_empty : 'a t -> bool
+(** [is_empty e] returns true if [e] does not contains any element. *)
+
+val peek : 'a t -> 'a option
+(** [peek e] returns [None] if [e] is empty or [Some x] where [x] is
+ the next element of [e]. The element is not removed from the enumeration. *)
+
+val get : 'a t -> 'a option
+(** [get e] returns [None] if [e] is empty or [Some x] where [x] is
+  the next element of [e], in which case the element is removed from the enumeration. *)
+
+val push : 'a t -> 'a -> unit
+(** [push e x] will add [x] at the beginning of [e]. *)
+
+val junk : 'a t -> unit
+(** [junk e] removes the first element from the enumeration, if any. *)
+
+val clone : 'a t -> 'a t
+(** [clone e] creates a new enumeration that is copy of [e]. If [e]
+ is consumed by later operations, the clone will not get affected. *)
+
+val force : 'a t -> unit
+(** [force e] forces the application of all lazy functions and the
+ enumeration of all elements, exhausting the enumeration. 
+ 
+  An efficient intermediate data structure
+  of enumerated elements is constructed and [e] will now enumerate over
+  that data structure. *)
+
+(** {6 Lazy constructors}
+
+ These functions are lazy which means that they will create a new modified
+ enumeration without actually enumerating any element until they are asked
+ to do so by the programmer (using one of the functions above).
+ 
+ When the resulting enumerations of these functions are consumed, the
+ underlying enumerations they were created from are also consumed. *)
+
+val map : ('a -> 'b) -> 'a t -> 'b t
+(** [map f e] returns an enumeration over [(f a1, f a2, ... , f aN)] where
+ a1...N are the elements of [e]. *)
+
+val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t
+(** [mapi] is similar to [map] except that [f] is passed one extra argument
+ which is the index of the element in the enumeration, starting from 0. *)
+
+val filter : ('a -> bool) -> 'a t -> 'a t
+(** [filter f e] returns an enumeration over all elements [x] of [e] such
+ as [f x] returns [true]. *)
+
+val filter_map : ('a -> 'b option) -> 'a t -> 'b t
+(** [filter_map f e] returns an enumeration over all elements [x] such as
+ [f y] returns [Some x] , where [y] is an element of [e]. *)
+
+val append : 'a t -> 'a t -> 'a t
+(** [append e1 e2] returns an enumeration that will enumerate over all
+ elements of [e1] followed by all elements of [e2]. *)
+
+val concat : 'a t t -> 'a t
+(** [concat e] returns an enumeration over all elements of all enumerations
+ of [e]. *)
+
+(** {6 Constructors} 
+
+ In this section the word {i shall} denotes a semantic
+ requirement. The correct operation
+ of the functions in this interface are conditional
+ on the client meeting these requirements.
+*)
+
+exception No_more_elements
+(** This exception {i shall} be raised by the [next] function of [make] 
+  or [from] when no more elements can be enumerated, it {i shall not}
+  be raised by any function which is an argument to any
+  other function specified in the interface.
+*)
+
+val empty : unit -> 'a t
+(** The empty enumeration : contains no element *)
+
+val make : next:(unit -> 'a) -> count:(unit -> int) -> clone:(unit -> 'a t) -> 'a t
+(** This function creates a fully defined enumeration.
+	{ul {li the [next] function {i shall} return the next element of the
+	enumeration or raise [No_more_elements] if the underlying data structure
+	does not have any more elements to enumerate.}
+	{li the [count] function {i shall} return the actual number of remaining
+	elements in the enumeration.}
+	{li the [clone] function {i shall} create a clone of the enumeration
+	such as operations on the original enumeration will not affect the
+	clone. }}
+ 
+	For some samples on how to correctly use [make], you can have a look
+		at implementation of [ExtList.enum]. 
+*)
+
+val from : (unit -> 'a) -> 'a t
+(** [from next] creates an enumeration from the [next] function.
+ [next] {i shall} return the next element of the enumeration or raise
+ [No_more_elements] when no more elements can be enumerated. Since the
+ enumeration definition is incomplete, a call to [clone] or [count] will
+ result in a call to [force] that will enumerate all elements in order to
+ return a correct value. *)
+
+val init : int -> (int -> 'a) -> 'a t
+(** [init n f] creates a new enumeration over elements
+  [f 0, f 1, ..., f (n-1)] *)
+
+(** {6 Counting} *)
+
+val count : 'a t -> int
+(** [count e] returns the number of remaining elements in [e] without
+  consuming the enumeration.
+
+Depending of the underlying data structure that is implementing the
+enumeration functions, the count operation can be costly, and even sometimes
+can cause a call to [force]. *)
+
+val fast_count : 'a t -> bool
+(** For users worried about the speed of [count] you can call the [fast_count]
+    function that will give an hint about [count] implementation. Basically, if
+    the enumeration has been created with [make] or [init] or if [force] has
+    been called on it, then [fast_count] will return true. *)

libs/extlib/extArray.ml

@@ -0,0 +1,165 @@
+(*
+ * ExtList - additional and modified functions for lists.
+ * Copyright (C) 2005 Richard W.M. Jones (rich @ annexia.org)
+ * 
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+module Array = struct
+
+include Array
+
+let rev_in_place xs =
+  let n = length xs in
+  let j = ref (n-1) in
+  for i = 0 to n/2-1 do
+    let c = xs.(i) in
+    xs.(i) <- xs.(!j);
+    xs.(!j) <- c;
+    decr j
+  done
+
+let rev xs =
+  let ys = Array.copy xs in
+  rev_in_place ys;
+  ys
+
+let for_all p xs =
+  let n = length xs in
+  let rec loop i =
+    if i = n then true
+    else if p xs.(i) then loop (succ i)
+    else false
+  in
+  loop 0
+
+let exists p xs =
+  let n = length xs in
+  let rec loop i =
+    if i = n then false
+    else if p xs.(i) then true
+    else loop (succ i)
+  in
+  loop 0
+
+let mem a xs =
+  let n = length xs in
+  let rec loop i =
+    if i = n then false
+    else if a = xs.(i) then true
+    else loop (succ i)
+  in
+  loop 0
+
+let memq a xs =
+  let n = length xs in
+  let rec loop i =
+    if i = n then false
+    else if a == xs.(i) then true
+    else loop (succ i)
+  in
+  loop 0
+
+let findi p xs =
+  let n = length xs in
+  let rec loop i =
+    if i = n then raise Not_found
+    else if p xs.(i) then i
+    else loop (succ i)
+  in
+  loop 0
+
+let find p xs = xs.(findi p xs)
+
+(* Use of BitSet suggested by Brian Hurt. *)
+let filter p xs =
+  let n = length xs in
+  (* Use a bitset to store which elements will be in the final array. *)
+  let bs = BitSet.create n in
+  for i = 0 to n-1 do
+    if p xs.(i) then BitSet.set bs i
+  done;
+  (* Allocate the final array and copy elements into it. *)
+  let n' = BitSet.count bs in
+  let j = ref 0 in
+  let xs' = init n'
+    (fun _ ->
+       (* Find the next set bit in the BitSet. *)
+       while not (BitSet.is_set bs !j) do incr j done;
+       let r = xs.(!j) in
+       incr j;
+       r) in
+  xs'
+
+let find_all = filter
+
+let partition p xs =
+  let n = length xs in
+  (* Use a bitset to store which elements will be in which final array. *)
+  let bs = BitSet.create n in
+  for i = 0 to n-1 do
+    if p xs.(i) then BitSet.set bs i
+  done;
+  (* Allocate the final arrays and copy elements into them. *)
+  let n1 = BitSet.count bs in
+  let n2 = n - n1 in
+  let j = ref 0 in
+  let xs1 = init n1
+    (fun _ ->
+       (* Find the next set bit in the BitSet. *)
+       while not (BitSet.is_set bs !j) do incr j done;
+       let r = xs.(!j) in
+       incr j;
+       r) in
+  let j = ref 0 in
+  let xs2 = init n2
+    (fun _ ->
+       (* Find the next clear bit in the BitSet. *)
+       while BitSet.is_set bs !j do incr j done;
+       let r = xs.(!j) in
+       incr j;
+       r) in
+  xs1, xs2
+
+let enum xs =
+  let rec make start xs =
+    let n = length xs in
+    Enum.make
+      ~next:(fun () ->
+	       if !start < n then (
+		 let r = xs.(!start) in
+		 incr start;
+		 r
+	       ) else
+		 raise Enum.No_more_elements)
+      ~count:(fun () ->
+		n - !start)
+      ~clone:(fun () ->
+		let xs' = Array.sub xs !start (n - !start) in
+		make (ref 0) xs')
+  in
+  make (ref 0) xs
+
+let of_enum e =
+  let n = Enum.count e in
+  (* This assumes, reasonably, that init traverses the array in order. *)
+  Array.init n
+    (fun i ->
+       match Enum.get e with
+       | Some x -> x
+       | None -> assert false)
+
+end

libs/extlib/extArray.mli

@@ -0,0 +1,129 @@
+(*
+ * ExtArray - additional and modified functions for arrays.
+ * Copyright (C) 2005 Richard W.M. Jones (rich @ annexia.org)
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** Additional and modified functions for arrays.
+
+	The OCaml standard library provides a module of array functions.
+	This ExtArray module can be used to override the Array module or
+	as a standalone module. It provides some additional functions.
+*)
+
+module Array :
+sig
+
+  (** {6 New functions} *)
+  val rev : 'a array -> 'a array
+    (** Array reversal. *)
+
+  val rev_in_place : 'a array -> unit
+    (** In-place array reversal.  The array argument is updated. *)
+
+  val for_all : ('a -> bool) -> 'a array -> bool
+    (** [for_all p [a1; ...; an]] checks if all elements of the array
+	satisfy the predicate [p].  That is, it returns
+	[ (p a1) && (p a2) && ... && (p an)].
+    *)
+
+  val exists : ('a -> bool) -> 'a array -> bool
+    (** [exists p [a1; ...; an]] checks if at least one element of
+	the array satisfies the predicate [p].  That is, it returns
+	[ (p a1) || (p a2) || ... || (p an)].
+    *)
+
+  val mem : 'a -> 'a array -> bool
+    (** [mem m a] is true if and only if [m] is equal to an element of [a]. *)
+
+  val memq : 'a -> 'a array -> bool
+    (** Same as {!Array.mem} but uses physical equality instead of
+	structural equality to compare array elements.
+    *)
+
+  val find : ('a -> bool) -> 'a array -> 'a
+    (** [find p a] returns the first element of array [a]
+	that satisfies the predicate [p].
+	Raise [Not_found] if there is no value that satisfies [p] in the
+	array [a].
+    *)
+
+  val findi : ('a -> bool) -> 'a array -> int
+    (** [findi p a] returns the index of the first element of array [a]
+	that satisfies the predicate [p].
+	Raise [Not_found] if there is no value that satisfies [p] in the
+	array [a].
+    *)
+
+  val filter : ('a -> bool) -> 'a array -> 'a array
+    (** [filter p a] returns all the elements of the array [a]
+	that satisfy the predicate [p].  The order of the elements
+	in the input array is preserved.  *)
+
+  val find_all : ('a -> bool) -> 'a array -> 'a array
+    (** [find_all] is another name for {!Array.filter}. *)
+
+  val partition : ('a -> bool) -> 'a array -> 'a array * 'a array
+    (** [partition p a] returns a pair of arrays [(a1, a2)], where
+	[a1] is the array of all the elements of [a] that
+	satisfy the predicate [p], and [a2] is the array of all the
+	elements of [a] that do not satisfy [p].
+	The order of the elements in the input array is preserved. *)
+
+  (** {6 Enumerations} *)
+
+  val enum : 'a array -> 'a Enum.t
+    (** Returns an enumeration of the elements of an array. *)
+
+  val of_enum : 'a Enum.t -> 'a array
+    (** Build an array from an enumeration. *)
+
+  (** {6 Old functions} *)
+
+  (** These functions are already part of the Ocaml standard library
+      and have not been modified. Please refer to the Ocaml Manual for
+      documentation. *)
+
+  external length : 'a array -> int = "%array_length"
+  external get : 'a array -> int -> 'a = "%array_safe_get"
+  external set : 'a array -> int -> 'a -> unit = "%array_safe_set"
+  external make : int -> 'a -> 'a array = "caml_make_vect"
+  external create : int -> 'a -> 'a array = "caml_make_vect"
+  val init : int -> (int -> 'a) -> 'a array
+  val make_matrix : int -> int -> 'a -> 'a array array
+  val create_matrix : int -> int -> 'a -> 'a array array
+  val append : 'a array -> 'a array -> 'a array
+  val concat : 'a array list -> 'a array
+  val sub : 'a array -> int -> int -> 'a array
+  val copy : 'a array -> 'a array
+  val fill : 'a array -> int -> int -> 'a -> unit
+  val blit : 'a array -> int -> 'a array -> int -> int -> unit
+  val to_list : 'a array -> 'a list
+  val of_list : 'a list -> 'a array
+  val iter : ('a -> unit) -> 'a array -> unit
+  val map : ('a -> 'b) -> 'a array -> 'b array
+  val iteri : (int -> 'a -> unit) -> 'a array -> unit
+  val mapi : (int -> 'a -> 'b) -> 'a array -> 'b array
+  val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+  val fold_right : ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a
+  val sort : ('a -> 'a -> int) -> 'a array -> unit
+  val stable_sort : ('a -> 'a -> int) -> 'a array -> unit
+  val fast_sort : ('a -> 'a -> int) -> 'a array -> unit
+  external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
+  external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
+
+end

libs/extlib/extHashtbl.ml

@@ -0,0 +1,136 @@
+(* 
+ * ExtHashtbl, extra functions over hashtables.
+ * Copyright (C) 2003 Nicolas Cannasse
+ * 
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+ 
+
+module Hashtbl =
+  struct
+
+	type ('a, 'b) h_bucketlist =
+		| Empty
+		| Cons of 'a * 'b * ('a, 'b) h_bucketlist
+
+	type ('a, 'b) h_t = {
+		mutable size: int;
+		mutable data: ('a, 'b) h_bucketlist array
+	}
+
+	include Hashtbl
+
+	external h_conv : ('a, 'b) t -> ('a, 'b) h_t = "%identity"
+	external h_make : ('a, 'b) h_t -> ('a, 'b) t = "%identity"
+
+	let create (size:int) = create size
+	
+	let exists = mem
+
+	let enum h =
+		let rec make ipos ibuck idata icount =
+			let pos = ref ipos in
+			let buck = ref ibuck in
+			let hdata = ref idata in
+			let hcount = ref icount in
+			let force() =
+				(** this is a hack in order to keep an O(1) enum constructor **)
+				if !hcount = -1 then begin
+					hcount := (h_conv h).size;
+					hdata := Array.copy (h_conv h).data;
+				end;
+			in
+			let rec next() =
+				force();
+				match !buck with
+				| Empty ->					
+					if !hcount = 0 then raise Enum.No_more_elements;
+					incr pos;
+					buck := Array.unsafe_get !hdata !pos;
+					next()
+				| Cons (k,i,next_buck) ->
+					buck := next_buck;
+					decr hcount;
+					(k,i)
+			in
+			let count() =
+				if !hcount = -1 then (h_conv h).size else !hcount
+			in
+			let clone() =
+				force();
+				make !pos !buck !hdata !hcount
+			in
+			Enum.make ~next ~count ~clone
+		in		
+		make (-1) Empty (Obj.magic()) (-1)
+
+	let keys h =
+		Enum.map (fun (k,_) -> k) (enum h)
+
+	let values h =
+		Enum.map (fun (_,v) -> v) (enum h)
+
+	let map f h =
+		let rec loop = function
+			| Empty -> Empty
+			| Cons (k,v,next) -> Cons (k,f v,loop next)
+		in
+		h_make {
+			size = (h_conv h).size;
+			data = Array.map loop (h_conv h).data; 
+		}
+
+	let remove_all h key =
+		let hc = h_conv h in
+		let rec loop = function
+			| Empty -> Empty
+			| Cons(k,v,next) ->
+				if k = key then begin
+					hc.size <- pred hc.size;
+					loop next
+				end else
+					Cons(k,v,loop next)
+		in
+		let pos = (hash key) mod (Array.length hc.data) in
+		Array.unsafe_set hc.data pos (loop (Array.unsafe_get hc.data pos))
+
+	let find_default h key defval =
+		let rec loop = function
+			| Empty -> defval
+			| Cons (k,v,next) ->
+				if k = key then v else loop next
+		in
+		let pos = (hash key) mod (Array.length (h_conv h).data) in
+		loop (Array.unsafe_get (h_conv h).data pos)
+
+	let find_option h key =
+		let rec loop = function
+			| Empty -> None
+			| Cons (k,v,next) ->
+				if k = key then Some v else loop next
+		in
+		let pos = (hash key) mod (Array.length (h_conv h).data) in
+		loop (Array.unsafe_get (h_conv h).data pos)
+
+	let of_enum e =
+		let h = create (if Enum.fast_count e then Enum.count e else 0) in
+		Enum.iter (fun (k,v) -> add h k v) e;
+		h
+	
+	let length h =
+		(h_conv h).size
+
+  end

libs/extlib/extHashtbl.mli

@@ -0,0 +1,89 @@
+(* 
+ * ExtHashtbl - extra functions over hashtables.
+ * Copyright (C) 2003 Nicolas Cannasse
+ * 
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+ 
+(** Extra functions over hashtables. *)
+
+module Hashtbl :
+  (** The wrapper module *)
+  sig
+
+	type ('a,'b) t = ('a,'b) Hashtbl.t
+	(** The type of a hashtable. *)
+
+	(** {6 New Functions} *)
+
+	val exists : ('a,'b) t -> 'a -> bool
+	(** [exists h k] returns true is at least one item with key [k] is
+		found in the hashtable. *)
+
+	val keys : ('a,'b) t -> 'a Enum.t
+	(** Return an enumeration of all the keys of a hashtable.
+	    If the key is in the Hashtable multiple times, all occurrences
+	    will be returned.  *)
+
+	val values : ('a,'b) t -> 'b Enum.t
+	(** Return an enumeration of all the values of a hashtable. *)
+
+	val enum : ('a, 'b) t -> ('a * 'b) Enum.t
+	(** Return an enumeration of (key,value) pairs of a hashtable. *)
+
+	val of_enum : ('a * 'b) Enum.t -> ('a, 'b) t
+	(** Create a hashtable from a (key,value) enumeration. *)
+
+	val find_default : ('a,'b) t -> 'a -> 'b -> 'b
+	  (** Find a binding for the key, and return a default
+	    value if not found *)
+
+	val find_option : ('a,'b) Hashtbl.t -> 'a -> 'b option
+	(** Find a binding for the key, or return [None] if no
+		value is found *)
+
+	val remove_all : ('a,'b) t -> 'a -> unit
+	(** Remove all bindings for the given key *)
+
+	val map : ('b -> 'c) -> ('a,'b) t -> ('a,'c) t
+	(** [map f x] creates a new hashtable with the same
+	    keys as [x], but with the function [f] applied to
+		all the values *)
+
+	val length : ('a,'b) t -> int
+	(** Return the number of elements inserted into the Hashtbl 
+		(including duplicates) *)
+	
+	(** {6 Older Functions} *)
+
+	(** Please refer to the Ocaml Manual for documentation of these
+		functions. (note : functor support removed to avoid code
+		duplication). *)
+
+	val create : int -> ('a, 'b) t
+	val clear : ('a, 'b) t -> unit
+	val add : ('a, 'b) t -> 'a -> 'b -> unit
+	val copy : ('a, 'b) t -> ('a, 'b) t
+	val find : ('a, 'b) t -> 'a -> 'b
+	val find_all : ('a, 'b) t -> 'a -> 'b list
+	val mem : ('a, 'b) t -> 'a -> bool
+	val remove : ('a, 'b) t -> 'a -> unit
+	val replace : ('a, 'b) t -> 'a -> 'b -> unit
+	val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit
+	val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
+	val hash : 'a -> int
+
+  end

libs/extlib/extLib.ml

@@ -0,0 +1,43 @@
+(* 
+ * ExtLib - use extensions as separate modules
+ * Copyright (C) 2003 Nicolas Cannasse
+ * 
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(* 
+	Note:
+	
+	Since ExtLib is provided for namespace convenience for
+	users who wants to keep the usage of the original
+	Ocaml Standard Library, no MLI CMI nor documentation will
+	be provided for this module.
+
+	Users can simply do an "open ExtLib" to import all Ext*
+	namespaces instead of doing "open ExtList" for example.
+
+	The trade-off is that they'll have to link all the modules
+	included below so the resulting binary is bigger.
+*)
+
+module List = ExtList.List
+module String = ExtString.String
+module Hashtbl = ExtHashtbl.Hashtbl
+module Array = ExtArray.Array
+
+exception Invalid_string = ExtString.Invalid_string
+
+include Std

libs/extlib/extList.ml

@@ -0,0 +1,508 @@
+(*
+ * ExtList - additional and modified functions for lists.
+ * Copyright (C) 2003 Brian Hurt
+ * Copyright (C) 2003 Nicolas Cannasse
+ * 
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+module List = struct
+
+exception Empty_list
+exception Invalid_index of int
+exception Different_list_size of string
+
+include List
+
+(* Thanks to Jacques Garrigue for suggesting the following structure *)
+type 'a mut_list =  {
+	hd: 'a; 
+	mutable tl: 'a list
+}
+external inj : 'a mut_list -> 'a list = "%identity"
+
+
+let dummy_node () = { hd = Obj.magic (); tl = [] }
+
+let hd = function
+	| [] -> raise Empty_list
+	| h :: t -> h
+
+let tl = function
+	| [] -> raise Empty_list
+	| h :: t -> t
+
+let nth l index =
+	if index < 0 then raise (Invalid_index index);
+	let rec loop n = function
+		| [] -> raise (Invalid_index index);
+		| h :: t -> 
+			if n = 0 then h else loop (n - 1) t
+	in
+	loop index l
+
+let append l1 l2 =
+	match l1 with
+	| [] -> l2
+	| h :: t ->
+		let rec loop dst = function
+		| [] ->
+			dst.tl <- l2
+		| h :: t ->
+			let cell = { hd = h; tl = [] } in
+			dst.tl <- inj cell;
+			loop cell t
+		in
+		let r = { hd = h; tl = [] } in
+		loop r t;
+		inj r
+
+let rec flatten l =
+	let rec inner dst = function
+		| [] -> dst
+		| h :: t ->
+			let r = { hd = h; tl = [] } in
+			dst.tl <- inj r;
+			inner r t
+	in
+	let rec outer dst = function
+		| [] -> ()
+		| h :: t -> outer (inner dst h) t
+	in
+	let r = dummy_node () in
+	outer r l;
+	r.tl
+
+let concat = flatten
+
+let map f = function
+	| [] -> []
+	| h :: t ->
+		let rec loop dst = function
+		| [] -> ()
+		| h :: t ->
+			let r = { hd = f h; tl = [] } in
+			dst.tl <- inj r;
+			loop r t
+		in
+		let r = { hd = f h; tl = [] } in
+		loop r t;
+		inj r
+
+let rec drop n = function
+	| _ :: l when n > 0 -> drop (n-1) l
+	| l -> l
+
+let take n l =
+	let rec loop n dst = function
+		| h :: t when n > 0 ->
+			let r = { hd = h; tl = [] } in
+			dst.tl <- inj r;
+			loop (n-1) r t
+		| _ ->
+			()
+	in
+	let dummy = dummy_node() in
+	loop n dummy l;
+	dummy.tl
+
+(* takewhile and dropwhile by Richard W.M. Jones. *)
+let rec takewhile f = function
+  | [] -> []
+  | x :: xs when f x -> x :: takewhile f xs
+  | _ -> []
+
+let rec dropwhile f = function
+  | [] -> []
+  | x :: xs when f x -> dropwhile f xs
+  | xs -> xs
+
+
+let rec unique ?(cmp = ( = )) l =
+	let rec loop dst = function
+		| [] -> ()
+		| h :: t ->
+			match exists (cmp h) t with
+			| true -> loop dst t
+			| false ->
+				let r = { hd =  h; tl = [] }  in
+				dst.tl <- inj r;
+				loop r t
+	in
+	let dummy = dummy_node() in
+	loop dummy l;
+	dummy.tl
+
+let filter_map f l =
+	let rec loop dst = function
+		| [] -> ()
+		| h :: t ->
+			match f h with
+			| None -> loop dst t
+			| Some x ->
+				let r = { hd = x; tl = [] }  in
+				dst.tl <- inj r;
+				loop r t
+	in
+	let dummy = dummy_node() in
+	loop dummy l;
+	dummy.tl
+	
+let fold_right_max = 1000
+
+let fold_right f l init =
+	let rec tail_loop acc = function
+		| [] -> acc
+		| h :: t -> tail_loop (f h acc) t
+	in
+	let rec loop n = function
+		| [] -> init
+		| h :: t ->
+			if n < fold_right_max then
+				f h (loop (n+1) t)
+			else
+				f h (tail_loop init (rev t))
+	in
+	loop 0 l
+
+let map2 f l1 l2 =
+	let rec loop dst src1 src2 =
+		match src1, src2 with
+			| [], [] -> ()
+			| h1 :: t1, h2 :: t2 ->
+				let r = { hd = f h1 h2; tl = [] } in
+				dst.tl <- inj r;
+				loop r t1 t2
+			| _ -> raise (Different_list_size "map2")
+	in
+	let dummy = dummy_node () in
+	loop dummy l1 l2;
+	dummy.tl
+
+let rec iter2 f l1 l2 =
+	match l1, l2 with
+	| [], [] -> ()
+	| h1 :: t1, h2 :: t2 -> f h1 h2; iter2 f t1 t2
+	| _ -> raise (Different_list_size "iter2")
+
+let rec fold_left2 f accum l1 l2 =
+	match l1, l2 with
+	| [], [] -> accum
+	| h1 :: t1, h2 :: t2 -> fold_left2 f (f accum h1 h2) t1 t2
+	| _ -> raise (Different_list_size "fold_left2")
+
+let fold_right2 f l1 l2 init =
+	let rec tail_loop acc l1 l2 =
+		match l1, l2 with
+		| [] , [] -> acc
+		| h1 :: t1 , h2 :: t2 -> tail_loop (f h1 h2 acc) t1 t2
+		| _ -> raise (Different_list_size "fold_right2")
+	in
+	let rec loop n l1 l2 =
+		match l1, l2 with
+		| [], [] -> init
+		| h1 :: t1, h2 :: t2 ->
+			if n < fold_right_max then
+				f h1 h2 (loop (n+1) t1 t2)
+			else
+				f h1 h2 (tail_loop init (rev t1) (rev t2))
+		| _ -> raise (Different_list_size "fold_right2")
+	in
+	loop 0 l1 l2
+
+let for_all2 p l1 l2 =
+	let rec loop l1 l2 =
+		match l1, l2 with
+		| [], [] -> true
+		| h1 :: t1, h2 :: t2 -> if p h1 h2 then loop t1 t2 else false
+		| _ -> raise (Different_list_size "for_all2")
+	in
+	loop l1 l2
+
+let exists2 p l1 l2 =
+	let rec loop l1 l2 =
+		match l1, l2 with
+			| [], [] -> false
+			| h1 :: t1, h2 :: t2 -> if p h1 h2 then true else loop t1 t2
+			| _ -> raise (Different_list_size "exists2")
+	in
+	loop l1 l2
+
+let remove_assoc x lst = 
+	let rec loop dst = function
+		| [] -> ()
+		| (a, _ as pair) :: t ->
+			if a = x then
+				dst.tl <- t
+			else
+				let r = { hd = pair; tl = [] } in
+				dst.tl <- inj r;
+				loop r t
+	in
+	let dummy = dummy_node () in
+	loop dummy lst;
+	dummy.tl
+
+let remove_assq x lst = 
+	let rec loop dst = function
+		| [] -> ()
+		| (a, _ as pair) :: t ->
+			if a == x then
+				dst.tl <- t
+			else
+				let r = { hd =  pair; tl = [] } in
+				dst.tl <- inj r;
+				loop r t
+	in
+	let dummy = dummy_node() in
+	loop dummy lst;
+	dummy.tl
+
+let rfind p l = find p (rev l)
+
+let find_all p l = 
+	let rec findnext dst = function
+		| [] -> ()
+		| h :: t -> 
+			if p h then
+				let r = { hd = h; tl = [] } in
+				dst.tl <- inj r;
+				findnext r t
+			else
+				findnext dst t
+	in
+	let dummy = dummy_node () in
+	findnext dummy l;
+	dummy.tl
+
+let rec findi p l =
+	let rec loop n = function
+		| [] -> raise Not_found
+		| h :: t ->
+			if p n h then (n,h) else loop (n+1) t
+	in
+	loop 0 l
+
+let filter = find_all
+
+let partition p lst = 
+	let rec loop yesdst nodst = function
+		| [] -> ()
+		| h :: t ->
+			let r = { hd = h; tl = [] } in
+			if p h then
+				begin
+					yesdst.tl <- inj r;
+					loop r nodst t
+				end
+			else
+				begin
+					nodst.tl <- inj r;
+					loop yesdst r t
+				end
+	in
+	let yesdummy = dummy_node()
+	and nodummy = dummy_node()
+	in
+	loop yesdummy nodummy lst;
+	yesdummy.tl, nodummy.tl
+
+let split lst =
+	let rec loop adst bdst = function
+		| [] -> ()
+		| (a, b) :: t -> 
+			let x = { hd = a; tl = [] } 
+			and y = { hd = b; tl = [] } in
+			adst.tl <- inj x;
+			bdst.tl <- inj y;
+			loop x y t
+	in
+	let adummy = dummy_node ()
+	and bdummy = dummy_node ()
+	in
+	loop adummy bdummy lst;
+	adummy.tl, bdummy.tl
+
+let combine l1 l2 =
+	let rec loop dst l1 l2 =
+		match l1, l2 with
+		| [], [] -> ()
+		| h1 :: t1, h2 :: t2 -> 
+			let r = { hd = h1, h2; tl = [] } in
+			dst.tl <- inj r;
+			loop r t1 t2
+		| _, _ -> raise (Different_list_size "combine")
+	in
+	let dummy = dummy_node () in
+	loop dummy l1 l2;
+	dummy.tl
+
+let sort ?(cmp=compare) = List.sort cmp
+
+let rec init size f =
+	if size = 0 then [] 
+	else if size < 0 then invalid_arg "ExtList.init"
+	else
+		let rec loop dst n =
+			if n < size then
+				let r = { hd = f n; tl = [] } in
+				dst.tl <- inj r;
+				loop r (n+1)
+		in
+		let r = { hd = f 0; tl = [] } in
+		loop r 1;
+		inj r
+
+(* make by Richard W.M. Jones. *)
+let make i x =
+  if i < 0 then invalid_arg "ExtList.List.make";
+  let rec make' x = function
+    | 0 -> []
+    | i -> x :: make' x (i-1)
+  in
+  make' x i
+
+let mapi f = function
+	| [] -> []
+	| h :: t ->
+		let rec loop dst n = function
+			| [] -> ()
+			| h :: t -> 
+				let r = { hd = f n h; tl = [] } in
+				dst.tl <- inj r;
+				loop r (n+1) t
+		in	
+		let r = { hd = f 0 h; tl = [] } in
+		loop r 1 t;
+		inj r
+
+let iteri f l = 
+	let rec loop n = function
+		| [] -> ()
+		| h :: t ->
+			f n h;
+			loop (n+1) t
+	in
+	loop 0 l
+
+let first = hd
+
+let rec last = function
+	| [] -> raise Empty_list
+	| h :: [] -> h
+	| _ :: t -> last t
+
+let split_nth index = function
+	| [] -> if index = 0 then [],[] else raise (Invalid_index index)
+	| (h :: t as l) ->
+		if index = 0 then [],l
+		else if index < 0 then raise (Invalid_index index)
+		else
+			let rec loop n dst l =
+				if n = 0 then l else
+				match l with
+				| [] -> raise (Invalid_index index)
+				| h :: t ->
+					let r = { hd =  h; tl = [] } in
+					dst.tl <- inj r;
+					loop (n-1) r t 
+			in
+			let r = { hd = h; tl = [] } in
+			inj r, loop (index-1) r t
+
+let find_exc f e l =
+	try
+		find f l
+	with
+		Not_found -> raise e
+
+let remove l x =
+	let rec loop dst = function
+		| [] -> raise Not_found
+		| h :: t ->
+			if x = h then 
+				dst.tl <- t
+			else
+				let r = { hd = h; tl = [] } in
+				dst.tl <- inj r;
+				loop r t
+	in
+	let dummy = dummy_node () in
+	loop dummy l;
+	dummy.tl
+
+let rec remove_if f lst =
+	let rec loop dst = function
+		| [] -> ()
+		| x :: l ->
+			if f x then
+				dst.tl <- l
+			else
+				let r = { hd = x; tl = [] } in
+				dst.tl <- inj r;
+				loop r l
+	in
+	let dummy = dummy_node () in
+	loop dummy lst;
+	dummy.tl
+
+let rec remove_all l x =
+	let rec loop dst = function
+		| [] -> ()
+		| h :: t ->
+			if x = h then
+				loop dst t
+			else
+				let r = { hd = h; tl = [] } in
+				dst.tl <- inj r;
+				loop r t
+	in
+	let dummy = dummy_node () in
+	loop dummy l;
+	dummy.tl
+
+let enum l =
+	let rec make lr count =
+		Enum.make
+			~next:(fun () ->
+				match !lr with
+				| [] -> raise Enum.No_more_elements
+				| h :: t ->
+					decr count;
+					lr := t;
+					h
+			)
+			~count:(fun () ->
+				if !count < 0 then count := length !lr;
+				!count
+			)
+			~clone:(fun () ->
+				make (ref !lr) (ref !count)
+			)
+	in
+	make (ref l) (ref (-1))
+
+let of_enum e =
+	let h = dummy_node() in
+	let _ = Enum.fold (fun x acc ->
+		let r = { hd = x; tl = [] }  in
+		acc.tl <- inj r;
+		r) h e in
+	h.tl
+
+end
+
+let ( @ ) = List.append

libs/extlib/extList.mli

@@ -0,0 +1,238 @@
+(*
+ * ExtList - additional and modified functions for lists.
+ * Copyright (C) 2003 Brian Hurt
+ * Copyright (C) 2003 Nicolas Cannasse
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** Additional and modified functions for lists.
+
+	The OCaml standard library provides a module for list functions.
+	This ExtList module can be used to override the List module or
+	as a standalone module. It provides new functions and modify
+	the behavior of some other ones (in particular all functions
+	are now {b tail-recursive}).
+*)
+
+module List :
+    sig
+
+	(** {6 New functions} *)
+
+	val init : int -> (int -> 'a) -> 'a list
+	(** Similar to [Array.init], [init n f] returns the list containing
+	 the results of (f 0),(f 1).... (f (n-1)).
+	 Raise [Invalid_arg "ExtList.init"] if n < 0.*)
+
+	val make : int -> 'a -> 'a list
+	  (** Similar to [String.make], [make n x] returns a
+	    * list containing [n] elements [x].
+    	    *)
+
+	val first : 'a list -> 'a
+	(** Returns the first element of the list, or raise [Empty_list] if
+	 the list is empty (similar to [hd]). *)
+
+	val last : 'a list -> 'a
+	(** Returns the last element of the list, or raise [Empty_list] if
+	 the list is empty. This function takes linear time. *)
+
+	val iteri : (int -> 'a -> 'b) -> 'a list -> unit
+	(** [iteri f l] will call [(f 0 a0);(f 1 a1) ... (f n an)] where
+	 [a0..an] are the elements of the list [l]. *)
+
+	val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
+	(** [mapi f l] will build the list containing
+	 [(f 0 a0);(f 1 a1) ... (f n an)] where [a0..an] are the elements of
+	 the list [l]. *)
+
+	val rfind : ('a -> bool) -> 'a list -> 'a
+	(** [rfind p l] returns the last element [x] of [l] such as [p x] returns
+	 [true] or raises [Not_found] if such element as not been found. *)
+
+	val find_exc : ('a -> bool) -> exn -> 'a list -> 'a
+	(** [find_exc p e l] returns the first element of [l] such as [p x]
+	 returns [true] or raises [e] if such element as not been found. *)
+
+	val findi : (int -> 'a -> bool) -> 'a list -> (int * 'a)
+	(** [findi p e l] returns the first element [ai] of [l] along with its
+	 index [i] such that [p i ai] is true, or raises [Not_found] if no
+	 such element has been found. *)
+
+	val unique : ?cmp:('a -> 'a -> bool) -> 'a list -> 'a list
+	(** [unique cmp l] returns the list [l] without any duplicate element.
+	 Default comparator ( = ) is used if no comparison function specified. *)
+
+	val filter_map : ('a -> 'b option) -> 'a list -> 'b list
+	(** [filter_map f l] call [(f a0) (f a1).... (f an)] where [a0..an] are
+	 the elements of [l]. It returns the list of elements [bi] such as
+	 [f ai = Some bi] (when [f] returns [None], the corresponding element of
+	 [l] is discarded). *)
+
+	val split_nth : int -> 'a list -> 'a list * 'a list
+	(** [split_nth n l] returns two lists [l1] and [l2], [l1] containing the
+	 first [n] elements of [l] and [l2] the others. Raise [Invalid_index] if
+	 [n] is outside of [l] size bounds. *)
+
+	val remove : 'a list -> 'a -> 'a list
+	(** [remove l x] returns the list [l] without the first element [x] found
+	 or returns  [l] if no element is equal to [x]. Elements are compared
+	 using ( = ). *)
+
+	val remove_if : ('a -> bool) -> 'a list -> 'a list
+	(** [remove_if cmp l] is similar to [remove], but with [cmp] used
+	 instead of ( = ). *)
+
+	val remove_all : 'a list -> 'a -> 'a list
+	(** [remove_all l x] is similar to [remove] but removes all elements that
+	 are equal to [x] and not only the first one. *)
+
+	val take : int -> 'a list -> 'a list
+	(** [take n l] returns up to the [n] first elements from list [l], if
+	 available. *)
+
+	val drop : int -> 'a list -> 'a list
+	(** [drop n l] returns [l] without the first [n] elements, or the empty
+	 list if [l] have less than [n] elements. *)
+
+	val takewhile : ('a -> bool) -> 'a list -> 'a list
+	  (** [takewhile f xs] returns the first elements of list [xs]
+	      which satisfy the predicate [f]. *)
+
+	val dropwhile : ('a -> bool) -> 'a list -> 'a list
+	  (** [dropwhile f xs] returns the list [xs] with the first
+	      elements satisfying the predicate [f] dropped. *)
+
+	(** {6 Enum functions} *)
+
+	(** Enumerations are important in ExtLib, they are a good way to work with
+	 abstract enumeration of elements, regardless if they are located in a list,
+	 an array, or a file. *)
+
+	val enum : 'a list -> 'a Enum.t
+	(** Returns an enumeration of the elements of a list. *)
+
+	val of_enum : 'a Enum.t -> 'a list
+	(** Build a list from an enumeration. *)
+
+	(** {6 Modified functions} *)
+
+	(** Some minor modifications have been made to the specification of some
+	 functions, especially concerning exceptions raised. *)
+
+	val hd : 'a list -> 'a
+	(** Returns the first element of the list or raise [Empty_list] if the
+	 list is empty. *)
+
+	val tl : 'a list -> 'a list
+	(** Returns the list without its first elements or raise [Empty_list] if
+	 the list is empty. *)
+
+	val nth : 'a list -> int -> 'a
+	(** [nth l n] returns the n-th element of the list [l] or raise
+	 [Invalid_index] is the index is outside of [l] bounds. *)
+
+	val sort : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list
+	(** Sort the list using optional comparator (by default [compare]). *)
+
+	(** The following functions have been improved so all of them are
+	 tail-recursive. They have also been modified so they no longer
+	 raise [Invalid_arg] but [Different_list_size] when used on two
+	 lists having a different number of elements. *)
+
+	val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+	val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit
+	val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a
+	val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
+	val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+	val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+	val combine : 'a list -> 'b list -> ('a * 'b) list
+
+
+	(** {6 Improved functions} *)
+
+	(** The following functions have the same behavior as the [List]
+		module ones but are tail-recursive. That means they will not
+		cause a [Stack_overflow] when used on very long list.
+
+		The implementation might be a little more slow in bytecode,
+		but compiling in native code will not affect performances. *)
+
+	val map : ('a -> 'b) -> 'a list -> 'b list
+	val append : 'a list -> 'a list -> 'a list
+	val flatten : 'a list list -> 'a list
+	val concat : 'a list list -> 'a list
+	val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
+	val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list
+	val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
+	val split : ('a * 'b) list -> 'a list * 'b list
+
+	(** The following functions were already tail-recursive in the [List]
+		module but were using [List.rev] calls. The new implementations
+		have better performances. *)
+
+	val filter : ('a -> bool) -> 'a list -> 'a list
+	val find_all : ('a -> bool) -> 'a list -> 'a list
+	val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
+
+	(** {6 Older functions} *)
+
+	(** These functions are already part of the Ocaml standard library
+		and have not been modified. Please refer to the Ocaml Manual for
+		documentation. *)
+
+	val length : 'a list -> int
+	val rev_append : 'a list -> 'a list -> 'a list
+	val rev : 'a list -> 'a list
+	val rev_map : ('a -> 'b) -> 'a list -> 'b list
+	val iter : ('a -> unit) -> 'a list -> unit
+	val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a list -> 'b
+	val for_all : ('a -> bool) -> 'a list -> bool
+	val exists : ('a -> bool) -> 'a list -> bool
+	val find : ('a -> bool) -> 'a list -> 'a
+
+	val mem : 'a -> 'a list -> bool
+	val memq : 'a -> 'a list -> bool
+	val assoc : 'a -> ('a * 'b) list -> 'b
+	val assq : 'a -> ('a * 'b) list -> 'b
+	val mem_assoc : 'a -> ('a * 'b) list -> bool
+	val mem_assq : 'a -> ('a * 'b) list -> bool
+
+
+	val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list
+	val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list
+	val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
+
+	(** {6 Exceptions} *)
+
+	exception Empty_list
+	(** [Empty_list] is raised when an operation applied on an empty list
+		is invalid : [hd] for example. *)
+
+	exception Invalid_index of int
+	(** [Invalid_index] is raised when an indexed access on a list is
+		out of list bounds. *)
+
+	exception Different_list_size of string
+	(** [Different_list_size] is raised when applying functions such as
+		[iter2] on two lists having different size. *)
+
+
+end
+
+val ( @ ) : 'a list -> 'a list -> 'a list
+(** the new implementation for ( @ ) operator, see [List.append]. *)

libs/extlib/extString.ml

@@ -0,0 +1,237 @@
+(*
+ * ExtString - Additional functions for string manipulations.
+ * Copyright (C) 2003 Nicolas Cannasse
+ * 
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+exception Invalid_string
+
+module String = struct
+
+include String
+
+let init len f =
+	let s = create len in
+	for i = 0 to len - 1 do
+		unsafe_set s i (f i)
+	done;
+	s
+
+let starts_with str p =
+	let len = length p in
+	if length str < len then 
+		false
+	else
+		sub str 0 len = p
+
+let ends_with s e =
+	let el = length e in
+	let sl = length s in
+	if sl < el then
+		false
+	else
+		sub s (sl-el) el = e
+
+let find str sub =
+	let sublen = length sub in
+	if sublen = 0 then
+		0
+	else
+		let found = ref 0 in
+		let len = length str in
+		try
+			for i = 0 to len - sublen do
+				let j = ref 0 in
+				while unsafe_get str (i + !j) = unsafe_get sub !j do
+					incr j;
+					if !j = sublen then begin found := i; raise Exit; end;
+				done;
+			done;
+			raise Invalid_string
+		with
+			Exit -> !found
+
+let exists str sub =
+	try
+		ignore(find str sub);
+		true
+	with
+		Invalid_string -> false
+
+let strip ?(chars=" \t\r\n") s =
+	let p = ref 0 in
+	let l = length s in
+	while !p < l && contains chars (unsafe_get s !p) do
+		incr p;
+	done;
+	let p = !p in
+	let l = ref (l - 1) in
+	while !l >= p && contains chars (unsafe_get s !l) do
+		decr l;
+	done;
+	sub s p (!l - p + 1)
+
+let split str sep =
+	let p = find str sep in
+	let len = length sep in
+	let slen = length str in
+	sub str 0 p, sub str (p + len) (slen - p - len)
+
+let rec nsplit str sep =
+	try
+		let s1 , s2 = split str sep in
+		s1 :: nsplit s2 sep
+	with
+		Invalid_string -> [str]
+
+let join = concat
+
+let slice ?(first=0) ?(last=Sys.max_string_length) s =
+	let clip _min _max x = max _min (min _max x) in
+	let i = clip 0 (length s)
+		(if (first<0) then (length s) + first else first)
+	and j = clip 0 (length s)
+		(if (last<0) then (length s) + last else last)
+	in
+	if i>=j || i=length s then
+		create 0
+        else
+          	sub s i (j-i)
+
+let lchop s =
+	if s = "" then "" else sub s 1 (length s - 1)
+
+let rchop s =
+	if s = "" then "" else sub s 0 (length s - 1)
+
+let of_int = string_of_int
+
+let of_float = string_of_float
+
+let of_char = make 1
+
+let to_int s =
+	try
+		int_of_string s
+	with
+		_ -> raise Invalid_string
+
+let to_float s =
+	try
+		float_of_string s
+	with
+		_ -> raise Invalid_string
+
+let enum s =
+	let l = length s in
+	let rec make i =
+		Enum.make 
+		~next:(fun () ->
+			if !i = l then
+				raise Enum.No_more_elements
+			else
+				let p = !i in
+				incr i;
+				unsafe_get s p
+			)
+		~count:(fun () -> l - !i)
+		~clone:(fun () -> make (ref !i))
+	in
+	make (ref 0)
+
+let of_enum e =
+	let l = Enum.count e in
+	let s = create l in
+	let i = ref 0 in
+	Enum.iter (fun c -> unsafe_set s !i c; incr i) e;
+	s
+
+let map f s =
+	let len = length s in
+	let sc = create len in
+	for i = 0 to len - 1 do
+		unsafe_set sc i (f (unsafe_get s i))
+	done;
+	sc
+
+(* fold_left and fold_right by Eric C. Cooper *)
+let fold_left f init str =
+  let n = String.length str in
+  let rec loop i result =
+    if i = n then result
+    else loop (i + 1) (f result str.[i])
+  in
+  loop 0 init
+
+let fold_right f str init =
+  let n = String.length str in
+  let rec loop i result =
+    if i = 0 then result
+    else
+      let i' = i - 1 in
+      loop i' (f str.[i'] result)
+  in
+  loop n init
+
+(* explode and implode from the OCaml Expert FAQ. *)
+let explode s =
+  let rec exp i l =
+    if i < 0 then l else exp (i - 1) (s.[i] :: l) in
+  exp (String.length s - 1) []
+
+let implode l =
+  let res = String.create (List.length l) in
+  let rec imp i = function
+  | [] -> res
+  | c :: l -> res.[i] <- c; imp (i + 1) l in
+  imp 0 l
+
+
+let replace_chars f s =
+	let len = String.length s in
+	let tlen = ref 0 in
+	let rec loop i acc =
+		if i = len then
+			acc
+		else 
+			let s = f (unsafe_get s i) in
+			tlen := !tlen + length s;
+			loop (i+1) (s :: acc)
+	in
+	let strs = loop 0 [] in
+	let sbuf = create !tlen in
+	let pos = ref !tlen in
+	let rec loop2 = function
+		| [] -> ()
+		| s :: acc ->
+			let len = length s in
+			pos := !pos - len;
+			blit s 0 sbuf !pos len;
+			loop2 acc
+	in
+	loop2 strs;
+	sbuf
+
+let replace ~str ~sub ~by =
+	try
+		let i = find str sub in
+		(true, (slice ~last:i str) ^ by ^ 
+                   (slice ~first:(i+(String.length sub)) str))
+        with
+		Invalid_string -> (false, String.copy str)
+
+end

libs/extlib/extString.mli

@@ -0,0 +1,180 @@
+(*
+ * ExtString - Additional functions for string manipulations.
+ * Copyright (C) 2003 Nicolas Cannasse
+ * 
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** Additional functions for string manipulations. *)
+
+exception Invalid_string
+
+module String :
+  sig
+
+	(** {6 New Functions} *)
+
+	val init : int -> (int -> char) -> string
+	(** [init l f] returns the string of length [l] with the chars
+		f 0 , f 1 , f 2 ... f (l-1). *)
+
+	val find : string -> string -> int
+	(** [find s x] returns the starting index of the string [x]
+	    within the string [s] or raises [Invalid_string] if [x]
+	    is not a substring of [s]. *)
+
+	val split : string -> string -> string * string
+	(** [split s sep] splits the string [s] between the first
+		occurrence of [sep].
+	    raises [Invalid_string] if the separator is not found. *)
+
+	val nsplit : string -> string -> string list
+	(** [nsplit s sep] splits the string [s] into a list of strings
+		which are separated by [sep]. *)
+
+	val join : string -> string list -> string
+	(** Same as [concat] *)
+
+        val slice : ?first:int -> ?last:int -> string -> string
+        (** [slice ?first ?last s] returns a "slice" of the string
+          which corresponds to the characters [s.[first]],
+          [s.[first+1]], ..., [s[last-1]]. Note that the character at
+          index [last] is {b not} included! If [first] is omitted it
+          defaults to the start of the string, i.e. index 0, and if
+          [last] is omitted is defaults to point just past the end of
+          [s], i.e. [length s].  Thus, [slice s] is equivalent to
+          [copy s].
+
+          Negative indexes are interpreted as counting from the end of
+          the string. For example, [slice ~last:-2 s] will return the
+          string [s], but without the last two characters.
+
+          This function {b never} raises any exceptions. If the
+          indexes are out of bounds they are automatically clipped.
+        *)
+
+	val lchop : string -> string
+	(** Returns the same string but without the first character.
+	    does nothing if the string is empty. *)
+
+	val rchop : string -> string
+	(** Returns the same string but without the last character.
+	   does nothing if the string is empty. *)
+
+	val of_int : int -> string
+	(** Returns the string representation of an int. *)
+
+	val of_float : float -> string
+	(** Returns the string representation of an float. *)
+
+	val of_char : char -> string
+	(** Returns a string containing one given character. *)
+
+	val to_int : string -> int
+	(** Returns the integer represented by the given string or
+	    raises [Invalid_string] if the string does not represent an integer.*)
+
+	val to_float : string -> float
+	(** Returns the float represented by the given string or
+	    raises Invalid_string if the string does not represent a float. *)
+
+	val ends_with : string -> string -> bool
+	(** [ends_with s x] returns true if the string [s] is ending with [x]. *)
+
+	val starts_with : string -> string -> bool
+	(** [starts_with s x] return true if [s] is starting with [x]. *)
+
+	val enum : string -> char Enum.t
+	(** Returns an enumeration of the characters of a string.*)
+
+	val of_enum : char Enum.t -> string
+	(** Creates a string from a character enumeration. *)
+	
+	val map : (char -> char) -> string -> string
+	(** [map f s] returns a string where all characters [c] in [s] have been
+		replaced by [f c]. **)
+
+	val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a
+	  (** [fold_left f a s] is
+	      [f (... (f (f a s.[0]) s.[1]) ...) s.[n-1]] *)
+	val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a
+	  (** [fold_right f s b] is
+	      [f s.[0] (f s.[1] (... (f s.[n-1] b) ...))] *)
+
+	val explode : string -> char list
+	  (** [explode s] returns the list of characters in the string [s]. *)
+	val implode : char list -> string
+	  (** [implode cs] returns a string resulting from concatenating
+	      the characters in the list [cs]. *)
+
+	val strip : ?chars:string -> string -> string
+	(** Returns the string without the chars if they are at the beginning or
+		at the end of the string. By default chars are " \t\r\n". *)
+
+	val exists : string -> string -> bool
+	(** [exists str sub] returns true if [sub] is a substring of [str] or
+		false otherwise. *)
+
+	val replace_chars : (char -> string) -> string -> string
+	(** [replace_chars f s] returns a string where all chars [c] of [s] have been
+		replaced by the string returned by [f c]. *)
+
+        val replace : str:string -> sub:string -> by:string -> bool * string
+        (** [replace ~str ~sub ~by] returns a tuple constisting of a boolean
+		and a string where the first occurrence of the string [sub]
+		within [str] has been replaced by the string [by]. The boolean
+		is true if a subtitution has taken place. *)
+
+	(** {6 Older Functions} *)
+
+	(** Please refer to the Ocaml Manual for documentation of these
+		functions. *)
+
+	val length : string -> int
+	val get : string -> int -> char
+	val set : string -> int -> char -> unit
+	val create : int -> string
+	val make : int -> char -> string
+	val copy : string -> string
+	val sub : string -> int -> int -> string
+	val fill : string -> int -> int -> char -> unit
+	val blit : string -> int -> string -> int -> int -> unit
+	val concat : string -> string list -> string
+	val iter : (char -> unit) -> string -> unit
+	val escaped : string -> string
+	val index : string -> char -> int
+	val rindex : string -> char -> int
+	val index_from : string -> int -> char -> int
+	val rindex_from : string -> int -> char -> int
+	val contains : string -> char -> bool
+	val contains_from : string -> int -> char -> bool
+	val rcontains_from : string -> int -> char -> bool
+	val uppercase : string -> string
+	val lowercase : string -> string
+	val capitalize : string -> string
+	val uncapitalize : string -> string
+
+	type t = string
+	val compare : t -> t -> int
+
+	(**/**)
+
+	external unsafe_get : string -> int -> char = "%string_unsafe_get"
+	external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set"
+	external unsafe_blit : string -> int -> string -> int -> int -> unit = "caml_blit_string" "noalloc"
+	external unsafe_fill : string -> int -> int -> char -> unit = "caml_fill_string" "noalloc"
+
+  end

libs/extlib/global.ml

@@ -0,0 +1,40 @@
+(*
+ * Global - Mutable global variable
+ * Copyright (C) 2003 Nicolas Cannasse
+ * 
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+ 
+exception Global_not_initialized of string
+
+type 'a t = ('a option ref * string)
+
+let empty name = ref None,name
+
+let name = snd
+
+let set (r,_) v = r := Some v
+
+let get (r,name) =
+	match !r with
+	| None -> raise (Global_not_initialized name)
+	| Some v -> v
+
+let undef (r,_) = r := None
+
+let isdef (r,_) = !r <> None
+
+let opt (r,_) = !r

libs/extlib/global.mli

@@ -0,0 +1,58 @@
+(*
+ * Global - Mutable global variable
+ * Copyright (C) 2003 Nicolas Cannasse
+ * 
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** Mutable global variable.
+ 
+	Often in OCaml you want to have a global variable, which is mutable 
+    and uninitialized when declared. You can use a ['a option ref] but
+	this is not very convenient. The Global module provides functions
+	to easily create and manipulate such variables.
+*)
+
+type 'a t
+(** Abstract type of a global *)
+
+exception Global_not_initialized of string
+(** Raised when a global variable is accessed without first having been
+ assigned a value. The parameter contains the name of the global. *)
+
+val empty : string -> 'a t
+(** Returns an new named empty global. The name of the global can be any
+ string. It identifies the global and makes debugging easier. *)
+
+val name : 'a t -> string
+(** Retrieve the name of a global. *)
+
+val set : 'a t -> 'a -> unit
+(** Set the global value contents. *)
+
+val get : 'a t -> 'a
+(** Get the global value contents - raise Global_not_initialized if not
+ defined. *)
+
+val undef : 'a t -> unit 
+(** Reset the global value contents to undefined. *)
+
+val isdef : 'a t -> bool 
+  (** Return [true] if the global value has been set. *)
+
+val opt : 'a t -> 'a option 
+  (** Return [None] if the global is undefined, else [Some v] where v is the
+  current global value contents. *)

libs/extlib/install.ml

@@ -0,0 +1,217 @@
+(*
+ * Install - ExtLib installation
+ * Copyright (C) 2003 Nicolas Cannasse
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+open Printf
+
+type path =
+	| PathUnix
+	| PathDos
+
+let modules = [
+	"enum";
+	"bitSet";
+	"dynArray";
+	"extArray";
+	"extHashtbl";
+	"extList";
+	"extString";
+	"global";
+	"IO";
+	"option";
+	"pMap";
+	"std";
+	"uChar";
+	"uTF8";
+	"base64";
+	"unzip";
+	"refList";
+	"optParse";
+    "dllist";
+]
+
+let m_list suffix =
+	String.concat " " (List.map (fun m -> m ^ suffix) modules)
+
+let obj_ext , lib_ext , cp_cmd , path_type = match Sys.os_type with
+	| "Unix" | "Cygwin" | "MacOS" -> ".o" , ".a" , "cp", PathUnix
+	| "Win32" -> ".obj" , ".lib" , "copy", PathDos
+	| _ -> failwith "Unknown OS"
+
+let run cmd =
+	print_endline cmd;
+	let ecode = Sys.command cmd in
+	if ecode <> 0 then failwith (sprintf "Exit Code %d - Stopped" ecode)
+
+let copy file dest =
+	if dest <> "" && dest <> "." then begin
+		print_endline ("Installing " ^ file);
+		let path = dest ^ file in
+		(try Sys.remove path with _ -> ());
+		try
+			Sys.rename file path;
+		with
+			_ -> failwith "Aborted"
+	end
+
+let complete_path p =
+	if p = "" then
+		p
+	else
+		let c = p.[String.length p - 1] in
+		if c = '/' || c = '\\' then
+			p
+		else
+			p ^ (match path_type with PathUnix -> "/" | PathDos -> "\\")
+
+let remove file =
+	try
+		Sys.remove file
+	with
+		_ -> prerr_endline ("Warning : failed to delete " ^ file)
+
+let is_findlib() =
+	let findlib = Sys.command (if Sys.os_type = "Win32" then "ocamlfind printconf 2>NUL" else "ocamlfind printconf") = 0 in
+	if findlib then	print_endline "Using Findlib";
+	findlib
+
+type install_dir = Findlib | Dir of string
+
+let install() =
+	let autodir = ref None in
+	let docflag = ref None in
+	let autodoc = ref false in
+	let autobyte = ref false in
+	let autonative = ref false in
+	let usage = "ExtLib installation program v1.3\n(c)2003,2004 Nicolas Cannasse" in
+	Arg.parse [
+		("-d", Arg.String (fun s -> autodir := Some s) , "<dir> : install in target directory");
+		("-b", Arg.Unit (fun () -> autobyte := true) , ": byte code installation");
+		("-n", Arg.Unit (fun () -> autonative := true) , ": native code installation");
+		("-doc", Arg.Unit (fun () -> docflag := Some true) , ": documentation installation");
+		("-nodoc", Arg.Unit (fun () -> docflag := Some false) , ": documentation installation");
+	] (fun s -> raise (Arg.Bad s)) usage;
+	let findlib = is_findlib () in
+	let install_dir = (
+		match !autodir with
+		| Some dir ->
+			if not !autobyte && not !autonative && not !autodoc then failwith "Nothing to do.";
+			Dir (complete_path dir)
+		| None ->
+			let byte, native =
+			  if !autobyte || !autonative then
+			    (!autobyte, !autonative)
+			  else begin
+			printf "Choose one of the following :\n1- Bytecode installation only\n2- Native installation only\n3- Both Native and Bytecode installation\n> ";
+			  (match read_line() with
+				| "1" -> true, false
+				| "2" -> false, true
+				| "3" -> true, true
+				| _ -> failwith "Invalid choice, exit.")
+			  end
+			in
+			let dest =
+			  if not findlib then begin
+			    printf "Choose installation directory :\n> ";
+			    let dest = complete_path (read_line()) in
+			    (try
+			      close_out (open_out (dest ^ "test.file"));
+			      Sys.remove (dest ^ "test.file");
+			    with
+			      _ -> failwith ("Directory " ^ dest ^ " does not exists or cannot be written."));
+			    Dir dest;
+			  end else Findlib in
+			autobyte := byte;
+			autonative := native;
+			dest
+	) in
+	let doc =
+		match !docflag with
+		Some doc -> doc
+		| None ->
+			printf "Do you want to generate ocamldoc documentation (Y/N) ?\n> ";
+			(match read_line() with
+			| "y" | "Y" -> true
+			| "n" | "N" -> false
+			| _ -> failwith "Invalid choice, exit.")
+	in
+	autodoc := doc;
+	let doc_dir =
+	  match install_dir with
+	    Findlib -> "extlib-doc"
+	  | Dir install_dir ->
+	      sprintf "%sextlib-doc" install_dir in
+	if !autodoc && not (Sys.file_exists doc_dir) then run (sprintf "mkdir %s" doc_dir);
+	run (sprintf "ocamlc -c %s" (m_list ".mli"));
+	if !autobyte then begin
+		List.iter (fun m -> run (sprintf "ocamlc -c %s.ml" m)) modules;
+		run (sprintf "ocamlc -a -o extLib.cma %s extLib.ml" (m_list ".cmo"));
+		List.iter (fun m -> remove (m ^ ".cmo")) modules;
+		remove "extLib.cmo";
+	end;
+	if !autonative then begin
+		List.iter (fun m -> run (sprintf "ocamlopt -c %s.ml" m)) modules;
+		run (sprintf "ocamlopt -a -o extLib.cmxa %s extLib.ml" (m_list ".cmx"));
+		List.iter (fun m -> remove (m ^ obj_ext)) modules;
+		remove ("extLib" ^ obj_ext);
+	end;
+	if !autodoc then begin
+		run (sprintf "ocamldoc -sort -html -d %s %s" doc_dir (m_list ".mli"));
+		run ((match path_type with
+				| PathDos -> sprintf "%s odoc_style.css %s\\style.css";
+				| PathUnix -> sprintf "%s odoc_style.css %s/style.css") cp_cmd doc_dir);
+	end;
+	match install_dir with
+	  Findlib ->
+	    let files = Buffer.create 0 in
+	    List.iter (fun m ->
+	      Buffer.add_string files (m ^ ".cmi");
+	      Buffer.add_char files ' ';
+	      Buffer.add_string files (m ^ ".mli");
+	      Buffer.add_char files ' ')
+	      modules;
+	    Buffer.add_string files "extLib.cmi ";
+	    if !autobyte then Buffer.add_string files "extLib.cma ";
+	    if !autonative then begin
+	      Buffer.add_string files "extLib.cmxa ";
+	      Buffer.add_string files ("extLib" ^ lib_ext^ " ");
+	    end;
+	    run (sprintf "%s META.txt META" cp_cmd);
+	    let files = Buffer.contents files in
+	    run (sprintf "ocamlfind install extlib %s META" files);
+	| Dir install_dir ->
+	    List.iter (fun m ->
+			copy (m ^ ".cmi") install_dir;
+			if !autonative then copy (m ^ ".cmx") install_dir
+		) ("extLib" :: modules);
+	    if !autobyte then copy "extLib.cma"  install_dir;
+	    if !autonative then begin
+	      copy "extLib.cmxa" install_dir;
+	      copy ("extLib" ^ lib_ext) install_dir;
+	    end;
+;;
+try
+	install();
+	printf "Done.";
+with
+	Failure msg ->
+		prerr_endline msg;
+		exit 1
+
+

libs/extlib/odoc_style.css

@@ -0,0 +1,24 @@
+body { padding: 0px 20px 0px 26px; background: #ffffff; color: #000000; font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 90%; }
+h1 { padding : 5px 0px 5px 0px; font-size : 16pt; font-weight : normal; background-color : #E0E0FF }
+h6 { padding : 5px 0px 5px 20px; font-size : 16pt; font-weight : normal; background-color : #E0E0FF }
+a:link, a:visited, a:active { text-decoration: none; }
+a:link { color: #000077; }
+a:visited { color: #000077; }
+a:hover { color: #cc9900; }
+.keyword { font-weight : bold ; color : Blue }
+.keywordsign { color : #606060 }
+.superscript { font-size : 4 }
+.subscript { font-size : 4 }
+.comment { color : #606060 }
+.constructor { color : #808080; }
+.type { color : #606060 }
+.string { color : Red }
+.warning { color : Red ; font-weight : bold }
+.info { margin-left : 3em; margin-right : 3em }
+.code { color : #606060 ; }
+.title1 { font-size : 16pt ; background-color : #E0E0E0 }
+.title2 { font-size : 16pt ; background-color : #E0E0E0 }
+.title3 { font-size : 16pt ; background-color : #E0E0E0 }
+.title4 { font-size : 16pt ; background-color : #E0E0E0 }
+.title5 { font-size : 16pt ; background-color : #E0E0E0 }
+.title6 { font-size : 16pt ; background-color : #E0E0E0; }

libs/extlib/optParse.ml

@@ -0,0 +1,720 @@
+(*
+ * optParse - Functions for parsing command line arguments.
+ * Copyright (C) 2004 Bardur Arantsson
+ *
+ * Heavily influenced by the optparse.py module from the Python
+ * standard library, but with lots of adaptation to the 'Ocaml Way'
+ *
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+open Printf
+open ExtString
+open ExtList
+
+
+let terminal_width =
+  try 
+    int_of_string (Sys.getenv "COLUMNS")    (* Might as well use it if it's there... *)
+  with
+    Failure _ -> 80
+  | Not_found -> 80
+
+module GetOpt =
+  struct
+
+    type action = string -> string list -> unit
+    type long_opt = string * int * action
+    type short_opt = char * int * action
+
+    exception Error of (string * string)
+
+    let split1 haystack needle =
+      try 
+        let (h, x) = String.split haystack needle in h, [x] 
+      with
+        Invalid_string -> haystack, []
+
+    let find_opt format_name options s =
+      let rec loop l =
+        match l with
+          (x, y, z) :: t -> if x = s then x, y, z else loop t
+        | [] -> raise (Error (format_name s, "no such option"))
+      in
+      loop options
+
+    let find_short_opt options = find_opt (fun c -> sprintf "-%c" c) options
+
+    let find_long_opt options = find_opt (fun s -> "--" ^ s) options
+
+    let parse other find_short_opt find_long_opt args =
+      let rec loop args =
+        let rec gather_args name n args =
+          try 
+            List.split_nth n args 
+          with
+            List.Invalid_index _ ->
+              raise (Error (name, "missing required arguments"))
+        in
+        let gather_long_opt s args =
+          let (h, t) = split1 s "=" in
+          let (_, nargs, action) = find_long_opt (String.slice ~first:2 h) in
+          let (accum, args') = gather_args h (nargs - List.length t) args in
+          action h (t @ accum); args'
+        in
+        let rec gather_short_opt_concat seen_args s k args =
+          if k < String.length s then
+            let ostr = sprintf "-%c" s.[k]
+            and (_, nargs, action) = find_short_opt s.[k] in
+            if nargs = 0 then
+              begin
+                action ostr [];
+                gather_short_opt_concat seen_args s (k + 1) args
+              end
+            else if not seen_args then
+              let (accum, args') = gather_args ostr nargs args in
+              action ostr accum; gather_short_opt_concat true s (k + 1) args'
+            else
+              raise
+                (Error
+                   (sprintf "-%c" s.[k],
+                    sprintf "option list '%s' already contains an option requiring an argument"
+                      s))
+          else args
+        in
+        let gather_short_opt s k args =
+          let ostr = sprintf "-%c" s.[k] in
+          let (_, nargs, action) = find_short_opt s.[k] in
+          if nargs = 0 then gather_short_opt_concat false s k args
+          else
+            let (accum, args') =
+              let h = String.slice ~first:(k+1) s in
+              if String.length h = 0 then gather_args ostr nargs args
+              else
+                let (t, args'') = gather_args ostr (nargs - 1) args in
+                h :: t, args''
+            in
+            action ostr accum; args'
+        in
+        match args with
+          [] -> []
+        | arg :: args' ->
+            if arg = "--" then args'
+            else if String.starts_with arg "--" then
+              loop (gather_long_opt arg args')
+            else if arg = "-" then begin other arg; loop args' end
+            else if String.starts_with arg "-" then
+              loop (gather_short_opt arg 1 args')
+            else begin other arg; loop args' end
+      in
+      let args' = loop args in List.iter other args'
+  end
+
+
+module Opt =
+  struct
+
+    exception No_value
+    exception Option_error of string * string
+    exception Option_help
+
+    type 'a t = { 
+      option_set : string -> string list -> unit;
+      option_set_value : 'a -> unit;
+      option_get : unit -> 'a option;
+      option_metavars : string list;
+      option_defhelp : string option 
+    }
+
+    let get opt =
+      match opt.option_get () with
+        Some x -> x
+      | None -> raise No_value
+
+    let set opt v =
+      opt.option_set_value v
+
+    let is_set opt = Option.is_some (opt.option_get ())
+
+    let opt opt = opt.option_get ()
+
+    let value_option metavar default coerce errfmt =
+      let data = ref default in
+      {
+        option_metavars = [metavar]; 
+        option_defhelp = None;
+        option_get = (fun _ -> !data);
+        option_set_value = (fun x -> data := Some x);
+        option_set =
+         (fun option args ->
+            let arg = List.hd args in
+              try 
+                data := Some (coerce arg)
+              with
+                  exn -> raise (Option_error (option, errfmt exn arg)))
+      }
+
+    let callback_option metavar coerce errfmt f =
+      {
+        option_metavars = [metavar]; 
+        option_defhelp = None;
+        option_get = (fun _ -> Some ());
+        option_set_value = (fun () -> ());
+        option_set =
+         (fun option args ->
+            let arg = List.hd args in
+            let datum = ref None in
+              begin 
+              try 
+                datum := Some (coerce arg)
+              with
+                  exn -> raise (Option_error (option, errfmt exn arg))
+              end;
+
+              Option.may f !datum)
+      }
+  end
+
+module StdOpt =
+  struct
+
+    open Opt
+
+    let store_const ?default const =
+      let data = ref default in
+      {
+        option_metavars = []; 
+        option_defhelp = None;
+        option_get = (fun _ -> !data);
+        option_set_value = (fun x -> data := Some x);
+        option_set = fun _ _ -> data := Some const
+      }
+
+    let store_true () = store_const ~default:false true
+
+    let store_false () = store_const ~default:true false
+
+    let int_option ?default ?(metavar = "INT") () =
+      value_option metavar default int_of_string
+        (fun _ s -> sprintf "invalid integer value '%s'" s)
+
+    let int_callback ?(metavar = "INT") =
+      callback_option metavar int_of_string
+        (fun _ s -> sprintf "invalid integer value '%s'" s)
+
+    let float_option ?default ?(metavar = "FLOAT") () =
+      value_option metavar default float_of_string
+        (fun _ s -> sprintf "invalid floating point value '%s'" s)
+
+    let float_callback ?(metavar = "FLOAT") =
+      callback_option metavar float_of_string
+        (fun _ s -> sprintf "invalid floating point value '%s'" s)
+
+    let str_option ?default ?(metavar = "STR") () =
+      value_option metavar default (fun s -> s) (fun _ _ -> "cannot happen")
+
+    let str_callback ?(metavar = "STR") =
+      callback_option metavar (fun s -> s) (fun _ _ -> "cannot happen")
+
+    let count_option ?(dest = ref 0) ?(increment = 1) () =
+      {
+        option_metavars = []; 
+        option_defhelp = None;
+        option_get = (fun _ -> Some !dest);
+        option_set_value = (fun x -> dest := x);
+        option_set = fun _ _ -> dest := !dest + increment
+      }
+
+    let incr_option ?(dest = ref 0) = 
+      count_option ~dest ~increment:1
+
+    let decr_option ?(dest = ref 0) = 
+      count_option ~dest ~increment:(-1)
+
+    let help_option () =
+      {
+        option_metavars = [];
+        option_defhelp = Some "show this help message and exit";
+        option_get = (fun _ -> raise No_value);
+        option_set_value = (fun _ -> ());
+        option_set = fun _ _ -> raise Option_help
+      }
+
+    let version_option vfunc =
+      {
+        option_metavars = [];
+        option_defhelp = Some "show program's version and exit";
+        option_get = (fun _ -> raise No_value);
+        option_set_value = (fun _ -> ());
+        option_set = fun _ _ -> print_endline (vfunc ()); exit 0
+      }
+  end
+
+
+
+
+module Formatter =
+  struct
+
+    (* Note that the whitespace regexps must NOT treat the non-breaking
+       space character as whitespace. *)
+    let whitespace = "\t\n\013\014\r "
+
+    let split_into_chunks s =
+      let buf = Buffer.create (String.length s) in
+      let flush () =
+        let s = Buffer.contents buf
+        in
+          Buffer.clear buf;
+          s
+      in
+      let rec loop state accum i =
+        if (i<String.length s) then
+          if ((state && not (String.contains whitespace s.[i])) || 
+              ((not state) && String.contains whitespace s.[i])) then
+            if Buffer.length buf > 0 then
+               loop (not state) (flush () :: accum) i 
+             else 
+               loop (not state) accum i
+          else
+            begin
+              Buffer.add_char buf s.[i];
+              loop state accum (i+1)
+            end
+        else
+          if Buffer.length buf > 0 then
+            flush () :: accum
+          else 
+            accum
+      in
+        List.rev (loop false [] 0)
+
+    let is_whitespace s =
+      let rec loop i =
+        if i<String.length s then
+          if String.contains whitespace s.[i] then
+            loop (i+1)
+          else 
+            false
+        else 
+          true
+      in
+        loop 0
+
+    let expand_tabs ?(tab_size = 8) s =
+      let len = String.length s in
+      let spaces n = String.make n ' '
+      and b = Buffer.create len in
+      let rec expand i col =
+        if i < len then
+          match s.[i] with
+            '\t' ->
+              let n = tab_size - col mod tab_size in
+              Buffer.add_string b (spaces n);
+              expand (i + 1) (col + n)
+          | '\n' -> 
+              Buffer.add_string b "\n";
+              expand (i + 1) 0
+          | c -> 
+              Buffer.add_char b c;
+              expand  (i + 1) (col + 1)
+      in
+      expand 0 0; 
+      Buffer.contents b
+
+    let wrap ?(initial_indent = 0) ?(subsequent_indent = 0) text _width =
+      let wrap_chunks_line width acc =
+        let rec wrap (chunks, cur_line, cur_len) =
+          match chunks with
+            [] -> [], cur_line, cur_len
+          | hd :: tl ->
+              let l = String.length hd in
+              if cur_len + l <= width then
+                wrap (tl, hd :: cur_line, cur_len + l)
+              else chunks, cur_line, cur_len
+        in
+        wrap acc
+      in
+      let wrap_long_last_word width (chunks, cur_line, cur_len) =
+        match chunks with
+          [] -> [], cur_line, cur_len
+        | hd :: tl ->
+            let l = String.length hd in
+            if l > width then
+              match cur_line with
+                [] -> tl, [hd], cur_len + l
+              | _ -> chunks, cur_line, cur_len
+            else chunks, cur_line, cur_len
+      in
+      let wrap_remove_last_ws (chunks, cur_line, cur_len) =
+        match cur_line with
+          [] -> chunks, cur_line, cur_len
+        | hd :: tl ->
+            if is_whitespace hd then chunks, tl, cur_len - String.length hd
+            else chunks, cur_line, cur_len
+      in
+      let rec wrap_chunks_lines chunks lines =
+        let indent =
+          match lines with
+            [] -> initial_indent
+          | _ -> subsequent_indent
+        in
+        let width = _width - indent in
+        match chunks with
+          hd :: tl ->
+            if is_whitespace hd && lines <> [] then wrap_chunks_lines tl lines
+            else (* skip *)
+              let (chunks', cur_line, _) =
+                wrap_remove_last_ws
+                  (wrap_long_last_word width
+                     (wrap_chunks_line width (chunks, [], 0)))
+              in
+              wrap_chunks_lines chunks'
+                ((String.make indent ' ' ^
+                    String.concat "" (List.rev cur_line)) ::
+                   lines)
+        | [] -> List.rev lines
+      in
+      let chunks = split_into_chunks (expand_tabs text) in
+      wrap_chunks_lines chunks []
+
+
+    let fill ?(initial_indent = 0) ?(subsequent_indent = 0) text width =
+      String.concat "\n" (wrap ~initial_indent ~subsequent_indent text width)
+
+
+
+    type t = { 
+      indent : unit -> unit;
+      dedent : unit -> unit;
+      format_usage : string -> string;
+      format_heading : string -> string;
+      format_description : string -> string;
+      format_option : char list * string list -> string list -> 
+                                             string option -> string
+    }
+
+    let format_option_strings short_first (snames, lnames) metavars =
+      let metavar = String.concat " " metavars in
+      let lopts =
+        List.map
+          (match metavar with
+             "" -> (fun z -> sprintf "--%s" z)
+           | _ -> fun z -> sprintf "--%s=%s" z metavar)
+          lnames
+      and sopts = List.map (fun x -> sprintf "-%c%s" x metavar) snames in
+      match short_first with
+        true -> String.concat ", " (sopts @ lopts)
+      | false -> String.concat ", " (lopts @ sopts)
+
+
+    let indented_formatter ?level:(extlevel = ref 0)
+      ?indent:(extindent = ref 0) ?(indent_increment = 2) 
+      ?(max_help_position = 24) ?(width = terminal_width - 1) 
+      ?(short_first = true) () =
+      let indent = ref 0
+      and level = ref 0 in
+      let help_position = ref max_help_position
+      and help_width = ref (width - max_help_position) in
+      {
+        indent =
+         (fun () ->
+            indent := !indent + indent_increment;
+            level := !level + 1;
+            extindent := !indent;
+            extlevel := !level);
+
+        dedent =
+         (fun () ->
+            indent := !indent - indent_increment;
+            level := !level - 1;
+            assert (!level >= 0);
+            extindent := !indent;
+            extlevel := !level);
+        
+        format_usage = (fun usage -> sprintf "usage: %s\n" usage);
+        
+        format_heading =
+         (fun heading -> sprintf "%*s%s:\n\n" !indent "" heading);
+        
+        format_description =
+         (fun description ->
+            let x =
+              fill ~initial_indent:(!indent) ~subsequent_indent:(!indent)
+                description (width - !indent)
+            in
+              if not (String.ends_with x "\n") then x ^ "\n\n" else x ^ "\n");
+        
+        format_option =
+         fun names metavars help ->
+           let opt_width = !help_position - !indent - 2 in
+           let opt_strings =
+             format_option_strings short_first names metavars
+           in
+           let buf = Buffer.create 256 in
+           let indent_first =
+             if String.length opt_strings > opt_width then
+               begin
+                 bprintf buf "%*s%s\n" !indent "" opt_strings; !help_position
+               end
+             else
+               begin
+                 bprintf buf "%*s%-*s  " !indent "" opt_width opt_strings; 0
+               end
+           in
+           Option.may
+             (fun option_help ->
+                let lines = wrap option_help !help_width in
+                match lines with
+                  h :: t ->
+                    bprintf buf "%*s%s\n" indent_first "" h;
+                    List.iter
+                      (fun x -> bprintf buf "%*s%s\n" !help_position "" x) t
+                | [] -> ())
+             help;
+
+           let contents =
+             Buffer.contents buf
+           in
+             if String.length contents > 0 && not (String.ends_with contents "\n") then
+               contents ^ "\n"
+             else
+               contents
+      }
+
+    let titled_formatter ?(level = ref 0) ?(indent = ref 0) 
+      ?(indent_increment = 0) ?(max_help_position = 24) 
+      ?(width = terminal_width - 1) ?(short_first = true) 
+      () =
+      let formatter =
+        indented_formatter ~level ~indent ~indent_increment ~max_help_position
+          ~width ~short_first ()
+      in
+      let format_heading h =
+        let c =
+          match !level with
+            0 -> '='
+          | 1 -> '-'
+          | _ -> failwith "titled_formatter: Too much indentation"
+        in
+        sprintf "%*s%s\n%*s%s\n\n" !indent "" (String.capitalize h) !indent ""
+          (String.make (String.length h) c)
+      in
+      let format_usage usage =
+        sprintf "%s  %s\n" (format_heading "Usage") usage
+      in
+      { formatter with 
+          format_usage = format_usage;
+          format_heading = format_heading
+      }
+  end
+
+
+
+open Opt
+open Formatter
+
+module OptParser =
+  struct
+
+    exception Option_conflict of string
+
+    type group = { 
+      og_heading : string;
+      og_description : string option;
+      og_options :
+        ((char list * string list) * string list * string option) RefList.t;
+      og_children : group RefList.t 
+    }
+
+    type t = { 
+      op_usage : string;
+      op_suppress_usage : bool;
+      op_prog : string;
+
+      op_formatter : Formatter.t;
+      
+      op_long_options : GetOpt.long_opt RefList.t;
+      op_short_options : GetOpt.short_opt RefList.t;
+      
+      op_groups : group 
+    }
+
+    let unprogify optparser s =
+      (snd (String.replace ~str:s ~sub:"%prog" ~by:optparser.op_prog))
+
+    let add optparser ?(group = optparser.op_groups) ?help ?(hide = false)
+      ?short_name ?(short_names = []) ?long_name ?(long_names = []) opt =
+      let lnames =
+        match long_name with
+            None -> long_names
+          | Some x -> x :: long_names
+      and snames =
+        match short_name with
+            None -> short_names
+          | Some x -> x :: short_names
+      in
+      if lnames = [] && snames = [] then
+        failwith "Options must have at least one name"
+      else
+        (* Checking for duplicates: *)
+        let snames' =
+          List.fold_left (fun r (x, _, _) -> x :: r) []
+            (RefList.to_list optparser.op_short_options)
+        and lnames' =
+          List.fold_left (fun r (x, _, _) -> x :: r) []
+            (RefList.to_list optparser.op_long_options)
+        in
+        let sconf =
+          List.filter (fun e -> List.exists (( = ) e) snames') snames
+        and lconf =
+          List.filter (fun e -> List.exists (( = ) e) lnames') lnames
+        in
+        if List.length sconf > 0 then
+          raise (Option_conflict (sprintf "-%c" (List.hd sconf)))
+        else if List.length lconf > 0 then
+          raise (Option_conflict (sprintf "--%s" (List.hd lconf)));
+          
+        (* Add to display list. *)
+        if not hide then
+          RefList.add group.og_options
+            ((snames, lnames), opt.option_metavars,
+             (match help with
+                  None -> opt.option_defhelp
+                | Some _ -> help));
+          
+        (* Getopt: *)
+        let nargs = List.length opt.option_metavars in
+          List.iter
+            (fun short ->
+               RefList.add optparser.op_short_options
+               (short, nargs, opt.option_set))
+            snames;
+          List.iter
+            (fun long ->
+               RefList.add optparser.op_long_options
+               (long, nargs, opt.option_set))
+            lnames
+            
+    let add_group optparser ?(parent = optparser.op_groups) ?description heading =
+      let g =
+        {
+          og_heading = heading; 
+          og_description = description;
+          og_options = RefList.empty (); 
+          og_children = RefList.empty ()
+        }
+      in
+      RefList.add parent.og_children g; g
+
+    let make ?(usage = "%prog [options]") ?description ?version
+      ?(suppress_usage = false) ?(suppress_help = false) ?prog 
+      ?(formatter = Formatter.indented_formatter ()) () =
+      let optparser =
+        {
+          op_usage = usage; 
+          op_suppress_usage = suppress_usage;
+          op_prog = Option.default (Filename.basename Sys.argv.(0)) prog;
+          op_formatter = formatter; 
+          op_short_options = RefList.empty ();
+          op_long_options = RefList.empty ();
+          op_groups = {
+            og_heading = "options"; 
+            og_options = RefList.empty ();
+            og_children = RefList.empty ();
+            og_description = description
+          }
+        }
+      in
+      Option.may                         (* Add version option? *)
+        (fun version ->
+           add optparser ~long_name:"version"
+             (StdOpt.version_option
+                (fun () -> unprogify optparser version)))
+        version;
+      if not suppress_help then              (* Add help option? *)
+        add optparser ~short_name:'h' ~long_name:"help"
+          (StdOpt.help_option ());
+
+      optparser
+
+    let format_usage optparser eol =
+      match optparser.op_suppress_usage with
+        true -> ""
+      | false ->
+          unprogify optparser
+            (optparser.op_formatter.format_usage optparser.op_usage) ^ eol
+
+    let error optparser ?(chn = stderr) ?(status = 1) message =
+      fprintf chn "%s%s: %s\n" (format_usage optparser "\n") optparser.op_prog
+        message;
+      flush chn;
+      exit status
+
+    let usage optparser ?(chn = stdout) () =
+      let rec loop g =
+        (* Heading: *)
+        output_string chn
+          (optparser.op_formatter.format_heading g.og_heading);
+
+        optparser.op_formatter.indent ();
+        (* Description: *)
+        Option.may
+          (fun x ->
+             output_string chn (optparser.op_formatter.format_description x))
+          g.og_description;
+        (* Options: *)
+        RefList.iter
+          (fun (names, metavars, help) ->
+             output_string chn
+               (optparser.op_formatter.format_option names metavars help))
+          g.og_options;
+        (* Child groups: *)
+        output_string chn "\n";
+        RefList.iter loop g.og_children;
+
+        optparser.op_formatter.dedent ()
+      in
+      output_string chn (format_usage optparser "\n");
+      loop optparser.op_groups;
+      flush chn
+
+    let parse optparser ?(first = 0) ?last argv =
+      let args = RefList.empty ()
+      and n =
+        match last with
+          None -> Array.length argv - first
+        | Some m -> m - first + 1
+      in
+      begin 
+        try
+          GetOpt.parse (RefList.push args)
+            (GetOpt.find_short_opt
+               (RefList.to_list optparser.op_short_options))
+            (GetOpt.find_long_opt (RefList.to_list optparser.op_long_options))
+            (Array.to_list (Array.sub argv first n))
+        with
+            GetOpt.Error (opt, errmsg) ->
+              error optparser (sprintf "option '%s': %s" opt errmsg)
+          | Option_error (opt, errmsg) ->
+              error optparser (sprintf "option '%s': %s" opt errmsg)
+          | Option_help -> usage optparser (); exit 0
+      end;
+      List.rev (RefList.to_list args)
+
+    let parse_argv optparser = 
+      parse optparser ~first:1 Sys.argv
+  end

libs/extlib/optParse.mli

@@ -0,0 +1,466 @@
+(*
+ * optParse - Functions for parsing command line arguments.
+ * Copyright (C) 2004 Bardur Arantsson
+ *
+ * Heavily influenced by the optparse.py module from the Python
+ * standard library, but with lots of adaptation to the 'Ocaml Way'
+ *
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** Modules for GNU [getopt(3)]-style command line parsing. *)
+
+
+(** This module contains the basic functions and types for defining
+  new option types and accessing the values of options. *)
+module Opt :
+  sig
+
+    (** {6 Exceptions} *)
+
+    exception No_value
+    (** [No_value] gets raised by {!OptParse.Opt.get} when an option
+      value is not available. *)
+
+    exception Option_error of string * string
+    (** This exception signals that an option value is invalid. The
+      first string contains the option string ('-x' or '--long-name')
+      and the second string contains an error message.
+
+      This exception is only used when implementing custom option types
+      and can never "escape" the scope of a {!OptParse.OptParser.parse}.
+      The user should therefore not attempt to catch it.  *)
+
+    exception Option_help
+    (** When an option wants to display a usage message, this exception
+      may be raised.  It can never "escape" the scope of a
+      {!OptParse.OptParser.parse} call and the user should therefore not
+      attempt to catch it. *)
+
+
+    (** {6 Types} *)
+
+    type 'a t = {
+      option_set : string -> string list -> unit;
+      option_set_value : 'a -> unit;
+      option_get : unit -> 'a option;
+      option_metavars : string list;
+      option_defhelp : string option
+    }
+    (** Option type.
+
+      [option_set] is a closure which converts and records the value of
+      an option so that it can be retrieved with a later call to the
+      [option_get] closure. It is called with the option name which was
+      given on the command line and a list of strings, each representing
+      one of the argument values given on the command line. It may raise
+      [Option_error] if the value is invalid (for whatever reason).
+
+      [option_set_value] is a closure which sets the value of an option
+      to a particular value.
+
+      [option_get] is a closure which retrieves the recorded value
+      of the option. If the option value has not been set from the
+      command line, the default value is used.  If there is no default
+      value, then [None] should be returned.
+
+      [option_metavars] is a list of "meta-variables" (arguments)
+      which this option accepts. This is mainly for display purposes,
+      but the length of this list determines how many arguments the
+      option parser accepts for this option (currently only lists of
+      length 0 or 1 are supported).
+
+      [option_defhelp] is the default help string (if any).  It is
+      used for displaying help messages whenever the user does {b
+      not} specify a help string manually when adding this
+      option. Using a non-None value here only makes sense for
+      completely generic options like {!OptParse.StdOpt.help_option}.
+
+    *)
+
+
+    (** {6 Option value retrieval} *)
+
+    val get : 'a t -> 'a
+    (** Get the value of an option.
+
+      @return the value of the option. If the option has not been
+      encountered while parsing the command line, the default value is
+      returned.
+
+      @raise No_value if no default values has been given
+      and the option value has not been set from the command line.
+
+    *)
+
+    val set : 'a t -> 'a -> unit
+    (** Set the value of an option. *)
+
+    val opt : 'a t -> 'a option
+    (** Get the value of an option as an optional value.
+
+      @return [Some x] if the option has value [x] (either by default or
+      from the command line). If the option doesn't have a value [None]
+      is returned. *)
+
+    val is_set : 'a t -> bool
+    (** Find out if the option has a value (either by default or
+      from the command line).
+
+      @return [True] iff the option has a value.
+    *)
+
+
+
+    (** {6 Option creation} *)
+
+    val value_option :
+      string -> 'a option -> (string -> 'a) -> (exn -> string -> string) ->
+        'a t
+    (** Make an option which takes a single argument.
+
+      [value_option metavar default coerce errfmt] returns an option
+      which takes a single argument from the command line and calls
+      [coerce] to coerce it to the proper type. If [coerce] raises an
+      exception, [exn], then [errfmt exn argval] is called to generate
+      an error message for display. [metavar] is the name of the
+      metavariable of the option.
+
+      [default] is the default value of the option. If [None], the the
+      option has no default value.
+
+      @return the newly created option.
+
+    *)
+
+    val callback_option :
+      string -> (string -> 'a) -> (exn -> string -> string) -> ('a -> unit) ->
+        unit t
+    (** Make a callback option which takes a single argument.
+
+      [callback_option metavar coerce errfmt f] returns an option which
+      takes a single argument from the command line and calls [coerce]
+      to coerce it to the proper type. If [coerce] raises an exception
+      [errfmt exn argval] is called to format an error message for
+      display. If [coerce] succeeds, the callback function [f] is called
+      with the coerced value. Finally, [metavar] is the name of the
+      metavariable of the option.
+
+      @return the newly created option.
+    *)
+
+
+  end
+
+
+(** This module contains various standard options. *)
+module StdOpt :
+  sig
+
+    (** {6 Flag options} *)
+
+    val store_const : ?default: 'a -> 'a -> 'a Opt.t
+    (** [store_const ?default const] returns a flag option which
+      stores the constant value [const] when the option is
+      encountered on the command line. *)
+
+    val store_true : unit -> bool Opt.t
+    (** [store_true ()] returns an option which is set to true when
+      it is encountered on the command line. The default value is
+      false. *)
+
+    val store_false : unit -> bool Opt.t
+    (** [store_false ()] returns an option which is set to false when
+      it is encountered on the command line. The default value is
+      true. *)
+
+    val count_option : ?dest: int ref -> ?increment: int -> unit -> int Opt.t
+    (** Create a counting option which increments its value each time the
+      option is encountered on the command line.
+
+      @param increment Increment to add to the option value each
+      time the option is encountered.
+
+      @param dest Reference to the option value. Useful for making
+      options like '--quiet' and '--verbose' sharing a single value.
+
+      @return the newly created option.
+    *)
+
+    val incr_option : ?dest: int ref -> unit -> int Opt.t
+    (** Exactly identical to [count_option ~dest:dest ~increment:1 ()]. *)
+
+    val decr_option : ?dest: int ref -> unit -> int Opt.t
+    (** Exactly identical to [count_option ~dest:dest ~increment:(-1) ()]. *)
+
+
+    (** {6 Value options} *)
+
+    val int_option : ?default: int -> ?metavar: string -> unit -> int Opt.t
+    (** [int_option ?default ?metavar ()] returns an option which takes
+      a single integer argument. If [~default] is given it is the
+      default value returned when the option has not been encountered
+      on the command line. *)
+
+    val float_option :
+      ?default: float -> ?metavar: string -> unit -> float Opt.t
+    (** See {!OptParse.StdOpt.int_option}. *)
+
+    val str_option :
+      ?default: string -> ?metavar: string -> unit -> string Opt.t
+    (** See {!OptParse.StdOpt.int_option}. *)
+
+
+    (** {6 Callback options} *)
+
+    val int_callback : ?metavar: string -> (int -> unit) -> unit Opt.t
+    (** [int_callback ?metavar f] returns an option which takes a single
+      integer argument and calls [f] with that argument when encountered
+      on the command line. *)
+
+    val float_callback : ?metavar: string -> (float -> unit) -> unit Opt.t
+    (** See {!OptParse.StdOpt.int_callback}. *)
+
+    val str_callback : ?metavar: string -> (string -> unit) -> unit Opt.t
+    (** See {!OptParse.StdOpt.int_callback}. *)
+
+
+    (** {6 Special options} *)
+
+    val help_option : unit -> 'a Opt.t
+    (** [help_option ()] returns the standard help option which
+      displays a usage message and exits the program when encountered
+      on the command line. *)
+
+    val version_option : (unit -> string) -> 'a Opt.t
+    (** [version_option f] returns the standard version option which
+      displays the string returned by [f ()] (and nothing else) on
+      standard output and exits. *)
+
+  end
+
+
+(** This module contains the types and functions for implementing
+  custom usage message formatters. *)
+module Formatter :
+  sig
+    type t = {
+      indent : unit -> unit; (** Increase the indentation level. *)
+      dedent : unit -> unit; (** Decrease the indentation level. *)
+      format_usage : string -> string; (** Format usage string into style of this formatter. *)
+      format_heading : string -> string; (** Format heading into style of this formatter. *)
+      format_description : string -> string; (** Format description into style of this formatter. *)
+      format_option :
+        char list * string list -> string list -> string option -> string (** Format option into style of this formatter (see explanation below). *)
+    }
+
+    (** This is the type of a formatter. The [format_option] has
+      signature [format_option (snames,lnames) metavars help], where
+      [snames] is a list of the short option names, [lnames] is a
+      list of the long option names, [metavars] is a list of the
+      metavars the option takes as arguments, and [help] is the help
+      string supplied by the user.  *)
+
+
+    (** {6 Standard formatters} *)
+
+
+    val indented_formatter :
+      ?level: int ref -> ?indent: int ref -> ?indent_increment: int ->
+        ?max_help_position: int -> ?width: int -> ?short_first: bool ->
+        unit -> t
+    (** Create an "indented" formatter with the given options.
+
+      @param width Total with of the usage messages printed.
+
+      @param max_help_position Maximum starting column for the help
+      messages relating to each option.
+
+      @param short_first List all the short option names first?
+
+      @param indent_increment Number of columns to indent by when
+      more indentation is required.
+
+      @param indent Reference to the current indentation amount. Its
+      value reflects changes in indentation level.
+
+      @param level Reference to the current indentation level. Its
+      value reflects changes in indentation level.  *)
+
+    val titled_formatter : ?level: int ref -> ?indent: int ref ->
+      ?indent_increment: int -> ?max_help_position: int ->
+      ?width: int -> ?short_first: bool -> unit -> t
+    (** Creates a titled formatter which is quite similar to the
+      indented formatter. See
+      {!OptParse.Formatter.indented_formatter} for a description of
+      the options. *)
+
+
+    (** {6 Low-level formatting} *)
+
+
+    val wrap : ?initial_indent: int -> ?subsequent_indent: int ->
+      string -> int -> string list
+    (** [wrap text width] reflows the given text paragraph into lines
+      of width at most [width] (lines may exceed this if the are
+      single words that exceed this limit).
+
+      @param initial_indent Indentation of the first line.
+
+      @param subsequent_indent Indentation of the following lines.
+
+      @return a list of lines making up the reformatted paragraph. *)
+
+    val fill : ?initial_indent: int -> ?subsequent_indent: int ->
+      string -> int -> string
+    (** See {!OptParse.Formatter.wrap}.
+
+      @return a string containing the reformatted paragraph. *)
+
+  end
+
+
+
+(** This module contains the option parser itself.
+
+  It provides functions to create, populate and use option parsers to
+  parse command line arguments. *)
+module OptParser :
+  sig
+
+    (** {6 Exceptions} *)
+
+
+    exception Option_conflict of string
+    (** [Option_conflic name] is raised by {!OptParse.OptParser.add}
+      when two different options are added with identical
+      names. Usually this doesn't need to be caught since this error
+      is usually easily fixed permanently by removing/renaming the
+      conflicting option names. *)
+
+
+    (** {6 Types} *)
+
+
+    type t
+    (** The type of an option parser. *)
+
+    type group
+    (** The type of an option group. *)
+
+
+    (** {6 Option parser creation} *)
+
+    val make : ?usage: string -> ?description: string -> ?version: string ->
+      ?suppress_usage: bool -> ?suppress_help: bool -> ?prog: string ->
+      ?formatter: Formatter.t -> unit -> t
+    (** Creates a new option parser with the given options.
+
+      @param usage Usage message. The default is a reasonable usage
+      message for most programs. Any occurrence of the substring
+      ["%prog"] in [usage] is replaced with the name of the program
+      (see [prog]).
+
+      @param prog Program name. The default is the base name of the
+      executable.
+
+      @param suppress_usage Suppress the usage message if set.
+
+      @param suppress_help Suppress the 'help' option which is
+      otherwise added by default.
+
+      @param version Version string. If set, a '--version' option is
+      automatically added. When encountered on the command line it
+      causes [version] to be printed to the standard output and the
+      program to exit.
+
+      @param description: description of the main purpose of the
+      program.
+
+      @return the new option parser.
+
+    *)
+
+
+    val add : t -> ?group: group -> ?help: string -> ?hide: bool ->
+        ?short_name: char -> ?short_names: char list -> ?long_name: string ->
+        ?long_names: string list -> 'a Opt.t -> unit
+    (** Add an option to the option parser.
+
+      @raise Option_conflict if the short name(s) or long name(s)
+      have alread been used for some other option.
+
+      @param help Short help message describing the option (for the usage message).
+
+      @param hide If true, hide the option from the usage
+      message. This can be used to implement "secret" options which
+      are not shown, but work just the same as regular options in all
+      other respects.
+
+      @param short_name is the name for the short form of the option
+      (e.g. ['x'] means that the option is invoked with [-x] on the
+      command line).
+
+      @param short_names is a list of names for the short form of the
+      option (see [short_name]).
+
+      @param long_name is the name for the long form of the option
+      (e.g. ["xyzzy"] means that the option is invoked with [--xyzzy]
+      on the command line).
+
+      @param long_names is a list of names for the long form of the
+      option (see [long_name]).
+    *)
+
+
+    val add_group : t -> ?parent: group -> ?description: string ->
+      string -> group
+    (** Add a group to the option parser.
+
+      @param parent is the parent group (if any).
+
+      @param description is a description of the group.
+
+      @return the new group.
+
+    *)
+
+    (** {6 Output and error handling} *)
+
+    val error : t -> ?chn: out_channel -> ?status: int -> string -> unit
+    (** Display an error message and exit the program. The error
+      message is printed to the channel [chn] (default is
+      [Pervasives.stderr]) and the program exits with exit status
+      [status] (default is 1). *)
+
+    val usage : t -> ?chn: out_channel -> unit -> unit
+    (** Display the usage message to the channel [chn] (default is
+      [Pervasives.stdout]) and return. *)
+
+
+    (** {6 Option parsing} *)
+
+    val parse : t -> ?first: int -> ?last: int -> string array -> string list
+    (** Parse arguments as if the arguments [args.(first)],
+      [args.(first+1)], ..., [args.(last)] had been given on the
+      command line. By default [first] is 0 and [last] is the index
+      of the last element of the array. *)
+
+    val parse_argv : t -> string list
+    (** Parse all the arguments in [Sys.argv]. *)
+
+  end

libs/extlib/option.ml

@@ -0,0 +1,49 @@
+(*
+ * Option - functions for the option type
+ * Copyright (C) 2003 Nicolas Cannasse
+ * 
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+ 
+exception No_value
+
+let may f = function
+	| None -> ()
+	| Some v -> f v
+
+let map f = function
+	| None -> None
+	| Some v -> Some (f v)
+
+let default v = function
+	| None -> v
+	| Some v -> v
+
+let is_some = function
+	| None -> false
+	| _ -> true
+
+let is_none = function
+	| None -> true
+	| _ -> false
+
+let get = function
+	| None -> raise No_value
+	| Some v -> v
+
+let map_default f v = function
+	| None -> v
+	| Some v2 -> f v2

libs/extlib/option.mli

@@ -0,0 +1,53 @@
+(*
+ * Options - functions for the option type
+ * Copyright (C) 2003 Nicolas Cannasse
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** Functions for the option type.
+
+    Options are an Ocaml standard type that can be either [None] (undefined)
+	or [Some x] where x can be any value. Options are widely used in Ocaml
+	to represent undefined values (a little like NULL in C, but in a type
+	and memory safe way). This module adds some functions for working with
+	options.
+*)
+
+val may : ('a -> unit) -> 'a option -> unit
+(** [may f (Some x)] calls [f x] and [may f None] does nothing. *)
+
+val map : ('a -> 'b) -> 'a option -> 'b option
+(** [map f (Some x)] returns [Some (f x)] and [map None] returns [None]. *)
+
+val default : 'a -> 'a option -> 'a
+(** [default x (Some v)] returns [v] and [default x None] returns [x]. *)
+
+val map_default : ('a -> 'b) -> 'b -> 'a option -> 'b
+(** [map_default f x (Some v)] returns [f v] and [map_default f x None]
+	returns [x]. *)
+
+val is_none : 'a option -> bool
+(** [is_none None] returns [true] otherwise it returns [false]. *)
+
+val is_some : 'a option -> bool
+(** [is_some (Some x)] returns [true] otherwise it returns [false]. *)
+
+val get : 'a option -> 'a
+(** [get (Some x)] returns [x] and [get None] raises [No_value]. *)
+
+exception No_value
+(** Raised when calling [get None]. *)

libs/extlib/pMap.ml

@@ -0,0 +1,197 @@
+(*
+ * PMap - Polymorphic maps
+ * Copyright (C) 1996-2003 Xavier Leroy, Nicolas Cannasse, Markus Mottl
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+type ('k, 'v) map =
+  | Empty
+  | Node of ('k, 'v) map * 'k * 'v * ('k, 'v) map * int
+
+type ('k, 'v) t =
+  {
+    cmp : 'k -> 'k -> int;
+    map : ('k, 'v) map;
+  }
+
+let height = function
+  | Node (_, _, _, _, h) -> h
+  | Empty -> 0
+
+let make l k v r = Node (l, k, v, r, max (height l) (height r) + 1)
+
+let bal l k v r =
+  let hl = height l in
+  let hr = height r in
+  if hl > hr + 2 then
+    match l with
+    | Node (ll, lk, lv, lr, _) ->
+        if height ll >= height lr then make ll lk lv (make lr k v r)
+        else
+          (match lr with
+          | Node (lrl, lrk, lrv, lrr, _) ->
+              make (make ll lk lv lrl) lrk lrv (make lrr k v r)
+          | Empty -> assert false)
+    | Empty -> assert false
+  else if hr > hl + 2 then
+    match r with
+    | Node (rl, rk, rv, rr, _) ->
+        if height rr >= height rl then make (make l k v rl) rk rv rr
+        else
+          (match rl with
+          | Node (rll, rlk, rlv, rlr, _) ->
+              make (make l k v rll) rlk rlv (make rlr rk rv rr)
+          | Empty -> assert false)
+    | Empty -> assert false
+  else Node (l, k, v, r, max hl hr + 1)
+
+let rec min_binding = function
+  | Node (Empty, k, v, _, _) -> k, v
+  | Node (l, _, _, _, _) -> min_binding l
+  | Empty -> raise Not_found
+
+let rec remove_min_binding = function
+  | Node (Empty, _, _, r, _) -> r
+  | Node (l, k, v, r, _) -> bal (remove_min_binding l) k v r
+  | Empty -> invalid_arg "PMap.remove_min_binding"
+
+let merge t1 t2 =
+  match t1, t2 with
+  | Empty, _ -> t2
+  | _, Empty -> t1
+  | _ ->
+      let k, v = min_binding t2 in
+      bal t1 k v (remove_min_binding t2)
+
+let create cmp = { cmp = cmp; map = Empty }
+let empty = { cmp = compare; map = Empty }
+
+let is_empty x = 
+	x.map = Empty
+
+let add x d { cmp = cmp; map = map } =
+  let rec loop = function
+    | Node (l, k, v, r, h) ->
+        let c = cmp x k in
+        if c = 0 then Node (l, x, d, r, h)
+        else if c < 0 then
+          let nl = loop l in
+          bal nl k v r
+        else
+          let nr = loop r in
+          bal l k v nr
+    | Empty -> Node (Empty, x, d, Empty, 1) in
+  { cmp = cmp; map = loop map }
+
+let find x { cmp = cmp; map = map } =
+  let rec loop = function
+    | Node (l, k, v, r, _) ->
+        let c = cmp x k in
+        if c < 0 then loop l
+        else if c > 0 then loop r
+        else v
+    | Empty -> raise Not_found in
+  loop map
+
+let remove x { cmp = cmp; map = map } =
+  let rec loop = function
+    | Node (l, k, v, r, _) ->
+        let c = cmp x k in
+        if c = 0 then merge l r else
+        if c < 0 then bal (loop l) k v r else bal l k v (loop r)
+    | Empty -> Empty in
+  { cmp = cmp; map = loop map }
+
+let mem x { cmp = cmp; map = map } =
+  let rec loop = function
+    | Node (l, k, v, r, _) ->
+        let c = cmp x k in
+        c = 0 || loop (if c < 0 then l else r)
+    | Empty -> false in
+  loop map
+
+let exists = mem
+
+let iter f { map = map } =
+  let rec loop = function
+    | Empty -> ()
+    | Node (l, k, v, r, _) -> loop l; f k v; loop r in
+  loop map
+
+let map f { cmp = cmp; map = map } =
+  let rec loop = function
+    | Empty -> Empty
+    | Node (l, k, v, r, h) -> 
+	  let l = loop l in
+	  let r = loop r in
+	  Node (l, k, f v, r, h) in
+  { cmp = cmp; map = loop map }
+
+let mapi f { cmp = cmp; map = map } =
+  let rec loop = function
+    | Empty -> Empty
+    | Node (l, k, v, r, h) ->
+	  let l = loop l in
+	  let r = loop r in
+	  Node (l, k, f k v, r, h) in
+  { cmp = cmp; map = loop map }
+
+let fold f { cmp = cmp; map = map } acc =
+  let rec loop acc = function
+    | Empty -> acc
+    | Node (l, k, v, r, _) ->
+	  loop (f v (loop acc l)) r in
+  loop acc map
+
+let foldi f { cmp = cmp; map = map } acc =
+  let rec loop acc = function
+    | Empty -> acc
+	| Node (l, k, v, r, _) ->
+       loop (f k v (loop acc l)) r in
+  loop acc map
+
+let rec enum m =
+  let rec make l =
+    let l = ref l in
+    let rec next() =
+      match !l with
+      | [] -> raise Enum.No_more_elements
+      | Empty :: tl -> l := tl; next()
+      | Node (m1, key, data, m2, h) :: tl ->
+        l := m1 :: m2 :: tl;
+        (key, data)
+    in
+    let count() =
+      let n = ref 0 in
+      let r = !l in
+      try
+        while true do
+          ignore (next());
+          incr n
+        done;
+        assert false
+      with
+		Enum.No_more_elements -> l := r; !n
+    in
+    let clone() = make !l in
+	Enum.make ~next ~count ~clone
+  in
+  make [m.map]
+
+
+let uncurry_add (k, v) m = add k v m
+let of_enum ?(cmp = compare) e = Enum.fold uncurry_add (create cmp) e

libs/extlib/pMap.mli

@@ -0,0 +1,92 @@
+(*
+ * PMap - Polymorphic maps
+ * Copyright (C) 1996-2003 Xavier Leroy, Nicolas Cannasse, Markus Mottl
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** Polymorphic Map.
+
+	This is a polymorphic map, similar to standard library [Map] module
+	but in a defunctorized style.
+*)
+
+type ('a, 'b) t
+
+val empty : ('a, 'b) t
+(** The empty map, using [compare] as key comparison function. *)
+
+val is_empty : ('a, 'b) t -> bool
+(** returns true if the map is empty. *)
+
+val create : ('a -> 'a -> int) -> ('a, 'b) t
+(** creates a new empty map, using the provided function for key comparison.*)
+
+val add : 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t
+(** [add x y m] returns a map containing the same bindings as
+    [m], plus a binding of [x] to [y]. If [x] was already bound
+    in [m], its previous binding disappears. *)
+
+val find : 'a -> ('a, 'b) t -> 'b
+(** [find x m] returns the current binding of [x] in [m],
+    or raises [Not_found] if no such binding exists. *)
+
+val remove : 'a -> ('a, 'b) t -> ('a, 'b) t
+(** [remove x m] returns a map containing the same bindings as
+    [m], except for [x] which is unbound in the returned map. *)
+
+val mem : 'a -> ('a, 'b) t -> bool
+(** [mem x m] returns [true] if [m] contains a binding for [x],
+    and [false] otherwise. *)
+
+val exists : 'a -> ('a, 'b) t -> bool
+(** same as [mem]. *)
+
+val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit
+(** [iter f m] applies [f] to all bindings in map [m].
+    [f] receives the key as first argument, and the associated value
+    as second argument. The order in which the bindings are passed to
+    [f] is unspecified. Only current bindings are presented to [f]:
+    bindings hidden by more recent bindings are not passed to [f]. *)
+
+val map : ('b -> 'c) -> ('a, 'b) t -> ('a, 'c) t
+(** [map f m] returns a map with same domain as [m], where the
+    associated value [a] of all bindings of [m] has been
+    replaced by the result of the application of [f] to [a].
+    The order in which the associated values are passed to [f]
+    is unspecified. *)
+
+val mapi : ('a -> 'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t
+(** Same as [map], but the function receives as arguments both the
+    key and the associated value for each binding of the map. *)
+
+val fold : ('b -> 'c -> 'c) -> ('a , 'b) t -> 'c -> 'c
+(** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)],
+    where [k1 ... kN] are the keys of all bindings in [m],
+    and [d1 ... dN] are the associated data.
+    The order in which the bindings are presented to [f] is
+    unspecified. *)
+
+val foldi : ('a -> 'b -> 'c -> 'c) -> ('a , 'b) t -> 'c -> 'c
+(** Same as [fold], but the function receives as arguments both the
+    key and the associated value for each binding of the map. *)
+
+val enum : ('a, 'b) t -> ('a * 'b) Enum.t
+(** creates an enumeration for this map. *)
+
+val of_enum : ?cmp:('a -> 'a -> int) -> ('a * 'b) Enum.t -> ('a, 'b) t
+(** creates a map from an enumeration, using the specified function
+  for key comparison or [compare] by default. *)

libs/extlib/refList.ml

@@ -0,0 +1,139 @@
+(*
+ * RefList - List reference
+ * Copyright (C) 2003 Nicolas Cannasse
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+open ExtList
+
+exception Empty_list
+exception Invalid_index of int
+
+type 'a t = 'a list ref
+
+let empty () = ref []
+
+let is_empty x =
+	match !x with
+	| [] -> true
+	| _ -> false
+
+let of_list l = ref l
+let to_list rl = !rl
+let copy ~dst ~src = dst := !src
+let copy_list ~dst ~src = dst := src
+
+let add rl item = rl := List.append !rl [item]
+let push rl item = rl := item::!rl
+
+let clear rl = rl := []
+
+let length rl = List.length !rl
+let hd rl = try List.hd !rl with _ -> raise Empty_list
+let tl rl = try ref (List.tl !rl) with _ -> raise Empty_list
+let iter f rl = List.iter f !rl
+let for_all f rl = List.for_all f !rl
+let map f rl = ref (List.map f !rl)
+let transform f rl = rl := List.map f !rl
+let map_list f rl = List.map f !rl
+let find f rl = List.find f !rl
+let rev rl = rl := List.rev !rl
+let find_exc f exn rl = try List.find f !rl with _ -> raise exn
+let exists f rl = List.exists f !rl
+let sort ?(cmp=compare) rl = rl := List.sort ~cmp !rl
+
+let rfind f rl = List.rfind f !rl
+
+let first = hd
+
+let last rl = 
+	let rec loop = function
+		| x :: [] -> x
+		| x :: l -> loop l
+		| [] -> assert false
+	in
+	match !rl with
+	| [] -> raise Empty_list
+	| l -> loop l
+
+let remove rl item = rl := List.remove !rl item
+let remove_if pred rl = rl := List.remove_if pred !rl
+let remove_all rl item = rl := List.remove_all !rl item
+let filter pred rl = rl := List.filter pred !rl
+
+let add_sort ?(cmp=compare) rl item =
+	let rec add_aux = function
+		| x::lnext as l ->
+			let r = cmp x item in
+			if r < 0 then item::l else x::(add_aux lnext)
+		| [] -> [item]
+	in
+	rl := add_aux !rl
+
+let pop rl =
+	match !rl with
+	| [] -> raise Empty_list
+	| e::l -> rl := l; e
+
+let npop rl n =		
+	let rec pop_aux l n =
+		if n = 0 then begin
+			rl := l;
+			[]
+		end else
+			match l with
+			| [] -> raise Empty_list
+			| x::l -> x::(pop_aux l (n-1))
+	in
+	pop_aux !rl n
+
+let copy_enum ~dst ~src = dst := List.of_enum src
+let enum rl = List.enum !rl
+let of_enum e = ref (List.of_enum e)
+
+module Index = struct
+
+	let remove_at rl pos =
+		let p = ref (-1) in
+		let rec del_aux = function			
+			| x::l -> incr p; if !p = pos then l else x::(del_aux l)
+			| [] -> raise (Invalid_index pos)
+		in
+		rl := del_aux !rl
+
+	let index pred rl =
+		let index = ref (-1) in
+		List.find (fun it -> incr index; pred it; ) !rl;
+		!index
+
+	let index_of rl item =
+		let index = ref (-1) in
+		List.find (fun it -> incr index; it = item; ) !rl;
+		!index
+
+	let at_index rl pos =
+		try
+			List.nth !rl pos
+		with
+			_ -> raise (Invalid_index pos)
+
+	let set rl pos newitem =
+		let p = ref (-1) in
+		rl := List.map (fun item -> incr p; if !p = pos then newitem else item) !rl;
+		if !p < pos || pos < 0 then raise (Invalid_index pos)
+
+
+end

libs/extlib/refList.mli

@@ -0,0 +1,201 @@
+(*
+ * RefList - List reference
+ * Copyright (C) 2003 Nicolas Cannasse
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** Reference on lists.
+
+  RefList is a extended set of functions that manipulate list
+  references.
+*)
+
+exception Empty_list
+exception Invalid_index of int
+
+type 'a t
+
+val empty : unit -> 'a t
+(** Returns a new empty ref list *)
+  
+val is_empty : 'a t -> bool
+(** Return [true] if a ref list is empty *)
+
+val clear : 'a t -> unit
+(** Removes all elements *)
+
+val length : 'a t -> int
+(** Returns the number of elements - O(n) *)
+
+val copy : dst:'a t -> src:'a t -> unit
+(** Makes a copy of a ref list - O(1) *)
+
+val copy_list : dst:'a t -> src:'a list -> unit
+(** Makes a copy of a list - O(1) *)
+
+val copy_enum : dst:'a t -> src:'a Enum.t -> unit
+(** Makes a copy of a enum *)
+
+val of_list : 'a list -> 'a t
+(** Creates a ref list from a list - O(1) *)
+
+val to_list : 'a t -> 'a list
+(** Returns the current elements as a list - O(1) *)
+
+val of_enum : 'a Enum.t -> 'a t
+(** Creates a ref list from an enumeration *)
+
+val enum : 'a t -> 'a Enum.t
+(** Returns an enumeration of current elements in the ref list *)
+
+val add : 'a t -> 'a -> unit
+(** Adds an element at the end - O(n) *)
+
+val push : 'a t -> 'a -> unit
+(** Adds an element at the head - O(1) *)
+
+val add_sort : ?cmp:('a -> 'a -> int) -> 'a t -> 'a -> unit
+(** Adds an element in a sorted list, using optional comparator
+    or 'compare' as default. *)
+
+val first : 'a t -> 'a
+(** Returns the first element or
+    raises [Empty_list] if the ref list is empty *)
+
+val last : 'a t -> 'a
+(** Returns the last element - O(n) or
+    raises Empty_list if the ref list is empty *)
+
+val pop : 'a t -> 'a
+(** Removes and returns the first element or
+   raises [Empty_list] if the ref list is empty *)
+
+val npop : 'a t -> int -> 'a list
+(** Removes and returns the n first elements or
+   raises [Empty_list] if the ref list does not
+   contain enough elements *)
+
+val hd : 'a t -> 'a
+(** same as [first] *)
+
+val tl : 'a t -> 'a t
+(** Returns a ref list containing the same elements
+    but without the first one or
+    raises [Empty_list] if the ref list is empty *)
+
+val rev : 'a t -> unit
+(** Reverses the ref list - O(n) *)
+
+(** {6 Functional Operations} *)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** Apply the given function to all elements of the
+    ref list, in respect with the order of the list *)
+
+val find : ('a -> bool) -> 'a t -> 'a
+(** Find the first element matching
+    the specified predicate
+    raise [Not_found] if no element is found *)
+
+val rfind : ('a -> bool) -> 'a t -> 'a
+(** Find the first element in the reversed ref list matching
+    the specified predicate
+    raise [Not_found] if no element is found *)
+
+val find_exc : ('a -> bool) -> exn -> 'a t -> 'a
+(** Same as find but takes an exception to be raised when
+    no element is found as additional parameter *)
+
+val exists : ('a -> bool) -> 'a t -> bool
+(** Return [true] if an element matches the specified
+    predicate *)
+
+val for_all : ('a -> bool) -> 'a t -> bool
+(** Return [true] if all elements match the specified
+    predicate *)
+
+val map : ('a -> 'b) -> 'a t -> 'b t
+(** Apply a function to all elements
+    and return the ref list constructed with
+    the function returned values *)
+
+val transform : ('a -> 'a) -> 'a t -> unit
+(** transform all elements in the ref list
+    using a function. *)
+
+val map_list : ('a -> 'b) -> 'a t -> 'b list
+(** Apply a function to all elements
+    and return the list constructed with
+    the function returned values *)
+
+val sort : ?cmp:('a -> 'a -> int) -> 'a t -> unit
+(** Sort elements using the specified comparator
+    or compare as default comparator *)
+
+val filter : ('a -> bool) -> 'a t -> unit
+(** Remove all elements that do not match the
+    specified predicate *)
+
+val remove : 'a t -> 'a -> unit
+(** Remove an element from the ref list
+    raise [Not_found] if the element is not found *)
+
+val remove_if : ('a -> bool) -> 'a t -> unit
+(** Remove the first element matching the
+    specified predicate
+    raise [Not_found] if no element has been removed *)
+
+val remove_all : 'a t -> 'a -> unit
+(** Remove all elements equal to the specified
+    element from the ref list *)
+
+
+
+(** Functions that operate on the [i]th element of a list.
+
+    While it is sometimes necessary to perform these
+    operations on lists (hence their inclusion here), the
+    functions were moved to an inner module to prevent
+    their overuse: all functions work in O(n) time. You
+	might prefer to use [Array] or [DynArray] for constant
+	time indexed element access.
+*)
+module Index : sig
+
+	val index_of : 'a t -> 'a -> int
+	(** Return the index (position : 0 starting) of an element in
+	    a ref list, using ( = ) for testing element equality
+	    raise [Not_found] if no element was found *)
+
+	val index : ('a -> bool) -> 'a t -> int
+	(** Return the index (position : 0 starting) of an element in
+	    a ref list, using the specified comparator
+	    raise [Not_found] if no element was found *)
+
+	val at_index : 'a t -> int -> 'a
+	(** Return the element of ref list at the specified index
+	    raise [Invalid_index] if the index is outside [0 ; length-1] *)
+
+	val set : 'a t -> int -> 'a -> unit
+	(** Change the element at the specified index
+	    raise [Invalid_index] if the index is outside [0 ; length-1] *)
+
+	val remove_at : 'a t -> int -> unit
+	(** Remove the element at the specified index
+	    raise [Invalid_index] if the index is outside [0 ; length-1] *)
+
+end

libs/extlib/std.ml

@@ -0,0 +1,185 @@
+(*
+ * Std - Additional functions
+ * Copyright (C) 2003 Nicolas Cannasse and Markus Mottl
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+let input_lines ch =
+  Enum.from (fun () ->
+    try input_line ch with End_of_file -> raise Enum.No_more_elements)
+
+let input_chars ch =
+  Enum.from (fun () ->
+    try input_char ch with End_of_file -> raise Enum.No_more_elements)
+
+type 'a _mut_list = {
+  hd : 'a;
+  mutable tl : 'a _mut_list;
+}
+
+let input_list ch =
+  let _empty = Obj.magic [] in
+  let rec loop dst =
+    let r = { hd = input_line ch; tl = _empty } in
+    dst.tl <- r;
+    loop r in
+  let r = { hd = Obj.magic(); tl = _empty } in
+  try loop r
+  with
+    End_of_file ->
+      Obj.magic r.tl
+
+let buf_len = 8192
+
+let input_all ic =
+  let rec loop acc total buf ofs =
+    let n = input ic buf ofs (buf_len - ofs) in
+    if n = 0 then
+      let res = String.create total in
+      let pos = total - ofs in
+      let _ = String.blit buf 0 res pos ofs in
+      let coll pos buf =
+        let new_pos = pos - buf_len in
+        String.blit buf 0 res new_pos buf_len;
+        new_pos in
+      let _ = List.fold_left coll pos acc in
+      res
+    else
+      let new_ofs = ofs + n in
+      let new_total = total + n in
+      if new_ofs = buf_len then
+        loop (buf :: acc) new_total (String.create buf_len) 0
+      else loop acc new_total buf new_ofs in
+  loop [] 0 (String.create buf_len) 0
+
+let input_file ?(bin=false) fname =
+  let ch = (if bin then open_in_bin else open_in) fname in
+  let str = input_all ch in
+  close_in ch;
+  str
+
+let output_file ~filename ~text =
+  let ch = open_out filename in
+  output_string ch text;
+  close_out ch
+
+let print_bool = function
+  | true -> print_string "true"
+  | false -> print_string "false"
+
+let prerr_bool = function
+  | true -> prerr_string "true"
+  | false -> prerr_string "false"
+
+let string_of_char c = String.make 1 c
+
+external identity : 'a -> 'a = "%identity"
+
+let rec dump r =
+	if Obj.is_int r then
+		string_of_int (Obj.magic r : int)
+	else (* Block. *)
+	let rec get_fields acc = function
+		| 0 -> acc
+		| n -> let n = n-1 in get_fields (Obj.field r n :: acc) n
+	in
+    let rec is_list r =
+		if Obj.is_int r then
+			r = Obj.repr 0 (* [] *)
+		else
+			let s = Obj.size r and t = Obj.tag r in
+			t = 0 && s = 2 && is_list (Obj.field r 1) (* h :: t *)
+	in
+    let rec get_list r =
+		if Obj.is_int r then
+			[]
+		else 
+			let h = Obj.field r 0 and t = get_list (Obj.field r 1) in
+			h :: t
+    in
+    let opaque name =
+		(* XXX In future, print the address of value 'r'.  Not possible in
+		* pure OCaml at the moment.
+		*)
+		"<" ^ name ^ ">"
+    in
+    let s = Obj.size r and t = Obj.tag r in
+    (* From the tag, determine the type of block. *)
+	match t with 
+	| _ when is_list r ->
+		let fields = get_list r in
+		"[" ^ String.concat "; " (List.map dump fields) ^ "]"
+	| 0 ->
+		let fields = get_fields [] s in
+		"(" ^ String.concat ", " (List.map dump fields) ^ ")"
+	| x when x = Obj.lazy_tag ->
+		(* Note that [lazy_tag .. forward_tag] are < no_scan_tag.  Not
+		* clear if very large constructed values could have the same
+		* tag. XXX *)
+		opaque "lazy"
+	| x when x = Obj.closure_tag ->
+		opaque "closure"
+	| x when x = Obj.object_tag ->
+		let fields = get_fields [] s in
+		let clasz, id, slots =
+			match fields with
+			| h::h'::t -> h, h', t 
+			| _ -> assert false
+		in
+		(* No information on decoding the class (first field).  So just print
+		* out the ID and the slots. *)
+		"Object #" ^ dump id ^ " (" ^ String.concat ", " (List.map dump slots) ^ ")"
+    | x when x = Obj.infix_tag ->
+		opaque "infix"
+    | x when x = Obj.forward_tag ->
+		opaque "forward"
+	| x when x < Obj.no_scan_tag ->
+		let fields = get_fields [] s in
+		"Tag" ^ string_of_int t ^
+		" (" ^ String.concat ", " (List.map dump fields) ^ ")"
+	| x when x = Obj.string_tag ->
+		"\"" ^ String.escaped (Obj.magic r : string) ^ "\""
+	| x when x = Obj.double_tag ->
+		string_of_float (Obj.magic r : float)
+	| x when x = Obj.abstract_tag ->
+		opaque "abstract"
+	| x when x = Obj.custom_tag ->
+		opaque "custom"
+	| x when x = Obj.final_tag ->
+		opaque "final"
+	| _ ->
+		failwith ("Std.dump: impossible tag (" ^ string_of_int t ^ ")")
+
+let dump v = dump (Obj.repr v)
+
+let print v = print_endline (dump v)
+
+let finally handler f x =
+	let r = (
+		try
+			f x
+		with
+			e -> handler(); raise e
+	) in
+	handler();
+	r
+
+let __unique_counter = ref 0
+
+let unique() =
+  incr __unique_counter;
+  !__unique_counter

libs/extlib/std.mli

@@ -0,0 +1,69 @@
+(*
+ * Std - Additional functions
+ * Copyright (C) 2003 Nicolas Cannasse
+ * 
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** Additional functions. *)
+
+val input_lines : in_channel -> string Enum.t
+(** Returns an enumeration over lines of an input channel, as read by the
+ [input_line] function. *)
+
+val input_chars : in_channel -> char Enum.t
+(** Returns an enumeration over characters of an input channel. *)
+
+val input_list : in_channel -> string list
+(** Returns the list of lines read from an input channel. *)
+
+val input_all : in_channel -> string
+(** Return the whole contents of an input channel as a single
+ string. *)
+
+val print_bool : bool -> unit
+(** Print a boolean to stdout. *)
+
+val prerr_bool : bool -> unit
+(** Print a boolean to stderr. *)
+
+val input_file : ?bin:bool -> string -> string
+(** returns the data of a given filename. *)
+
+val output_file : filename:string -> text:string -> unit
+(** creates a filename, write text into it and close it. *)
+
+val string_of_char : char -> string
+(** creates a string from a char. *)
+
+external identity : 'a -> 'a = "%identity"
+(** the identity function. *)
+
+val unique : unit -> int
+(** returns an unique identifier every time it is called. *)
+
+val dump : 'a -> string
+(** represent a runtime value as a string. Since types are lost at compile
+	time, the representation might not match your type. For example, None
+	will be printed 0 since they share the same runtime representation. *)
+
+val print : 'a -> unit
+(** print the representation of a runtime value on stdout.
+	See remarks for [dump]. *)
+
+val finally : (unit -> unit) -> ('a -> 'b) -> 'a -> 'b 
+(** finally [fend f x] calls [f x] and then [fend()] even if [f x] raised
+	an exception. *)

libs/extlib/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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+type t = int
+
+exception Out_of_range
+
+external unsafe_chr_of_uint : int -> t = "%identity"
+external uint_code : t -> int = "%identity"
+
+let char_of c = 
+  if c >= 0 && c < 0x100 then Char.chr c else raise Out_of_range
+
+let of_char = Char.code
+
+let code c = if c >= 0 then c else raise Out_of_range
+
+let chr n =
+  if n >= 0 && n lsr 31 = 0 then n else invalid_arg "UChar.chr"
+
+let chr_of_uint n = if n lsr 31 = 0 then n else invalid_arg "UChar.uint_chr"
+  
+let eq (u1 : t) (u2 : t) = u1 = u2
+let compare u1 u2 =
+  let sgn = (u1 lsr 16) - (u2 lsr 16) in
+  if sgn = 0 then (u1 land 0xFFFF) -  (u2 land 0xFFFF) else sgn
+
+type uchar = t
+
+let int_of_uchar u = uint_code u
+let uchar_of_int n = chr_of_uint n

libs/extlib/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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** Unicode (ISO-UCS) characters.
+
+   This module implements Unicode (actually ISO-UCS) characters.  All
+   31-bit code points are allowed.
+*)
+
+(** Unicode characters. All 31-bit code points are allowed.*) 
+type t
+
+exception Out_of_range
+
+(** [char_of u] returns the Latin-1 representation of [u].
+   If [u] can not be represented by Latin-1, raises Out_of_range *)
+val char_of : t -> char
+
+(** [of_char c] returns the Unicode character of the Latin-1 character [c] *)
+val of_char : char -> t
+
+(** [code u] returns the Unicode code number of [u].
+   If the value can not be represented by a positive integer,
+   raise Out_of_range *)
+val code : t -> int
+
+(** [code n] returns the Unicode character with the code number [n]. 
+   If n >= 2^32 or n < 0, raises [invalid_arg] *)
+val chr : int -> t
+
+(** [uint_code u] returns the Unicode code number of [u].
+   The returned int is unsigned, that is, on 32-bit platforms,
+   the sign bit is used for storing the 31-th bit of the code number. *)
+external uint_code : t -> int = "%identity"
+
+(** [chr_of_uint n] returns the Unicode character of the code number [n].
+   [n] is interpreted as unsigned, that is, on 32-bit platforms,
+   the sign bit is treated as the 31-th bit of the code number.
+   If n exceeds 31-bit values, then raise [Invalid_arg]. *)
+val chr_of_uint : int -> t
+
+(** Unsafe version of {!UChar.chr_of_uint}.
+   No check of its argument is performed. *)
+external unsafe_chr_of_uint : int -> t = "%identity"
+
+(** Equality by code point comparison *)
+val eq : t -> t -> bool
+
+(** [compare u1 u2] returns, 
+   a value > 0 if [u1] has a larger Unicode code number than [u2], 
+   0 if [u1] and [u2] are the same Unicode character,
+   a value < 0 if [u1] has a smaller Unicode code number than [u2]. *)
+val compare : t -> t -> int
+
+(** Aliases of [type t] *)
+type uchar = t
+
+(** Alias of [uint_code] *)
+val int_of_uchar : uchar -> int
+
+(** Alias of [chr_of_uint] *)
+val uchar_of_int : int -> uchar

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

libs/extlib/uTF8.mli

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

libs/extlib/unzip.ml

@@ -0,0 +1,449 @@
+(*
+ * Unzip - inflate format decompression algorithm
+ * Copyright (C) 2004 Nicolas Cannasse
+ * Compliant with RFC 1950 and 1951
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+type huffman =
+	| Found of int
+	| NeedBit of huffman * huffman
+	| NeedBits of int * huffman array
+
+
+type adler32 = {
+	mutable a1 : int;
+	mutable a2 : int;
+}
+
+type window = {
+	mutable wbuffer : string;
+	mutable wpos : int;
+	wcrc : adler32;
+}
+
+type state =
+	| Head
+	| Block
+	| CData
+	| Flat
+	| Crc
+	| Dist
+	| DistOne
+	| Done
+
+type t = {
+	mutable znbits : int;
+	mutable zbits : int;
+	mutable zstate : state;
+	mutable zfinal : bool;
+	mutable zhuffman : huffman;
+	mutable zhuffdist : huffman option;
+	mutable zlen : int;
+	mutable zdist : int;
+	mutable zneeded : int;
+	mutable zoutput : string;
+	mutable zoutpos : int;
+	zinput : IO.input;
+	zlengths : int array;
+	zwindow : window;
+}
+
+type error_msg =
+	| Invalid_huffman
+	| Invalid_data
+	| Invalid_crc
+	| Truncated_data
+	| Unsupported_dictionary
+
+exception Error of error_msg
+
+let error msg = raise (Error msg)
+
+(* ************************************************************************ *)
+(* HUFFMAN TREES *)
+
+let rec tree_depth = function
+	| Found _ -> 0
+	| NeedBits _ -> assert false
+	| NeedBit (a,b) ->
+		1 + min (tree_depth a) (tree_depth b)
+
+let rec tree_compress t =
+	match tree_depth t with
+	| 0 -> t
+	| 1 ->
+		(match t with
+		| NeedBit (a,b) -> NeedBit (tree_compress a,tree_compress b)
+		| _ -> assert false)
+	| d ->
+		let size = 1 lsl d in
+		let tbl = Array.make size (Found (-1)) in
+		tree_walk tbl 0 0 d t;
+		NeedBits (d,tbl)
+
+and tree_walk tbl p cd d = function
+	| NeedBit (a,b) when d > 0 ->
+		tree_walk tbl p (cd + 1) (d-1) a;
+		tree_walk tbl (p lor (1 lsl cd)) (cd + 1) (d-1) b;
+	| t ->
+		Array.set tbl p (tree_compress t)
+
+let make_huffman lengths pos nlengths maxbits =
+	let counts = Array.make maxbits 0 in
+	for i = 0 to nlengths - 1 do
+		let p = Array.unsafe_get lengths (i + pos) in
+		if p >= maxbits then error Invalid_huffman;
+		Array.unsafe_set counts p (Array.unsafe_get counts p + 1);
+	done;
+	let code = ref 0 in
+	let tmp = Array.make maxbits 0 in
+	for i = 1 to maxbits - 2 do
+		code := (!code + Array.unsafe_get counts i) lsl 1;
+		Array.unsafe_set tmp i !code;
+	done;
+	let bits = Hashtbl.create 0 in
+	for i = 0 to nlengths - 1 do
+		let l = Array.unsafe_get lengths (i + pos) in
+		if l <> 0 then begin
+			let n = Array.unsafe_get tmp (l - 1) in
+			Array.unsafe_set tmp (l - 1) (n + 1);
+			Hashtbl.add bits (n,l) i;
+		end;
+	done;
+	let rec tree_make v l =
+		if l > maxbits then error Invalid_huffman;
+		try
+			Found (Hashtbl.find bits (v,l))
+		with
+			Not_found ->
+				NeedBit (tree_make (v lsl 1) (l + 1) , tree_make (v lsl 1 lor 1) (l + 1))
+	in
+	tree_compress (NeedBit (tree_make 0 1 , tree_make 1 1))
+
+(* ************************************************************************ *)
+(* ADLER32 (CRC) *)
+
+let adler32_create() = {
+	a1 = 1;
+	a2 = 0;
+}
+
+let adler32_update a s p l =
+	let p = ref p in
+	for i = 0 to l - 1 do
+		let c = int_of_char (String.unsafe_get s !p) in
+		a.a1 <- (a.a1 + c) mod 65521;
+		a.a2 <- (a.a2 + a.a1) mod 65521;
+		incr p;
+	done
+
+let adler32_read ch =
+	let a2a = IO.read_byte ch in
+	let a2b = IO.read_byte ch in
+	let a1a = IO.read_byte ch in
+	let a1b = IO.read_byte ch in
+	{
+		a1 = (a1a lsl 8) lor a1b;
+		a2 = (a2a lsl 8) lor a2b;
+	}
+
+(* ************************************************************************ *)
+(* WINDOW *)
+
+let window_size = 1 lsl 15
+let buffer_size = 1 lsl 16
+
+let window_create size = {
+		wbuffer = String.create buffer_size;
+		wpos = 0;
+		wcrc = adler32_create()
+	}
+
+let window_slide w =
+	adler32_update w.wcrc w.wbuffer 0 window_size;
+	let b = String.create buffer_size in
+	w.wpos <- w.wpos - window_size;
+	String.unsafe_blit w.wbuffer window_size b 0 w.wpos;
+	w.wbuffer <- b
+
+let window_add_string w s p len =
+	if w.wpos + len > buffer_size then window_slide w;
+	String.unsafe_blit s p w.wbuffer w.wpos len;
+	w.wpos <- w.wpos + len
+
+let window_add_char w c =
+	if w.wpos = buffer_size then window_slide w;
+	String.unsafe_set w.wbuffer w.wpos c;
+	w.wpos <- w.wpos + 1
+
+let window_get_last_char w =
+	String.unsafe_get w.wbuffer (w.wpos - 1)
+
+let window_available w =
+	w.wpos
+
+let window_checksum w =
+	adler32_update w.wcrc w.wbuffer 0 w.wpos;
+	w.wcrc
+
+(* ************************************************************************ *)
+
+let len_extra_bits_tbl = [|0;0;0;0;0;0;0;0;1;1;1;1;2;2;2;2;3;3;3;3;4;4;4;4;5;5;5;5;0;-1;-1|]
+let len_base_val_tbl = [|3;4;5;6;7;8;9;10;11;13;15;17;19;23;27;31;35;43;51;59;67;83;99;115;131;163;195;227;258|]
+let dist_extra_bits_tbl = [|0;0;0;0;1;1;2;2;3;3;4;4;5;5;6;6;7;7;8;8;9;9;10;10;11;11;12;12;13;13;-1;-1|]
+let dist_base_val_tbl = [|1;2;3;4;5;7;9;13;17;25;33;49;65;97;129;193;257;385;513;769;1025;1537;2049;3073;4097;6145;8193;12289;16385;24577|]
+let code_lengths_pos = [|16;17;18;0;8;7;9;6;10;5;11;4;12;3;13;2;14;1;15|]
+
+let fixed_huffman = make_huffman (Array.init 288 (fun n ->
+									if n <= 143 then 8
+									else if n <= 255 then 9
+									else if n <= 279 then 7
+									else 8
+								)) 0 288 10
+
+let get_bits z n =
+	while z.znbits < n do
+		z.zbits <- z.zbits lor ((IO.read_byte z.zinput) lsl z.znbits);
+		z.znbits <- z.znbits + 8;
+	done;
+	let b = z.zbits land (1 lsl n - 1) in
+	z.znbits <- z.znbits - n;
+	z.zbits <- z.zbits lsr n;
+	b
+
+let get_bit z =
+	if z.znbits = 0 then begin
+		z.znbits <- 8;
+		z.zbits <- IO.read_byte z.zinput;
+	end;
+	let b = z.zbits land 1 = 1 in
+	z.znbits <- z.znbits - 1;
+	z.zbits <- z.zbits lsr 1;
+	b
+
+let rec get_rev_bits z n =
+	if n = 0 then
+		0
+	else if get_bit z then
+		(1 lsl (n - 1)) lor (get_rev_bits z (n-1))
+	else
+		get_rev_bits z (n-1)
+
+let reset_bits z =
+	z.zbits <- 0;
+	z.znbits <- 0
+
+let add_string z s p l =
+	window_add_string z.zwindow s p l;
+	String.unsafe_blit s p z.zoutput z.zoutpos l;
+	z.zneeded <- z.zneeded - l;
+	z.zoutpos <- z.zoutpos + l
+
+let add_char z c =
+	window_add_char z.zwindow c;
+	String.unsafe_set z.zoutput z.zoutpos c;
+	z.zneeded <- z.zneeded - 1;
+	z.zoutpos <- z.zoutpos + 1
+
+let add_dist_one z n =
+	let c = window_get_last_char z.zwindow in
+	let s = String.make n c in
+	add_string z s 0 n
+
+let add_dist z d l =
+	add_string z z.zwindow.wbuffer (z.zwindow.wpos - d) l
+
+let rec apply_huffman z = function
+	| Found n -> n
+	| NeedBit (a,b) -> apply_huffman z (if get_bit z then b else a)
+	| NeedBits (n,t) -> apply_huffman z (Array.unsafe_get t (get_bits z n))
+
+let inflate_lengths z a max =
+	let i = ref 0 in
+	let prev = ref 0 in
+	while !i < max do
+		match apply_huffman z z.zhuffman with
+		| n when n <= 15 ->
+			prev := n;
+			Array.unsafe_set a !i n;
+			incr i
+		| 16 ->
+			let n = 3 + get_bits z 2 in
+			if !i + n > max then error Invalid_data;
+			for k = 0 to n - 1 do
+				Array.unsafe_set a !i !prev;
+				incr i;
+			done;
+		| 17 ->
+			let n = 3 + get_bits z 3 in
+			i := !i + n;
+			if !i > max then error Invalid_data;
+		| 18 ->
+			let n = 11 + get_bits z 7 in
+			i := !i + n;
+			if !i > max then error Invalid_data;
+		| _ ->
+			error Invalid_data
+	done
+
+let rec inflate_loop z =
+	match z.zstate with
+	| Head ->
+		let cmf = IO.read_byte z.zinput in
+		let cm = cmf land 15 in
+		let cinfo = cmf lsr 4 in
+		if cm <> 8 || cinfo <> 7 then error Invalid_data;
+		let flg = IO.read_byte z.zinput in
+		(*let fcheck = flg land 31 in*)
+		let fdict = flg land 32 <> 0 in
+		(*let flevel = flg lsr 6 in*)
+		if (cmf lsl 8 + flg) mod 31 <> 0 then error Invalid_data;
+		if fdict then error Unsupported_dictionary;
+		z.zstate <- Block;
+		inflate_loop z
+	| Crc ->
+		let calc = window_checksum z.zwindow in
+		let crc = adler32_read z.zinput in
+		if calc <> crc then error Invalid_crc;
+		z.zstate <- Done;
+		inflate_loop z
+	| Done ->
+		()
+	| Block ->
+		z.zfinal <- get_bit z;
+		let btype = get_bits z 2 in
+		(match btype with
+		| 0 -> (* no compression *)
+			z.zlen <- IO.read_ui16 z.zinput;
+			let nlen = IO.read_ui16 z.zinput in
+			if nlen <> 0xFFFF - z.zlen then error Invalid_data;
+			z.zstate <- Flat;
+			inflate_loop z;
+			reset_bits z
+		| 1 -> (* fixed Huffman *)
+			z.zhuffman <- fixed_huffman;
+			z.zhuffdist <- None;
+			z.zstate <- CData;
+			inflate_loop z
+		| 2 -> (* dynamic Huffman *)
+			let hlit = get_bits z 5 + 257 in
+			let hdist = get_bits z 5 + 1 in
+			let hclen = get_bits z 4 + 4 in
+			for i = 0 to hclen - 1 do
+				Array.unsafe_set z.zlengths (Array.unsafe_get code_lengths_pos i) (get_bits z 3);
+			done;
+			for i = hclen to 18 do
+				Array.unsafe_set z.zlengths (Array.unsafe_get code_lengths_pos i) 0;
+			done;
+			z.zhuffman <- make_huffman z.zlengths 0 19 8;
+			let lengths = Array.make (hlit + hdist) 0 in
+			inflate_lengths z lengths (hlit + hdist);
+			z.zhuffdist <- Some (make_huffman lengths hlit hdist 16);
+			z.zhuffman <- make_huffman lengths 0 hlit 16;
+			z.zstate <- CData;
+			inflate_loop z
+		| _ ->
+			error Invalid_data)
+	| Flat ->
+		let rlen = min z.zlen z.zneeded in
+		let str = IO.nread z.zinput rlen in
+		let len = String.length str in
+		z.zlen <- z.zlen - len;
+		add_string z str 0 len;
+		if z.zlen = 0 then z.zstate <- (if z.zfinal then Crc else Block);
+		if z.zneeded > 0 then inflate_loop z
+	| DistOne ->
+		let len = min z.zlen z.zneeded in
+		add_dist_one z len;
+		z.zlen <- z.zlen - len;
+		if z.zlen = 0 then z.zstate <- CData;
+		if z.zneeded > 0 then inflate_loop z
+	| Dist ->
+		while z.zlen > 0 && z.zneeded > 0 do
+			let len = min z.zneeded (min z.zlen z.zdist) in
+			add_dist z z.zdist len;
+			z.zlen <- z.zlen - len;
+		done;
+		if z.zlen = 0 then z.zstate <- CData;
+		if z.zneeded > 0 then inflate_loop z
+	| CData ->
+		match apply_huffman z z.zhuffman with
+		| n when n < 256 ->
+			add_char z (Char.unsafe_chr n);
+			if z.zneeded > 0 then inflate_loop z
+		| 256 ->
+			z.zstate <- if z.zfinal then Crc else Block;
+			inflate_loop z
+		| n ->
+			let n = n - 257 in
+			let extra_bits = Array.unsafe_get len_extra_bits_tbl n in
+			if extra_bits = -1 then error Invalid_data;
+			z.zlen <- (Array.unsafe_get len_base_val_tbl n) + (get_bits z extra_bits);
+			let dist_code = (match z.zhuffdist with None -> get_rev_bits z 5 | Some h -> apply_huffman z h) in
+			let extra_bits = Array.unsafe_get dist_extra_bits_tbl dist_code in
+			if extra_bits = -1 then error Invalid_data;
+			z.zdist <- (Array.unsafe_get dist_base_val_tbl dist_code) + (get_bits z extra_bits);
+			if z.zdist > window_available z.zwindow then error Invalid_data;
+			z.zstate <- (if z.zdist = 1 then DistOne else Dist);
+			inflate_loop z
+
+let inflate_data z s pos len =
+	if pos < 0 || len < 0 || pos + len > String.length s then invalid_arg "inflate_data";
+	z.zneeded <- len;
+	z.zoutpos <- pos;
+	z.zoutput <- s;
+	try
+		if len > 0 then inflate_loop z;
+		len - z.zneeded
+	with
+		IO.No_more_input -> error Truncated_data
+
+let inflate_init ?(header=true) ch =
+	{
+		zfinal = false;
+		zhuffman = fixed_huffman;
+		zhuffdist = None;
+		zlen = 0;
+		zdist = 0;
+		zstate = (if header then Head else Block);
+		zinput = ch;
+		zbits = 0;
+		znbits = 0;
+		zneeded = 0;
+		zoutput = "";
+		zoutpos = 0;
+		zlengths = Array.make 19 (-1);
+		zwindow = window_create (1 lsl 15)
+	}
+
+let inflate ?(header=true) ch =
+	let z = inflate_init ~header ch in
+	let s = String.create 1 in
+	IO.create_in
+		~read:(fun() ->
+			let l = inflate_data z s 0 1 in
+			if l = 1 then String.unsafe_get s 0 else raise IO.No_more_input
+		)
+		~input:(fun s p l ->
+			let n = inflate_data z s p l in
+			if n = 0 then raise IO.No_more_input;
+			n
+		)
+		~close:(fun () ->
+			IO.close_in ch
+		)

libs/extlib/unzip.mli

@@ -0,0 +1,45 @@
+(*
+ * Unzip - inflate format decompression algorithm
+ * Copyright (C) 2004 Nicolas Cannasse
+ * Compliant with RFC 1950 and 1951
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version,
+ * with the special exception on linking described in file LICENSE.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+(** Decompression algorithm.
+
+	Unzip decompression algorithm is compliant with RFC 1950 and 1951 which
+	are describing the "inflate" algorithm used in most popular file formats.
+	This format is also the one used by the popular ZLib library.	
+*)
+
+type error_msg =
+	| Invalid_huffman
+	| Invalid_data
+	| Invalid_crc
+	| Truncated_data
+	| Unsupported_dictionary
+
+exception Error of error_msg
+
+val inflate : ?header:bool -> IO.input -> IO.input
+(** wrap an input using "inflate" decompression algorithm. raises [Error] if
+  an error occurs (this can only be caused by malformed input data). *)
+
+type t
+
+val inflate_init : ?header:bool -> IO.input -> t
+val inflate_data : t -> string -> int -> int -> int

libs/javalib/Makefile

@@ -0,0 +1,5 @@
+all:
+	ocamlopt -g -I ../extlib -a -o java.cmxa jData.mli jReader.ml
+	
+clean:
+	rm -rf java.cmxa java.lib java.a $(wildcard *.cmx) $(wildcard *.obj) $(wildcard *.o) $(wildcard *.cmi)

libs/javalib/jData.mli

@@ -0,0 +1,198 @@
+(*
+ *  This file is part of JavaLib
+ *  Copyright (c)2004-2012 Nicolas Cannasse and Caue Waneck
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+type jpath = (string list) * string
+
+type jversion = int * int (* minor + major *)
+
+(** unqualified names cannot have the characters '.', ';', '[' or '/' *)
+type unqualified_name = string
+
+type jwildcard =
+  | WExtends (* + *)
+  | WSuper (* -  *)
+  | WNone
+
+type jtype_argument =
+  | TType of jwildcard * jsignature
+  | TAny (* * *)
+
+and jsignature = 
+  | TByte (* B *)
+  | TChar (* C *)
+  | TDouble (* D *)
+  | TFloat (* F *)
+  | TInt (* I *)
+  | TLong (* J *)
+  | TShort (* S *)
+  | TBool (* Z *)
+  | TObject of jpath * jtype_argument list (* L Classname *)
+  | 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 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

libs/javalib/jReader.ml

@@ -0,0 +1,578 @@
+(*
+ *  This file is part of JavaLib
+ *  Copyright (c)2004-2012 Nicolas Cannasse and Caue Waneck
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+open JData;;
+open IO.BigEndian;;
+open ExtString;;
+open ExtList;;
+
+exception Error_message of string
+
+let error msg = raise (Error_message msg)
+
+let get_reference_type i constid =
+  match i with
+  | 1 -> RGetField 
+  | 2 -> RGetStatic
+  | 3 -> RPutField 
+  | 4 -> RPutStatic
+  | 5 -> RInvokeVirtual
+  | 6 -> RInvokeStatic
+  | 7 -> RInvokeSpecial
+  | 8 -> RNewInvokeSpecial
+  | 9 -> RInvokeInterface
+  | _ -> error (string_of_int constid ^ ": Invalid reference type " ^ string_of_int i)
+
+let parse_constant max idx ch =
+  let cid = IO.read_byte ch in
+  let error() = error (string_of_int idx ^ ": Invalid constant " ^ string_of_int cid) in
+  let index() =
+    let n = read_ui16 ch in
+    if n = 0 || n >= max then error();		
+    n
+  in
+  match cid with
+  | 7 ->
+    KClass (index())
+  | 9 ->
+    let n1 = index() in
+    let n2 = index() in
+    KFieldRef (n1,n2)
+  | 10 ->
+    let n1 = index() in
+    let n2 = index() in
+    KMethodRef (n1,n2)
+  | 11 ->
+    let n1 = index() in
+    let n2 = index() in
+    KInterfaceMethodRef (n1,n2)
+  | 8 ->
+    KString (index())
+  | 3 ->		
+    KInt (read_real_i32 ch)
+  | 4 ->
+    let f = Int32.float_of_bits (read_real_i32 ch) in		
+    KFloat f
+  | 5 ->
+    KLong (read_i64 ch)
+  | 6 ->
+    KDouble (read_double ch)
+  | 12 ->
+    let n1 = index() in
+    let n2 = index() in
+    KNameAndType (n1, n2)
+  | 1 ->
+    let len = read_ui16 ch in
+    let str = IO.nread ch len in
+    (* TODO: correctly decode modified UTF8 *)
+    KUtf8String str
+  | 15 ->
+  	let reft = get_reference_type (read_ui16 ch) idx in
+  	let dynref = index() in
+  	KMethodHandle (reft, dynref)
+  | 16 ->
+  	KMethodType (index())
+  | 18 ->
+    let bootstrapref = read_ui16 ch in (* not index *)
+    let nametyperef = index() in
+    KInvokeDynamic (bootstrapref, nametyperef)
+  | n -> 
+    error()
+
+let expand_path s =
+  let rec loop remaining acc =
+    match remaining with
+    | name :: [] -> List.rev acc, name
+    | v :: tl -> loop tl (v :: acc)
+    | _ -> assert false
+  in
+  loop (String.nsplit s "/") []
+
+let rec parse_type_parameter_part s =
+  match s.[0] with
+  | '*' -> TAny, 1
+  | c ->
+    let wildcard, i = match c with
+      | '+' -> WExtends, 1
+      | '-' -> WSuper, 1
+      | _ -> WNone, 0
+    in
+    let jsig, l = parse_signature_part (String.sub s i (String.length s - 1)) in
+    (TType (wildcard, jsig), l + i)
+
+and parse_signature_part s =
+  let len = String.length s in
+  if len = 0 then raise Exit;
+  match s.[0] with
+  | 'B' -> TByte, 1
+  | 'C' -> TChar, 1
+  | 'D' -> TDouble, 1
+  | 'F' -> TFloat, 1
+  | 'I' -> TInt, 1
+  | 'J' -> TLong, 1
+  | 'S' -> TShort, 1
+  | 'Z' -> TBool, 1
+  | 'L' -> 
+    (try
+      let 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 + 1)
+        | '<' ->
+          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
+          if s.[_end] <> ';' then error ("End of complex type signature expected after type parameter. Got '" ^ Char.escaped s.[_end] ^ "'");
+          List.rev acc, name, params, (_end + 1)
+        | _ -> loop start (i+ 1) acc
+      in
+      let pack, name, params, l = loop 1 1 [] in
+      TObject ((pack,name), params), l
+    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]));
+      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 ifacei (ifacesig :: acc)
+        | _ -> acc, idx
+      in
+      let ifaces, idx = loop l [] in
+      let acc = (id, ext, ifaces) :: acc in
+      if s.[idx] = '>' then 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 (len - idx)) in
+      loop (idx + l) (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 l (len - 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 = read_ui16 ch in
+  match Char.chr tag with
+  | 'B' | 'C' | 'D' | 'E' | 'F' | 'I' | 'J' | 'S' | 'Z' | 's' ->
+    ValConst (get_constant consts (read_ui16 ch))
+  | 'e' ->
+    let path = parse_signature (get_string consts ch) in
+    let name = get_string consts ch in
+    ValEnum (path, name)
+  | 'c' ->
+    let name = get_string consts ch in
+    let jsig = if name = "V" then 
+      TObject(([], "Void"), [])
+    else
+      parse_signature name
+    in
+    ValClass jsig
+  | '@' ->
+    ValAnnotation (parse_annotation consts ch)
+  | '[' ->
+    let num_vals = read_ui16 ch in
+    ValArray (List.init (num_vals) (fun _ -> parse_element_value consts ch))
+  | tag -> error ("Invalid element value: '" ^  Char.escaped tag ^ "'")
+
+and parse_ann_element consts ch =
+  let name = get_string consts ch in
+  let element_value = parse_element_value consts ch in
+  name, element_value
+
+and parse_annotation consts ch =
+  let anntype = parse_signature (get_string consts ch) in
+  let count = read_ui16 ch in
+  {
+    ann_type = anntype;
+    ann_elements = List.init count (fun _ -> parse_ann_element consts ch)
+  }
+
+let parse_attribute on_special consts ch =
+  let aname = get_string consts ch in
+  let error() = error ("Malformed attribute " ^ aname) in
+  let alen = read_i32 ch in
+  match aname with
+  | "Deprecated" ->
+    if alen <> 0 then error();
+    Some (AttrDeprecated)
+  | "RuntimeVisibleAnnotations" ->
+    let anncount = read_ui16 ch in
+    Some (AttrVisibleAnnotations (List.init anncount (fun _ -> parse_annotation consts ch)))
+  | "RuntimeInvisibleAnnotations" ->
+    let anncount = read_ui16 ch in
+    Some (AttrInvisibleAnnotations (List.init anncount (fun _ -> parse_annotation consts ch)))
+  | _ ->
+    let do_default () =
+      Some (AttrUnknown (aname,IO.nread ch alen))
+    in
+    match on_special with
+    | None -> do_default()
+    | Some fn -> fn consts ch aname alen do_default
+
+let parse_attributes ?on_special consts ch count =
+  let rec loop i acc =
+    if i >= count then List.rev acc
+    else match parse_attribute on_special consts ch with
+    | None -> loop (i + 1) acc
+    | Some attrib -> loop (i + 1) (attrib :: acc)
+  in
+  loop 0 []
+
+let parse_field kind consts ch =
+  let all_flags = match kind with
+    | JKField ->
+      [JPublic; JPrivate; JProtected; JStatic; JFinal; JUnusable; JVolatile; JTransient; JSynthetic; JEnum]
+    | JKMethod ->
+      [JPublic; JPrivate; JProtected; JStatic; JFinal; JSynchronized; JBridge; JVarArgs; JNative; JUnusable; JAbstract; JStrict; JSynthetic]
+  in
+  let acc = ref (parse_access_flags ch all_flags) in
+  let name = get_string consts ch in
+  let sign = parse_signature (get_string consts ch) in
+
+  let jsig = ref sign in
+  let throws = ref [] in
+  let types = ref [] in
+  let constant = ref None in
+  let code = ref None in
+
+  let attrib_count = read_ui16 ch in
+  let attribs = parse_attributes ~on_special:(fun _ _ aname alen do_default ->
+    match kind, aname with
+    | JKField, "ConstantValue" ->
+      constant := Some (get_constant consts (read_ui16 ch));
+      None
+    | JKField, "Synthetic" ->
+      if not (List.mem JSynthetic !acc) then acc := !acc @ [JSynthetic];
+      None
+    | JKField, "Signature" ->
+      let s = get_string consts ch in
+      jsig := parse_signature s;
+      None
+    | JKMethod, "Code" -> (* TODO *)
+      do_default()
+    | JKMethod, "Exceptions" ->
+      let num = read_ui16 ch in
+      throws := List.init num (fun _ -> TObject(get_class consts ch,[]));
+      None
+    | JKMethod, "Signature" ->
+      let s = get_string consts ch in
+      let tp, sgn, thr = parse_complete_method_signature s in
+      if thr <> [] then throws := thr;
+      types := tp;
+      jsig := TMethod(sgn);
+      None
+    | _ -> do_default()
+  ) consts ch attrib_count in
+  {
+    jf_name = name;
+    jf_kind = kind;
+    (* signature, as used by the vm *)
+    jf_vmsignature = sign;
+    (* actual signature, as used in java code *)
+    jf_signature = !jsig;
+    jf_throws = !throws;
+    jf_types = !types;
+    jf_flags = !acc;
+    jf_attributes = attribs;
+    jf_constant = !constant;
+    jf_code = !code;
+  }
+
+let parse_class ch =
+  if read_real_i32 ch <> 0xCAFEBABEl then error "Invalid header";
+  let minorv = read_ui16 ch in
+  let majorv = read_ui16 ch in
+  let constant_count = read_ui16 ch in
+  let const_big = ref true in
+  let consts = Array.init constant_count (fun idx ->
+  	if !const_big then begin
+  	  const_big := false;
+  	  KUnusable
+  	end else
+  	  let c = parse_constant constant_count idx ch in
+  	  (match c with KLong _ | KDouble _ -> const_big := true | _ -> ());
+  	  c
+  ) in
+  let consts = Array.mapi (fun i _ -> expand_constant consts i) consts in
+  let flags = parse_access_flags ch [JPublic; JUnusable; JUnusable; JUnusable; JFinal; JSuper; JUnusable; JUnusable; JUnusable; JInterface; JAbstract; JUnusable; JSynthetic; JAnnotation; JEnum] in
+  let this = get_class consts ch in
+  let super_idx = read_ui16 ch in
+  let super = match super_idx with
+  	| 0 -> TObject((["java";"lang"], "Object"), []);
+  	| idx -> match get_constant consts idx with
+  	  | ConstClass path -> TObject(path,[])
+  	  | _ -> error "Invalid super index"
+  in
+  let interfaces = List.init (read_ui16 ch) (fun _ -> TObject (get_class consts ch, [])) in
+  let fields = List.init (read_ui16 ch) (fun _ -> parse_field JKField consts ch) in
+  let methods = List.init (read_ui16 ch) (fun _ -> parse_field JKMethod consts ch) in
+
+  let inner = ref [] in
+  let types = ref [] in
+  let super = ref super in
+  let interfaces = ref interfaces in
+
+  let attribs = read_ui16 ch in
+  let attribs = parse_attributes ~on_special:(fun _ _ aname alen do_default ->
+    match aname with
+    | "InnerClasses" ->
+      let count = read_ui16 ch in
+      let classes = List.init count (fun _ -> 
+        let inner_ci = get_class consts ch in
+        let outeri = read_ui16 ch in
+        let outer_ci = match outeri with
+          | 0 -> None
+          | _ -> match get_constant consts outeri with
+          | ConstClass n -> Some n
+          | _ -> error "Invalid class index" 
+        in
+
+        let inner_namei = read_ui16 ch in
+        let inner_name = match inner_namei with
+          | 0 -> None
+          | _ -> match get_constant consts inner_namei with
+          | ConstUtf8 s -> Some s
+          | _ -> error ("Invalid string index " ^ string_of_int inner_namei)
+        in
+        let flags = parse_access_flags ch [JPublic; JPrivate; JProtected; JStatic; JFinal; JUnusable; JUnusable; JUnusable; JUnusable; JInterface; JAbstract; JSynthetic; JAnnotation; JEnum] in
+        inner_ci, outer_ci, inner_name, flags
+      ) in
+      inner := classes;
+      None
+    | "Signature" ->
+      let s = get_string consts ch in
+      let formal, idx = parse_formal_type_params s in
+      types := formal;
+      let s = String.sub s idx (String.length s - idx) in
+      let len = String.length s in
+      let sup, idx = parse_signature_part s in
+      let rec loop idx acc = 
+        if idx = len then 
+          acc
+        else begin
+          let s = String.sub s idx (len - idx) in
+          let iface, i2 = parse_signature_part s in
+          loop (idx + i2) (iface :: acc)
+        end
+      in
+      interfaces := loop idx [];
+      super := sup;
+      None
+    | _ -> do_default()
+  ) consts ch attribs in
+  {
+    cversion = majorv, minorv;
+    cpath = this;
+    csuper = !super;
+    cflags = flags;
+    cinterfaces = !interfaces;
+    cfields = fields;
+    cmethods = methods;
+    cattributes = attribs;
+    cinner_types = !inner;
+    ctypes = !types;
+  }
+

libs/neko/Makefile

@@ -0,0 +1,5 @@
+all:
+	ocamlopt -I ../extlib -a -o neko.cmxa nast.ml nxml.ml binast.ml nbytecode.ml ncompile.ml
+
+clean:
+	rm -rf neko.cmxa neko.lib neko.a $(wilcard *.cmx) $(wildcard *.obj) $(wildcard *.o) $(wildcard *.cmi)

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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  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 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 10;
+		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 ctx.ch s
+
+let write ch e =
+	let ctx = {
+		ch = ch;
+		curfile = "";
+		curline = -1;
+		scount = 0;
+		strings = Hashtbl.create 0;
+	} in
+	IO.nwrite 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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  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 ch "NEKO";
+	let ids , pos , csize = code_tables ops in
+	IO.write_i32 ch (Array.length globals);
+	IO.write_i32 ch (Array.length ids);
+	IO.write_i32 ch csize;
+	Array.iter (fun x ->
+		match x with
+		| GlobalVar s -> IO.write_byte ch 1; IO.write_string ch s
+		| GlobalFunction (p,nargs) -> IO.write_byte ch 2; IO.write_i32 ch (pos.(p) lor (nargs lsl 24))
+		| GlobalString s -> IO.write_byte ch 3; IO.write_ui16 ch (String.length s); IO.nwrite ch s
+		| GlobalFloat s -> IO.write_byte ch 4; IO.write_string ch s
+		| GlobalDebug (files,inf) -> IO.write_byte ch 5; write_debug_infos ch files inf;
+		| GlobalVersion v -> IO.write_byte ch 6; IO.write_byte ch v
+	) globals;
+	Array.iter (fun s ->
+		IO.write_string ch s;
+	) ids;
+	Array.iteri (fun i op ->
+		let pop = ref None in
+		let opid = (match op with
+			| AccNull -> 0
+			| AccTrue -> 1
+			| AccFalse -> 2
+			| AccThis -> 3
+			| AccInt n -> pop := Some n; 4
+			| AccInt32 n ->
+				let opid = 4 in
+				IO.write_byte ch ((opid lsl 2) lor 3);
+				IO.write_real_i32 ch n;
+				-1
+			| AccStack n -> pop := Some (n - 2); 5
+			| AccGlobal n -> pop := Some n; 6
+			| AccEnv n -> pop := Some n; 7
+			| AccField s -> pop := Some (hash_field s); 8
+			| AccArray -> 9
+			| AccIndex n -> pop := Some (n - 2); 10
+			| AccBuiltin s -> pop := Some (hash_field s); 11
+			| SetStack n -> pop := Some n; 12
+			| SetGlobal n -> pop := Some n; 13
+			| SetEnv n -> pop := Some n; 14
+			| SetField s -> pop := Some (hash_field s); 15
+			| SetArray -> 16
+			| SetIndex n -> pop := Some n; 17
+			| SetThis -> 18
+			| Push -> 19
+			| Pop n -> pop := Some n; 20
+			| Call n -> pop := Some n; 21
+			| ObjCall n -> pop := Some n; 22
+			| Jump n -> pop := Some (pos.(i+n) - pos.(i)); 23
+			| JumpIf n -> pop := Some (pos.(i+n) - pos.(i)); 24
+			| JumpIfNot n -> pop := Some (pos.(i+n) - pos.(i)); 25
+			| Trap n -> pop := Some (pos.(i+n) - pos.(i)); 26
+			| EndTrap -> 27
+			| Ret n -> pop := Some n; 28
+			| MakeEnv n -> pop := Some n; 29
+			| MakeArray n -> pop := Some n; 30
+			| Bool -> 31
+			| IsNull -> 32
+			| IsNotNull -> 33
+			| Add -> 34
+			| Sub -> 35
+			| Mult -> 36
+			| Div -> 37
+			| Mod -> 38
+			| Shl -> 39
+			| Shr -> 40
+			| UShr -> 41
+			| Or -> 42
+			| And -> 43
+			| Xor -> 44
+			| Eq -> 45
+			| Neq -> 46
+			| Gt -> 47
+			| Gte -> 48
+			| Lt -> 49
+			| Lte -> 50
+			| Not -> 51
+			| TypeOf -> 52
+			| Compare -> 53
+			| Hash -> 54
+			| New -> 55
+			| JumpTable n -> pop := Some n; 56
+			| Apply n -> pop := Some n; 57
+			| AccStack0 -> 58
+			| AccStack1 -> 59
+			| AccIndex0 -> 60
+			| AccIndex1 -> 61
+			| PhysCompare -> 62
+			| TailCall (args,st) -> pop := Some (args lor (st lsl 3)); 63
+			| Loop -> pop := Some 64; 0
+		) in
+		match !pop with
+		| None ->
+			if opid >= 0 then IO.write_byte ch (opid lsl 2)
+		| Some n ->
+			if opid < 32 && (n = 0 || n = 1) then
+				IO.write_byte ch ((opid lsl 3) lor (n lsl 2) lor 1)
+			else if n >= 0 && n <= 0xFF then begin
+				IO.write_byte ch ((opid lsl 2) lor 2);
+				IO.write_byte ch n;
+			end else begin
+				IO.write_byte ch ((opid lsl 2) lor 3);
+				IO.write_i32 ch n;
+			end
+	) ops

libs/neko/ncompile.ml

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

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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  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 ch "/>"
+		| l ->
+			IO.nwrite 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 ch "/>"
+		| l ->
+			IO.nwrite 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/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 informations 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 informations 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 ("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 $(CFLAGS) -c $<\n";
+		fprint ".ml.cmx:\n\tocamlopt $(CFLAGS) -c $<\n";
+		fprint ".mli.cmi:\n\tocamlc $(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/swflib/LICENSE

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

libs/swflib/Makefile

@@ -0,0 +1,54 @@
+# Makefile generated by OCamake
+# http://tech.motion-twin.com
+.SUFFIXES : .ml .mli .cmo .cmi .cmx .mll .mly
+
+CFLAGS= -I ../extlib -I ../extc -g
+LIBS=
+LFLAGS= -o swflib.cmxa -a
+
+MODULES=as3code.cmx png.cmx swf.cmx actionScript.cmx as3parse.cmx swfPic.cmx as3hlparse.cmx swfParser.cmx
+
+all: swflib.cmxa
+
+swflib.cmxa: $(MODULES)
+	ocamlopt $(LFLAGS) $(LIBS) $(MODULES)
+
+actionScript.cmx: swf.cmx
+
+as3code.cmx: as3.cmi
+
+as3hl.cmi: as3.cmi
+
+as3hlparse.cmx: as3parse.cmx as3hl.cmi as3code.cmx as3.cmi
+
+as3parse.cmx: as3code.cmx as3.cmi
+
+png.cmx: png.cmi
+
+swf.cmx: as3.cmi
+
+swfParser.cmx: swf.cmx as3parse.cmx actionScript.cmx
+
+swfPic.cmx: swf.cmx png.cmi
+
+
+clean:
+	rm -f swflib.cmxa swflib.lib swflib.a as3.cmi as3hl.cmi
+	rm -f $(MODULES) $(MODULES:.cmx=.obj) $(MODULES:.cmx=.cmi) $(MODULES:.cmx=.o)
+
+# SUFFIXES
+.ml.cmo:
+	ocamlc $(CFLAGS) -c $<
+
+.ml.cmx:
+	ocamlopt $(CFLAGS) -c $<
+
+.mli.cmi:
+	ocamlc $(CFLAGS) $<
+
+.mll.ml:
+	ocamllex $<
+
+.mly.ml:
+	ocamlyacc $<
+

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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+open Swf
+open IO
+open Printf
+
+let push_item_length = function
+	| PString s -> String.length s + 1
+	| PFloat _ -> 4
+	| PNull -> 0
+	| PUndefined -> 0
+	| PReg _ -> 1
+	| PBool _ -> 1
+	| PDouble _ -> 8
+	| PInt _ -> 4
+	| PStack _ -> 1
+	| PStack2 _ -> 2
+
+let push_item_id = function
+	| PString s -> 0
+	| PFloat _ -> 1
+	| PNull -> 2
+	| PUndefined -> 3
+	| PReg _ -> 4
+	| PBool _ -> 5
+	| PDouble _ -> 6
+	| PInt _ -> 7
+	| PStack _ -> 8
+	| PStack2 _ -> 9
+
+
+let opcodes = Hashtbl.create 0
+let opcodes_rev = Hashtbl.create 0
+let opcodes_names = Hashtbl.create 0
+
+let ( => ) code (op,name) =
+	Hashtbl.add opcodes op code;
+	Hashtbl.add opcodes_rev code op;
+	Hashtbl.add opcodes_names op name
+
+let short_op_codes = begin
+	0x00 => (AEnd,"END");
+	0x04 => (ANextFrame,"NEXTFRAME");
+	0x05 => (APrevFrame,"PREVFRAME");
+	0x06 => (APlay,"PLAY");
+	0x07 => (AStop,"STOP");
+	0x08 => (AToggleHighQuality,"TGLHIGHQULTY");
+	0x09 => (AStopSounds,"STOPSOUNDS");
+	0x0A => (AAddNum,"ADDNUM");
+	0x0B => (ASubtract,"SUB");
+	0x0C => (AMultiply,"MULT");
+	0x0D => (ADivide,"DIV");
+	0x0E => (ACompareNum,"CMP");
+	0x0F => (AEqualNum,"EQNUM");
+	0x10 => (ALogicalAnd,"LAND");
+	0x11 => (ALogicalOr,"LOR");
+	0x12 => (ANot,"NOT");
+	0x13 => (AStringEqual,"STREQ");
+	0x14 => (AStringLength,"STRLEN");
+	0x15 => (ASubString,"SUBSTR");
+	0x17 => (APop,"POP");
+	0x18 => (AToInt,"TOINT");
+	0x1C => (AEval,"EVAL");
+	0x1D => (ASet,"SET");
+	0x20 => (ATellTarget,"TELLTARGET");
+	0x21 => (AStringAdd,"STRADD");
+	0x22 => (AGetProperty,"GETPROP");
+	0x23 => (ASetProperty,"SETPROP");
+	0x24 => (ADuplicateMC,"DUPLICATEMC");
+	0x25 => (ARemoveMC,"REMOVEMC");
+	0x26 => (ATrace,"TRACE");
+	0x27 => (AStartDrag,"STARTDRAG");
+	0x28 => (AStopDrag,"STOPDRAG");
+	0x2A => (AThrow,"THROW");
+	0x2B => (ACast,"CAST");
+	0x2C => (AImplements,"IMPLEMENTS");
+	0x2D => (AFSCommand2,"FSCOMMAND2");
+	0x30 => (ARandom,"RANDOM");
+	0x31 => (AMBStringLength,"MBSTRLEN");
+	0x32 => (AOrd,"ORD");
+	0x33 => (AChr,"CHR");
+	0x34 => (AGetTimer,"GETTIMER");
+	0x35 => (AMBStringSub,"MBSTRSUB");
+	0x36 => (AMBOrd,"MBORD");
+	0x37 => (AMBChr,"MBCHR");
+	0x3A => (ADeleteObj,"DELETEOBJ");
+	0x3B => (ADelete,"DELETE");
+	0x3C => (ALocalAssign,"VARSET");
+	0x3D => (ACall,"CALL");
+	0x3E => (AReturn,"RET");
+	0x3F => (AMod,"MOD");
+	0x40 => (ANew,"NEW");
+	0x41 => (ALocalVar,"VAR");
+	0x42 => (AInitArray,"ARRAY");
+	0x43 => (AObject,"OBJECT");
+	0x44 => (ATypeOf,"TYPEOF");
+	0x45 => (ATargetPath,"TARGETPATH");
+	0x46 => (AEnum,"ENUM");
+	0x47 => (AAdd,"ADD");
+	0x48 => (ACompare,"CMP");
+	0x49 => (AEqual,"EQ");
+	0x4A => (AToNumber,"TONUMBER");
+	0x4B => (AToString,"TOSTRING");
+	0x4C => (ADup,"DUP");
+	0x4D => (ASwap,"SWAP");
+	0x4E => (AObjGet,"OBJGET");
+	0x4F => (AObjSet,"OBJSET");
+	0x50 => (AIncrement,"INCR");
+	0x51 => (ADecrement,"DECR");
+	0x52 => (AObjCall,"OBJCALL");
+	0x53 => (ANewMethod,"NEWMETHOD");
+	0x54 => (AInstanceOf,"INSTANCEOF");
+	0x55 => (AEnum2,"ENUM2");
+	0x60 => (AAnd,"AND");
+	0x61 => (AOr,"OR");
+	0x62 => (AXor,"XOR");
+	0x63 => (AShl,"SHL");
+	0x64 => (AShr,"SHR");
+	0x65 => (AAsr,"ASR");
+	0x66 => (APhysEqual,"PHYSEQ");
+	0x67 => (AGreater,"GT");
+	0x68 => (AStringGreater,"STRGT");
+	0x69 => (AExtends,"EXTENDS");
+	0x9E => (ACallFrame,"CALLFRAME"); (* special case *)
+
+end
+
+let action_id = function
+	| AGotoFrame _ -> 0x81
+	| AGetURL _ -> 0x83
+	| ASetReg _ -> 0x87
+	| AStringPool _ -> 0x88
+	| AWaitForFrame _ -> 0x8A
+	| ASetTarget _ -> 0x8B
+	| AGotoLabel _ -> 0x8C
+	| AWaitForFrame2 _ -> 0x8D
+	| AFunction2 _ -> 0x8E
+	| ATry _ -> 0x8F
+	| AWith _ -> 0x94
+	| APush _ -> 0x96
+	| AJump _ -> 0x99
+	| AGetURL2 _ -> 0x9A
+	| AFunction _ -> 0x9B
+	| ACondJump _ -> 0x9D
+	| AGotoFrame2 _ -> 0x9F
+	| AUnknown (id,_) -> id
+
+	| op ->
+		try
+			Hashtbl.find opcodes op
+		with
+			Not_found -> error "Unknown opcode id"
+
+let action_data_length = function
+	| AGotoFrame _ ->
+		2
+	| AGetURL (url,target) ->
+		2 + String.length url + String.length target
+	| ASetReg _ ->
+		1
+	| AStringPool strs ->
+		List.fold_left (fun acc item -> acc + 1 + String.length item) 2 strs
+	| AWaitForFrame _ ->
+		3
+	| AFunction2 f ->
+		let base = String.length f.f2_name + 1 + 2 + 1 + 2 + 2 in
+		List.fold_left (fun acc (_,s) -> acc + 2 + String.length s) base f.f2_args
+	| ASetTarget target ->
+		String.length target + 1
+	| AGotoLabel label ->
+		String.length label + 1
+	| AWaitForFrame2 _ ->
+		1
+	| ATry t ->
+		1 + 6 + (match t.tr_style with TryVariable n -> String.length n + 1 | TryRegister _ -> 1)
+	| AWith _ ->
+		2 (* the string does not count in length *)
+	| APush items ->
+		List.fold_left (fun acc item -> acc + 1 + push_item_length item) 0 items
+	| AJump _ ->
+		2
+	| AGetURL2 _ ->
+		1
+	| AFunction f ->
+		List.fold_left (fun acc s -> acc + 1 + String.length s) 4 (f.f_name :: f.f_args)
+	| ACondJump _ ->
+		2
+	| AGotoFrame2 (_,id) ->
+		1 + (if id = None then 0 else 2)
+	| AUnknown (_,data) ->
+		String.length data
+	| _ ->
+		0
+
+let action_length a =
+	let len = (if action_id a >= 0x80 then 3 else 1) in
+	len + action_data_length a
+
+let actions_length acts =
+	DynArray.fold_left (fun acc a -> acc + action_length a) (action_length AEnd) acts
+
+let read_mm_double ch =
+	let i1 = Int64.of_int32 (read_real_i32 ch) in
+	let i2 = Int64.of_int32 (read_real_i32 ch) in
+	let i2 = (if i2 < Int64.zero then Int64.add i2 (Int64.shift_left Int64.one 32) else i2) in
+	Int64.float_of_bits (Int64.logor i2 (Int64.shift_left i1 32))
+
+let write_mm_double ch f =
+	let i64 = Int64.bits_of_float f in
+	write_real_i32 ch (Int64.to_int32 (Int64.shift_right_logical i64 32));
+	write_real_i32 ch (Int64.to_int32 i64)
+
+let read_string_max ch len =
+	let b = Buffer.create 0 in
+	let rec loop l =
+		if l = 0 then begin
+			let s = Buffer.contents b in
+			String.sub s 0 (String.length s - 1)
+		end else
+			let c = read ch in
+			if c = '\000' then
+				Buffer.contents b
+			else begin
+				Buffer.add_char b c;
+				loop (l - 1)
+			end;
+	in
+	loop len
+
+let parse_push_item ch len =
+	let id = read_byte ch in
+	match id with
+	| 0 -> PString (read_string_max ch len)
+	| 1 -> PFloat (read_real_i32 ch)
+	| 2 -> PNull
+	| 3 -> PUndefined
+	| 4 -> PReg (read_byte ch)
+	| 5 -> PBool (read_byte ch <> 0)
+	| 6 -> PDouble (read_mm_double ch)
+	| 7 -> PInt (read_real_i32 ch)
+	| 8 -> PStack (read_byte ch)
+	| 9 -> PStack2 (read_ui16 ch)
+	| _ -> error (sprintf "Unknown PUSH item id : %d" id)
+
+let rec parse_push_items ch len =
+	if len < 0 then error "PUSH parse overflow";
+	if len = 0 then
+		 []
+	else
+		let item = parse_push_item ch len in
+		item :: parse_push_items ch (len - 1 - push_item_length item)
+
+let rec read_strings ch n =
+	if n = 0 then
+		[]
+	else
+		let s = read_string ch in
+		s :: read_strings ch (n-1)
+
+let parse_function_decl ch =
+	let name = read_string ch in
+	let nargs = read_ui16 ch in
+	let args = read_strings ch nargs in
+	let clen = read_ui16 ch in
+	{
+		f_name = name;
+		f_args = args;
+		f_codelen = clen;
+	}
+
+let parse_f2_flags n =
+	let flags = ref [] in
+	let v = ref 1 in
+	let add_flag f =
+		if n land !v <> 0 then flags := f :: !flags;
+		v := !v lsl 1
+	in
+	List.iter add_flag
+		[ThisRegister; ThisNoVar; ArgumentsRegister; ArgumentsNoVar; SuperRegister;
+		 SuperNoVar; RootRegister; ParentRegister; GlobalRegister];
+	!flags
+
+let parse_function_decl2 ch =
+	let name = read_string ch in
+	let nargs = read_ui16 ch in
+	let nregs = read_byte ch in
+	let flags = parse_f2_flags (read_ui16 ch) in
+	let rec loop n =
+		if n = 0 then
+			[]
+		else
+			let r = read_byte ch in
+			let s = read_string ch in
+			(r,s) :: loop (n-1)
+	in
+	let args = loop nargs in
+	let clen = read_ui16 ch in
+	{
+		f2_name = name;
+		f2_args = args;
+		f2_flags = flags;
+		f2_codelen = clen;
+		f2_nregs = nregs;
+	}
+
+
+let parse_action ch =
+	let id = read_byte ch in
+	let len = (if id >= 0x80 then read_ui16 ch else 0) in
+	let len = (if len = 0xFFFF then 0 else len) in
+	let act =
+		(match id with
+		| 0x81 ->
+			AGotoFrame (read_ui16 ch)
+		| 0x83 ->
+			let url = read_string ch in
+			let target = read_string ch in
+			AGetURL (url,target)
+		| 0x87 ->
+			ASetReg (read_byte ch)
+		| 0x88 ->
+			let nstrs = read_ui16 ch in
+			AStringPool (read_strings ch nstrs)
+		| 0x8A ->
+			let frame = read_ui16 ch in
+			let skip = read_byte ch in
+			AWaitForFrame (frame,skip)
+		| 0x8B ->
+			ASetTarget (read_string ch)
+		| 0x8C ->
+			AGotoLabel (read_string ch)
+		| 0x8D ->
+			AWaitForFrame2 (read_byte ch)
+		| 0x8E ->
+			AFunction2 (parse_function_decl2 ch)
+		| 0x8F ->
+			let flags = read_byte ch in
+			let tsize = read_ui16 ch in
+			let csize = read_ui16 ch in
+			let fsize = read_ui16 ch in
+			let tstyle = (if flags land 4 == 0 then TryVariable (read_string ch) else TryRegister (read_byte ch)) in
+			ATry {
+				tr_style = tstyle;
+				tr_trylen = tsize;
+				tr_catchlen = (if flags land 1 == 0 then None else Some csize);
+				tr_finallylen = (if flags land 2 == 0 then None else Some fsize);
+			}
+		| 0x94 ->
+			let size = read_ui16 ch in
+			AWith size
+		| 0x96 ->
+			APush (parse_push_items ch len)
+		| 0x99 ->
+			AJump (read_i16 ch)
+		| 0x9A ->
+			AGetURL2 (read_byte ch)
+		| 0x9B ->
+			AFunction (parse_function_decl ch)
+		| 0x9D ->
+			ACondJump (read_i16 ch)
+		| 0x9E ->
+			ACallFrame
+		| 0x9F ->
+			let flags = read_byte ch in
+			let play = flags land 1 <> 0 in
+			let delta = (if flags land 2 == 0 then None else Some (read_ui16 ch)) in
+			AGotoFrame2 (play,delta)
+		| _ ->
+			try
+				Hashtbl.find opcodes_rev id
+			with
+				Not_found ->
+					printf "Unknown Action 0x%.2X (%d)\n" id len;
+					AUnknown (id,nread ch len)
+	) in
+(*	let len2 = action_data_length act in
+	if len <> len2 then error (sprintf "Datalen mismatch for action 0x%.2X (%d != %d)" id len len2);
+*)	act
+
+let size_to_jump_index acts curindex size =
+	let delta = ref 0 in
+	let size = ref size in
+	if !size >= 0 then begin
+		while !size > 0 do
+			incr delta;
+			size := !size - action_length (DynArray.get acts (curindex + !delta));
+			if !size < 0 then error "Unaligned code";
+		done;
+	end else begin
+		while !size < 0 do
+			size := !size + action_length (DynArray.get acts (curindex + !delta));
+			if !size > 0 then error "Unaligned code";
+			decr delta;
+		done;
+	end;
+	!delta
+
+let parse_actions ch =
+	let acts = DynArray.create() in
+	let rec loop() =
+		match parse_action ch with
+		| AEnd -> ()
+		| AUnknown (0xFF,"") ->
+			DynArray.add acts APlay;
+			DynArray.add acts APlay;
+			DynArray.add acts APlay;
+			loop()
+		| a ->
+			DynArray.add acts a;
+			loop();
+	in
+	loop();
+	(* process jump indexes *)
+	let process_jump curindex = function
+		| AJump size ->
+			let index = size_to_jump_index acts curindex size in
+			DynArray.set acts curindex (AJump index)
+		| ACondJump size ->
+			let index = size_to_jump_index acts curindex size in
+			DynArray.set acts curindex (ACondJump index)
+		| AFunction f ->
+			let index = size_to_jump_index acts curindex f.f_codelen in
+			DynArray.set acts curindex (AFunction { f with f_codelen = index })
+		| AFunction2 f ->
+			let index = size_to_jump_index acts curindex f.f2_codelen in
+			DynArray.set acts curindex (AFunction2 { f with f2_codelen = index })
+		| AWith size ->
+			let index = size_to_jump_index acts curindex size in
+			DynArray.set acts curindex (AWith index)
+		| ATry t ->
+			let tindex = size_to_jump_index acts curindex t.tr_trylen in
+			let cindex = (match t.tr_catchlen with None -> None | Some size -> Some (size_to_jump_index acts (curindex + tindex) size)) in
+			let findex = (match t.tr_finallylen with None -> None | Some size -> Some (size_to_jump_index acts (curindex + tindex + (match cindex with None -> 0 | Some i -> i)) size)) in
+			DynArray.set acts curindex (ATry { t with tr_trylen = tindex; tr_catchlen = cindex; tr_finallylen = findex })
+		| _ ->
+			()
+	in
+	DynArray.iteri process_jump acts;
+	acts
+
+let jump_index_to_size acts curindex target =
+	let size = ref 0 in
+	if target >= 0 then begin
+		for i = 1 to target do
+			size := !size + action_length (DynArray.get acts (curindex + i));
+		done;
+	end else begin
+		for i = 0 downto target+1 do
+			size := !size - action_length (DynArray.get acts (curindex + i));
+		done;
+	end;
+	!size
+
+let rec write_strings ch = function
+	| [] -> ()
+	| s :: l ->
+		write_string ch s;
+		write_strings ch l
+
+let write_push_item_data ch = function
+	| PString s -> write_string ch s
+	| PFloat f -> write_real_i32 ch f
+	| PNull -> ()
+	| PUndefined -> ()
+	| PReg r -> write_byte ch r
+	| PBool b -> write_byte ch (if b then 1 else 0)
+	| PDouble f -> write_mm_double ch f
+	| PInt n -> write_real_i32 ch n
+	| PStack index -> write_byte ch index
+	| PStack2 index -> write_ui16 ch index
+
+let f2_flags_value flags =
+	let fval = function
+		| ThisRegister -> 1
+		| ThisNoVar -> 2
+		| ArgumentsRegister -> 4
+		| ArgumentsNoVar -> 8
+		| SuperRegister -> 16
+		| SuperNoVar -> 32
+		| RootRegister -> 64
+		| ParentRegister -> 128
+		| GlobalRegister -> 256
+	in
+	List.fold_left (fun n f -> n lor (fval f)) 0 flags
+
+let write_action_data acts curindex ch = function
+	| AGotoFrame frame ->
+		write_ui16 ch frame
+	| AGetURL (url,target) ->
+		write_string ch url;
+		write_string ch target
+	| ASetReg reg ->
+		write_byte ch reg
+	| AStringPool strs ->
+		write_ui16 ch (List.length strs);
+		write_strings ch strs
+	| AWaitForFrame (frame,skip) ->
+		write_ui16 ch frame;
+		write_byte ch skip
+	| ASetTarget target ->
+		write_string ch target
+	| AGotoLabel label ->
+		write_string ch label
+	| AWaitForFrame2 n ->
+		write_byte ch n
+	| AFunction2 f ->
+		write_string ch f.f2_name;
+		write_ui16 ch (List.length f.f2_args);
+		write_byte ch f.f2_nregs;
+		write_ui16 ch (f2_flags_value f.f2_flags);
+		List.iter (fun (r,s) ->
+			write_byte ch r;
+			write_string ch s;
+		) f.f2_args;
+		let size = jump_index_to_size acts curindex f.f2_codelen in
+		write_ui16 ch size;
+	| ATry t ->
+		let tsize = jump_index_to_size acts curindex t.tr_trylen in
+		let csize = (match t.tr_catchlen with None -> 0 | Some idx -> jump_index_to_size acts (curindex + t.tr_trylen) idx) in
+		let fsize = (match t.tr_finallylen with None -> 0 | Some idx -> jump_index_to_size acts (curindex + t.tr_trylen + (match t.tr_catchlen with None -> 0 | Some n -> n)) idx) in
+		let flags = (if t.tr_catchlen <> None then 1 else 0) lor (if t.tr_finallylen <> None then 2 else 0) lor (match t.tr_style with TryRegister _ -> 4 | TryVariable _ -> 0) in
+		write_byte ch flags;
+		write_ui16 ch tsize;
+		write_ui16 ch csize;
+		write_ui16 ch fsize;
+		(match t.tr_style with
+		| TryVariable v -> write_string ch v
+		| TryRegister r -> write_byte ch r)
+	| AWith target ->
+		let size = jump_index_to_size acts curindex target in
+		write_ui16 ch size
+	| APush items ->
+		List.iter (fun item ->
+			write_byte ch (push_item_id item);
+			write_push_item_data ch item
+		) items
+	| AJump target ->
+		let size = jump_index_to_size acts curindex target in
+		write_i16 ch size
+	| AGetURL2 n ->
+		write_byte ch n
+	| AFunction f ->
+		write_string ch f.f_name;
+		write_ui16 ch (List.length f.f_args);
+		write_strings ch f.f_args;
+		let size = jump_index_to_size acts curindex f.f_codelen in
+		write_ui16 ch size;
+	| ACondJump target ->
+		let size = jump_index_to_size acts curindex target in
+		write_i16 ch size;
+	| AGotoFrame2 (play,None) ->
+		write_byte ch (if play then 1 else 0)
+	| AGotoFrame2 (play,Some delta) ->
+		write_byte ch (if play then 3 else 2);
+		write_ui16 ch delta;
+	| ACallFrame ->
+		()
+	| AUnknown (_,data) ->
+		nwrite ch data
+	| _ ->
+		assert false
+
+let write_action acts curindex ch a =
+	let id = action_id a in
+	let len = action_data_length a in
+	if id < 0x80 && len > 0 then error "Invalid Action Written";
+	write_byte ch id;
+	if len > 0 || id >= 0x80 then begin
+		write_ui16 ch len;
+		write_action_data acts curindex ch a;
+	end
+
+let write_actions ch acts =
+	DynArray.iteri (fun index act -> write_action acts index ch act) acts;
+	write_action acts (DynArray.length acts) ch AEnd
+
+let sprintf = Printf.sprintf
+
+let action_string get_ident pos = function
+	| AGotoFrame n -> sprintf "GOTOFRAME %d" n
+	| AGetURL (a,b) -> sprintf "GETURL '%s' '%s'" a b
+	| ASetReg n -> sprintf "SETREG %d" n
+	| AStringPool strlist ->
+		let b = Buffer.create 0 in
+		Buffer.add_string b "STRINGS ";
+		let p = ref 0 in
+		List.iter (fun s ->
+			Buffer.add_string b (string_of_int !p);
+			incr p;
+			Buffer.add_char b ':';
+			Buffer.add_string b s;
+			Buffer.add_char b ' ';
+		) strlist;
+		Buffer.contents b
+	| AWaitForFrame (i,j) -> sprintf "WAITFORFRAME %d %d" i j
+	| ASetTarget s -> sprintf "SETTARGET %s" s
+	| AGotoLabel s -> sprintf "GOTOLABEL %s" s
+	| AWaitForFrame2 n -> sprintf "WAITFORFRAME2 %d" n
+	| AFunction2 f ->
+		let b = Buffer.create 0 in
+		Buffer.add_string b "FUNCTION2 ";
+		Buffer.add_string b f.f2_name;
+		Buffer.add_char b '(';
+		Buffer.add_string b (String.concat "," (List.map (fun (n,str) -> sprintf "%d:%s" n str) f.f2_args));
+		Buffer.add_char b ')';
+		Buffer.add_string b (sprintf " nregs:%d flags:%d " f.f2_nregs (f2_flags_value f.f2_flags));
+		Buffer.add_string b (sprintf "0x%.4X" (pos + 1 + f.f2_codelen));
+		Buffer.contents b
+	| APush pl ->
+		let b = Buffer.create 0 in
+		Buffer.add_string b "PUSH";
+		List.iter (fun it ->
+			Buffer.add_char b ' ';
+			match it with
+			| PString s ->
+				Buffer.add_char b '"';
+				Buffer.add_string b s;
+				Buffer.add_char b '"'
+			| PFloat _ ->
+				Buffer.add_string b "<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,329 @@
+(*
+ *  This file is part of SwfLib
+ *  Copyright (c)2004-2006 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+type 'a index
+type 'a index_nz
+
+type as3_ident = string
+type as3_int = int32
+type as3_uint = int32
+type as3_float = float
+type as3_slot = int
+
+type reg = int
+type nargs = int
+
+type as3_jump =
+	| J3NotLt
+	| J3NotLte
+	| J3NotGt
+	| J3NotGte
+	| J3Always
+	| J3True
+	| J3False
+	| J3Eq
+	| J3Neq
+	| J3Lt
+	| J3Lte
+	| J3Gt
+	| J3Gte
+	| J3PhysEq
+	| J3PhysNeq
+
+type as3_op =
+	| A3OAs
+	| A3ONeg
+	| A3OIncr
+	| A3ODecr
+	| A3ONot
+	| A3OBitNot
+	| A3OAdd
+	| A3OSub
+	| A3OMul
+	| A3ODiv
+	| A3OMod
+	| A3OShl
+	| A3OShr
+	| A3OUShr
+	| A3OAnd
+	| A3OOr
+	| A3OXor
+	| A3OEq
+	| A3OPhysEq
+	| A3OLt
+	| A3OLte
+	| A3OGt
+	| A3OGte
+	| A3OIs
+	| A3OIn
+	| A3OIIncr
+	| A3OIDecr
+	| A3OINeg
+	| A3OIAdd
+	| A3OISub
+	| A3OIMul
+	| A3OMemSet8
+	| A3OMemSet16
+	| A3OMemSet32
+	| A3OMemSetFloat
+	| A3OMemSetDouble
+	| A3OMemGet8
+	| A3OMemGet16
+	| A3OMemGet32
+	| A3OMemGetFloat
+	| A3OMemGetDouble
+	| A3OSign1
+	| A3OSign8
+	| A3OSign16
+
+type as3_name = as3_multi_name index
+
+and as3_opcode =
+	| A3BreakPoint
+	| A3Nop
+	| A3Throw
+	| A3GetSuper of as3_name
+	| A3SetSuper of as3_name
+	| A3DxNs of as3_ident index
+	| A3DxNsLate
+	| A3RegKill of reg
+	| A3Label
+	| A3Jump of as3_jump * int
+	| A3Switch of int * int list
+	| A3PushWith
+	| A3PopScope
+	| A3ForIn
+	| A3HasNext
+	| A3Null
+	| A3Undefined
+	| A3ForEach
+	| A3SmallInt of int
+	| A3Int of int
+	| A3True
+	| A3False
+	| A3NaN
+	| A3Pop
+	| A3Dup
+	| A3Swap
+	| A3String of as3_ident index
+	| A3IntRef of as3_int index
+	| A3UIntRef of as3_uint index
+	| A3Float of as3_float index
+	| A3Scope
+	| A3Namespace of as3_namespace index
+	| A3Next of reg * reg
+	| A3Function of as3_method_type index_nz
+	| A3CallStack of nargs
+	| A3Construct of nargs
+	| A3CallMethod of as3_slot * nargs
+	| A3CallStatic of as3_method_type index * nargs
+	| A3CallSuper of as3_name * nargs
+	| A3CallProperty of as3_name * nargs
+	| A3RetVoid
+	| A3Ret
+	| A3ConstructSuper of nargs
+	| A3ConstructProperty of as3_name * nargs
+	| A3CallPropLex of as3_name * nargs
+	| A3CallSuperVoid of as3_name * nargs
+	| A3CallPropVoid of as3_name * nargs
+	| A3ApplyType of nargs
+	| A3Object of nargs
+	| A3Array of nargs
+	| A3NewBlock
+	| A3ClassDef of unit index_nz
+	| A3GetDescendants of as3_name
+	| A3Catch of int
+	| A3FindPropStrict of as3_name
+	| A3FindProp of as3_name
+	| A3FindDefinition of as3_name
+	| A3GetLex of as3_name
+	| A3SetProp of as3_name
+	| A3Reg of reg
+	| A3SetReg of reg
+	| A3GetGlobalScope
+	| A3GetScope of int
+	| A3GetProp of as3_name
+	| A3InitProp of as3_name
+	| A3DeleteProp of as3_name
+	| A3GetSlot of as3_slot
+	| A3SetSlot of as3_slot
+	| A3ToString
+	| A3ToXml
+	| A3ToXmlAttr
+	| A3ToInt
+	| A3ToUInt
+	| A3ToNumber
+	| A3ToBool
+	| A3ToObject
+	| A3CheckIsXml
+	| A3Cast of as3_name
+	| A3AsAny
+	| A3AsString
+	| A3AsType of as3_name
+	| A3AsObject
+	| A3IncrReg of reg
+	| A3DecrReg of reg
+	| A3Typeof
+	| A3InstanceOf
+	| A3IsType of as3_name
+	| A3IncrIReg of reg
+	| A3DecrIReg of reg
+	| A3This
+	| A3SetThis
+	| A3DebugReg of as3_ident index * reg * int
+	| A3DebugLine of int
+	| A3DebugFile of as3_ident index
+	| A3BreakPointLine of int
+	| A3Timestamp
+	| A3Op of as3_op
+	| A3Unk of char
+
+and as3_namespace =
+	| A3NPrivate of as3_ident index option
+	| A3NPublic of as3_ident index option
+	| A3NInternal of as3_ident index option
+	| A3NProtected of as3_ident index
+	| A3NNamespace of as3_ident index
+	| A3NExplicit of as3_ident index
+	| A3NStaticProtected of as3_ident index option
+
+and as3_ns_set = as3_namespace index list
+
+and as3_multi_name =
+	| A3MName of as3_ident index * as3_namespace index
+	| A3MMultiName of as3_ident index option * as3_ns_set index
+	| A3MRuntimeName of as3_ident index
+	| A3MRuntimeNameLate
+	| A3MMultiNameLate of as3_ns_set index
+	| A3MAttrib of as3_multi_name
+	| A3MParams of as3_multi_name index * as3_multi_name index list
+	| 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 array;
+	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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+open IO
+open As3
+
+let s = Printf.sprintf
+
+let f_int_length : (int -> int) ref = ref (fun _ -> assert false)
+let f_int_read : (IO.input -> int) ref = ref (fun _ -> assert false)
+let f_int_write : (unit IO.output -> int -> unit) ref = ref (fun _ _ -> assert false)
+
+let int_length i = (!f_int_length) i
+let read_int ch = (!f_int_read) ch
+let write_int (ch : 'a IO.output) i = (!f_int_write) (Obj.magic ch) i
+
+let int_index (x : 'a index) : int = Obj.magic x
+let index_int (x : int) : 'a index = Obj.magic x
+let int_index_nz (x : 'a index_nz) : int = Obj.magic x
+let index_nz_int (x : int) : 'a index_nz = Obj.magic x
+
+let read_index ch = index_int (read_int ch)
+let write_index ch i = write_int ch (int_index i)
+
+let read_index_nz ch = index_nz_int (read_int ch)
+let write_index_nz ch i = write_int ch (int_index_nz i)
+
+let iget (t : 'a array) (i : 'a index) : 'a =
+	t.(Obj.magic i - 1)
+
+let write_signed_byte = write_byte
+
+let max_i24 = 1 lsl 23 - 1
+
+let read_i24 ch =
+	let a = read_byte ch in
+	let b = read_byte ch in
+	let c = read_byte ch in
+	let n = a lor (b lsl 8) lor (c lsl 16) in
+	if c land 128 <> 0 then
+		n - (1 lsl 24)
+	else
+		n
+
+let rec write_i24 ch n =
+	if n < -max_i24 || n > max_i24 then assert false;
+	let n = (if n land (1 lsl 23) <> 0 then n + (1 lsl 24) else n) in
+	write_byte ch n;
+	write_byte ch (n lsr 8);
+	write_byte ch (n lsr 16)
+
+let ops , ops_ids =
+	let h = Hashtbl.create 0 in
+	let h2 = Hashtbl.create 0 in
+	List.iter (fun (o,b) -> Hashtbl.add h b o; Hashtbl.add h2 o b)
+	[
+		A3OAs, 0x87;
+		A3ONeg, 0x90;
+		A3OIncr, 0x91;
+		(* 0x92 : REGINCR *)
+		A3ODecr, 0x93;
+		(* 0x94 : REGDECR *)
+		(* 0x95 : TYPEOF *)
+		A3ONot, 0x96;
+		A3OBitNot, 0x97;
+		A3OAdd, 0xA0;
+		A3OSub, 0xA1;
+		A3OMul, 0xA2;
+		A3ODiv, 0xA3;
+		A3OMod, 0xA4;
+		A3OShl, 0xA5;
+		A3OShr, 0xA6;
+		A3OUShr, 0xA7;
+		A3OAnd, 0xA8;
+		A3OOr, 0xA9;
+		A3OXor, 0xAA;
+		A3OEq, 0xAB;
+		A3OPhysEq, 0xAC;
+		A3OLt, 0xAD;
+		A3OLte, 0xAE;
+		A3OGt, 0xAF;
+		A3OGte, 0xB0;
+		A3OIs, 0xB3;
+		A3OIn, 0xB4;
+		A3OIIncr, 0xC0;
+		A3OIDecr, 0xC1;
+		A3OINeg, 0xC4;
+		A3OIAdd, 0xC5;
+		A3OISub, 0xC6;
+		A3OIMul, 0xC7;
+		A3OMemGet8, 0x35;
+		A3OMemGet16, 0x36;
+		A3OMemGet32, 0x37;
+		A3OMemGetFloat, 0x38;
+		A3OMemGetDouble, 0x39;
+		A3OMemSet8, 0x3A;
+		A3OMemSet16, 0x3B;
+		A3OMemSet32, 0x3C;
+		A3OMemSetFloat, 0x3D;
+		A3OMemSetDouble, 0x3E;
+		A3OSign1, 0x50;
+		A3OSign8, 0x51;
+		A3OSign16, 0x52;
+	];
+	h , h2
+
+let length = function
+	| A3SmallInt _ -> 2
+	| A3Construct n
+	| A3Object n
+	| A3RegKill n
+	| A3Catch n
+	| A3IncrReg n
+	| A3DecrReg n
+	| A3IncrIReg n
+	| A3DecrIReg n
+	| A3Array n
+	| A3Int n
+	| A3CallStack n
+	| A3ConstructSuper n
+	| A3BreakPointLine n
+	| A3ApplyType n
+	| A3DebugLine n ->
+		1 + int_length n
+	| A3GetSlot s
+	| A3SetSlot s ->
+		1 + int_length s
+	| A3ClassDef n ->
+		1 + int_length (int_index_nz n)
+	| A3DxNs f
+	| A3String f
+	| A3DebugFile f ->
+		1 + int_length (int_index f)
+	| A3IntRef f ->
+		1 + int_length (int_index f)
+	| A3UIntRef f ->
+		1 + int_length (int_index f)
+	| A3Float f ->
+		1 + int_length (int_index f)
+	| A3Function f ->
+		1 + int_length (int_index_nz f)
+	| A3Namespace f ->
+		1 + int_length (int_index f)
+	| A3GetProp f
+	| A3InitProp f
+	| A3DeleteProp f
+	| A3FindPropStrict f
+	| A3FindProp f
+	| A3FindDefinition f
+	| A3GetLex f
+	| A3SetProp f
+	| A3Cast f
+	| A3GetSuper f
+	| A3GetDescendants f
+	| A3SetSuper f ->
+		1 + int_length (int_index f)
+	| A3Op _
+	| A3Undefined
+	| A3Null
+	| A3True
+	| A3False
+	| A3NaN
+	| A3RetVoid
+	| A3Ret
+	| A3Pop
+	| A3Dup
+	| A3Swap
+	| A3AsAny
+	| A3ToString
+	| A3ToXml
+	| A3ToXmlAttr
+	| A3ToInt
+	| A3ToUInt
+	| A3ToNumber
+	| A3ToBool
+	| A3ToObject
+	| A3AsString
+	| A3AsObject
+	| A3This
+	| A3Throw
+	| A3Nop
+	| A3Typeof
+	| A3InstanceOf
+	| A3Scope
+	| A3ForIn
+	| A3NewBlock
+	| A3ForEach
+	| A3PopScope
+	| A3CheckIsXml
+	| A3Label
+	| A3BreakPoint
+	| A3PushWith
+	| A3HasNext
+	| A3SetThis
+	| A3Timestamp
+	| A3DxNsLate
+	| A3Unk _ -> 1
+	| A3AsType n | A3IsType n ->
+		1 + int_length (int_index n)
+	| A3DebugReg (name,reg,line) -> 1 + 1 + int_length (int_index name) + 1 + int_length line
+	| A3GetGlobalScope -> 1
+	| A3GetScope n -> 1 + int_length n
+	| A3Reg n | A3SetReg n -> if n >= 1 && n <= 3 then 1 else (1 + int_length n)
+	| A3CallSuper (f,n) | A3CallProperty (f,n) | A3ConstructProperty (f,n) | A3CallPropLex (f,n) | A3CallPropVoid (f,n) | A3CallSuperVoid (f,n) ->
+		1 + int_length n + int_length (int_index f)
+	| A3CallMethod (f,n) ->
+		1 + int_length n + int_length f
+	| A3CallStatic (f,n) ->
+		1 + int_length n + int_length (int_index f)
+	| A3Jump _ -> 4
+	| A3Next (a,b) -> 1 + int_length a + int_length b
+	| A3Switch (_,cases) ->
+		let ncases = List.length cases in
+		1 + 3 + int_length (ncases - 1) + 3 * ncases
+
+let jump ch kind =
+	A3Jump (kind,read_i24 ch)
+
+let opcode ch =
+	let op = (try read_byte ch with IO.No_more_input -> raise Exit) in
+	match op with
+	| 0x01 -> A3BreakPoint
+	| 0x02 -> A3Nop
+	| 0x03 -> A3Throw
+	| 0x04 -> A3GetSuper (read_index ch)
+	| 0x05 -> A3SetSuper (read_index ch)
+	| 0x06 -> A3DxNs (read_index ch)
+	| 0x07 -> A3DxNsLate
+	| 0x08 -> A3RegKill (read_int ch)
+	| 0x09 -> A3Label
+	(* 0x0A -> NONE *)
+	(* 0x0B -> NONE *)
+	| 0x0C -> jump ch J3NotLt
+	| 0x0D -> jump ch J3NotLte
+	| 0x0E -> jump ch J3NotGt
+	| 0x0F -> jump ch J3NotGte
+	| 0x10 -> jump ch J3Always
+	| 0x11 -> jump ch J3True
+	| 0x12 -> jump ch J3False
+	| 0x13 -> jump ch J3Eq
+	| 0x14 -> jump ch J3Neq
+	| 0x15 -> jump ch J3Lt
+	| 0x16 -> jump ch J3Lte
+	| 0x17 -> jump ch J3Gt
+	| 0x18 -> jump ch J3Gte
+	| 0x19 -> jump ch J3PhysEq
+	| 0x1A -> jump ch J3PhysNeq
+	| 0x1B ->
+		let def = read_i24 ch in
+		let rec loop n =
+			if n = 0 then
+				[]
+			else
+				let j = read_i24 ch in
+				j :: loop (n - 1)
+		in
+		let cases = loop (read_int ch + 1) in
+		A3Switch (def,cases)
+	| 0x1C -> A3PushWith
+	| 0x1D -> A3PopScope
+	| 0x1E -> A3ForIn
+	| 0x1F -> A3HasNext
+	| 0x20 -> A3Null
+	| 0x21 -> A3Undefined
+	(* 0x22 -> NONE *)
+	| 0x23 -> A3ForEach
+	| 0x24 -> A3SmallInt (read_signed_byte ch)
+	| 0x25 -> A3Int (read_int ch)
+	| 0x26 -> A3True
+	| 0x27 -> A3False
+	| 0x28 -> A3NaN
+	| 0x29 -> A3Pop
+	| 0x2A -> A3Dup
+	| 0x2B -> A3Swap
+	| 0x2C -> A3String (read_index ch)
+	| 0x2D -> A3IntRef (read_index ch)
+	| 0x2E -> A3UIntRef (read_index ch)
+	| 0x2F -> A3Float (read_index ch)
+	| 0x30 -> A3Scope
+	| 0x31 -> A3Namespace (read_index ch)
+	| 0x32 ->
+		let r1 = read_int ch in
+		let r2 = read_int ch in
+		A3Next (r1,r2)
+	(* 0x33 - 0x3F -> NONE *)
+	| 0x40 -> A3Function (read_index_nz ch)
+	| 0x41 -> A3CallStack (read_int ch)
+	| 0x42 -> A3Construct (read_int ch)
+	| 0x43 ->
+		let id = read_int ch in
+		let nargs = read_int ch in
+		A3CallMethod (id,nargs)
+	| 0x44 ->
+		let id = read_index ch in
+		let nargs = read_int ch in
+		A3CallStatic (id,nargs)
+	| 0x45 ->
+		let id = read_index ch in
+		let nargs = read_int ch in
+		A3CallSuper (id,nargs)
+	| 0x46 ->
+		let id = read_index ch in
+		let nargs = read_int ch in
+		A3CallProperty (id,nargs)
+	| 0x47 -> A3RetVoid
+	| 0x48 -> A3Ret
+	| 0x49 -> A3ConstructSuper (read_int ch)
+	| 0x4A ->
+		let id = read_index ch in
+		let nargs = read_int ch in
+		A3ConstructProperty (id,nargs)
+	(* 0x4B -> NONE *)
+	| 0x4C ->
+		let id = read_index ch in
+		let nargs = read_int ch in
+		A3CallPropLex (id,nargs)
+	(* 0x4D -> NONE *)
+	| 0x4E ->
+		let id = read_index ch in
+		let nargs = read_int ch in
+		A3CallSuperVoid (id,nargs)
+	| 0x4F ->
+		let id = read_index ch in
+		let nargs = read_int ch in
+		A3CallPropVoid (id,nargs)
+	(* 0x50 - 0x52 -> NONE *)
+	| 0x53 -> A3ApplyType (read_int ch)
+	(* 0x54 -> NONE *)
+	| 0x55 -> A3Object (read_int ch)
+	| 0x56 -> A3Array (read_int ch)
+	| 0x57 -> A3NewBlock
+	| 0x58 -> A3ClassDef (read_index_nz ch)
+	| 0x59 -> A3GetDescendants (read_index ch)
+	| 0x5A -> A3Catch (read_int ch)
+	(* 0x5B -> NONE *)
+	(* 0x5C -> NONE *)
+	| 0x5D -> A3FindPropStrict (read_index ch)
+	| 0x5E -> A3FindProp (read_index ch)
+	| 0x5F -> A3FindDefinition (read_index ch)
+	| 0x60 -> A3GetLex (read_index ch)
+	| 0x61 -> A3SetProp (read_index ch)
+	| 0x62 -> A3Reg (read_int ch)
+	| 0x63 -> A3SetReg (read_int ch)
+	| 0x64 -> A3GetGlobalScope
+	| 0x65 -> A3GetScope (IO.read_byte ch)
+	| 0x66 -> A3GetProp (read_index ch)
+	(* 0x67 -> NONE *)
+	| 0x68 -> A3InitProp (read_index ch)
+	(* 0x69 -> NONE *)
+	| 0x6A -> A3DeleteProp (read_index ch)
+	(* 0x6B -> NONE *)
+	| 0x6C -> A3GetSlot (read_int ch)
+	| 0x6D -> A3SetSlot (read_int ch)
+	(* 0x6E -> DEPRECATED getglobalslot *)
+	(* 0x6F -> DEPRECATED setglobalslot *)
+	| 0x70 -> A3ToString
+	| 0x71 -> A3ToXml
+	| 0x72 -> A3ToXmlAttr
+	| 0x73 -> A3ToInt
+	| 0x74 -> A3ToUInt
+	| 0x75 -> A3ToNumber
+	| 0x76 -> A3ToBool
+	| 0x77 -> A3ToObject
+	| 0x78 -> A3CheckIsXml
+	(* 0x79 -> NONE *)
+	| 0x80 -> A3Cast (read_index ch)
+	(* 0x81 -> DEPRECATED asbool *)
+	| 0x82 -> A3AsAny
+	(* 0x83 -> DEPRECATED asint *)
+	(* 0x84 -> DEPRECATED asnumber *)
+	| 0x85 -> A3AsString
+	| 0x86 -> A3AsType (read_index ch)
+	(* 0x87 -> OP *)
+	(* 0x88 -> DEPRECATED asuint *)
+	| 0x89 -> A3AsObject
+	(* 0x8A - 0x8F -> NONE *)
+	(* 0x90 - 0x91 -> OP *)
+	| 0x92 -> A3IncrReg (read_int ch)
+	(* 0x93 -> OP *)
+	| 0x94 -> A3DecrReg (read_int ch)
+	| 0x95 -> A3Typeof
+	(* 0x96 -> OP *)
+	(* 0x97 -> OP *)
+	(* 0x98 - 0x9F -> NONE *)
+	(* 0xA0 - 0xB0 -> OP *)
+	| 0xB1 -> A3InstanceOf
+	| 0xB2 -> A3IsType (read_index ch)
+	(* 0xB3 -> OP *)
+	(* 0xB4 -> OP *)
+	(* 0xB5 - 0xBF -> NONE *)
+	(* 0xC0 -> OP *)
+	(* 0xC1 -> OP *)
+	| 0xC2 -> A3IncrIReg (read_int ch)
+	| 0xC3 -> A3DecrIReg (read_int ch)
+	(* 0xC4 - 0xC7 -> OP *)
+	(* 0xC8 - 0xCF -> NONE *)
+	| 0xD0 -> A3This
+	| 0xD1 -> A3Reg 1
+	| 0xD2 -> A3Reg 2
+	| 0xD3 -> A3Reg 3
+	| 0xD4 -> A3SetThis
+	| 0xD5 -> A3SetReg 1
+	| 0xD6 -> A3SetReg 2
+	| 0xD7 -> A3SetReg 3
+	(* 0xD8 - 0xEE -> NONE *)
+	| 0xEF ->
+		if IO.read_byte ch <> 1 then assert false;
+		let name = read_index ch in
+		let reg = read_byte ch + 1 in
+		let line = read_int ch in
+		A3DebugReg (name,reg,line)
+	| 0xF0 -> A3DebugLine (read_int ch)
+	| 0xF1 -> A3DebugFile (read_index ch)
+	| 0xF2 -> A3BreakPointLine (read_int ch)
+	| 0xF3 -> A3Timestamp
+	(* 0xF4 - 0xFF -> NONE *)
+	| _ ->
+		try
+			A3Op (Hashtbl.find ops op)
+		with Not_found ->
+			Printf.printf "Unknown opcode 0x%.2X\n" op;
+			A3Unk (char_of_int op)
+
+let parse ch len =
+	let data = nread ch len in
+	let ch = input_string data in
+	let a = DynArray.create() in
+	let rec loop() =
+		DynArray.add a (opcode ch);
+		loop();
+	in
+	(try loop() with Exit -> ());
+	DynArray.to_array 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,248 @@
+(*
+ *  This file is part of SwfLib
+ *  Copyright (c)2004-2008 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+open As3
+
+type hl_ident = string
+type hl_int = int32
+type hl_uint = int32
+type hl_float = float
+type hl_slot = int
+type hl_jump = as3_jump
+type hl_op = as3_op
+
+type hl_opcode =
+	| HBreakPoint
+	| HNop
+	| HThrow
+	| HGetSuper of hl_name
+	| HSetSuper of hl_name
+	| HDxNs of hl_ident
+	| HDxNsLate
+	| HRegKill of reg
+	| HLabel
+	| HJump of hl_jump * int
+	| HSwitch of int * int list
+	| HPushWith
+	| HPopScope
+	| HForIn
+	| HHasNext
+	| HNull
+	| HUndefined
+	| HForEach
+	| HSmallInt of int
+	| HInt of int
+	| HTrue
+	| HFalse
+	| HNaN
+	| HPop
+	| HDup
+	| HSwap
+	| HString of hl_ident
+	| HIntRef of hl_int
+	| HUIntRef of hl_uint
+	| HFloat of hl_float
+	| HScope
+	| HNamespace of hl_namespace
+	| HNext of reg * reg
+	| HFunction of hl_method
+	| HCallStack of nargs
+	| HConstruct of nargs
+	| HCallMethod of hl_slot * nargs
+	| HCallStatic of hl_method * nargs
+	| HCallSuper of hl_name * nargs
+	| HCallProperty of hl_name * nargs
+	| HRetVoid
+	| HRet
+	| HConstructSuper of nargs
+	| HConstructProperty of hl_name * nargs
+	| HCallPropLex of hl_name * nargs
+	| HCallSuperVoid of hl_name * nargs
+	| HCallPropVoid of hl_name * nargs
+	| HApplyType of nargs
+	| HObject of nargs
+	| HArray of nargs
+	| HNewBlock
+	| HClassDef of hl_class
+	| HGetDescendants of hl_name
+	| HCatch of int
+	| HFindPropStrict of hl_name
+	| HFindProp of hl_name
+	| HFindDefinition of hl_name
+	| HGetLex of hl_name
+	| HSetProp of hl_name
+	| HReg of reg
+	| HSetReg of reg
+	| HGetGlobalScope
+	| HGetScope of int
+	| HGetProp of hl_name
+	| HInitProp of hl_name
+	| HDeleteProp of hl_name
+	| HGetSlot of hl_slot
+	| HSetSlot of hl_slot
+	| HToString
+	| HToXml
+	| HToXmlAttr
+	| HToInt
+	| HToUInt
+	| HToNumber
+	| HToBool
+	| HToObject
+	| HCheckIsXml
+	| HCast of hl_name
+	| HAsAny
+	| HAsString
+	| HAsType of hl_name
+	| HAsObject
+	| HIncrReg of reg
+	| HDecrReg of reg
+	| HTypeof
+	| HInstanceOf
+	| HIsType of hl_name
+	| HIncrIReg of reg
+	| HDecrIReg of reg
+	| HThis
+	| HSetThis
+	| HDebugReg of hl_ident * reg * int
+	| HDebugLine of int
+	| HDebugFile of hl_ident
+	| HBreakPointLine of int
+	| HTimestamp
+	| HOp of hl_op
+	| HUnk of char
+
+and hl_namespace =
+	| HNPrivate of hl_ident option
+	| HNPublic of hl_ident option
+	| HNInternal of hl_ident option
+	| HNProtected of hl_ident
+	| HNNamespace of hl_ident
+	| HNExplicit of hl_ident
+	| HNStaticProtected of hl_ident option
+
+and hl_ns_set = hl_namespace list
+
+and hl_name =
+	| HMPath of hl_ident list * hl_ident
+	| HMName of hl_ident * hl_namespace
+	| HMMultiName of hl_ident option * hl_ns_set
+	| HMRuntimeName of hl_ident
+	| HMRuntimeNameLate
+	| HMMultiNameLate of hl_ns_set
+	| HMAttrib of hl_name
+	| HMParams of hl_name * hl_name list
+	| 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 array;
+	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,918 @@
+(*
+ *  This file is part of SwfLib
+ *  Copyright (c)2004-2008 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+open As3
+open As3hl
+
+type parse_ctx = {
+	as3 : as3_tag;
+	mutable namespaces : hl_namespace array;
+	mutable nsets : hl_ns_set array;
+	mutable names : hl_name array;
+	mutable methods : hl_method array;
+	mutable classes : hl_class array;
+	mutable jumps : (int * int) list;
+	mutable pos : int;
+	delta_mt : int;
+	delta_cl : int;
+}
+
+let get = As3parse.iget
+let no_nz = As3parse.no_nz
+let idx n = As3parse.index_int n - 1
+
+let ident ctx i = get ctx.as3.as3_idents i
+let name ctx n = ctx.names.(idx n)
+let method_type ctx n = ctx.methods.(idx (no_nz n))
+let getclass ctx n = ctx.classes.(idx (no_nz n))
+
+let opt f ctx = function
+	| None -> None
+	| Some x -> Some (f ctx x)
+
+let stack_delta = function
+	| HBreakPoint -> 0
+	| HNop -> 0
+	| HThrow -> -1
+	| HGetSuper _ -> 0
+	| HSetSuper _ -> -1
+	| 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 = DynArray.create() in
+	ctx.pos <- 0;
+	ctx.jumps <- [];
+	let codepos pos delta =
+		let id = (try DynArray.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));*)
+			DynArray.get indexes pos; (* jump 0 *)
+		end else
+			id
+	in
+	let hcode = Array.mapi (fun i op ->
+		let len = As3code.length op in
+		DynArray.add indexes i;
+		for k = 2 to len do DynArray.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 *)
+	DynArray.add indexes (Array.length code);
+	(* patch jumps *)
+	List.iter (fun (j,pos) ->
+		Array.set hcode j (match Array.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))
+	| A3MAny -> HMAny
+	| A3MMultiName (id,ns) -> HMMultiName (opt ident ctx id,ctx.nsets.(idx ns))
+	| A3MRuntimeName id -> HMRuntimeName (ident ctx id)
+	| A3MRuntimeNameLate -> HMRuntimeNameLate
+	| A3MMultiNameLate ns -> HMMultiNameLate ctx.nsets.(idx ns)
+	| A3MAttrib multi -> HMAttrib (parse_name names ctx multi)
+	| A3MParams (id,pl) -> HMParams (parse_name names ctx names.(idx id),List.map (fun id -> parse_name names ctx names.(idx id)) pl)
+
+let parse_try_catch ctx t =
+	{
+		hltc_start = t.tc3_start;
+		hltc_end = t.tc3_end;
+		hltc_handle = t.tc3_handle;
+		hltc_type = opt name ctx t.tc3_type;
+		hltc_name = opt name ctx t.tc3_name;
+	}
+
+let parse_function ctx f =
+	{
+		hlf_stack_size = f.fun3_stack_size;
+		hlf_nregs = f.fun3_nregs;
+		hlf_init_scope = f.fun3_init_scope;
+		hlf_max_scope = f.fun3_max_scope;
+		hlf_code = [||]; (* 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)
+	| 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 = Array.create (Array.length hcode + 1) 0 in
+	let pos = ref 0 in
+	let old = ctx.fjumps in
+	ctx.fjumps <- [];
+	let code = Array.mapi (fun i op ->
+		let op = flatten_opcode ctx i op in
+		pos := !pos + As3code.length op;
+		Array.set positions (i + 1) !pos;
+		op
+	) hcode in
+	(* patch jumps *)
+	List.iter (fun j ->
+		Array.set code j (match Array.get code j with
+			| A3Jump (jc,n) ->
+				A3Jump (jc,positions.(j+n) - positions.(j+1))
+			| A3Switch (n,infos) ->
+				A3Switch (positions.(j+n) - positions.(j),List.map (fun n -> positions.(j+n) - positions.(j)) infos)
+			| _ -> assert false);
+	) ctx.fjumps;
+	(* patch trys *)
+	let trys = Array.mapi (fun i t ->
+		{
+			tc3_start = positions.(t.hltc_start);
+			tc3_end = positions.(t.hltc_end);
+			tc3_handle = positions.(t.hltc_handle);
+			tc3_type = opt lookup_name ctx t.hltc_type;
+			tc3_name = opt lookup_name ctx t.hltc_name;
+		}
+	) trys in
+	ctx.fjumps <- old;
+	code, trys
+
+let flatten_function ctx f mid =
+	let code, trys = flatten_code ctx f.hlf_code f.hlf_trys in
+	{
+		fun3_id = mid;
+		fun3_stack_size = f.hlf_stack_size;
+		fun3_nregs = f.hlf_nregs;
+		fun3_init_scope = f.hlf_init_scope;
+		fun3_max_scope = f.hlf_max_scope;
+		fun3_code = code;
+		fun3_trys = trys;
+		fun3_locals = Array.map (fun (n,t,s,c) ->
+			{
+				f3_name = lookup_name ctx n;
+				f3_slot = s;
+				f3_kind = A3FVar { v3_type = opt lookup_name ctx t; v3_value = A3VNone; v3_const = c };
+				f3_metas = None;
+			}
+		) f.hlf_locals;
+	}
+
+let flatten_method ctx m =
+	let mid = lookup_method ctx m in
+	(match m.hlmt_function with
+	| None -> ()
+	| Some f -> ctx.ffunctions <- flatten_function ctx f mid :: ctx.ffunctions);
+	{
+		mt3_ret = opt lookup_name ctx m.hlmt_ret;
+		mt3_args = List.map (opt lookup_name ctx) m.hlmt_args;
+		mt3_native = m.hlmt_native;
+		mt3_var_args = m.hlmt_var_args;
+		mt3_arguments_defined = m.hlmt_arguments_defined;
+		mt3_uses_dxns = m.hlmt_uses_dxns;
+		mt3_new_block = m.hlmt_new_block;
+		mt3_unused_flag = m.hlmt_unused_flag;
+		mt3_debug_name = opt lookup_ident ctx m.hlmt_debug_name;
+		mt3_dparams = opt (fun ctx -> List.map (flatten_value ctx)) ctx m.hlmt_dparams;
+		mt3_pnames = opt (fun ctx -> List.map (opt lookup_ident ctx)) ctx m.hlmt_pnames;
+	}
+
+let flatten_static ctx s =
+	{
+		st3_method = lookup_method ctx s.hls_method;
+		st3_fields = Array.map (flatten_field ctx) s.hls_fields;
+	}
+
+let rec browse_method ctx m =
+	let ml, _ = ctx in
+	if not (List.memq m !ml) then begin
+		ml := m :: !ml;
+		match m.hlmt_function with
+		| None -> ()
+		| Some f ->
+			Array.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,1099 @@
+(*
+ *  This file is part of SwfLib
+ *  Copyright (c)2004-2006 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+open As3
+
+let parse_idents = true
+let parse_namespaces = true && parse_idents
+let parse_ns_sets = true && parse_namespaces
+let parse_names = true && parse_ns_sets
+let parse_mtypes = true && parse_names
+let parse_metadata = true && parse_mtypes
+let parse_classes = true && parse_metadata
+let parse_statics = true && parse_classes
+let parse_inits = true && parse_statics
+let parse_functions = true && parse_inits
+let parse_bytecode = true && parse_functions
+
+let magic_index (i : int) : 'a index =
+	Obj.magic i
+
+let magic_index_nz (i : int) : 'a index_nz =
+	Obj.magic i
+
+let index (t : 'a array) (i : int) : 'a index =
+	if i <= 0 || i - 1 >= Array.length t then assert false;
+	magic_index i
+
+let index_opt t i =
+	if i = 0 then
+		None
+	else
+		Some (index t i)
+
+let index_nz (t : 'a array) (i : int) : 'a index_nz =
+	if i < 0 || i >= Array.length t then assert false;
+	Obj.magic i
+
+let index_int (i : 'a index) =
+	(Obj.magic i : int)
+
+let index_nz_int (i : 'a index_nz) =
+	(Obj.magic i : int)
+
+let iget (t : 'a array) (i : 'a index) : 'a =
+	t.(index_int i - 1)
+
+let no_nz (i : 'a index_nz) : 'a index =
+	Obj.magic ((Obj.magic i) + 1)
+
+(* ************************************************************************ *)
+(* LENGTH *)
+
+let as3_empty_index ctx =
+	let empty_index = ref 0 in
+	try
+		Array.iteri (fun i x -> if x = "" then begin empty_index := (i + 1); raise Exit; end) ctx.as3_idents;
+		if parse_idents then assert false;
+		magic_index 0
+	with Exit ->
+		index ctx.as3_idents (!empty_index)
+
+let as3_int_length i =
+	if Int32.compare (Int32.shift_right_logical i 28) 0l > 0 then
+		5
+	else if Int32.compare (Int32.shift_right i 21) 0l > 0 then
+		4
+	else if Int32.compare (Int32.shift_right i 14) 0l > 0 then
+		3
+	else if Int32.compare (Int32.shift_right i 7) 0l > 0 then
+		2
+	else
+		1
+
+let as3_uint_length i =
+	as3_int_length i
+
+let sum f l =
+	List.fold_left (fun acc n -> acc + f n) 0 l
+
+let int_length i =
+	as3_int_length (Int32.of_int i)
+
+let idx_length i =
+	int_length (index_int i)
+
+let idx_length_nz i =
+	int_length (index_nz_int i)
+
+let idx_opt_length = function
+	| None -> int_length 0
+	| Some i -> idx_length i
+
+let as3_ident_length s =
+	let n = String.length s in
+	n + int_length n
+
+let as3_namespace_length ei = function
+	| A3NStaticProtected o
+	| A3NPrivate o ->
+		1 + (match o with None -> int_length 0 | Some n -> idx_length n)
+	| A3NPublic o
+	| A3NInternal o ->
+		1 + idx_length (match o with None -> ei | Some n -> n)
+	| A3NExplicit n
+	| A3NNamespace n
+	| A3NProtected n ->
+		1 + idx_length n
+
+let as3_ns_set_length l =
+	int_length (List.length l) + sum idx_length l
+
+let rec as3_name_length t =
+	1 +
+	match t with
+	| A3MMultiName (id,r) ->
+		idx_opt_length id + idx_length r
+	| A3MName (id,r) ->
+		idx_length r + idx_length id
+	| 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 = Array.fold_left (fun acc op -> acc + As3code.length op) 0 f.fun3_code in
+	idx_length_nz f.fun3_id +
+	int_length f.fun3_stack_size +
+	int_length f.fun3_nregs +
+	int_length f.fun3_init_scope +
+	int_length f.fun3_max_scope +
+	int_length clen +
+	clen +
+	list2_length as3_try_catch_length f.fun3_trys +
+	list2_length as3_field_length f.fun3_locals
+
+let as3_length ctx =
+	let ei = as3_empty_index ctx in
+	String.length ctx.as3_unknown +
+	4 +
+	list_length as3_int_length ctx.as3_ints +
+	list_length as3_uint_length ctx.as3_uints +
+	list_length (fun _ -> 8) ctx.as3_floats
+	+ if parse_idents then list_length as3_ident_length ctx.as3_idents
+	+ if parse_namespaces then list_length (as3_namespace_length ei) ctx.as3_namespaces
+	+ if parse_ns_sets then list_length as3_ns_set_length ctx.as3_nsets
+	+ if parse_names then list_length as3_name_length ctx.as3_names
+	+ if parse_mtypes then list2_length as3_method_type_length ctx.as3_method_types
+	+ if parse_metadata then list2_length as3_metadata_length ctx.as3_metadatas
+	+ if parse_classes then list2_length as3_class_length ctx.as3_classes
+	+ if parse_statics then Array.fold_left (fun acc x -> acc + as3_static_length x) 0 ctx.as3_statics
+	+ if parse_inits then list2_length as3_static_length ctx.as3_inits
+	+ if parse_functions then list2_length as3_function_length ctx.as3_functions
+	  else 0 else 0 else 0 else 0 else 0 else 0 else 0 else 0 else 0 else 0
+
+(* ************************************************************************ *)
+(* PARSING *)
+
+let read_as3_int ch =
+	let a = IO.read_byte ch in
+	if a < 128 then
+		Int32.of_int a
+	else
+	let a = a land 127 in
+	let b = IO.read_byte ch in
+	if b < 128 then
+		Int32.of_int ((b lsl 7) lor a)
+	else
+	let b = b land 127 in
+	let c = IO.read_byte ch in
+	if c < 128 then
+		Int32.of_int ((c lsl 14) lor (b lsl 7) lor a)
+	else
+	let c = c land 127 in
+	let d = IO.read_byte ch in
+	if d < 128 then
+		Int32.of_int ((d lsl 21) lor (c lsl 14) lor (b lsl 7) lor a)
+	else
+	let d = d land 127 in
+	let e = IO.read_byte ch in
+	if e > 15 then assert false;
+	let small = Int32.of_int ((d lsl 21) lor (c lsl 14) lor (b lsl 7) lor a) in
+	let big = Int32.shift_left (Int32.of_int e) 28 in
+	Int32.logor big small
+
+let read_as3_uint ch =
+	read_as3_int ch
+
+let read_int ch =
+	Int32.to_int (read_as3_int ch)
+
+let read_ident ch =
+	IO.nread ch (read_int ch)
+
+let read_namespace idents ch =
+	let k = IO.read_byte ch in
+	let p = index_opt idents (read_int ch) in
+	match k with
+	| 0x05 ->
+		A3NPrivate p
+	| 0x08 ->
+		(match p with
+		| None -> assert false
+		| Some idx -> A3NNamespace idx)
+	| 0x16 ->
+		(match p with
+		| None -> assert false
+		| Some p when iget idents p = "" -> A3NPublic None
+		| _ -> A3NPublic p)
+	| 0x17 ->
+		(match p with
+		| None -> assert false
+		| Some p when iget idents p = "" -> A3NInternal None
+		| _ -> A3NInternal p)
+	| 0x18 ->
+		(match p with
+		| None -> assert false
+		| Some idx -> A3NProtected idx)
+	| 0x19 ->
+		(match p with
+		| None -> assert false
+		| Some idx -> A3NExplicit idx)
+	| 0x1A ->
+		A3NStaticProtected p
+	| _ ->
+		assert false
+
+let read_ns_set namespaces ch =
+	let rec loop n =
+		if n = 0 then
+			[]
+		else
+			let r = index namespaces (read_int ch) in
+			r :: loop (n - 1)
+	in
+	loop (IO.read_byte ch)
+
+let rec read_name ctx ?k ch =
+	let k = (match k with None -> IO.read_byte ch | Some k -> k) in
+	match k with
+	| 0x07 ->
+		let i = read_int ch in
+		let j = read_int ch in
+		if i = 0 && j = 0 then
+			A3MAny
+		else
+		let ns = index ctx.as3_namespaces i in
+		let id = index ctx.as3_idents j in
+		(* both ns and id can be 0 <=> '*' *)
+		A3MName (id,ns)
+	| 0x09 ->
+		let id = index_opt ctx.as3_idents (read_int ch) in
+		let ns = index ctx.as3_nsets (read_int ch) in
+		A3MMultiName (id,ns)
+	| 0x0D ->
+		A3MAttrib (read_name ctx ~k:0x07 ch)
+	| 0x0E ->
+		A3MAttrib (read_name ctx ~k:0x09 ch)
+	| 0x0F ->
+		let id = index ctx.as3_idents (read_int ch) in
+		A3MRuntimeName id
+	| 0x10 ->
+		A3MAttrib (read_name ctx ~k:0x0F ch)
+	| 0x11 ->
+		A3MRuntimeNameLate
+	| 0x12 ->
+		A3MAttrib (read_name ctx ~k:0x11 ch)
+	| 0x1B ->
+		let ns = index ctx.as3_nsets (read_int ch) in
+		A3MMultiNameLate ns
+	| 0x1C ->
+		A3MAttrib (read_name ctx ~k:0x1B ch)
+	| 0x1D ->
+		let rec loop n =
+			if n = 0 then
+				[]
+			else
+				let name = magic_index (read_int ch) in
+				name :: loop (n - 1)
+		in
+		let id = magic_index (read_int ch) in
+		A3MParams (id,loop (IO.read_byte ch))
+	| n ->
+		prerr_endline (string_of_int n);
+		assert false
+
+let read_value ctx ch extra =
+	let idx = read_int ch in
+	if idx = 0 then begin
+		if extra && IO.read_byte ch <> 0 then assert false;
+		A3VNone
+	end else match IO.read_byte ch with
+	| 0x01 ->
+		A3VString (index ctx.as3_idents idx)
+	| 0x03 ->
+		A3VInt (index ctx.as3_ints idx)
+	| 0x04 ->
+		A3VUInt (index ctx.as3_uints idx)
+	| 0x06 ->
+		A3VFloat (index ctx.as3_floats idx)
+	| 0x08 | 0x16 | 0x17 | 0x18 | 0x19 | 0x1A | 0x05 as n->
+		A3VNamespace (n,index ctx.as3_namespaces idx)
+	| 0x0A ->
+		if idx <> 0x0A then assert false;
+		A3VBool false
+	| 0x0B ->
+		if idx <> 0x0B then assert false;
+		A3VBool true
+	| 0x0C ->
+		if idx <> 0x0C then assert false;
+		A3VNull
+	| _ ->
+		assert false
+
+let read_method_type ctx ch =
+	let nargs = IO.read_byte ch in
+	let tret = index_opt ctx.as3_names (read_int ch) in
+	let targs = Array.to_list (Array.init nargs (fun _ -> index_opt ctx.as3_names (read_int ch))) in
+	let dname = index_opt ctx.as3_idents (read_int ch) in
+	let flags = IO.read_byte ch in
+	let dparams = (if flags land 0x08 <> 0 then
+		Some (Array.to_list (Array.init (IO.read_byte ch) (fun _ -> read_value ctx ch true)))
+	else
+		None
+	) in
+	let pnames = (if flags land 0x80 <> 0 then
+		Some (Array.to_list (Array.init nargs (fun _ -> index_opt ctx.as3_idents (read_int ch))))
+	else
+		None
+	) in
+	{
+		mt3_ret = tret;
+		mt3_args = targs;
+		mt3_var_args = flags land 0x04 <> 0;
+		mt3_native = flags land 0x20 <> 0;
+		mt3_new_block = flags land 0x02 <> 0;
+		mt3_debug_name = dname;
+		mt3_dparams = dparams;
+		mt3_pnames = pnames;
+		mt3_arguments_defined = flags land 0x01 <> 0;
+		mt3_uses_dxns = flags land 0x40 <> 0;
+		mt3_unused_flag = flags land 0x10 <> 0;
+	}
+
+let read_list ch f =
+	match read_int ch with
+	| 0 -> [||]
+	| n -> Array.init (n - 1) (fun _ -> f ch)
+
+let read_list2 ch f =
+	Array.init (read_int ch) (fun _ -> f ch)
+
+let read_field ctx ch =
+	let name = index ctx.as3_names (read_int ch) in
+	let kind = IO.read_byte ch in
+	let has_meta = kind land 0x40 <> 0 in
+	let slot = read_int ch in
+	let kind = (match kind land 0xF with
+		| 0x00 | 0x06 ->
+			let t = index_opt ctx.as3_names (read_int ch) in
+			let value = read_value ctx ch false in
+			A3FVar {
+				v3_type = t;
+				v3_value = value;
+				v3_const = kind = 0x06;
+			}
+		| 0x02
+		| 0x03
+		| 0x01 ->
+			let meth = index_nz ctx.as3_method_types (read_int ch) in
+			let final = kind land 0x10 <> 0 in
+			let override = kind land 0x20 <> 0 in
+			A3FMethod {
+				m3_type = meth;
+				m3_final = final;
+				m3_override = override;
+				m3_kind = (match kind land 0xF with 0x01 -> MK3Normal | 0x02 -> MK3Getter | 0x03 -> MK3Setter | _ -> assert false);
+			}
+		| 0x04 ->
+			let c = index_nz ctx.as3_classes (read_int ch) in
+			A3FClass c
+		| 0x05 ->
+			let f = index_nz ctx.as3_method_types (read_int ch) in
+			A3FFunction f
+		| _ ->
+			assert false
+	) in
+	let metas = (if has_meta then
+		Some (read_list2 ch (fun _ -> index_nz ctx.as3_metadatas (read_int ch)))
+	else
+		None
+	) in
+	{
+		f3_name = name;
+		f3_slot = slot;
+		f3_kind = kind;
+		f3_metas = metas;
+	}
+
+let read_class ctx ch =
+	let name = index ctx.as3_names (read_int ch) in
+	let csuper = index_opt ctx.as3_names (read_int ch) in
+	let flags = IO.read_byte ch in
+	let namespace =
+		if flags land 8 <> 0 then
+			let r = index ctx.as3_namespaces (read_int ch) in
+			Some r
+		else
+			None
+	in
+	let impls = read_list2 ch (fun _ -> index ctx.as3_names (read_int ch)) in
+	let construct = index_nz ctx.as3_method_types (read_int ch) in
+	let fields = read_list2 ch (read_field ctx) in
+	{
+		cl3_name = name;
+		cl3_super = csuper;
+		cl3_sealed = (flags land 1) <> 0;
+		cl3_final = (flags land 2) <> 0;
+		cl3_interface = (flags land 4) <> 0;
+		cl3_namespace = namespace;
+		cl3_implements = impls;
+		cl3_construct = construct;
+		cl3_fields = fields;
+	}
+
+let read_static ctx ch =
+	let meth = index_nz ctx.as3_method_types (read_int ch) in
+	let fields = read_list2 ch (read_field ctx) in
+	{
+		st3_method = meth;
+		st3_fields = fields;
+	}
+
+let read_metadata ctx ch =
+	let name = index ctx.as3_idents (read_int ch) in
+	let data = read_list2 ch (fun _ -> index_opt ctx.as3_idents (read_int ch)) in
+	let data = Array.map (fun i1 -> i1 , index ctx.as3_idents (read_int ch)) data in
+	{
+		meta3_name = name;
+		meta3_data = data;
+	}
+
+let read_try_catch ctx ch =
+	let start = read_int ch in
+	let pend = read_int ch in
+	let handle = read_int ch in
+	let t = index_opt ctx.as3_names (read_int ch) in
+	let name = index_opt ctx.as3_names (read_int ch) in
+	{
+		tc3_start = start;
+		tc3_end = pend;
+		tc3_handle = handle;
+		tc3_type = t;
+		tc3_name = name;
+	}
+
+let read_function ctx ch =
+	let id = index_nz ctx.as3_method_types (read_int ch) in
+	let ss = read_int ch in
+	let nregs = read_int ch in
+	let init_scope = read_int ch in
+	let max_scope = read_int ch in
+	let size = read_int ch in
+	let code = if parse_bytecode then As3code.parse ch size else Array.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 namespaces = (if parse_namespaces then read_list ch (read_namespace idents) else [||]) in
+	let nsets = (if parse_ns_sets then read_list ch (read_ns_set namespaces) else [||]) in
+	let ctx = {
+		as3_ints = ints;
+		as3_uints = uints;
+		as3_floats = floats;
+		as3_idents = idents;
+		as3_namespaces = namespaces;
+		as3_nsets = nsets;
+		as3_names = [||];
+		as3_method_types = [||];
+		as3_metadatas = [||];
+		as3_classes = [||];
+		as3_statics = [||];
+		as3_inits = [||];
+		as3_functions = [||];
+		as3_unknown = "";
+	} in
+	if parse_names then ctx.as3_names <- read_list ch (read_name ctx);
+	if parse_mtypes then ctx.as3_method_types <- read_list2 ch (read_method_type ctx);
+	if parse_metadata then ctx.as3_metadatas <- read_list2 ch (read_metadata ctx);
+	if parse_classes then ctx.as3_classes <- read_list2 ch (read_class ctx);
+	if parse_statics then ctx.as3_statics <- Array.map (fun _ -> read_static ctx ch) ctx.as3_classes;
+	if parse_inits then ctx.as3_inits <- read_list2 ch (read_static ctx);
+	if parse_functions then ctx.as3_functions <- read_list2 ch (read_function ctx);
+	ctx.as3_unknown <- IO.really_nread ch (len - (get_pos()));
+	if parse_functions && String.length ctx.as3_unknown <> 0 then assert false;
+(*	let len2 = as3_length ctx in
+	if len2 <> len then begin Printf.printf "%d != %d" len len2; assert false; end;
+*)	ctx
+
+(* ************************************************************************ *)
+(* WRITING *)
+
+let write_as3_int ch i =
+	let e = Int32.to_int (Int32.shift_right_logical i 28) in
+	let d = Int32.to_int (Int32.shift_right i 21) land 0x7F in
+	let c = Int32.to_int (Int32.shift_right i 14) land 0x7F in
+	let b = Int32.to_int (Int32.shift_right i 7) land 0x7F in
+	let a = Int32.to_int (Int32.logand i 0x7Fl) in
+	if b <> 0 || c <> 0 || d <> 0 || e <> 0 then begin
+		IO.write_byte ch (a lor 0x80);
+		if c <> 0 || d <> 0 || e <> 0 then begin
+			IO.write_byte ch (b lor 0x80);
+			if d <> 0 || e <> 0 then begin
+				IO.write_byte ch (c lor 0x80);
+				if e <> 0 then begin
+					IO.write_byte ch (d lor 0x80);
+					IO.write_byte ch e;
+				end else
+					IO.write_byte ch d;
+			end else
+				IO.write_byte ch c;
+		end else
+			IO.write_byte ch b;
+	end else
+		IO.write_byte ch a
+
+let write_as3_uint = write_as3_int
+
+let write_int ch i =
+	write_as3_int ch (Int32.of_int i)
+
+let write_index ch n =
+	write_int ch (index_int n)
+
+let write_index_nz ch n =
+	write_int ch (index_nz_int n)
+
+let write_index_opt ch = function
+	| None -> write_int ch 0
+	| Some n -> write_index ch n
+
+let write_as3_ident ch id =
+	write_int ch (String.length id);
+	IO.nwrite ch id
+
+let write_namespace empty_index ch = function
+	| A3NPrivate n ->
+		IO.write_byte ch 0x05;
+		(match n with
+		| None -> write_int ch 0
+		| Some n -> write_index ch n);
+	| A3NPublic n ->
+		IO.write_byte ch 0x16;
+		(match n with
+		| None -> write_index ch empty_index
+		| Some n -> write_index ch n);
+	| A3NInternal n ->
+		IO.write_byte ch 0x17;
+		(match n with
+		| None -> write_index ch empty_index
+		| Some n -> write_index ch n);
+	| A3NProtected n ->
+		IO.write_byte ch 0x18;
+		write_index ch n
+	| A3NNamespace n ->
+		IO.write_byte ch 0x08;
+		write_index ch n
+	| A3NExplicit n ->
+		IO.write_byte ch 0x19;
+		write_index ch n
+	| A3NStaticProtected n ->
+		IO.write_byte ch 0x1A;
+		(match n with
+		| None -> write_int ch 0
+		| Some n -> write_index ch n)
+
+let write_rights ch l =
+	IO.write_byte ch (List.length l);
+	List.iter (write_index ch) l
+
+let rec write_name ch ?k x =
+	let b n = match k with None -> n | Some v -> v in
+	match x with
+	| A3MMultiName (id,r) ->
+		IO.write_byte ch (b 0x09);
+		write_index_opt ch id;
+		write_index ch r;
+	| A3MName (id,r) ->
+		IO.write_byte ch (b 0x07);
+		write_index ch r;
+		write_index ch id
+	| 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 _ | 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 = Array.fold_left (fun acc op -> acc + As3code.length op) 0 f.fun3_code in
+	write_int ch clen;
+	Array.iter (As3code.write ch) f.fun3_code;
+	write_list2 ch write_try_catch f.fun3_trys;
+	write_list2 ch write_field f.fun3_locals
+
+let write ch1 ctx =
+	let ch = IO.output_strings() in
+	let empty_index = as3_empty_index ctx in
+	IO.write_i32 ch header_magic;
+	write_list ch write_as3_int ctx.as3_ints;
+	write_list ch write_as3_uint ctx.as3_uints;
+	write_list ch IO.write_double ctx.as3_floats;
+	if parse_idents then write_list ch write_as3_ident ctx.as3_idents;
+	if parse_namespaces then write_list ch (write_namespace empty_index) ctx.as3_namespaces;
+	if parse_ns_sets then write_list ch write_rights ctx.as3_nsets;
+	if parse_names then write_list ch (write_name ?k:None) ctx.as3_names;
+	if parse_mtypes then write_list2 ch write_method_type ctx.as3_method_types;
+	if parse_metadata then write_list2 ch write_metadata ctx.as3_metadatas;
+	if parse_classes then write_list2 ch write_class ctx.as3_classes;
+	if parse_statics then Array.iter (write_static ch) ctx.as3_statics;
+	if parse_inits then write_list2 ch write_static ctx.as3_inits;
+	if parse_functions then write_list2 ch write_function ctx.as3_functions;
+	IO.nwrite ch ctx.as3_unknown;
+	let str = IO.close_out ch in
+	List.iter (IO.nwrite ch1) str
+
+(* ************************************************************************ *)
+(* DUMP *)
+
+let dump_code_size = ref true
+
+let ident_str ctx i =
+	iget ctx.as3_idents i
+
+let namespace_str ctx i =
+	match iget ctx.as3_namespaces i with
+	| A3NPrivate None -> "private"
+	| A3NPrivate (Some n) -> "private:" ^ ident_str ctx n
+	| A3NPublic None -> "public"
+	| A3NPublic (Some n) -> "public:" ^ ident_str ctx n
+	| A3NInternal None -> "internal"
+	| A3NInternal (Some n) -> "internal:" ^ ident_str ctx n
+	| A3NProtected n -> "protected:" ^ ident_str ctx n
+	| A3NExplicit n -> "explicit:" ^ ident_str ctx n
+	| A3NStaticProtected None -> "static_protected"
+	| A3NStaticProtected (Some n) -> "static_protectec:" ^ ident_str ctx n
+	| A3NNamespace n -> "namespace:" ^ ident_str ctx n
+
+let ns_set_str ctx i =
+	let l = iget ctx.as3_nsets i in
+	String.concat " " (List.map (fun r -> namespace_str ctx r) l)
+
+let rec name_str ctx kind t =
+	let rec loop = function
+		| A3MName (id,r) -> Printf.sprintf "%s %s%s" (namespace_str ctx r) kind (ident_str ctx id)
+		| 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
+	Array.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,386 @@
+(*
+ *  PNG File Format Library
+ *  Copyright (c)2005 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+type grey_bits =
+	| GBits1
+	| GBits2
+	| GBits4
+	| GBits8
+	| GBits16
+
+type grey_alpha_bits =
+	| GABits8
+	| GABits16
+
+type true_bits =
+	| TBits8
+	| TBits16
+
+type index_bits =
+	| IBits1
+	| IBits2
+	| IBits4
+	| IBits8
+
+type alpha =
+	| NoAlpha
+	| HaveAlpha
+
+type color =
+	| ClGreyScale of grey_bits
+	| ClGreyAlpha of grey_alpha_bits
+	| ClTrueColor of true_bits * alpha
+	| ClIndexed of index_bits
+
+type header = {
+	png_width : int;
+	png_height : int;
+	png_color : color;
+	png_interlace : bool;
+}
+
+type chunk_id = string
+
+type chunk =
+	| CEnd
+	| CHeader of header
+	| CData of string
+	| CPalette of string
+	| CUnknown of chunk_id * string
+
+type png = chunk list
+
+type error_msg =
+	| Invalid_header
+	| Invalid_file
+	| Truncated_file
+	| Invalid_CRC
+	| Invalid_colors
+	| Unsupported_colors
+	| Invalid_datasize
+	| Invalid_filter of int
+	| Invalid_array
+
+exception Error of error_msg
+
+let error_msg = function
+	| Invalid_header -> "Invalid header"
+	| Invalid_file -> "Invalid file"
+	| Truncated_file -> "Truncated file"
+	| Invalid_CRC -> "Invalid CRC"
+	| Invalid_colors -> "Invalid color model"
+	| Unsupported_colors -> "Unsupported color model"
+	| Invalid_datasize -> "Invalid data size"
+	| Invalid_filter f -> "Invalid filter " ^ string_of_int f
+	| Invalid_array -> "Invalid array"
+
+let error msg = raise (Error msg)
+
+let is_upper c = ((int_of_char c) land 32) <> 0
+
+let is_critical id = is_upper id.[0]
+
+let is_public id = is_upper id.[1]
+
+let is_reseverd id = is_upper id.[2]
+
+let is_safe_to_copy id = is_upper id.[3]
+
+let is_id_char c =
+	(c >= '\065' && c <= '\090') || (c >= '\097' && c <= '\122')
+
+let rec header = function
+	| [] -> error Invalid_file
+	| CHeader h :: _ -> h
+	| _ :: l -> header l
+
+let rec data = function
+	| [] -> error Invalid_file
+	| CData s :: _ -> s
+	| _ :: l -> data l
+
+let color_bits = function
+	| ClGreyScale g -> (match g with
+		| GBits1 -> 1
+		| GBits2 -> 2
+		| GBits4 -> 4
+		| GBits8 -> 8
+		| GBits16 -> 16)
+	| ClGreyAlpha g -> (match g with
+		| GABits8 -> 8
+		| GABits16 -> 16)
+	| ClTrueColor (t,_) -> (match t with
+		| TBits8 -> 8
+		| TBits16 -> 16)
+	| ClIndexed i -> (match i with
+		| IBits1 -> 1
+		| IBits2 -> 2
+		| IBits4 -> 4
+		| IBits8 -> 8)
+
+let crc_table = Array.init 256 (fun n ->
+	let c = ref (Int32.of_int n) in
+	for k = 0 to 7 do
+		if Int32.logand !c 1l <> 0l then
+			c := Int32.logxor 0xEDB88320l (Int32.shift_right_logical !c 1)
+		else
+			c := (Int32.shift_right_logical !c 1);
+	done;
+	!c)
+
+let input_crc ch =
+	let crc = ref 0xFFFFFFFFl in
+	let update c =
+		let c = Int32.of_int (int_of_char c) in
+		let k = Array.unsafe_get crc_table (Int32.to_int (Int32.logand (Int32.logxor !crc c) 0xFFl)) in
+		crc := Int32.logxor k (Int32.shift_right_logical !crc 8)
+	in
+	let ch2 = IO.create_in
+		~read:(fun () ->
+			let c = IO.read ch in
+			update c;
+			c
+		)
+		~input:(fun s p l ->
+			let l = IO.input ch s p l in
+			for i = 0 to l - 1 do
+				update s.[p+i]
+			done;
+			l
+		)
+		~close:(fun () ->
+			IO.close_in ch
+		)
+	in
+	ch2 , (fun () -> Int32.logxor !crc 0xFFFFFFFFl)
+
+let output_crc ch =
+	let crc = ref 0xFFFFFFFFl in
+	let update c =
+		let c = Int32.of_int (int_of_char c) in
+		let k = Array.unsafe_get crc_table (Int32.to_int (Int32.logand (Int32.logxor !crc c) 0xFFl)) in
+		crc := Int32.logxor k (Int32.shift_right_logical !crc 8)
+	in
+	let ch2 = IO.create_out
+		~write:(fun c ->
+			IO.write ch c;
+			update c;
+		)
+		~output:(fun s p l ->
+			let l = IO.output ch s p l in
+			for i = 0 to l - 1 do
+				update s.[p+i]
+			done;
+			l
+		)
+		~flush:(fun () ->
+			IO.flush ch
+		)
+		~close:(fun () ->
+			IO.close_out ch
+		)
+	in
+	ch2 , (fun () -> Int32.logxor !crc 0xFFFFFFFFl)
+
+let parse_header ch =
+	let width = IO.BigEndian.read_i32 ch in
+	let height = IO.BigEndian.read_i32 ch in
+	if width < 0 || height < 0 then error Invalid_header;
+	let bits = IO.read_byte ch in
+	let color = IO.read_byte ch in
+	let color = (match color with
+		| 0 -> ClGreyScale (match bits with 1 -> GBits1 | 2 -> GBits2 | 4 -> GBits4 | 8 -> GBits8 | 16 -> GBits16 | _ -> error Invalid_colors)
+		| 2 -> ClTrueColor ((match bits with 8 -> TBits8 | 16 -> TBits16 | _ -> error Invalid_colors) , NoAlpha)
+		| 3 -> ClIndexed (match bits with 1 -> IBits1 | 2 -> IBits2 | 4 -> IBits4 | 8 -> IBits8 | _ -> error Invalid_colors)
+		| 4 -> ClGreyAlpha (match bits with 8 -> GABits8 | 16 -> GABits16 | _ -> error Invalid_colors)
+		| 6 -> ClTrueColor ((match bits with 8 -> TBits8 | 16 -> TBits16 | _ -> error Invalid_colors) , HaveAlpha)
+		| _ -> error Invalid_colors)
+	in
+	let compress = IO.read_byte ch in
+	let filter = IO.read_byte ch in
+	if compress <> 0 || filter <> 0 then error Invalid_header;
+	let interlace = IO.read_byte ch in
+	let interlace = (match interlace with 0 -> false | 1 -> true | _ -> error Invalid_header) in
+	{
+		png_width = width;
+		png_height = height;
+		png_color = color;
+		png_interlace = interlace;
+	}
+
+let parse_chunk ch =
+	let len = IO.BigEndian.read_i32 ch in
+	let ch2 , crc = input_crc ch in
+	let id = IO.nread ch2 4 in
+	if len < 0 || not (is_id_char id.[0]) || not (is_id_char id.[1]) || not (is_id_char id.[2]) || not (is_id_char id.[3]) then error Invalid_file;
+	let data = IO.nread ch2 len in
+	let crc_val = IO.BigEndian.read_real_i32 ch in
+	if crc_val <> crc() then error Invalid_CRC;
+	match id with
+	| "IEND" -> CEnd
+	| "IHDR" -> CHeader (parse_header (IO.input_string data))
+	| "IDAT" -> CData data
+	| "PLTE" -> CPalette data
+	| _ -> CUnknown (id,data)
+
+let png_sign = "\137\080\078\071\013\010\026\010"
+
+let parse ch =
+	let sign = (try IO.nread ch (String.length png_sign) with IO.No_more_input -> error Invalid_header) in
+	if sign <> png_sign then error Invalid_header;
+	let rec loop acc =
+		match parse_chunk ch with
+		| CEnd -> List.rev acc
+		| c -> loop (c :: acc)
+	in
+	try
+		loop []
+	with
+		| IO.No_more_input -> error Truncated_file
+		| IO.Overflow _ -> error Invalid_file
+
+let write_chunk ch cid cdata =
+	IO.BigEndian.write_i32 ch (String.length cdata);
+	let ch2 , crc = output_crc ch in
+	IO.nwrite ch2 cid;
+	IO.nwrite ch2 cdata;
+	IO.BigEndian.write_real_i32 ch (crc())
+
+let write_header real_ch h =
+	let ch = IO.output_string() in
+	IO.BigEndian.write_i32 ch h.png_width;
+	IO.BigEndian.write_i32 ch h.png_height;
+	IO.write_byte ch (color_bits h.png_color);
+	IO.write_byte ch (match h.png_color with
+		| ClGreyScale _ -> 0
+		| ClTrueColor (_,NoAlpha) -> 2
+		| ClIndexed _ -> 3
+		| ClGreyAlpha _ -> 4
+		| ClTrueColor (_,HaveAlpha) -> 6);
+	IO.write_byte ch 0;
+	IO.write_byte ch 0;
+	IO.write_byte ch (if h.png_interlace then 1 else 0);
+	let data = IO.close_out ch in
+	write_chunk real_ch "IHDR" data
+
+let write ch png =
+	IO.nwrite ch png_sign;
+	List.iter (function
+		| CEnd -> write_chunk ch "IEND" ""
+		| CHeader h -> write_header ch h
+		| CData s -> write_chunk ch "IDAT" s
+		| CPalette s -> write_chunk ch "PLTE" s
+		| CUnknown (id,data) -> write_chunk ch id data
+	) png
+
+let filter png data =
+	let head = header png in
+	let w = head.png_width in
+	let h = head.png_height in
+	match head.png_color with
+	| ClGreyScale _
+	| ClGreyAlpha _
+	| ClIndexed _
+	| ClTrueColor (TBits16,_) -> error Unsupported_colors
+	| ClTrueColor (TBits8,alpha) ->
+		let alpha = (match alpha with NoAlpha -> false | HaveAlpha -> true) in
+		let buf = String.create (w * h * 4) in
+		let nbytes = if alpha then 4 else 3 in
+		let stride = nbytes * w + 1 in
+		if String.length data < h * stride then error Invalid_datasize;
+		let bp = ref 0 in
+		let get p = int_of_char (String.unsafe_get data p) in
+		let bget p = int_of_char (String.unsafe_get buf p) in
+		let set v = String.unsafe_set buf !bp (Char.unsafe_chr v); incr bp in
+		let filters = [|
+			(fun x y v -> v
+			);
+			(fun x y v ->
+				let v2 = if x = 0 then 0 else bget (!bp - 4) in
+				v + v2
+			);
+			(fun x y v ->
+				let v2 = if y = 0 then 0 else bget (!bp - 4*w) in
+				v + v2
+			);
+			(fun x y v ->
+				let v2 = if x = 0 then 0 else bget (!bp - 4) in
+				let v3 = if y = 0 then 0 else bget (!bp - 4*w) in
+				v + (v2 + v3) / 2
+			);
+			(fun x y v ->
+				let a = if x = 0 then 0 else bget (!bp - 4) in
+				let b = if y = 0 then 0 else bget (!bp - 4*w) in
+				let c = if x = 0 || y = 0 then 0 else bget (!bp - 4 - 4*w) in
+				let p = a + b - c in
+				let pa = abs (p - a) in
+				let pb = abs (p - b) in
+				let pc = abs (p - c) in
+				let d = (if pa <= pb && pa <= pc then a else if pb <= pc then b else c) in
+				v + d
+			);
+		|] in
+		for y = 0 to h - 1 do
+			let f = get (y * stride) in
+			let f = (if f < 5 then filters.(f) else error (Invalid_filter f)) in
+			for x = 0 to w - 1 do
+				let p = x * nbytes + y * stride in
+				if not alpha then begin
+					set 255;
+					for c = 1 to 3 do
+						let v = get (p + c) in
+						set (f x y v)
+					done;
+				end else begin
+					let v = get (p + 4) in
+					let a = f x y v in
+					set a;
+					for c = 1 to 3 do
+						let v = get (p + c) in
+						set (f x y v)
+					done;
+				end;
+			done;
+		done;
+		buf
+
+let make ~width ~height ~pixel ~compress =
+	let data = String.create (width * height * 4 + height) in
+	let p = ref 0 in
+	let set v = String.unsafe_set data !p (Char.unsafe_chr v); incr p in
+	for y = 0 to height - 1 do
+		set 0;
+		for x = 0 to width - 1 do
+			let c = pixel x y in
+			let ic = Int32.to_int c in
+			(* RGBA *)
+			set (ic lsr 16);
+			set (ic lsr 8);
+			set ic;
+			set (Int32.to_int (Int32.shift_right_logical c 24));
+		done;
+	done;
+	let data = compress data in
+	let header = {
+		png_width = width;
+		png_height = height;
+		png_color = ClTrueColor (TBits8,HaveAlpha);
+		png_interlace = false;
+	} in
+	[CHeader header; CData data; CEnd]

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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+type grey_bits =
+	| GBits1
+	| GBits2
+	| GBits4
+	| GBits8
+	| GBits16
+
+type grey_alpha_bits =
+	| GABits8
+	| GABits16
+
+type true_bits =
+	| TBits8
+	| TBits16
+
+type index_bits =
+	| IBits1
+	| IBits2
+	| IBits4
+	| IBits8
+
+type alpha =
+	| NoAlpha
+	| HaveAlpha
+
+type color =
+	| ClGreyScale of grey_bits
+	| ClGreyAlpha of grey_alpha_bits
+	| ClTrueColor of true_bits * alpha
+	| ClIndexed of index_bits
+
+type header = {
+	png_width : int;
+	png_height : int;
+	png_color : color;
+	png_interlace : bool;
+}
+
+type chunk_id = string
+
+type chunk =
+	| CEnd
+	| CHeader of header
+	| CData of string
+	| CPalette of string
+	| CUnknown of chunk_id * string
+
+type png = chunk list
+
+type error_msg =
+	| Invalid_header
+	| Invalid_file
+	| Truncated_file
+	| Invalid_CRC
+	| Invalid_colors
+	| Unsupported_colors
+	| Invalid_datasize
+	| Invalid_filter of int
+	| Invalid_array
+
+exception Error of error_msg
+
+val error_msg : error_msg -> string
+
+val is_critical : chunk_id -> bool
+val is_public : chunk_id -> bool
+val is_reseverd : chunk_id -> bool
+val is_safe_to_copy : chunk_id -> bool
+
+val header : png -> header
+val data : png -> string
+
+val color_bits : color -> int
+val parse : IO.input -> png
+val write : 'a IO.output -> png -> unit
+val filter : png -> string -> string
+
+val make : width:int -> height:int -> pixel:(int -> int -> int32) -> compress:(string -> string) -> png

libs/swflib/swf.ml

@@ -0,0 +1,631 @@
+(*
+ *  This file is part of SwfLib
+ *  Copyright (c)2004 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+type float16 = int
+
+type unknown = string
+
+type binary = string
+
+type action_count = int
+
+type rgb = {
+	cr : int;
+	cg : int;
+	cb : int;
+}
+
+type rgba = {
+	r : int;
+	g : int;
+	b : int;
+	a : int;
+}
+
+type color =
+	| ColorRGB of rgb
+	| ColorRGBA of rgba
+
+type gradient =
+	| GradientRGB of ((int * rgb) list * int)
+	| GradientRGBA of ((int * rgba) list * int)
+
+type rect = {
+	rect_nbits : int;
+	left : int;
+	right : int;
+	top : int;
+	bottom : int;
+}
+
+type big_rect = {
+	brect_nbits : int;
+	bleft : int list;
+	bright : int list;
+	btop : int list;
+	bbottom : int list;
+}
+
+type matrix_part = {
+	m_nbits : int;
+	mx : int;
+	my : int;
+}
+
+type matrix = {
+	scale : matrix_part option;
+	rotate : matrix_part option;
+	trans : matrix_part;
+}
+
+type color_transform_alpha = {
+	cxa_nbits : int;
+	cxa_add : rgba option;
+	cxa_mult : rgba option;
+}
+
+type function_decl = {
+	f_name : string;
+	f_args : string list;
+	mutable f_codelen : action_count;
+}
+
+type func2_flags =
+	| ThisRegister
+	| ThisNoVar
+	| ArgumentsRegister
+	| ArgumentsNoVar
+	| SuperRegister
+	| SuperNoVar
+	| RootRegister
+	| ParentRegister
+	| GlobalRegister
+
+type function_decl2 = {
+	f2_name : string;
+	f2_flags : func2_flags list;
+	f2_args : (int * string) list;
+	mutable f2_nregs : int;
+	mutable f2_codelen : action_count;
+}
+
+type try_style =
+	| TryRegister of int
+	| TryVariable of string
+
+type try_block = {
+	tr_style : try_style;
+	mutable tr_trylen : action_count;
+	mutable tr_catchlen : action_count option;
+	mutable tr_finallylen : action_count option
+}
+
+type push_item =
+	| PString of string
+	| PFloat of int32
+	| PNull
+	| PUndefined
+	| PReg of int
+	| PBool of bool
+	| PDouble of float
+	| PInt of int32
+	| PStack of int
+	| PStack2 of int
+
+type property =
+	| PX
+	| PY
+	| PXScale
+	| PYScale
+	| PCurrentFrame
+	| PTotalFrames
+	| PAlpha
+	| PVisible
+	| PWidth
+	| PHeight
+	| PRotation
+	| PTarget
+	| PFramesLoaded
+	| PName
+	| PDropTarget
+	| PUrl
+	| PHighQuality
+	| PFocusRect
+	| PSoundBufTime
+	| PQuality
+	| PXMouse
+	| PYMouse
+
+type action =
+	| AEnd
+
+	| ANextFrame
+	| APrevFrame
+	| APlay
+	| AStop
+	| AToggleHighQuality
+	| AStopSounds
+	| AAddNum
+	| ASubtract
+	| AMultiply
+	| ADivide
+	| ACompareNum
+	| AEqualNum
+	| ALogicalAnd
+	| ALogicalOr
+	| ANot
+	| AStringEqual
+	| AStringLength
+	| ASubString
+	| APop
+	| AToInt
+	| AEval
+	| ASet
+	| ATellTarget
+	| AStringAdd
+	| AGetProperty
+	| ASetProperty
+	| ADuplicateMC
+	| ARemoveMC
+	| ATrace
+	| AStartDrag
+	| AStopDrag
+	| AThrow
+	| ACast
+	| AImplements
+	| AFSCommand2
+	| ARandom
+	| AMBStringLength
+	| AOrd
+	| AChr
+	| AGetTimer
+	| AMBStringSub
+	| AMBOrd
+	| AMBChr
+	| ADeleteObj
+	| ADelete
+	| ALocalAssign
+	| ACall
+	| AReturn
+	| AMod
+	| ANew
+	| ALocalVar
+	| AInitArray
+	| AObject
+	| ATypeOf
+	| ATargetPath
+	| AEnum
+	| AAdd
+	| ACompare
+	| AEqual
+	| AToNumber
+	| AToString
+	| ADup
+	| ASwap
+	| AObjGet
+	| AObjSet
+	| AIncrement
+	| ADecrement
+	| AObjCall
+	| ANewMethod
+	| AInstanceOf
+	| AEnum2
+	| AAnd
+	| AOr
+	| AXor
+	| AShl
+	| AShr
+	| AAsr
+	| APhysEqual
+	| AGreater
+	| AStringGreater
+	| AExtends
+
+	| AGotoFrame of int
+	| AGetURL of string * string
+	| ASetReg of int
+	| AStringPool of string list
+	| AWaitForFrame of int * int
+	| ASetTarget of string
+	| AGotoLabel of string
+	| AWaitForFrame2 of int
+	| AFunction2 of function_decl2
+	| ATry of try_block
+	| AWith of int
+	| APush of push_item list
+	| AJump of action_count
+	| AGetURL2 of int
+	| AFunction of function_decl
+	| ACondJump of action_count
+	| ACallFrame (* no data *)
+	| AGotoFrame2 of bool * int option
+
+	| AUnknown of int * unknown
+
+type actions = action DynArray.t
+
+type header = {
+	mutable h_version : int;
+	mutable h_size : rect;
+	mutable h_fps : float16;
+	mutable h_frame_count : int;
+	mutable h_compressed : bool;
+}
+
+type export = {
+	mutable exp_id : int;
+	exp_name : string;
+}
+
+type import = {
+	mutable imp_id : int;
+	imp_name : string;
+}
+
+type do_init_action = {
+	mutable dia_id : int;
+	dia_actions : actions;
+}
+
+type sound = {
+	mutable so_id : int;
+	so_flags : int;
+	so_samples : int;
+	so_data : unknown;
+}
+
+type start_sound = {
+	mutable sts_id : int;
+	sts_data : unknown;
+}
+
+type sfs_bitmap = {
+	sfb_repeat : bool;
+	sfb_smooth : bool;
+	mutable sfb_cid : int;
+	sfb_mpos : matrix;
+}
+
+type shape_fill_style =
+	| SFSSolid of rgb
+	| SFSSolid3 of rgba
+	| SFSLinearGradient of matrix * gradient
+	| SFSRadialGradient of matrix * gradient * int option
+	| SFSBitmap of sfs_bitmap
+
+type shape_line_style = {
+	sls_width : int;
+	sls_color : color;
+	sls_flags : int option;
+	sls_fill : shape_fill_style option;
+	sls_miter : int option;
+}
+
+type shape_new_styles = {
+	sns_fill_styles : shape_fill_style list;
+	sns_line_styles : shape_line_style list;
+	sns_nlbits : int;
+	sns_nfbits : int;
+}
+
+type shape_change_style_record = {
+	scsr_move : (int * int * int) option;
+	scsr_fs0 : int option;
+	scsr_fs1 : int option;
+	scsr_ls : int option;
+	scsr_new_styles : shape_new_styles option;
+}
+
+type shape_curved_edge_record = {
+	scer_nbits : int;
+	scer_cx : int;
+	scer_cy : int;
+	scer_ax : int;
+	scer_ay : int;
+}
+
+type shape_straight_edge_record = {
+	sser_nbits : int;
+	sser_line : int option * int option;
+}
+
+type shape_record =
+	| SRStyleChange of shape_change_style_record
+	| SRCurvedEdge of shape_curved_edge_record
+	| SRStraightEdge of shape_straight_edge_record
+
+type shape_records = {
+	srs_nlbits : int;
+	srs_nfbits : int;
+	srs_records : shape_record list;
+}
+
+type shape_with_style = {
+	sws_fill_styles : shape_fill_style list;
+	sws_line_styles : shape_line_style list;
+	sws_records : shape_records;
+}
+
+type shape = {
+	mutable sh_id : int;
+	sh_bounds : rect;
+	sh_bounds2 : (rect * int) option;
+	sh_style : shape_with_style;
+}
+
+type filter_gradient = {
+	fgr_colors : (rgba * int) list;
+	fgr_data : unknown;
+}
+
+type filter =
+	| FDropShadow of unknown
+	| FBlur of unknown
+	| FGlow of unknown
+	| FBevel of unknown
+	| FGradientGlow of filter_gradient
+	| FAdjustColor of unknown
+	| FGradientBevel of filter_gradient
+
+type bitmap_jpg = {
+	mutable jpg_id : int;
+	jpg_data : binary;
+}
+
+type bitmap_data = {
+	mutable bd_id : int;
+	bd_table : binary option;
+	bd_data : binary;
+	bd_alpha : binary option;
+	bd_deblock : int option;
+}
+
+type bitmap_lossless = {
+	mutable bll_id : int;
+	bll_format : int;
+	bll_width : int;
+	bll_height : int;
+	bll_data : unknown;
+}
+
+type morph_shape = {
+	mutable msh_id : int;
+	msh_start_bounds : rect;
+	msh_end_bounds : rect;
+	msh_data : unknown;
+}
+
+type cid_data = {
+	mutable cd_id : int;
+	cd_data : binary;
+}
+
+type text_glyph = {
+	txg_index : int;
+	txg_advanced : int;
+}
+
+type text_record = {
+	mutable txr_font : (int * int) option;
+	txr_color : color option;
+	txr_dx : int option;
+	txr_dy : int option;
+	txr_glyphs : text_glyph list;
+}
+
+type text = {
+	mutable txt_id : int;
+	txt_bounds : big_rect;
+	txt_matrix : matrix;
+	txt_ngbits : int;
+	txt_nabits : int;
+	txt_records : text_record list;
+}
+
+type button_record = {
+	btr_flags : int;
+	mutable btr_cid : int;
+	btr_depth : int;
+	btr_mpos : matrix;
+	btr_color : color_transform_alpha option;
+	btr_filters : filter list option;
+	btr_blendmode : int option;
+}
+
+type button_action = {
+	bta_flags : int;
+	bta_actions : actions;
+}
+
+type button2 = {
+	mutable bt2_id : int;
+	bt2_track_as_menu : bool;
+	bt2_records : button_record list;
+	bt2_actions : button_action list;
+}
+
+type remove_object = {
+	mutable rmo_id : int;
+	rmo_depth : int;
+}
+
+type edit_text_layout = {
+	edtl_align : int;
+	edtl_left_margin : int;
+	edtl_right_margin : int;
+	edtl_indent : int;
+	edtl_leading : int;
+}
+
+type edit_text = {
+	mutable edt_id : int;
+	edt_bounds : rect;
+	mutable edt_font : (int * int) option;
+	edt_color : rgba option;
+	edt_maxlen : int option;
+	edt_layout : edit_text_layout option;
+	edt_variable : string;
+	edt_text : string option;
+	edt_wordwrap : bool;
+	edt_multiline : bool;
+	edt_password : bool;
+	edt_readonly : bool;
+	edt_autosize : bool;
+	edt_noselect : bool;
+	edt_border : bool;
+	edt_html : bool;
+	edt_outlines : bool;
+}
+
+type f9class = {
+	mutable f9_cid : int option;
+	f9_classname : string;
+}
+
+type files_attrib = {
+	fa_network : bool;
+	fa_as3 : bool;
+	fa_metadata : bool;
+	fa_gpu : bool;
+	fa_direct_blt : bool;
+}
+
+type tag_data =
+	| TEnd
+	| TShowFrame
+	| TShape of shape
+	| TRemoveObject of remove_object
+	| TBitsJPEG of bitmap_jpg
+	| TJPEGTables of binary
+	| TSetBgColor of rgb
+	| TFont of cid_data
+	| TText of text
+	| TDoAction of actions
+	| TFontInfo of cid_data
+	| TSound of sound
+	| TStartSound of start_sound
+	| TBitsLossless of bitmap_lossless
+	| TBitsJPEG2 of bitmap_data
+	| TShape2 of shape
+	| TProtect
+	| TPlaceObject2 of place_object
+	| TRemoveObject2 of int
+	| TShape3 of shape
+	| TText2 of text
+	| TButton2 of button2
+	| TBitsJPEG3 of bitmap_data
+	| TBitsLossless2 of bitmap_lossless
+	| TEditText of edit_text
+	| TClip of clip
+	| TProductInfo of unknown
+	| TFrameLabel of string * char option
+	| TSoundStreamHead2 of unknown
+	| TMorphShape of morph_shape
+	| TFont2 of cid_data
+	| TExport of export list
+	| TImport of string * import list
+	| TDoInitAction of do_init_action
+	| TVideoStream of cid_data
+	| TVideoFrame of cid_data
+	| TFontInfo2 of cid_data
+	| TDebugID of unknown
+	| TEnableDebugger2 of int * string
+	| TScriptLimits of int * int
+	| TFilesAttributes of files_attrib
+	| TPlaceObject3 of place_object
+	| TImport2 of string * import list
+	| TFontAlignZones of cid_data
+	| TCSMSettings of cid_data
+	| TFont3 of cid_data
+	| TF9Classes of f9class list
+	| TMetaData of string
+	| TScale9 of int * rect
+	| TActionScript3 of (int * string) option * As3.as3_tag
+	| TShape4 of shape
+	| TMorphShape2 of morph_shape
+	| TScenes of (int * string) list * (int * string) list
+	| TBinaryData of int * binary
+	| 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 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,2203 @@
+(*
+ *  This file is part of SwfLib
+ *  Copyright (c)2004 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+open Swf
+open ActionScript
+open IO
+
+(* ************************************************************************ *)
+(* TOOLS *)
+
+let full_parsing = ref true
+let force_as3_parsing = ref false
+let swf_version = ref 0
+let id_count = ref 0
+let tag_end = { tid = 0; textended = false; tdata = TEnd }
+
+let sum f l =
+	List.fold_left (fun acc x -> acc + f x) 0 l
+
+let gen_id() =
+	incr id_count;
+	!id_count
+
+let const n = fun _ -> n
+
+let opt_len f = function
+	| None -> 0
+	| Some x -> f x
+
+let opt_flag flags fid f fparam =
+	if (flags land fid) = 0 then
+		None
+	else
+		Some (f fparam)
+
+let opt f = function
+	| None -> ()
+	| Some x -> f x
+
+let flag = function
+	| None -> false
+	| Some _ -> true
+
+let rec make_flags = function
+	| [] -> 0
+	| true :: l -> 1 lor ((make_flags l) lsl 1)
+	| false :: l -> (make_flags l) lsl 1
+
+let f16_value (a,b) =
+	let k = int_of_char a lor (int_of_char b lsl 8) in
+	float_of_int k /. float_of_int (1 lsl 8)
+
+let rec read_count n f arg =
+	if n = 0 then
+		[]
+	else
+		let v = f arg in
+		v :: read_count (n - 1) f arg
+
+(* ************************************************************************ *)
+(* LENGTH *)
+
+let _nbits x =
+	if x < 0 then error "Negative nbits";
+	if x = 0 then
+		0
+	else
+		let x = ref x in
+		let nbits = ref 0 in
+		while !x > 0 do
+			x := !x lsr 1;
+			incr nbits;
+		done;
+		!nbits
+
+let rect_nbits r =
+	r.rect_nbits
+
+let bigrect_nbits r =
+	r.brect_nbits
+
+let rgba_nbits c =
+	max
+		(max (_nbits c.r) (_nbits c.g))
+		(max (_nbits c.b) (_nbits c.a))
+
+let cxa_nbits c =
+	c.cxa_nbits
+
+let matrix_part_nbits m =
+	m.m_nbits
+
+let rgb_length = 3
+
+let rgba_length = 4
+
+let string_length s = String.length s + 1
+
+let color_length = function
+	| ColorRGB _ -> rgb_length
+	| ColorRGBA _ -> rgba_length
+
+let rect_length r =
+	let nbits = rect_nbits r in
+	let nbits = nbits * 4 + 5 in
+	(nbits + 7) / 8
+
+let big_rect_length r =
+	let nbits = bigrect_nbits r in
+	let nbits = nbits * 4 + 5 in
+	(nbits + 7) / 8
+
+let gradient_length = function
+	| GradientRGB (l,_) -> 1 + (1 + rgb_length) * List.length l
+	| GradientRGBA (l,_) -> 1 + (1 + rgba_length) * List.length l
+
+let matrix_length m =
+	let matrix_part_len m = 5 + matrix_part_nbits m * 2 in
+	let nbits = 2 + opt_len matrix_part_len m.scale + opt_len matrix_part_len m.rotate + matrix_part_len m.trans in
+	(nbits + 7) / 8
+
+let cxa_length c =
+	let nbits = cxa_nbits c in
+	let nbits = 6 + opt_len (const (nbits * 4)) c.cxa_add + opt_len (const (nbits * 4)) c.cxa_mult in
+	(nbits + 7) / 8
+
+let clip_event_length c =
+	(if !swf_version >= 6 then 4 else 2) + 4 + (opt_len (const 1) c.cle_key) + actions_length c.cle_actions
+
+let clip_events_length l =
+	(if !swf_version >= 6 then 10 else 6) + sum clip_event_length l
+
+let export_length e =
+	2 + string_length e.exp_name
+
+let import_length i =
+	2 + string_length i.imp_name
+
+let sound_length s =
+	2 + 1 + 4 + String.length s.so_data
+
+let shape_fill_style_length s =
+	1 + match s with
+	| SFSSolid _ -> rgb_length
+	| SFSSolid3 _ -> rgba_length
+	| SFSLinearGradient (m,g)
+	| SFSRadialGradient (m,g,None) -> matrix_length m + gradient_length g
+	| SFSRadialGradient (m,g,Some _) -> matrix_length m + gradient_length g + 2
+	| SFSBitmap b -> 2 + matrix_length b.sfb_mpos
+
+let shape_line_style_length s =
+	2 + match s.sls_flags with
+		| None -> color_length s.sls_color
+		| Some _ ->
+			2 + (match s.sls_fill with None -> color_length s.sls_color | Some f -> shape_fill_style_length f)
+			  + opt_len (const 2) s.sls_miter
+
+let shape_array_length f s =
+	let n = List.length s in
+	(if n < 0xFF then 1 else 3) + sum f s
+
+let shape_new_styles_length s =
+	shape_array_length shape_fill_style_length s.sns_fill_styles +
+	shape_array_length shape_line_style_length s.sns_line_styles +
+	1
+
+let 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
+	| TFontName c ->
+		cid_data_length c
+	| TBitsJPEG4 b ->
+		2 + 2 + 4 + opt_len String.length b.bd_table + String.length b.bd_data + opt_len String.length b.bd_alpha
+	| TFont4 c ->
+		cid_data_length c
+	| TUnknown (_,data) ->
+		String.length data
+
+and tag_length t =
+	let dlen = tag_data_length t.tdata in
+	dlen + 2 + (if t.textended || dlen >= 63 then 4 else 0)
+
+(* ************************************************************************ *)
+(* READ PRIMS *)
+
+let skip ch n =
+	seek_in ch ((Pervasives.pos_in ch) + n)
+
+let read_rgba ch =
+	let r = read_byte ch in
+	let g = read_byte ch in
+	let b = read_byte ch in
+	let a = read_byte ch in
+	{
+		r = r;
+		g = g;
+		b = b;
+		a = a;
+	}
+
+let read_rgb ch =
+	let r = read_byte ch in
+	let g = read_byte ch in
+	let b = read_byte ch in
+	{
+		cr = r;
+		cg = g;
+		cb = b;
+	}
+
+let read_gradient ch is_rgba =
+	let grad_rgb() =
+		let r = read_byte ch in
+		let c = read_rgb ch in
+		(r, c)
+	in
+	let grad_rgba() =
+		let r = read_byte ch in
+		let c = read_rgba ch in
+		(r, c)
+	in
+	let n = read_byte ch in
+	let n , flags = n land 0xF , n lsr 4 in
+	if is_rgba then
+		GradientRGBA (read_count n grad_rgba (),flags)
+	else
+		GradientRGB (read_count n grad_rgb (),flags)
+
+let read_rect ch =
+	let b = input_bits ch in
+	let nbits = read_bits b 5 in
+	let left = read_bits b nbits in
+	let right = read_bits b nbits in
+	let top = read_bits b nbits in
+	let bottom = read_bits b nbits in
+	{
+		rect_nbits = nbits;
+		left = left;
+		right = right;
+		top = top;
+		bottom = bottom;
+	}
+
+let rec read_multi_bits b n =
+	if n <= 30 then
+		[read_bits b n]
+	else
+		let d = read_bits b 30 in
+		d :: read_multi_bits b (n - 30)
+
+let read_big_rect ch =
+	let b = input_bits ch in
+	let nbits = read_bits b 5 in
+	let left = read_multi_bits b nbits in
+	let right = read_multi_bits b nbits in
+	let top = read_multi_bits b nbits in
+	let bottom = read_multi_bits b nbits in
+	{
+		brect_nbits = nbits;
+		bleft = left;
+		bright = right;
+		btop = top;
+		bbottom = bottom;
+	}
+
+let read_matrix ch =
+	let b = input_bits ch in
+	let read_matrix_part() =
+		let nbits = read_bits b 5 in
+		let x = read_bits b nbits in
+		let y = read_bits b nbits in
+		{
+			m_nbits = nbits;
+			mx = x;
+			my = y;
+		}
+	in
+	let has_scale = (read_bits b 1 = 1) in
+	let scale = (if has_scale then Some (read_matrix_part()) else None) in
+	let has_rotate = (read_bits b 1 = 1) in
+	let rotate = (if has_rotate then Some (read_matrix_part()) else None) in
+	let trans = read_matrix_part() in
+	{
+		scale = scale;
+		rotate = rotate;
+		trans = trans;
+	}
+
+let read_cxa ch =
+	let b = input_bits ch in
+	let has_add = (read_bits b 1 = 1) in
+	let has_mult = (read_bits b 1 = 1) in
+	let nbits = read_bits b 4 in
+	let read_cxa_color() =
+		let r = read_bits b nbits in
+		let g = read_bits b nbits in
+		let bl = read_bits b nbits in
+		let a = read_bits b nbits in
+		{
+			r = r;
+			g = g;
+			b = bl;
+			a = a;
+		}
+	in
+	let mult = (if has_mult then Some (read_cxa_color()) else None) in
+	let add = (if has_add then Some (read_cxa_color()) else None) in
+	{
+		cxa_nbits = nbits;
+		cxa_add = add;
+		cxa_mult = mult;
+	}
+
+let read_event ch =
+	(if !swf_version >= 6 then read_i32 else read_ui16) ch
+
+(* ************************************************************************ *)
+(* WRITE PRIMS *)
+
+let write_rgb ch c =
+	write_byte ch c.cr;
+	write_byte ch c.cg;
+	write_byte ch c.cb
+
+let write_rgba ch c =
+	write_byte ch c.r;
+	write_byte ch c.g;
+	write_byte ch c.b;
+	write_byte ch c.a
+
+let write_color ch = function
+	| ColorRGB c -> write_rgb ch c
+	| ColorRGBA c -> write_rgba ch c
+
+let write_gradient ch = function
+	| GradientRGB (l,flags) ->
+		let n = List.length l in
+		write_byte ch (n lor (flags lsl 4));
+		List.iter (fun (ratio,c) -> write_byte ch ratio; write_rgb ch c) l
+	| GradientRGBA (l,flags) ->
+		let n = List.length l in
+		write_byte ch (n lor (flags lsl 4));
+		List.iter (fun (ratio,c) -> write_byte ch ratio; write_rgba ch c) l
+
+let write_rect ch r =
+	let b = output_bits ch in
+	let nbits = rect_nbits r in
+	write_bits b 5 nbits;
+	write_bits b nbits r.left;
+	write_bits b nbits r.right;
+	write_bits b nbits r.top;
+	write_bits b nbits r.bottom;
+	flush_bits b
+
+let rec write_multi_bits b n l =
+	if n <= 30 then
+		match l with
+		| [] -> write_bits b n 0
+		| [x] -> write_bits b n x
+		| _ -> assert false
+	else
+		match l with
+		| [] -> write_bits b 30 0; write_multi_bits b (n - 30) []
+		| x :: l -> write_bits b 30 x; write_multi_bits b (n - 30) l
+
+let write_big_rect ch r =
+	let b = output_bits ch in
+	let nbits = bigrect_nbits r in
+	write_bits b 5 nbits;
+	write_multi_bits b nbits r.bleft;
+	write_multi_bits b nbits r.bright;
+	write_multi_bits b nbits r.btop;
+	write_multi_bits b nbits r.bbottom;
+	flush_bits b
+
+let write_matrix ch m =
+	let b = output_bits ch in
+	let write_matrix_part m =
+		let nbits = matrix_part_nbits m in
+		write_bits b 5 nbits;
+		write_bits b nbits m.mx;
+		write_bits b nbits m.my;
+	in
+	(match m.scale with
+	| None ->
+		write_bits b 1 0
+	| Some s ->
+		write_bits b 1 1;
+		write_matrix_part s
+	);
+	(match m.rotate with
+	| None ->
+		write_bits b 1 0
+	| Some r ->
+		write_bits b 1 1;
+		write_matrix_part r);
+	write_matrix_part m.trans;
+	flush_bits b
+
+let write_cxa ch c =
+	let b = output_bits ch in
+	let nbits = cxa_nbits c in
+	(match c.cxa_add , c.cxa_mult with
+	| None , None ->
+		write_bits b 2 0;
+		write_bits b 4 1; (* some strange MM thing... *)
+	| Some c , None ->
+		write_bits b 2 2;
+		write_bits b 4 nbits;
+		List.iter (write_bits b ~nbits) [c.r;c.g;c.b;c.a];
+	| None , Some c ->
+		write_bits b 2 1;
+		write_bits b 4 nbits;
+		List.iter (write_bits b ~nbits) [c.r;c.g;c.b;c.a];
+	| Some c1 , Some c2 ->
+		write_bits b 2 3;
+		write_bits b 4 nbits;
+		List.iter (write_bits b ~nbits) [c2.r;c2.g;c2.b;c2.a;c1.r;c1.g;c1.b;c1.a]
+	);
+	flush_bits b
+
+let write_event ch evt =
+	(if !swf_version >= 6 then write_i32 else write_ui16) ch evt
+
+(* ************************************************************************ *)
+(* PARSING *)
+
+let parse_clip_events ch =
+	ignore(read_ui16 ch); (* reserved *)
+	ignore(read_event ch); (* all_events *)
+	let rec loop() =
+		let events = read_event ch in
+		if events = 0 then
+			[]
+		else begin
+			ignore(read_i32 ch); (* len *)
+			let key = (if events land (1 lsl 17) <> 0 then Some (read ch) else None) in
+			let e = {
+				cle_events = events;
+				cle_key = key;
+				cle_actions = parse_actions ch
+			} in
+			e :: (loop())
+		end;
+	in
+	loop()
+
+let parse_shape_fill_style ch vshape =
+	let t = read_byte ch in
+	match t with
+	| 0x00 when vshape >= 3 -> SFSSolid3 (read_rgba ch)
+	| 0x00 -> SFSSolid (read_rgb ch)
+	| 0x10 ->
+		let m = read_matrix ch in
+		let g = read_gradient ch (vshape >= 3) in
+		SFSLinearGradient (m,g)
+	| 0x12 ->
+		let m = read_matrix ch in
+		let g = read_gradient ch (vshape >= 3) in
+		SFSRadialGradient (m,g,None)
+	| 0x13 ->
+		let m = read_matrix ch in
+		let g = read_gradient ch (vshape >= 3) in
+		let i = read_i16 ch in
+		SFSRadialGradient (m,g,Some i)
+	| 0x40
+	| 0x41
+	| 0x42
+	| 0x43 ->
+		let id = read_ui16 ch in
+		let m = read_matrix ch in
+		SFSBitmap {
+			sfb_repeat = (t = 0x40 || t = 0x42);
+			sfb_smooth = (t = 0x42 || t = 0x43);
+			sfb_cid = id;
+			sfb_mpos = m;
+		}
+	| _ ->
+		assert false
+
+let parse_shape_line_style ch vshape =
+	let width = read_ui16 ch in
+	if vshape >= 4 then begin
+		let flags = read_ui16 ch in
+		let fill = (flags land 8 <> 0) in
+		let miterjoin = (flags land 0x20 <> 0) in
+		let miter = (if miterjoin then Some (IO.read_ui16 ch) else None) in
+		let color = (if fill then { r = 0; g = 0; b = 0; a = 0 } else read_rgba ch) in
+		(*
+			let noVscale = (flags land 0x02 <> 0) in
+			let noHscale = (flags land 0x04 <> 0) in
+			let beveljoin = (flags land 0x10 <> 0) in
+			let nocap = (flags land 0x40 <> 0) in
+			let squarecap = (flags land 0x80 <> 0) in
+		*)
+		{
+			sls_width = width;
+			sls_color = ColorRGBA color;
+			sls_fill = if fill then Some (parse_shape_fill_style ch vshape) else None;
+			sls_flags = Some flags;
+			sls_miter = miter;
+		}
+	end else
+		{
+			sls_width = width;
+			sls_color = if vshape = 3 then ColorRGBA (read_rgba ch) else ColorRGB (read_rgb ch);
+			sls_fill = None;
+			sls_flags = None;
+			sls_miter = None;
+		}
+
+let parse_shape_array f ch vshape =
+	let n = (match read_byte ch with 0xFF -> read_ui16 ch | n -> n) in
+	read_count n (f ch) vshape
+
+let parse_shape_style_change_record ch b flags nlbits nfbits vshape =
+	let move = (if flags land 1 <> 0 then begin
+		let mbits = read_bits b 5 in
+		let dx = read_bits b mbits in
+		let dy = read_bits b mbits in
+		Some (mbits,dx,dy)
+	end else
+		None)
+	in
+	let fs0 = (if flags land 2 <> 0 then Some (read_bits b !nfbits) else None) in
+	let fs1 = (if flags land 4 <> 0 then Some (read_bits b !nfbits) else None) in
+	let ls = (if flags land 8 <> 0 then Some (read_bits b !nlbits) else None) in
+	let styles = (if flags land 16 <> 0 then begin
+		IO.drop_bits b;
+		let fstyles = parse_shape_array parse_shape_fill_style ch vshape in
+		let lstyles = parse_shape_array parse_shape_line_style ch vshape in
+		let bits = read_byte ch in
+		nlbits := bits land 15;
+		nfbits := bits lsr 4;
+		Some {
+			sns_fill_styles = fstyles;
+			sns_line_styles = lstyles;
+			sns_nlbits = !nlbits;
+			sns_nfbits = !nfbits;
+		}
+	end else
+		None
+	) in
+	{
+		scsr_move = move;
+		scsr_fs0 = fs0;
+		scsr_fs1 = fs1;
+		scsr_ls = ls;
+		scsr_new_styles = styles;
+	}
+
+let parse_shape_curved_edge_record b flags =
+	let nbits = (flags land 15) + 2 in
+	let cx = read_bits b nbits in
+	let cy = read_bits b nbits in
+	let ax = read_bits b nbits in
+	let ay = read_bits b nbits in
+	{
+		scer_nbits = nbits;
+		scer_cx = cx;
+		scer_cy = cy;
+		scer_ax = ax;
+		scer_ay = ay;
+	}
+
+let parse_shape_straight_edge_record b flags =
+	let nbits = (flags land 15) + 2 in
+	let is_general = (read_bits b 1 = 1) in
+	let l = (if is_general then
+		let dx = read_bits b nbits in
+		let dy = read_bits b nbits in
+		Some dx, Some dy
+	else
+		let is_vertical = (read_bits b 1 = 1) in
+		let p = read_bits b nbits in
+		if is_vertical then
+			None, Some p
+		else
+			Some p, None)
+	in
+	{
+		sser_nbits = nbits;
+		sser_line = l;
+	}
+
+let parse_shape_records ch nlbits nfbits vshape =
+	let b = input_bits ch in
+	let nlbits = ref nlbits in
+	let nfbits = ref nfbits in
+	let rec loop() =
+		let flags = read_bits b 6 in
+		if flags = 0 then
+			[]
+		else
+			let r =
+				(if (flags land 32) = 0 then
+					SRStyleChange (parse_shape_style_change_record ch b flags nlbits nfbits vshape)
+				else if (flags land 48) = 32 then
+					SRCurvedEdge (parse_shape_curved_edge_record b flags)
+				else
+					SRStraightEdge (parse_shape_straight_edge_record b flags))
+			in
+			r :: loop()
+	in
+	loop()
+
+let parse_shape_with_style ch vshape =
+	let fstyles = parse_shape_array parse_shape_fill_style ch vshape in
+	let lstyles = parse_shape_array parse_shape_line_style ch vshape in
+	let bits = read_byte ch in
+	let nlbits = bits land 15 in
+	let nfbits = bits lsr 4 in
+	let records = parse_shape_records ch nlbits nfbits vshape in
+	{
+		sws_fill_styles = fstyles;
+		sws_line_styles = lstyles;
+		sws_records = {
+			srs_nlbits = nlbits;
+			srs_nfbits = nfbits;
+			srs_records = records;
+		}
+	}
+
+
+let parse_shape ch len vshape =
+	let id = read_ui16 ch in
+	let bounds = read_rect ch in
+	let bounds2 = (if vshape = 4 then
+		let r = read_rect ch in
+		let b = read_byte ch in
+		Some (r, b)
+	else
+		None
+	) in
+	let style = parse_shape_with_style ch vshape in
+	{
+		sh_id = id;
+		sh_bounds = bounds;
+		sh_bounds2 = bounds2;
+		sh_style = style;
+	}
+
+let extract_jpg_table data =
+	match data.[0], data.[1] with
+	| '\xFF', '\xD8' ->
+		let ch = IO.input_string data in
+		let b = Buffer.create 0 in
+		let rec loop flag =
+			let c = IO.read ch in
+			Buffer.add_char b c;
+			match int_of_char c with
+			| 0xFF -> loop true
+			| 0xD9 when flag -> ()
+			| _ -> loop false
+		in
+		loop false;
+		let t = Buffer.contents b in
+		let l = String.length t in
+		String.sub data l (String.length data - l), Some t
+	| _ ->
+		data, None
+
+let parse_bitmap_lossless ch len =
+	let id = read_ui16 ch in
+	let format = read_byte ch in
+	let width = read_ui16 ch in
+	let height = read_ui16 ch in
+	let data = nread ch (len - 7) in
+	{
+		bll_id = id;
+		bll_format = format;
+		bll_width = width;
+		bll_height = height;
+		bll_data = data;
+	}
+
+let parse_text ch is_txt2 =
+	let id = read_ui16 ch in
+	let bounds = read_big_rect ch in
+	let matrix = read_matrix ch in
+	let ngbits = read_byte ch in
+	let nabits = read_byte ch in
+	let read_glyph bits =
+		let indx = read_bits bits ngbits in
+		let adv = read_bits bits nabits in
+		{
+			txg_index = indx;
+			txg_advanced = adv;
+		}
+	in
+	let rec loop() =
+		let flags = read_byte ch in
+		if flags = 0 then
+			[]
+		else
+			let font_id = (if flags land 8 <> 0 then read_ui16 ch else 0) in
+			let color = (if flags land 4 <> 0 then Some (if is_txt2 then ColorRGBA (read_rgba ch) else ColorRGB (read_rgb ch)) else None) in
+			let dx = (if flags land 1 <> 0 then Some (read_i16 ch) else None) in
+			let dy = (if flags land 2 <> 0 then Some (read_i16 ch) else None) in
+			let font = (if flags land 8 <> 0 then Some (font_id,read_ui16 ch) else None) in
+			let nglyphs = read_byte ch in
+			let r = {
+				txr_font = font;
+				txr_color = color;
+				txr_dx = dx;
+				txr_dy = dy;
+				txr_glyphs = read_count nglyphs read_glyph (input_bits ch);
+			} in
+			r :: loop()
+	in
+	{
+		txt_id = id;
+		txt_bounds = bounds;
+		txt_matrix = matrix;
+		txt_ngbits = ngbits;
+		txt_nabits = nabits;
+		txt_records = loop();
+	}
+
+let parse_edit_text_layout ch =
+	let align = read_byte ch in
+	let ml = read_ui16 ch in
+	let rl = read_ui16 ch in
+	let ident = read_ui16 ch in
+	let lead = read_ui16 ch in
+	{
+		edtl_align = align;
+		edtl_left_margin = ml;
+		edtl_right_margin = rl;
+		edtl_indent = ident;
+		edtl_leading = lead;
+	}
+
+let parse_edit_text ch =
+	let id = read_ui16 ch in
+	let bounds = read_rect ch in
+	let flags = read_ui16 ch in
+	let font = (if flags land 1 <> 0 then
+			let fid = read_ui16 ch in
+			let height = read_ui16 ch in
+			Some (fid, height)
+		else
+			None) in
+	let color = (if flags land 4 <> 0 then Some (read_rgba ch) else None) in
+	let maxlen = (if flags land 2 <> 0 then Some (read_ui16 ch) else None) in
+	let layout = (if flags land (1 lsl 13) <> 0 then Some (parse_edit_text_layout ch) else None) in
+	let variable = read_string ch in
+	let text = (if flags land 128 <> 0 then Some (read_string ch) else None) in
+	{
+		edt_id = id;
+		edt_bounds = bounds;
+		edt_font = font;
+		edt_color = color;
+		edt_maxlen = maxlen;
+		edt_layout = layout;
+		edt_variable = variable;
+		edt_text = text;
+		edt_wordwrap = (flags land 64) <> 0;
+		edt_multiline = (flags land 32) <> 0;
+		edt_password = (flags land 16) <> 0;
+		edt_readonly = (flags land 8) <> 0;
+		edt_autosize = (flags land (1 lsl 14)) <> 0;
+		edt_noselect = (flags land 4096) <> 0;
+		edt_border = (flags land 2048) <> 0;
+		edt_html = (flags land 512) <> 0;
+		edt_outlines = (flags land 256) <> 0;
+	}
+
+let parse_cid_data ch len =
+	let id = read_ui16 ch in
+	let data = nread ch (len - 2) in
+	{
+		cd_id = id;
+		cd_data = data;
+	}
+
+let parse_morph_shape ch len =
+	let id = read_ui16 ch in
+	let sbounds = read_rect ch in
+	let ebounds = read_rect ch in
+	let data = nread ch (len - 2 - rect_length sbounds - rect_length ebounds) in
+	{
+		msh_id = id;
+		msh_start_bounds = sbounds;
+		msh_end_bounds = ebounds;
+		msh_data = data;
+	}
+
+let parse_filter_gradient ch =
+	let ncolors = read_byte ch in
+	let colors = read_count ncolors read_rgba ch in
+	let cvals = read_count ncolors read_byte ch in
+	let data = nread ch 19 in
+	{
+		fgr_colors = List.combine colors cvals;
+		fgr_data = data;
+	}
+
+let parse_filter ch =
+	match read_byte ch with
+	| 0 -> FDropShadow (nread ch 23)
+	| 1 -> FBlur (nread ch 9)
+	| 2 -> FGlow (nread ch 15)
+	| 3 -> FBevel (nread ch 27)
+	| 4 -> FGradientGlow (parse_filter_gradient ch)
+	| 6 -> FAdjustColor (nread ch 80)
+	| 7 -> FGradientBevel (parse_filter_gradient ch)
+	| _ -> assert false
+
+let parse_filters ch =
+	let nf = read_byte ch in
+	read_count nf parse_filter ch
+
+let rec parse_button_records ch color =
+	let flags = read_byte ch in
+	if flags = 0 then
+		[]
+	else
+		let cid = read_ui16 ch in
+		let depth = read_ui16 ch in
+		let mpos = read_matrix ch in
+		let cxa = (if color then Some (read_cxa ch) else None) in
+		let filters = (if flags land 16 = 0 then None else Some (parse_filters ch)) in
+		let blendmode = (if flags land 32 = 0 then None else Some (read_byte ch)) in
+		let r = {
+			btr_flags = flags;
+			btr_cid = cid;
+			btr_depth = depth;
+			btr_mpos = mpos;
+			btr_color = cxa;
+			btr_filters = filters;
+			btr_blendmode = blendmode;
+		} in
+		r :: parse_button_records ch color
+
+let rec parse_button_actions ch =
+	let size = read_ui16 ch in
+	let flags = read_ui16 ch in
+	let actions = parse_actions ch in
+	let bta = {
+		bta_flags = flags;
+		bta_actions = actions;
+	} in
+	if size = 0 then
+		[bta]
+	else
+		bta :: parse_button_actions ch
+
+let parse_button2 ch len =
+	let id = read_ui16 ch in
+	let flags = read_byte ch in
+	let track = (match flags with 0 -> false | 1 -> true | _ -> assert false) in
+	let offset = read_ui16 ch in
+	let records = parse_button_records ch true in
+	let actions = (if offset = 0 then [] else parse_button_actions ch) in
+	{
+		bt2_id = id;
+		bt2_track_as_menu = track;
+		bt2_records = records;
+		bt2_actions = actions;
+	}
+
+let parse_place_object ch v3 =
+	let f = read_byte ch in
+	let fext = (if v3 then read_byte ch else 0) in
+	let depth = read_ui16 ch in
+	let move = (f land 1) <> 0 in
+	let cid = opt_flag f 2 read_ui16 ch in
+	let matrix = opt_flag f 4 read_matrix ch in
+	let color = opt_flag f 8 read_cxa ch in
+	let ratio = opt_flag f 16 read_ui16 ch in
+	let name = opt_flag f 32 read_string ch in
+	let clip_depth = opt_flag f 64 read_ui16 ch in
+	let clip_events = opt_flag f 128 parse_clip_events ch in
+	let filters = opt_flag fext 1 parse_filters ch in
+	let blend = opt_flag fext 2 read_byte ch in
+	let bcache = opt_flag fext 4 read_byte ch in
+	{
+		po_depth = depth;
+		po_move = move;
+		po_cid = cid;
+		po_matrix = matrix;
+		po_color = color;
+		po_ratio = ratio;
+		po_inst_name = name;
+		po_clip_depth = clip_depth;
+		po_events = clip_events;
+		po_filters = filters;
+		po_blend = blend;
+		po_bcache = bcache;
+	}
+
+let parse_import ch =
+	let cid = read_ui16 ch in
+	let name = read_string ch in
+	{
+		imp_id = cid;
+		imp_name = name
+	}
+
+let rec parse_tag ch h =
+	let id = h lsr 6 in
+	let len = h land 63 in
+	let len , extended = (
+		if len = 63 then
+			let len = read_i32 ch in
+			len , len < 63
+		else
+			len , false
+	) in
+	let t = (
+		match id with
+		| 0x00 ->
+			TEnd
+		| 0x01 ->
+			TShowFrame
+		| 0x02 when !full_parsing ->
+			TShape (parse_shape ch len 1)
+		(* 0x03 invalid *)
+		(*//0x04 TPlaceObject *)
+		| 0x05 ->
+			let cid = read_ui16 ch in
+			let depth = read_ui16 ch in
+			TRemoveObject {
+				rmo_id = cid;
+				rmo_depth = depth;
+			}
+		| 0x06 ->
+			let id = read_ui16 ch in
+			let data = nread ch (len - 2) in
+			TBitsJPEG {
+				jpg_id = id;
+				jpg_data = data;
+			}
+		(*//0x07 TButton *)
+		| 0x08 ->
+			TJPEGTables (nread ch len)
+		| 0x09 ->
+			TSetBgColor (read_rgb ch)
+		| 0x0A ->
+			TFont (parse_cid_data ch len)
+		| 0x0B when !full_parsing ->
+			TText (parse_text ch false)
+		| 0x0C ->
+			TDoAction (parse_actions ch)
+		| 0x0D ->
+			TFontInfo (parse_cid_data ch len)
+		| 0x0E ->
+			let sid = read_ui16 ch in
+			let flags = read_byte ch in
+			let samples = read_i32 ch in
+			let data = nread ch (len - 7) in
+			TSound {
+				so_id = sid;
+				so_flags = flags;
+				so_samples = samples;
+				so_data = data;
+			}
+		| 0x0F ->
+			let sid = read_ui16 ch in
+			let data = nread ch (len - 2) in
+			TStartSound {
+				sts_id = sid;
+				sts_data = data;
+			}
+		(* 0x10 invalid *)
+		(*//0x11 TButtonSound *)
+		(*//0x12 TSoundStreamHead *)
+		(*//0x13 TSoundStreamBlock *)
+		| 0x14 ->
+			TBitsLossless (parse_bitmap_lossless ch len)
+		| 0x15 ->
+			let id = read_ui16 ch in
+			let data = nread ch (len - 2) in
+			let data, table = extract_jpg_table data in
+			TBitsJPEG2 {
+				bd_id = id;
+				bd_table = table;
+				bd_data = data;
+				bd_alpha = None;
+				bd_deblock = None;
+			}
+		| 0x16 when !full_parsing ->
+			TShape2 (parse_shape ch len 2)
+		(*//0x17 TButtonCXForm *)
+		| 0x18 ->
+			TProtect
+		(* 0x19 invalid *)
+		| 0x1A when !full_parsing ->
+			TPlaceObject2 (parse_place_object ch false)
+		(* 0x1B invalid *)
+		| 0x1C ->
+			let depth = read_ui16 ch in
+			TRemoveObject2 depth
+		(* 0x1D-1F invalid *)
+		| 0x20 when !full_parsing ->
+			TShape3 (parse_shape ch len 3)
+		| 0x21 when !full_parsing ->
+			TText2 (parse_text ch true)
+		| 0x22 when !full_parsing ->
+			TButton2 (parse_button2 ch len)
+		| 0x23 ->
+			let id = read_ui16 ch in
+			let size = read_i32 ch in
+			let data = nread ch size in
+			let data, table = extract_jpg_table data in
+			let alpha = nread ch (len - 6 - size) in
+			TBitsJPEG3 {
+				bd_id = id;
+				bd_table = table;
+				bd_data = data;
+				bd_alpha = Some alpha;
+				bd_deblock = None;
+			}
+		| 0x24 ->
+			TBitsLossless2 (parse_bitmap_lossless ch len)
+		| 0x25 when !full_parsing ->
+			TEditText (parse_edit_text ch)
+		(* 0x26 invalid *)
+		| 0x27 ->
+			let cid = read_ui16 ch in
+			let fcount = read_ui16 ch in
+			let tags = parse_tag_list ch in
+			TClip {
+				c_id = cid;
+				c_frame_count = fcount;
+				c_tags = tags;
+			}
+		(* 0x28 invalid *)
+		| 0x29 ->
+			(* undocumented ? *)
+			TProductInfo (nread ch len)
+		(* 0x2A invalid *)
+		| 0x2B ->
+			let label = read_string ch in
+			let id = (if len = String.length label + 2 then Some (read ch) else None) in
+			TFrameLabel (label,id)
+		(* 0x2C invalid *)
+		| 0x2D ->
+			TSoundStreamHead2 (nread ch len)
+		| 0x2E when !full_parsing ->
+			TMorphShape (parse_morph_shape ch len)
+		(* 0x2F invalid *)
+		| 0x30 when !full_parsing ->
+			TFont2 (parse_cid_data ch len)
+		(* 0x31-37 invalid *)
+		| 0x38 ->
+			let read_export() =
+				let cid = read_ui16 ch in
+				let name = read_string ch in
+				{
+					exp_id = cid;
+					exp_name = name
+				}
+			in
+			TExport (read_count (read_ui16 ch) read_export ())
+		| 0x39 ->
+			let url = read_string ch in
+			TImport (url, read_count (read_ui16 ch) parse_import ch)
+		(*// 0x3A TEnableDebugger *)
+		| 0x3B ->
+			let cid = read_ui16 ch in
+			let actions = parse_actions ch in
+			TDoInitAction {
+				dia_id = cid;
+				dia_actions = actions;
+			}
+		| 0x3C ->
+			TVideoStream (parse_cid_data ch len)
+		| 0x3D ->
+			TVideoFrame (parse_cid_data ch len)
+		| 0x3E ->
+			TFontInfo2 (parse_cid_data ch len)
+		| 0x3F ->
+			(* undocumented ? *)
+			TDebugID (nread ch len)
+		| 0x40 ->
+			let tag = read_ui16 ch in
+			(* 0 in general, 6517 for some swfs *)
+			let pass_md5 = read_string ch in
+			TEnableDebugger2 (tag,pass_md5)
+		| 0x41 ->
+			let recursion_depth = read_ui16 ch in
+			let script_timeout = read_ui16 ch in
+			TScriptLimits (recursion_depth, script_timeout)
+		(*// 0x42 TSetTabIndex *)
+		(* 0x43-0x44 invalid *)
+		| 0x45 ->
+			let flags = IO.read_i32 ch in
+			let mask = 1 lor 8 lor 16 lor 32 lor 64 in
+			if (flags lor mask) <> mask then failwith ("Invalid file attributes " ^ string_of_int flags);
+			TFilesAttributes {
+				fa_network = (flags land 1) <> 0;
+				(* flags 2,4 : reserved *)
+				fa_as3 = (flags land 8) <> 0;
+				fa_metadata = (flags land 16) <> 0;
+				fa_gpu = (flags land 32) <> 0;
+				fa_direct_blt = (flags land 64) <> 0;
+			}
+		| 0x46 when !full_parsing ->
+			TPlaceObject3 (parse_place_object ch true)
+		| 0x47 ->
+			let url = read_string ch in
+			if IO.read_byte ch <> 1 then assert false;
+			if IO.read_byte ch <> 0 then assert false;
+			TImport2 (url, read_count (read_ui16 ch) parse_import ch)
+		| 0x48 when !full_parsing || !force_as3_parsing ->
+			TActionScript3 (None , As3parse.parse ch len)
+		| 0x49 when !full_parsing ->
+			TFontAlignZones (parse_cid_data ch len)
+		| 0x4A ->
+			TCSMSettings (parse_cid_data ch len)
+		| 0x4B when !full_parsing ->
+			TFont3 (parse_cid_data ch len)
+		| 0x4C ->
+			let i = read_ui16 ch in
+			let rec loop i =
+				if i = 0 then
+					[]
+				else
+					let a = read_ui16 ch in
+					let s = read_string ch in
+					{
+						f9_cid = if a = 0 then None else Some a;
+						f9_classname = s;
+					} :: loop (i - 1)
+			in
+			TF9Classes (loop i)
+		| 0x4D ->
+			TMetaData (read_string ch)
+		| 0x4E ->
+			let cid = read_ui16 ch in
+			let rect = read_rect ch in
+			TScale9 (cid,rect)
+		(* 0x4F-0x51 invalid *)
+		| 0x52 when !full_parsing || !force_as3_parsing ->
+			let id = read_i32 ch in
+			let frame = read_string ch in
+			let len = len - (4 + String.length frame + 1) in
+			TActionScript3 (Some (id,frame), As3parse.parse ch len)
+		| 0x53 when !full_parsing ->
+			TShape4 (parse_shape ch len 4)
+		| 0x54 when !full_parsing ->
+			TMorphShape2 (parse_morph_shape ch len)
+		(* 0x55 invalid *)
+		| 0x56 ->
+			let scenes = read_count (As3parse.read_int ch) (fun() ->
+				let offset = As3parse.read_int ch in
+				let name = read_string ch in
+				(offset, name)
+			) () in
+			let frames = read_count (As3parse.read_int ch) (fun() ->
+				let f = As3parse.read_int ch in
+				let name = read_string ch in
+				(f, name)
+			) () in
+			TScenes (scenes,frames)
+		| 0x57 ->
+			let cid = read_ui16 ch in
+			if read_i32 ch <> 0 then assert false;
+			let data = nread ch (len - 6) in
+			TBinaryData (cid,data)
+		| 0x58 ->
+			TFontName (parse_cid_data ch len)
+		(* // 0x59 TStartSound2 *)
+		| 0x5A ->
+			let id = read_ui16 ch in
+			let size = read_i32 ch in
+			let deblock = read_ui16 ch in
+			let data = nread ch size in
+			let data, table = extract_jpg_table data in
+			let alpha = nread ch (len - 6 - size) in
+			TBitsJPEG4 {
+				bd_id = id;
+				bd_table = table;
+				bd_data = data;
+				bd_alpha = Some alpha;
+				bd_deblock = Some deblock;
+			}
+		| 0x5B ->
+			TFont4 (parse_cid_data ch len)
+		| _ ->
+			(*if !Swf.warnings then Printf.printf "Unknown tag 0x%.2X\n" id;*)
+			TUnknown (id,nread ch len)
+	) in
+(*	let len2 = tag_data_length t in
+	if len <> len2 then error (Printf.sprintf "Datalen mismatch for tag 0x%.2X (%d != %d)" id len len2);
+*)	{
+		tid = gen_id();
+		tdata = t;
+		textended = extended;
+	}
+
+and parse_tag_list ch =
+	let rec loop acc =
+		let h = (try read_ui16 ch with IO.No_more_input -> 0) in
+		match parse_tag ch h with
+		| { tdata = TEnd } -> List.rev acc
+		| t -> loop (t :: acc)
+	in
+	loop []
+
+let parse ch =
+	let sign = nread ch 3 in
+	if sign <> "FWS" && sign <> "CWS" then error "Invalid SWF signature";
+	let ver = read_byte ch in
+	swf_version := ver;
+	ignore(read_i32 ch); (* file length *)
+	let compressed, ch = (if sign = "CWS" then true , inflate ch else false, ch) in
+	let size = read_rect ch in
+	let fps = read_ui16 ch in
+	let frame_count = read_ui16 ch in
+	let h = {
+		h_version = ver;
+		h_size = size;
+		h_fps = fps;
+		h_frame_count = frame_count;
+		h_compressed = compressed;
+	} in
+	let data = h , parse_tag_list ch in
+	if compressed then IO.close_in ch;
+	data
+
+(* ************************************************************************ *)
+(* WRITING *)
+
+let rec tag_id = function
+	| TEnd -> 0x00
+	| TShowFrame -> 0x01
+	| TShape _ -> 0x02
+	| TRemoveObject _ -> 0x05
+	| TBitsJPEG _ -> 0x06
+	| TJPEGTables _ -> 0x08
+	| TSetBgColor _ -> 0x09
+	| TFont _ -> 0x0A
+	| TText _ -> 0x0B
+	| TDoAction _ -> 0x0C
+	| TFontInfo _ -> 0x0D
+	| TSound _ -> 0x0E
+	| TStartSound _ -> 0x0F
+	| TBitsLossless _ -> 0x14
+	| TBitsJPEG2 _ -> 0x15
+	| TShape2 _ -> 0x16
+	| TProtect -> 0x18
+	| TPlaceObject2 _ -> 0x1A
+	| TRemoveObject2 _ -> 0x1C
+	| TShape3 _ -> 0x20
+	| TText2 _ -> 0x21
+	| TButton2 _ -> 0x22
+	| TBitsJPEG3 _ -> 0x23
+	| TBitsLossless2 _ -> 0x24
+	| TEditText _ -> 0x25
+	| TClip _ -> 0x27
+	| TProductInfo _ -> 0x29
+	| TFrameLabel _ -> 0x2B
+	| TSoundStreamHead2 _ -> 0x2D
+	| TMorphShape _ -> 0x2E
+	| TFont2 _ -> 0x30
+	| TExport _ -> 0x38
+	| TImport _ -> 0x39
+	| TDoInitAction _ -> 0x3B
+	| TVideoStream _ -> 0x3C
+	| TVideoFrame _ -> 0x3D
+	| TFontInfo2 _ -> 0x3E
+	| TDebugID _ -> 0x3F
+	| TEnableDebugger2 _ -> 0x40
+	| TScriptLimits _ -> 0x41
+	| TFilesAttributes _ -> 0x45
+	| TPlaceObject3 _ -> 0x46
+	| TImport2 _ -> 0x47
+	| TFontAlignZones _ -> 0x49
+	| TCSMSettings _ -> 0x4A
+	| TFont3 _ -> 0x4B
+	| TF9Classes _ -> 0x4C
+	| TMetaData _ -> 0x4D
+	| TScale9 _ -> 0x4E
+	| TActionScript3 (None,_) -> 0x48
+	| TActionScript3 _ -> 0x52
+	| TShape4 _ -> 0x53
+	| TMorphShape2 _ -> 0x54
+	| TScenes _ -> 0x56
+	| TBinaryData _ -> 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_with_style ch s =
+	write_shape_array ch write_shape_fill_style s.sws_fill_styles;
+	write_shape_array ch write_shape_line_style s.sws_line_styles;
+	let r = s.sws_records in
+	let b = output_bits ch in
+	write_bits b 4 r.srs_nfbits;
+	write_bits b 4 r.srs_nlbits;
+	let nlbits = ref r.srs_nlbits in
+	let nfbits = ref r.srs_nfbits in
+	List.iter (write_shape_record ch b nlbits nfbits) r.srs_records;
+	write_bits b 6 0;
+	flush_bits b
+
+let write_shape ch s =
+	write_ui16 ch s.sh_id;
+	write_rect ch s.sh_bounds;
+	(match s.sh_bounds2 with
+	| None -> ()
+	| Some (r,b) ->
+		write_rect ch r;
+		write_byte ch b);
+	write_shape_with_style ch s.sh_style
+
+let write_bitmap_lossless ch b =
+	write_ui16 ch b.bll_id;
+	write_byte ch b.bll_format;
+	write_ui16 ch b.bll_width;
+	write_ui16 ch b.bll_height;
+	nwrite ch b.bll_data
+
+let write_morph_shape ch s =
+	write_ui16 ch s.msh_id;
+	write_rect ch s.msh_start_bounds;
+	write_rect ch s.msh_end_bounds;
+	nwrite ch s.msh_data
+
+let write_text_record ch t r =
+	write_byte ch (make_flags [flag r.txr_dx; flag r.txr_dy; flag r.txr_color; flag r.txr_font; false; false; false; true]);
+	opt (fun (id,_) -> write_ui16 ch id) r.txr_font;
+	opt (write_color ch) r.txr_color;
+	opt (write_i16 ch) r.txr_dx;
+	opt (write_i16 ch) r.txr_dy;
+	opt (fun (_,id) -> write_ui16 ch id) r.txr_font;
+	write_byte ch (List.length r.txr_glyphs);
+	let bits = output_bits ch in
+	List.iter (fun g ->
+		write_bits bits t.txt_ngbits g.txg_index;
+		write_bits bits t.txt_nabits g.txg_advanced;
+	) r.txr_glyphs;
+	flush_bits bits
+
+let write_text ch t =
+	write_ui16 ch t.txt_id;
+	write_big_rect ch t.txt_bounds;
+	write_matrix ch t.txt_matrix;
+	write_byte ch t.txt_ngbits;
+	write_byte ch t.txt_nabits;
+	List.iter (write_text_record ch t) t.txt_records;
+	write_byte ch 0
+
+let write_edit_text_layout ch l =
+	write_byte ch l.edtl_align;
+	write_ui16 ch l.edtl_left_margin;
+	write_ui16 ch l.edtl_right_margin;
+	write_ui16 ch l.edtl_indent;
+	write_ui16 ch l.edtl_leading
+
+let write_edit_text ch t =
+	write_ui16 ch t.edt_id;
+	write_rect ch t.edt_bounds;
+	write_ui16 ch (make_flags [
+		flag t.edt_font; flag t.edt_maxlen; flag t.edt_color; t.edt_readonly;
+		t.edt_password; t.edt_multiline; t.edt_wordwrap; flag t.edt_text;
+		t.edt_outlines; t.edt_html; false; t.edt_border;
+		t.edt_noselect; flag t.edt_layout; t.edt_autosize; false
+	]);
+	opt (fun (id,h) -> write_ui16 ch id; write_ui16 ch h) t.edt_font;
+	opt (write_rgba ch) t.edt_color;
+	opt (write_ui16 ch) t.edt_maxlen;
+	opt (write_edit_text_layout ch) t.edt_layout;
+	write_string ch t.edt_variable;
+	opt (write_string ch) t.edt_text
+
+let write_cid_data ch c =
+	write_ui16 ch c.cd_id;
+	nwrite ch c.cd_data
+
+let write_filter_gradient ch fg =
+	write_byte ch (List.length fg.fgr_colors);
+	List.iter (fun (c,_) -> write_rgba ch c) fg.fgr_colors;
+	List.iter (fun (_,n) -> write_byte ch n) fg.fgr_colors;
+	nwrite ch fg.fgr_data
+
+let write_filter ch = function
+	| FDropShadow s ->
+		write_byte ch 0;
+		nwrite ch s
+	| FBlur s ->
+		write_byte ch 1;
+		nwrite ch s
+	| FGlow s ->
+		write_byte ch 2;
+		nwrite ch s
+	| FBevel s ->
+		write_byte ch 3;
+		nwrite ch s
+	| FGradientGlow fg ->
+		write_byte ch 4;
+		write_filter_gradient ch fg
+	| FAdjustColor s ->
+		write_byte ch 6;
+		nwrite ch s
+	| FGradientBevel fg ->
+		write_byte ch 7;
+		write_filter_gradient ch fg
+
+let write_button_record ch r =
+	write_byte ch r.btr_flags;
+	write_ui16 ch r.btr_cid;
+	write_ui16 ch r.btr_depth;
+	write_matrix ch r.btr_mpos;
+	(match r.btr_color with
+	| None -> ()
+	| Some c ->
+		write_cxa ch c);
+	opt (fun l ->
+		write_byte ch (List.length l);
+		List.iter (write_filter ch) l
+	) r.btr_filters;
+	(match r.btr_blendmode with
+	| None -> ()
+	| Some c ->
+		write_byte ch c)
+
+let rec write_button_actions ch = function
+	| [] -> assert false
+	| [a] ->
+		write_ui16 ch 0;
+		write_ui16 ch a.bta_flags;
+		write_actions ch a.bta_actions
+	| a :: l ->
+		let size = button_action_length a in
+		write_ui16 ch size;
+		write_ui16 ch a.bta_flags;
+		write_actions ch a.bta_actions;
+		write_button_actions ch l
+
+let write_button2 ch b =
+	write_ui16 ch b.bt2_id;
+	write_byte ch (if b.bt2_track_as_menu then 1 else 0);
+	if b.bt2_actions <> [] then write_ui16 ch (3 + sum button_record_length b.bt2_records) else write_ui16 ch 0;
+	List.iter (write_button_record ch) b.bt2_records;
+	write_byte ch 0;
+	if b.bt2_actions <> [] then write_button_actions ch b.bt2_actions
+
+let write_place_object ch p v3 =
+	write_byte ch (make_flags [
+		p.po_move;
+		flag p.po_cid;
+		flag p.po_matrix;
+		flag p.po_color;
+		flag p.po_ratio;
+		flag p.po_inst_name;
+		flag p.po_clip_depth;
+		flag p.po_events
+	]);
+	if v3 then write_byte ch (make_flags [flag p.po_filters; flag p.po_blend; flag p.po_bcache]);
+	write_ui16 ch p.po_depth;
+	opt (write_ui16 ch) p.po_cid;
+	opt (write_matrix ch) p.po_matrix;
+	opt (write_cxa ch) p.po_color;
+	opt (write_ui16 ch) p.po_ratio;
+	opt (write_string ch) p.po_inst_name;
+	opt (write_ui16 ch) p.po_clip_depth;
+	opt (write_clip_events ch) p.po_events;
+	if v3 then begin
+		opt (fun l ->
+			write_byte ch (List.length l);
+			List.iter (write_filter ch) l
+		) p.po_filters;
+		opt (write_byte ch) p.po_blend;
+		opt (write_byte ch) p.po_bcache;
+	end
+
+let rec write_tag_data ch = function
+	| TEnd ->
+		()
+	| TShowFrame ->
+		()
+	| TShape s ->
+		write_shape ch s
+	| TRemoveObject r ->
+		write_ui16 ch r.rmo_id;
+		write_ui16 ch r.rmo_depth;
+	| TBitsJPEG b ->
+		write_ui16 ch b.jpg_id;
+		nwrite ch b.jpg_data
+	| TJPEGTables tab ->
+		nwrite ch tab
+	| TSetBgColor c ->
+		write_rgb ch c
+	| TFont c ->
+		write_cid_data ch c
+	| TText t ->
+		write_text ch t
+	| TDoAction acts ->
+		write_actions ch acts
+	| TFontInfo c ->
+		write_cid_data ch c
+	| TSound s ->
+		write_ui16 ch s.so_id;
+		write_byte ch s.so_flags;
+		write_i32 ch s.so_samples;
+		nwrite ch s.so_data
+	| TStartSound s ->
+		write_ui16 ch s.sts_id;
+		nwrite ch s.sts_data
+	| TBitsLossless b ->
+		write_bitmap_lossless ch b
+	| TBitsJPEG2 b ->
+		write_ui16 ch b.bd_id;
+		opt (nwrite ch) b.bd_table;
+		nwrite ch b.bd_data;
+	| TShape2 s ->
+		write_shape ch s
+	| TProtect ->
+		()
+	| TPlaceObject2 p ->
+		write_place_object ch p false;
+	| TRemoveObject2 depth ->
+		write_ui16 ch depth;
+	| TShape3 s ->
+		write_shape ch s
+	| TText2 t ->
+		write_text ch t
+	| TButton2 b ->
+		write_button2 ch b
+	| TBitsJPEG3 b ->
+		write_ui16 ch b.bd_id;
+		write_i32 ch (String.length b.bd_data + opt_len String.length b.bd_table);
+		opt (nwrite ch) b.bd_table;
+		nwrite ch b.bd_data;
+		opt (nwrite ch) b.bd_alpha;
+	| TBitsLossless2 b ->
+		write_bitmap_lossless ch b
+	| TEditText t ->
+		write_edit_text ch t
+	| TClip c ->
+		write_ui16 ch c.c_id;
+		write_ui16 ch c.c_frame_count;
+		List.iter (write_tag ch) c.c_tags;
+		write_tag ch tag_end;
+	| TProductInfo s ->
+		nwrite ch s
+	| TFrameLabel (label,id) ->
+		write_string ch label;
+		opt (write ch) id;
+	| TSoundStreamHead2 data ->
+		nwrite ch data
+	| TMorphShape s ->
+		write_morph_shape ch s
+	| TFont2 c ->
+		write_cid_data ch c
+	| TExport el ->
+		write_ui16 ch (List.length el);
+		List.iter (fun e ->
+			write_ui16 ch e.exp_id;
+			write_string ch e.exp_name
+		) el
+	| TImport (url,il) ->
+		write_string ch url;
+		write_ui16 ch (List.length il);
+		List.iter (fun i ->
+			write_ui16 ch i.imp_id;
+			write_string ch i.imp_name
+		) il
+	| TDoInitAction i ->
+		write_ui16 ch i.dia_id;
+		write_actions ch i.dia_actions;
+	| TVideoStream c ->
+		write_cid_data ch c
+	| TVideoFrame c ->
+		write_cid_data ch c
+	| TFontInfo2 c ->
+		write_cid_data ch c
+	| TDebugID s ->
+		nwrite ch s
+	| TEnableDebugger2 (tag,pass) ->
+		write_ui16 ch tag;
+		write_string ch pass
+	| TScriptLimits (recursion_depth, script_timeout) ->
+		write_ui16 ch recursion_depth;
+		write_ui16 ch script_timeout;
+	| TFilesAttributes f ->
+		let flags = make_flags [f.fa_network;false;false;f.fa_as3;f.fa_metadata;f.fa_gpu;f.fa_direct_blt] in
+		write_i32 ch flags
+	| TPlaceObject3 p ->
+		write_place_object ch p true;
+	| TImport2 (url,il) ->
+		write_string ch url;
+		write_byte ch 1;
+		write_byte ch 0;
+		write_ui16 ch (List.length il);
+		List.iter (fun i ->
+			write_ui16 ch i.imp_id;
+			write_string ch i.imp_name
+		) il
+	| TFontAlignZones c ->
+		write_cid_data ch c
+	| TCSMSettings c ->
+		write_cid_data ch c
+	| TFont3 c ->
+		write_cid_data ch c
+	| TF9Classes l ->
+		write_ui16 ch (List.length l);
+		List.iter (fun c ->
+			write_ui16 ch (match c.f9_cid with None -> 0 | Some id -> id);
+			write_string ch c.f9_classname
+		) l
+	| TMetaData meta ->
+		write_string ch meta
+	| TScale9 (cid,r) ->
+		write_ui16 ch cid;
+		write_rect ch r;
+	| TActionScript3 (id,a) ->
+		(match id with
+		| None -> ()
+		| Some (id,frame) ->
+			write_i32 ch id;
+			write_string ch frame;
+		);
+		As3parse.write ch a
+	| TShape4 s ->
+		write_shape ch s
+	| TMorphShape2 m ->
+		write_morph_shape ch m
+	| TScenes (sl,fl) ->
+		As3parse.write_int ch (List.length sl);
+		List.iter (fun (n,s) ->
+			As3parse.write_int ch n;
+			write_string ch s;
+		) sl;
+		As3parse.write_int ch (List.length fl);
+		List.iter (fun (n,s) ->
+			As3parse.write_int ch n;
+			write_string ch s;
+		) sl;
+	| TBinaryData (id,data) ->
+		write_ui16 ch id;
+		write_i32 ch 0;
+		nwrite ch data
+	| TFontName c ->
+		write_cid_data ch c
+	| TBitsJPEG4 b ->
+		write_ui16 ch b.bd_id;
+		write_i32 ch (String.length b.bd_data + opt_len String.length b.bd_table);
+		opt (write_ui16 ch) b.bd_deblock;
+		opt (nwrite ch) b.bd_table;
+		nwrite ch b.bd_data;
+		opt (nwrite ch) b.bd_alpha;
+	| TFont4 c ->
+		write_cid_data ch c
+	| TUnknown (_,data) ->
+		nwrite ch data
+
+and write_tag ch t =
+	let id = tag_id t.tdata in
+	let dlen = tag_data_length t.tdata in
+	if t.textended || dlen >= 63 then begin
+		write_ui16 ch ((id lsl 6) lor 63);
+		write_i32 ch dlen;
+	end else begin
+		write_ui16 ch ((id lsl 6) lor dlen);
+	end;
+	write_tag_data ch t.tdata
+
+let write ch (h,tags) =
+	swf_version := h.h_version;
+	nwrite ch (if h.h_compressed then "CWS" else "FWS");
+	write ch (char_of_int h.h_version);
+	let rec calc_len = function
+		| [] -> tag_length tag_end
+		| t :: l ->
+			tag_length t + calc_len l
+	in
+	let len = calc_len tags in
+	let len = len + 4 + 4 + rect_length h.h_size + 2 + 2 in
+	write_i32 ch len;
+	let ch = (if h.h_compressed then deflate ch else ch) in
+	write_rect ch h.h_size;
+	write_ui16 ch h.h_fps;
+	write_ui16 ch h.h_frame_count;
+	List.iter (write_tag ch) tags;
+	write_tag ch tag_end;
+	if h.h_compressed then IO.close_out ch
+
+(* ************************************************************************ *)
+(* EXTRA *)
+
+let scan fid f t =
+	match t.tdata with
+	| TEnd
+	| TShowFrame
+	| TJPEGTables _
+	| TSetBgColor _
+	| TDoAction _
+	| TActionScript3 _
+	| TProtect
+	| TRemoveObject2 _
+	| TFrameLabel _
+	| TSoundStreamHead2 _
+	| TScenes _
+	| TEnableDebugger2 _
+	| TMetaData _
+	| TScriptLimits _
+	| TDebugID _
+	| TFilesAttributes _
+	| TProductInfo _
+		-> ()
+	| TF9Classes l ->
+		List.iter (fun c ->
+			match c.f9_cid with
+			| None -> ()
+			| Some id -> c.f9_cid <- Some (f id)
+		) l
+	| TShape s
+	| TShape2 s
+	| TShape3 s
+	| TShape4 s ->
+		s.sh_id <- fid s.sh_id;
+		let loop fs =
+			List.iter (fun s -> match s with
+				| SFSBitmap b ->
+					if b.sfb_cid <> 0xFFFF then b.sfb_cid <- f b.sfb_cid;
+				| _ ->
+					()
+			) fs
+		in
+		loop s.sh_style.sws_fill_styles;
+		List.iter (fun s -> match s with
+			| SRStyleChange { scsr_new_styles = Some s } ->
+				loop s.sns_fill_styles
+			| _ ->
+				()
+		) s.sh_style.sws_records.srs_records;
+	| TRemoveObject r ->
+		r.rmo_id <- f r.rmo_id
+	| TBitsJPEG b ->
+		b.jpg_id <- fid b.jpg_id
+	| TBitsJPEG2 b ->
+		b.bd_id <- fid b.bd_id
+	| TText t
+	| TText2 t ->
+		t.txt_id <- fid t.txt_id;
+		List.iter (fun r -> match r.txr_font with None -> () | Some (id,id2) -> r.txr_font <- Some (f id,id2)) t.txt_records
+	| TEditText t ->
+		t.edt_id <- fid t.edt_id;
+		(match t.edt_font with None -> () | Some (id,h) -> t.edt_font <- Some (f id,h))
+	| TSound s ->
+		s.so_id <- fid s.so_id
+	| TStartSound s ->
+		s.sts_id <- f s.sts_id
+	| TBitsLossless b
+	| TBitsLossless2 b ->
+		b.bll_id <- fid b.bll_id
+	| TPlaceObject2 p ->
+		p.po_cid <- (match p.po_cid with None -> None | Some id -> Some (f id))
+	| TButton2 b ->
+		b.bt2_id <- fid b.bt2_id;
+		List.iter (fun r ->
+			r.btr_cid <- f r.btr_cid
+		) b.bt2_records;
+	| TBitsJPEG3 j ->
+		j.bd_id <- fid j.bd_id
+	| TClip c ->
+		c.c_id <- fid c.c_id
+	| TMorphShape s | TMorphShape2 s ->
+		s.msh_id <- fid s.msh_id
+	| TFont c | TFont2 c | TFont3 c | TFont4 c ->
+		c.cd_id <- fid c.cd_id
+	| TExport el ->
+		List.iter (fun e -> e.exp_id <- f e.exp_id) el
+	| TImport (_,il) | TImport2 (_,il) ->
+		List.iter (fun i -> i.imp_id <- fid i.imp_id) il
+	| TDoInitAction a ->
+		a.dia_id <- f a.dia_id
+	| TVideoStream c ->
+		c.cd_id <- fid c.cd_id
+	| TVideoFrame c ->
+		c.cd_id <- f c.cd_id
+	| TPlaceObject3 p ->
+		p.po_cid <- (match p.po_cid with None -> None | Some id -> Some (f id))
+	| TCSMSettings c ->
+		c.cd_id <- f c.cd_id
+	| TBinaryData (id,data) ->
+		t.tdata <- TBinaryData (fid id,data)
+	| 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"
+	| 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,229 @@
+(*
+ *  This file is part of SwfLib
+ *  Copyright (c)2005 Nicolas Cannasse
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *)
+
+open Png
+open Swf
+open ExtList
+
+type error_msg =
+	| PngError of Png.error_msg
+	| Interlaced
+	| UnsupportedColorModel
+	| UnsupportedExtension
+	| UnzipFailed
+
+exception Error of error_msg
+exception File_not_found of string
+
+type picture = {
+	pwidth : int;
+	pheight : int;
+	pid : int;
+	pdata : tag_data;
+	pframe : string option;
+}
+
+let error_msg = function
+	| PngError m -> Png.error_msg m
+	| Interlaced -> "Interlaced mode is not supported"
+	| UnsupportedColorModel -> "Unsupported color model"
+	| UnsupportedExtension -> "Unsupported file extension"
+	| UnzipFailed -> "Decompression failed"
+
+let error msg = raise (Error msg)
+
+let unsigned v n =
+	if v < 0 then
+		(- ( v + 1 )) lxor (1 lsl n - 1)
+	else
+		v
+
+let load_picture file id =
+	let ch = IO.input_channel (try open_in_bin file with _ -> raise (File_not_found file)) in
+	let len = String.length file in
+	let p = (try String.rindex file '.' with Not_found -> len) in
+	let ext = String.sub file (p + 1) (len - (p + 1)) in
+	match String.uppercase ext with
+	| "PNG" ->
+		let png , header, data = (try
+			let p = Png.parse ch in
+			p , Png.header p, Png.data p
+		with Png.Error msg ->
+			IO.close_in ch; error (PngError msg)
+		) in
+		IO.close_in ch;
+		if header.png_interlace then error Interlaced;
+		let data = (try Extc.unzip data with _ -> error UnzipFailed) in
+		let w = header.png_width in
+		let h = header.png_height in
+		let data = (try Png.filter png data with Png.Error msg -> error (PngError msg)) in
+		{
+			pwidth = w;
+			pheight = h;
+			pid = id;
+			pframe = None;
+			pdata = (match header.png_color with
+				| ClTrueColor (TBits8,NoAlpha) ->
+					(* set alpha to 0 *)
+					for p = 0 to w * h - 1 do
+						String.unsafe_set data (p * 4) '\000';
+					done;
+					TBitsLossless {
+						bll_id = id;
+						bll_format = 5;
+						bll_width = w;
+						bll_height = h;
+						bll_data = Extc.zip data;
+					}
+				| ClTrueColor (TBits8,HaveAlpha) ->
+					(* premultiply rgb by alpha *)
+					for p = 0 to w * h - 1 do
+						let k = p * 4 in
+						let a = int_of_char (String.unsafe_get data k) in
+						String.unsafe_set data (k + 1) (Char.unsafe_chr ((int_of_char (String.unsafe_get data (k + 1)) * a) / 0xFF));
+						String.unsafe_set data (k + 2) (Char.unsafe_chr ((int_of_char (String.unsafe_get data (k + 2)) * a) / 0xFF));
+						String.unsafe_set data (k + 3) (Char.unsafe_chr ((int_of_char (String.unsafe_get data (k + 3)) * a) / 0xFF));
+					done;
+					TBitsLossless2 {
+						bll_id = id;
+						bll_format = 5;
+						bll_width = w;
+						bll_height = h;
+						bll_data = Extc.zip data;
+					}
+				| _ -> error UnsupportedColorModel);
+		}
+	| _ ->
+		IO.close_in ch;
+		error UnsupportedExtension
+
+let make_clip name pics baseid =
+	let npics = List.length pics in
+	let ids = Array.of_list (List.map (fun p -> p.pid) pics) in
+	let rec loop i p =
+		let w = p.pwidth in
+		let h = p.pheight in
+		let rb = if 20 * max w h >= 1 lsl 14 then 15 else 14 in
+		let nbits = rb in
+		TShape {
+			sh_id = baseid + i;
+			sh_bounds = {
+				rect_nbits = rb;
+				left = 0;
+				top = 0;
+				right = w * 20;
+				bottom = h * 20;
+			};
+			sh_bounds2 = None;
+			sh_style = {
+				sws_fill_styles = [
+					SFSBitmap {
+						sfb_repeat = true;
+						sfb_smooth = true;
+						sfb_cid = ids.(i);
+						sfb_mpos = {
+							scale = Some {
+								m_nbits = 22;
+								mx = 20 lsl 16;
+								my = 20 lsl 16;
+							};
+							rotate = None;
+							trans = {
+								m_nbits = 0;
+								mx = 0;
+								my = 0;
+							};
+						};
+					};
+				];
+				sws_line_styles = [];
+				sws_records = {
+					srs_nlbits = 0;
+					srs_nfbits = 1;
+					srs_records = [
+						SRStyleChange {
+							scsr_move = None;
+							scsr_fs0 = None;
+							scsr_fs1 = Some 1;
+							scsr_ls = None;
+							scsr_new_styles = None;
+						};
+						SRStraightEdge {
+							sser_nbits = nbits;
+							sser_line = Some (w * 20) , None;
+						};
+						SRStraightEdge {
+							sser_nbits = nbits;
+							sser_line = None , Some (h * 20);
+						};
+						SRStraightEdge {
+							sser_nbits = nbits;
+							sser_line = Some (unsigned (-w * 20) nbits), None;
+						};
+						SRStraightEdge {
+							sser_nbits = nbits;
+							sser_line = None , Some (unsigned (-h * 20) nbits);
+						};
+					];
+				};
+			};
+		}
+	in
+	let shapes = List.mapi loop pics in
+	let rec loop i =
+		if i = npics then
+			[]
+		else
+			TPlaceObject2 {
+				po_depth = 0;
+				po_move = (i > 0);
+				po_cid = Some (baseid+i);
+				po_color = None;
+				po_matrix = None;
+				po_ratio = None;
+				po_inst_name = None;
+				po_clip_depth = None;
+				po_events = None;
+				po_filters = None;
+				po_blend = None;
+				po_bcache = None;
+			} :: TShowFrame :: loop (i+1)
+	in
+	let tid = ref 0 in
+	let make_tag t =
+		incr tid;
+		{
+			tid = - !tid;
+			textended = false;
+			tdata = t;
+		}
+	in
+	let pics = List.map (fun p -> make_tag p.pdata) pics in
+	let shapes = List.map make_tag shapes in
+	pics @ shapes @ List.map make_tag [
+		TClip {
+			c_id = baseid + npics;
+			c_frame_count = npics;
+			c_tags = List.map make_tag (loop 0);
+		};
+		TExport [{
+			exp_id = baseid + npics;
+			exp_name = name;
+		}];
+	]

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/xml-light/META.in

@@ -0,0 +1,4 @@
+version="@VERSION@"
+directory="+xml-light"
+archive(byte)="xml-light.cma"
+archive(native)="xml-light.cmxa"

libs/xml-light/Makefile

@@ -0,0 +1,94 @@
+# Makefile generated by OCamake 
+# http://tech.motion-twin.com
+.SUFFIXES : .ml .mli .cmo .cmx .cmi .mll .mly
+
+INSTALLDIR=`ocamlc -where`
+CFLAGS=
+LFLAGS= -a
+LIBS=
+
+all: xml-light.cma test.exe doc
+
+opt: xml-light.cmxa test_opt.exe
+
+installcommon: all
+	cp xml.mli xmlParser.mli dtd.mli xml.cmi xmlParser.cmi dtd.cmi $(INSTALLDIR)
+
+installbyte: all installcommon
+	cp xml-light.cma $(INSTALLDIR)
+
+installopt: opt installcommon
+	cp xml-light.a xml-light.cmxa xml.cmx dtd.cmx xmlParser.cmx $(INSTALLDIR)
+
+install: installbyte installopt
+
+wininstall: all opt
+	cp xml-light.cmxa xml-light.lib xml-light.cma xml.mli xmlParser.mli dtd.mli xml.cmi xmlParser.cmi dtd.cmi xml.cmx dtd.cmx xmlParser.cmx c:\ocaml\lib
+
+doc:
+	mkdir doc
+	ocamldoc -sort -html -d doc xml.mli dtd.mli xmlParser.mli
+
+test.exe: xml-light.cma
+	ocamlc xml-light.cma test.ml -o test.exe
+	
+test_opt.exe: xml-light.cmxa
+	ocamlopt xml-light.cmxa test.ml -o test_opt.exe
+
+xml-light.cma: xml_parser.cmo xml_lexer.cmo dtd.cmo xmlParser.cmo xml.cmo 
+	ocamlc -o xml-light.cma $(LFLAGS) $(LIBS) xml_parser.cmo xml_lexer.cmo dtd.cmo xmlParser.cmo xml.cmo
+
+xml-light.cmxa: xml_parser.cmx xml_lexer.cmx dtd.cmx xmlParser.cmx xml.cmx 
+	ocamlopt -o xml-light.cmxa $(LFLAGS) $(LIBS) xml_parser.cmx xml_lexer.cmx dtd.cmx xmlParser.cmx xml.cmx
+
+dtd.cmo: xml.cmi xml_lexer.cmi dtd.cmi
+
+dtd.cmx: xml.cmi xml_lexer.cmi dtd.cmi
+
+xml.cmo: dtd.cmi xmlParser.cmi xml_lexer.cmi xml.cmi
+
+xml.cmx: dtd.cmi xmlParser.cmi xml_lexer.cmi xml.cmi
+
+xmlParser.cmo: dtd.cmi xml.cmi xml_lexer.cmi xmlParser.cmi
+
+xmlParser.cmx: dtd.cmi xml.cmi xml_lexer.cmi xmlParser.cmi
+
+dtd.cmi: xml.cmi
+
+xml.cmi: 
+
+xmlParser.cmi: dtd.cmi xml.cmi
+
+xml_lexer.cmi: dtd.cmi
+
+xml_parser.cmo: xml_parser.ml dtd.cmi xml_parser.mli xml_parser.cmi
+
+xml_parser.cmx: xml_parser.ml dtd.cmi xml_parser.mli xml_parser.cmi
+
+xml_parser.cmi: xml_parser.mli dtd.cmi xml.cmi
+
+xml_lexer.cmo: xml_lexer.ml xml_lexer.cmi
+
+xml_lexer.cmx: xml_lexer.ml xml_lexer.cmi
+
+clean:
+	rm -f xml-light.cma test.exe dtd.cmo dtd.cmi test.cmo test.cmi xml.cmo xml.cmi xmlParser.cmo xmlParser.cmi dtd.cmi xml.cmi xmlParser.cmi xml_lexer.cmi xml_lexer.cmo xml_lexer.ml xml_parser.mli xml_parser.cmi xml_parser.ml xml_parser.cmo
+	rm -f xml-light.lib xml-light.a xml-light.cmxa test_opt.exe dtd.cmx dtd.obj dtd.o test.cmx test.obj test.o xml.cmx xml.obj xml.o xmlParser.cmx xmlParser.obj xmlParser.o xml_lexer.cmx xml_lexer.obj xml_lexer.o xml_parser.cmx xml_parser.obj xml_parser.o
+
+
+# SUFFIXES
+.ml.cmo:
+	ocamlc $(CFLAGS) -c $<
+
+.ml.cmx:
+	ocamlopt $(CFLAGS) -c $<
+
+.mli.cmi:
+	ocamlc $(CFLAGS) $<
+
+.mll.ml:
+	ocamllex $<
+
+.mly.ml:
+	ocamlyacc $<
+

libs/xml-light/README

@@ -0,0 +1,79 @@
+Xml-Light Version 2.2 :
+-----------------------
+
+Last version : http://tech.motion-twin.com
+
+  Xml Light is a minimal Xml parser & printer for OCaml.
+  It provide few functions to parse a basic Xml document into
+  an OCaml data structure and to print back the data structures
+  to an Xml document.
+
+  Xml Light has also support for DTD (Document Type Definition).
+
+
+Install
+-------
+
+make install
+
+by default, Xml Light is installed in the 'ocamlc -where' directory.
+you can change it by editing the Makefile.
+
+for Windows users, if you're using the MSVC version of ocaml and
+don't have cygwin tools installed, you can do : nmake all
+and then copy manually the files to the place you want.
+
+Usage
+-----
+
+simple samples :
+
+
+-- parse / print an xml string ---
+
+let x = Xml.parse_string "<a href='url'>TEXT<begin/><end/></a>" in
+Printf.printf "XML formated = \n%s" (Xml.to_string_fmt x);
+
+-- load an xml and a dtd , prove and print ---
+
+let x = Xml.parse_file "myfile.xml" in
+let dtd = Dtd.parse_file "myfile.dtd" in
+let x = Dtd.prove (Dtd.check dtd) "start" x in
+print_endline (Xml.to_string x)
+
+
+Documentation
+-------------
+
+HTML documentation can be generated with ocamldoc :
+
+make doc
+
+you can also directly browse the MLI files to read it.
+
+Licence
+-------
+
+Xml Light is distributed under the terms of the GNU Library General
+Public License, with the special exception on linking described
+below. (This is the OCaml library licence.)
+
+As a special exception to the GNU Library General Public License, you
+may link, statically or dynamically, a "work that uses the Library"
+with a publicly distributed version of the Library to produce an
+executable file containing portions of the Library, and distribute
+that executable file under terms of your choice, without any of the
+additional requirements listed in clause 6 of the GNU Library General
+Public License. By "a publicly distributed version of the Library", we
+mean either the unmodified Library as distributed by INRIA, or a
+modified version of the Library that is distributed under the
+conditions defined in clause 3 of the GNU Library General Public
+License. This exception does not however invalidate any other reasons
+why the executable file might be covered by the GNU Library General
+Public License.
+
+Credits
+-------
+(c)2003-2005 Nicolas Cannasse ([email protected])
+(c)2003-2005 Motion-Twin
+Some parts of this code source has an additionnal copyright to Jacques Garrigue

libs/xml-light/dtd.ml

@@ -0,0 +1,555 @@
+(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse ([email protected])
+ *
+ * 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 has the special exception on linking described in file
+ * README.
+ *
+ * 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 Xml
+open Printf
+
+type parse_error_msg =
+	| InvalidDTDDecl
+	| InvalidDTDElement
+	| InvalidDTDAttribute
+	| InvalidDTDTag
+	| DTDItemExpected
+
+type check_error =
+	| ElementDefinedTwice of string
+	| AttributeDefinedTwice of string * string
+	| ElementEmptyContructor of string
+	| ElementReferenced of string * string
+	| ElementNotDeclared of string
+	| WrongImplicitValueForID of string * string
+
+type prove_error =
+	| UnexpectedPCData
+	| UnexpectedTag of string
+	| UnexpectedAttribute of string
+	| InvalidAttributeValue of string
+	| RequiredAttribute of string
+	| ChildExpected of string
+	| EmptyExpected
+	| DuplicateID of string
+	| MissingID of string
+
+type dtd_child =
+	| DTDTag of string
+	| DTDPCData
+	| DTDOptional of dtd_child
+	| DTDZeroOrMore of dtd_child
+	| DTDOneOrMore of dtd_child
+	| DTDChoice of dtd_child list
+	| DTDChildren of dtd_child list
+
+type dtd_element_type =
+	| DTDEmpty
+	| DTDAny
+	| DTDChild of dtd_child
+
+type dtd_attr_default =
+	| DTDDefault of string
+	| DTDRequired
+	| DTDImplied
+	| DTDFixed of string
+
+type dtd_attr_type =
+	| DTDCData
+	| DTDNMToken
+	| DTDEnum of string list
+	| DTDID
+	| DTDIDRef
+
+type dtd_item =
+	| DTDAttribute of string * string * dtd_attr_type * dtd_attr_default
+	| DTDElement of string * dtd_element_type
+
+type dtd_result =
+	| DTDNext
+	| DTDNotMatched
+	| DTDMatched
+	| DTDMatchedResult of dtd_child
+
+type error_pos = {
+	eline : int;
+	eline_start : int;
+	emin : int;
+	emax : int;
+}
+
+type parse_error = parse_error_msg * Xml.error_pos
+
+exception Parse_error of parse_error
+exception Check_error of check_error
+exception Prove_error of prove_error
+
+type dtd = dtd_item list
+
+module StringMap = Map.Make(String)
+
+type 'a map = 'a StringMap.t ref
+
+type checked = {
+	c_elements : dtd_element_type map;
+	c_attribs : (dtd_attr_type * dtd_attr_default) map map;
+}
+
+type dtd_state = {
+	elements : dtd_element_type map;
+	attribs : (dtd_attr_type * dtd_attr_default) map map;
+	mutable current : dtd_element_type;
+	mutable curtag : string;
+	state : (string * dtd_element_type) Stack.t;
+}
+
+let file_not_found = ref (fun _ -> assert false)
+
+let _raises e =
+	file_not_found := e
+
+let create_map() = ref StringMap.empty
+
+let empty_map = create_map()
+
+let find_map m k = StringMap.find k (!m)
+
+let set_map m k v = m := StringMap.add k v (!m)
+
+let unset_map m k = m := StringMap.remove k (!m)
+
+let iter_map f m = StringMap.iter f (!m)
+
+let fold_map f m = StringMap.fold f (!m)
+
+let mem_map m k = StringMap.mem k (!m)
+
+let pos source =
+	let line, lstart, min, max = Xml_lexer.pos source in
+	(Obj.magic {
+		eline = line;
+		eline_start = lstart;
+		emin = min;
+		emax = max;
+	} : Xml.error_pos)
+
+let convert = function
+	| Xml_lexer.EInvalidDTDDecl -> InvalidDTDDecl
+	| Xml_lexer.EInvalidDTDElement -> InvalidDTDElement
+	| Xml_lexer.EInvalidDTDTag -> InvalidDTDTag
+	| Xml_lexer.EDTDItemExpected -> DTDItemExpected
+	| Xml_lexer.EInvalidDTDAttribute -> InvalidDTDAttribute
+
+let parse source =
+	try
+		Xml_lexer.init source;
+		(* local cast Dtd.dtd -> dtd *)
+		let dtd = (Obj.magic Xml_lexer.dtd source : dtd) in
+		Xml_lexer.close source;
+		dtd
+	with
+		| Xml_lexer.DTDError e ->
+			Xml_lexer.close source;
+			raise (Parse_error (convert e,pos source))
+
+let parse_string s = parse (Lexing.from_string s)
+let parse_in ch = parse (Lexing.from_channel ch)
+
+let parse_file fname =
+	let ch = (try open_in fname with Sys_error _ -> raise (!file_not_found fname)) in
+	try
+		let x = parse (Lexing.from_channel ch) in
+		close_in ch;
+		x
+	with
+		e ->
+			close_in ch;
+			raise e
+
+let check dtd =
+	let attribs = create_map() in
+	let hdone = create_map() in
+	let htodo = create_map() in
+	let ftodo tag from =
+		try
+			ignore(find_map hdone tag);
+		with
+			Not_found ->
+				try
+					match find_map htodo tag with
+					| None -> set_map htodo tag from
+					| Some _ -> ()
+				with
+					Not_found ->
+						set_map htodo tag from
+	in
+	let fdone tag edata =
+		try
+			ignore(find_map hdone tag);
+			raise (Check_error (ElementDefinedTwice tag));
+		with
+			Not_found ->
+				unset_map htodo tag;
+				set_map hdone tag edata
+	in
+	let fattrib tag aname adata =
+		(match adata with
+	    | DTDID,DTDImplied -> ()
+	    | DTDID,DTDRequired -> ()
+	    | DTDID,_ -> raise (Check_error (WrongImplicitValueForID (tag,aname)))
+	    | _ -> ());
+		let h = (try
+				find_map attribs tag
+			with
+				Not_found ->
+					let h = create_map() in
+					set_map attribs tag h;
+					h) in
+		try
+			ignore(find_map h aname);
+			raise (Check_error (AttributeDefinedTwice (tag,aname)));
+		with
+			Not_found ->
+				set_map h aname adata
+	in
+	let check_item = function
+		| DTDAttribute (tag,aname,atype,adef) ->
+			let utag = String.uppercase tag in
+			ftodo utag None;
+			fattrib utag (String.uppercase aname) (atype,adef)
+		| DTDElement (tag,etype) ->
+			let utag = String.uppercase tag in
+			fdone utag etype;
+			let check_type = function
+				| DTDEmpty -> ()
+				| DTDAny -> ()
+				| DTDChild x ->
+					let rec check_child = function
+						| DTDTag s -> ftodo (String.uppercase s) (Some utag)
+						| DTDPCData -> ()
+						| DTDOptional c
+						| DTDZeroOrMore c
+						| DTDOneOrMore c ->
+							check_child c
+						| DTDChoice []
+						| DTDChildren [] ->
+							raise (Check_error (ElementEmptyContructor tag))
+						| DTDChoice l
+						| DTDChildren l ->
+							List.iter check_child l
+					in
+					check_child x
+			in
+			check_type etype
+	in
+	List.iter check_item dtd;
+	iter_map (fun t from ->
+		match from with
+		| None -> raise (Check_error (ElementNotDeclared t))
+		| Some tag -> raise (Check_error (ElementReferenced (t,tag)))
+	) htodo;
+	{
+		c_elements = hdone;
+		c_attribs = attribs;
+	}
+
+let start_prove dtd root =
+	let d = {
+		elements = dtd.c_elements;
+		attribs = dtd.c_attribs;
+		state = Stack.create();
+		current = DTDChild (DTDTag root);
+		curtag = "_root";
+	} in
+	try
+		ignore(find_map d.elements (String.uppercase root));
+		d
+	with
+		Not_found -> raise (Check_error (ElementNotDeclared root))
+
+
+(* - for debug only - *)
+
+let to_string_ref = ref (fun _ -> assert false)
+
+let trace dtd tag =
+	let item = DTDElement ("current",dtd.current) in
+	printf "%s : %s\n"
+		(match tag with None -> "#PCDATA" | Some t -> t)
+		(!to_string_ref item)
+
+exception TmpResult of dtd_result
+
+let prove_child dtd tag =
+	match dtd.current with
+	| DTDEmpty -> raise (Prove_error EmptyExpected)
+	| DTDAny -> ()
+	| DTDChild elt ->
+		let rec update = function
+		| DTDTag s ->
+			(match tag with
+			| None -> DTDNotMatched
+			| Some t when t = String.uppercase s -> DTDMatched
+			| Some _ -> DTDNotMatched)
+		| DTDPCData ->
+			(match tag with
+			| None -> DTDMatched
+			| Some _ -> DTDNotMatched)
+		| DTDOptional x ->
+			(match update x with
+			| DTDNotMatched
+			| DTDNext -> DTDNext
+			| DTDMatched
+			| DTDMatchedResult _ -> DTDMatched)
+		| DTDZeroOrMore x ->
+			(match update x with
+			| DTDNotMatched
+			| DTDNext -> DTDNext
+			| DTDMatched
+			| DTDMatchedResult _ -> DTDMatchedResult (DTDZeroOrMore x))
+		| DTDOneOrMore x ->
+			(match update x with
+			| DTDNotMatched
+			| DTDNext -> DTDNotMatched
+			| DTDMatched
+			| DTDMatchedResult _ -> DTDMatchedResult (DTDZeroOrMore x))
+		| DTDChoice l ->
+			(try
+				(match List.exists (fun x ->
+					match update x with
+					| DTDMatched -> true
+					| DTDMatchedResult _ as r -> raise (TmpResult r)
+					| DTDNext | DTDNotMatched -> false) l with
+				| true -> DTDMatched
+				| false -> DTDNotMatched)
+			with
+				TmpResult r -> r)
+		| DTDChildren [] -> assert false (* DTD is checked ! *)
+		| DTDChildren (h :: t) ->
+			(match update h with
+			| DTDNext ->
+				(match t with
+				| [] -> DTDNotMatched
+				| _ -> update (DTDChildren t))
+			| DTDNotMatched -> DTDNotMatched
+			| DTDMatchedResult r ->
+				DTDMatchedResult (DTDChildren (r::t))
+			| DTDMatched ->
+				match t with
+				| [] -> DTDMatched
+				| _ -> DTDMatchedResult (DTDChildren t))
+		in
+		match update elt with
+		| DTDNext | DTDNotMatched ->
+			(match tag with
+			| None -> raise (Prove_error UnexpectedPCData)
+			| Some t -> raise (Prove_error (UnexpectedTag t)))
+		| DTDMatched ->
+			dtd.current <- DTDEmpty
+		| DTDMatchedResult r ->
+			dtd.current <- DTDChild r
+
+let is_nmtoken_char = function
+	| 'A'..'Z' | 'a'..'z' | '0'..'9' | '.' | '-' | '_' | ':' -> true
+	| _ -> false
+
+let prove_attrib dtd hid hidref attr aname (atype,adef) accu =
+	let aval = (try Some (List.assoc aname attr) with Not_found -> None) in
+	(match atype, aval with
+	| DTDCData, _ -> ()
+	| DTDNMToken, None -> ()
+	| DTDNMToken, Some v ->
+		for i = 0 to String.length v - 1 do
+			if not (is_nmtoken_char v.[i]) then raise (Prove_error (InvalidAttributeValue aname));
+		done
+	| DTDEnum l, None -> ()
+	| DTDEnum l, Some v ->
+		if not (List.exists ((=) v) l) then raise (Prove_error (InvalidAttributeValue aname))
+	| DTDID, None -> ()
+	| DTDID, Some id ->
+		if mem_map hid id then raise (Prove_error (DuplicateID id));
+		set_map hid id ()
+	| DTDIDRef, None -> ()
+	| DTDIDRef, Some idref ->
+		set_map hidref idref ());
+	match adef, aval with
+	| DTDRequired, None -> raise (Prove_error (RequiredAttribute aname))
+	| DTDFixed v, Some av when v <> av -> raise (Prove_error (InvalidAttributeValue aname))
+	| DTDImplied, None -> accu
+	| DTDFixed v , None
+	| DTDDefault _, Some v
+	| DTDDefault v, None
+	| DTDRequired,  Some v
+	| DTDImplied, Some v
+	| DTDFixed _, Some v -> (aname,v) :: accu
+
+let check_attrib ahash (aname,_) =
+	try
+		ignore(find_map ahash aname);
+	with
+		Not_found -> raise (Prove_error (UnexpectedAttribute aname))
+
+let rec do_prove hid hidref dtd = function
+	| PCData s ->
+		prove_child dtd None;
+		PCData s
+	| Element (tag,attr,childs) ->
+		let utag = String.uppercase tag in
+		let uattr = List.map (fun (aname,aval) -> String.uppercase aname , aval) attr in
+		prove_child dtd (Some utag);
+		Stack.push (dtd.curtag,dtd.current) dtd.state;
+		let elt = (try find_map dtd.elements utag with Not_found -> raise (Prove_error (UnexpectedTag tag))) in
+		let ahash = (try find_map dtd.attribs utag with Not_found -> empty_map) in
+		dtd.curtag <- tag;
+		dtd.current <- elt;
+		List.iter (check_attrib ahash) uattr;
+		let attr = fold_map (prove_attrib dtd hid hidref uattr) ahash [] in
+		let childs = ref (List.map (do_prove hid hidref dtd) childs) in
+		(match dtd.current with
+		| DTDAny
+		| DTDEmpty -> ()
+		| DTDChild elt ->
+			let name = ref "" in
+			let rec check = function
+				| DTDTag t ->
+					name := t;
+					false
+				| DTDPCData when !childs = [] ->
+					childs := [PCData ""];
+					true
+				| DTDPCData ->
+					name := "#PCDATA";
+					false
+				| DTDOptional _ -> true
+				| DTDZeroOrMore _ -> true
+				| DTDOneOrMore e ->
+					ignore(check e);
+					false
+				| DTDChoice l -> List.exists check l
+				| DTDChildren l -> List.for_all check l
+			in
+			match check elt with
+			| true -> ()
+			| false -> raise (Prove_error (ChildExpected !name)));
+		let ctag, cur = Stack.pop dtd.state in
+		dtd.curtag <- tag;
+		dtd.current <- cur;
+		Element (tag,attr,!childs)
+
+let prove dtd root xml =
+	let hid = create_map() in
+	let hidref = create_map() in
+	let x = do_prove hid hidref (start_prove dtd root) xml in
+	iter_map (fun id () ->
+		if not (mem_map hid id) then raise (Prove_error (MissingID id))
+	) hidref;
+	x
+
+let parse_error_msg = function
+	| InvalidDTDDecl -> "Invalid DOCTYPE declaration"
+	| InvalidDTDElement -> "Invalid DTD element declaration"
+	| InvalidDTDAttribute -> "Invalid DTD attribute declaration"
+	| InvalidDTDTag -> "Invalid DTD tag"
+	| DTDItemExpected -> "DTD item expected"
+
+let parse_error (msg,pos) =
+	let pos = (Obj.magic pos : error_pos) in
+	if pos.emin = pos.emax then
+		sprintf "%s line %d character %d" (parse_error_msg msg) pos.eline (pos.emin - pos.eline_start)
+	else
+		sprintf "%s line %d characters %d-%d" (parse_error_msg msg) pos.eline (pos.emin - pos.eline_start) (pos.emax - pos.eline_start)
+
+let check_error = function
+	| ElementDefinedTwice tag -> sprintf "Element '%s' defined twice" tag
+	| AttributeDefinedTwice (tag,aname) -> sprintf "Attribute '%s' of element '%s' defined twice" aname tag
+	| ElementEmptyContructor tag -> sprintf "Element '%s' has empty constructor" tag
+	| ElementReferenced (tag,from) -> sprintf "Element '%s' referenced by '%s' is not declared" tag from
+	| ElementNotDeclared tag -> sprintf "Element '%s' needed but is not declared" tag
+	| WrongImplicitValueForID (tag,idname) -> sprintf "Attribute '%s' of type ID of element '%s' not defined with implicit value #REQUIRED or #IMPLIED" idname tag
+
+let prove_error = function
+	| UnexpectedPCData -> "Unexpected PCData"
+	| UnexpectedTag tag -> sprintf "Unexpected tag : '%s'" tag
+	| UnexpectedAttribute att -> sprintf "Unexpected attribute : '%s'" att
+	| InvalidAttributeValue att -> sprintf "Invalid attribute value for '%s'" att
+	| RequiredAttribute att -> sprintf "Required attribute not found : '%s'" att
+	| ChildExpected cname -> sprintf "Child expected : '%s'" cname
+	| EmptyExpected -> "No more children expected"
+	| DuplicateID id  -> sprintf "ID '%s' used several times" id
+	| MissingID idref -> sprintf "missing ID value for IDREF '%s'" idref
+
+let to_string = function
+	| DTDAttribute (tag,aname,atype,adef) ->
+		let atype_to_string = function
+			| DTDCData -> "CDATA"
+			| DTDNMToken -> "NMTOKEN"
+			| DTDEnum l -> sprintf "(%s)" (String.concat "|" l)
+			| DTDID -> "ID"
+			| DTDIDRef -> "IDREF"
+		in
+		let adefault_to_string = function
+			| DTDDefault s -> sprintf "\"%s\"" s
+			| DTDRequired -> "#REQUIRED"
+			| DTDImplied -> "#IMPLIED"
+			| DTDFixed s -> sprintf "#FIXED \"%s\"" s
+		in
+		sprintf "<!ATTLIST %s %s %s %s>" tag aname (atype_to_string atype) (adefault_to_string adef)
+	| DTDElement (tag,etype) ->
+		let rec echild_to_string = function
+			| DTDTag s -> s
+			| DTDPCData -> "#PCDATA"
+			| DTDOptional c -> sprintf "%s?" (echild_to_string c)
+			| DTDZeroOrMore c -> sprintf "%s*" (echild_to_string c)
+			| DTDOneOrMore c -> sprintf "%s+" (echild_to_string c)
+			| DTDChoice [c] -> echild_to_string c
+			| DTDChoice l -> sprintf "(%s)" (String.concat "|" (List.map echild_to_string l))
+			| DTDChildren [c] -> echild_to_string c
+			| DTDChildren l -> sprintf "(%s)" (String.concat "," (List.map echild_to_string l))
+		in
+		let etype_to_string = function
+			| DTDEmpty -> "EMPTY"
+			| DTDAny -> "ANY"
+			| DTDChild x ->
+				let rec op_to_string = function
+					| DTDOptional c -> sprintf "%s?" (op_to_string c)
+					| DTDZeroOrMore c -> sprintf "%s*" (op_to_string c)
+					| DTDOneOrMore c -> sprintf "%s+" (op_to_string c)
+					| _ -> ""
+				in
+				let rec root = function
+					| DTDOptional c
+					| DTDZeroOrMore c
+					| DTDOneOrMore c ->
+						root c
+					| DTDChoice [_]
+					| DTDChildren [_] as x ->
+						x, false
+					| DTDChoice _
+					| DTDChildren _ as x ->
+						x, true
+					| x -> x, false
+				in
+				match root x with
+				| r, true -> sprintf "%s%s" (echild_to_string r) (op_to_string x)
+				| r, false -> sprintf "(%s%s)" (echild_to_string r) (op_to_string x)
+		in
+		sprintf "<!ELEMENT %s %s>" tag (etype_to_string etype)
+
+;;
+to_string_ref := to_string

libs/xml-light/dtd.mli

@@ -0,0 +1,175 @@
+(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse ([email protected])
+ *
+ * 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 has the special exception on linking described in file
+ * README.
+ *
+ * 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
+ *)
+
+(** Xml Light DTD
+
+	This module provide several functions to create, check, and use DTD
+	to prove Xml documents : {ul
+	{li using the DTD types, you can directly create your own DTD structure}
+	{li the {!Dtd.check} function can then be used to check that all DTD
+		states have been declared, that no attributes are declared twice,
+		and so on.}
+	{li the {!Dtd.prove} function can be used to check an {!Xml} data
+		structure with a checked DTD. The function will return the
+		expanded Xml document or raise an exception if the DTD proving
+		fails.}
+	}
+
+	{i Note about ENTITIES:}
+	
+	While parsing Xml, PCDATA is always parsed and
+	the Xml entities & > < ' " are replaced by their
+	corresponding ASCII characters. For Xml attributes, theses can be
+	put between either double or simple quotes, and the backslash character
+	can be used to escape inner quotes. There is no support for CDATA Xml
+	nodes or PCDATA attributes declarations in DTD, and no support for
+	user-defined entities using the ENTITY DTD element.
+*)
+
+(** {6 The DTD Types} *)
+
+type dtd_child =
+	| DTDTag of string
+	| DTDPCData
+	| DTDOptional of dtd_child
+	| DTDZeroOrMore of dtd_child
+	| DTDOneOrMore of dtd_child
+	| DTDChoice of dtd_child list
+	| DTDChildren of dtd_child list
+
+type dtd_element_type =
+	| DTDEmpty
+	| DTDAny
+	| DTDChild of dtd_child
+
+type dtd_attr_default =
+	| DTDDefault of string
+	| DTDRequired
+	| DTDImplied
+	| DTDFixed of string
+
+type dtd_attr_type =
+	| DTDCData
+	| DTDNMToken
+	| DTDEnum of string list
+	| DTDID
+	| DTDIDRef
+
+type dtd_item =
+	| DTDAttribute of string * string * dtd_attr_type * dtd_attr_default
+	| DTDElement of string * dtd_element_type
+
+type dtd = dtd_item list
+
+type checked
+
+(** {6 The DTD Functions} *)
+
+(** Parse the named file into a Dtd data structure. Raise
+	{!Xml.File_not_found} if an error occured while opening the file. 
+	Raise {!Dtd.Parse_error} if parsing failed. *)
+val parse_file : string -> dtd
+
+(** Read the content of the in_channel and parse it into a Dtd data
+ structure. Raise {!Dtd.Parse_error} if parsing failed. *)
+val parse_in : in_channel -> dtd
+
+(** Parse the string containing a Dtd document into a Dtd data
+ structure. Raise {!Dtd.Parse_error} if parsing failed. *)
+val parse_string : string -> dtd
+
+(** Check the Dtd data structure declaration and return a checked
+ DTD. Raise {!Dtd.Check_error} if the DTD checking failed. *)
+val check : dtd -> checked
+
+(** Prove an Xml document using a checked DTD and an entry point.
+ The entry point is the first excepted tag of the Xml document,
+ the returned Xml document has the same structure has the original
+ one, excepted that non declared optional attributes have been set
+ to their default value specified in the DTD.
+ Raise {!Dtd.Check_error} [ElementNotDeclared] if the entry point
+ is not found, raise {!Dtd.Prove_error} if the Xml document failed
+ to be proved with the DTD. *)
+val prove : checked -> string -> Xml.xml -> Xml.xml
+
+(** Print a DTD element into a string. You can easily get a DTD
+ document from a DTD data structure using for example
+ [String.concat "\n" (List.map Dtd.to_string) my_dtd] *)
+val to_string : dtd_item -> string
+
+(** {6 The DTD Exceptions} *)
+
+(** There is three types of DTD excecptions : {ul
+	{li {!Dtd.Parse_error} is raised when an error occured while
+	parsing a DTD document into a DTD data structure.}
+	{li {!Dtd.Check_error} is raised when an error occured while
+	checking a DTD data structure for completeness, or when the
+	prove entry point is not found when calling {!Dtd.prove}.}
+	{li {!Dtd.Prove_error} is raised when an error occured while
+	proving an Xml document.}
+	}
+
+	Several string conversion functions are provided to enable you
+	to report errors to the user.
+*)
+
+type parse_error_msg =
+	| InvalidDTDDecl
+	| InvalidDTDElement
+	| InvalidDTDAttribute
+	| InvalidDTDTag
+	| DTDItemExpected
+
+type check_error =
+	| ElementDefinedTwice of string
+	| AttributeDefinedTwice of string * string
+	| ElementEmptyContructor of string
+	| ElementReferenced of string * string
+	| ElementNotDeclared of string
+	| WrongImplicitValueForID of string * string
+
+type prove_error =
+	| UnexpectedPCData
+	| UnexpectedTag of string
+	| UnexpectedAttribute of string
+	| InvalidAttributeValue of string
+	| RequiredAttribute of string
+	| ChildExpected of string
+	| EmptyExpected
+	| DuplicateID of string
+	| MissingID of string
+
+type parse_error = parse_error_msg * Xml.error_pos
+
+exception Parse_error of parse_error
+exception Check_error of check_error
+exception Prove_error of prove_error
+
+val parse_error : parse_error -> string
+val check_error : check_error -> string
+val prove_error : prove_error -> string
+
+(**/**)
+
+(* internal usage only... *)
+val _raises : (string -> exn) -> unit

libs/xml-light/makedoc.bat

@@ -0,0 +1,2 @@
+@ocamldoc -sort -html -d doc xml.mli dtd.mli xmlParser.mli
+@pause

libs/xml-light/test.ml

@@ -0,0 +1,58 @@
+(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse ([email protected])
+ *
+ * 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 has the special exception on linking described in file
+ * README.
+ *
+ * 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 Xml
+open Dtd
+
+let parse data =
+	match data.[0] with
+	| '#' -> Xml.parse_file (String.sub data 1 ((String.length data)-2))
+	| _ -> Xml.parse_string data
+
+;;
+let buf = ref "" in
+print_endline "Please enter some XML data followed (press return twice to parse) :";
+try
+	while true do
+		match read_line() with
+		| "" when !buf <> "" ->
+			let data = !buf in
+			buf := "";
+			(try
+				let x = parse data in
+				print_endline "Parsing...";
+				print_endline (Xml.to_string_fmt x);
+			with
+				| Xml.Error msg as e ->
+					Printf.printf "Xml error : %s\n" (Xml.error msg)
+				| Dtd.Parse_error msg as e ->
+					Printf.printf "Dtd parse error : %s\n" (Dtd.parse_error msg)
+				| Dtd.Check_error msg as e ->
+					Printf.printf "Dtd check error : %s\n" (Dtd.check_error msg)
+				| Dtd.Prove_error msg as e ->
+					Printf.printf "Dtd prove error : %s\n" (Dtd.prove_error msg))
+		| s -> 
+			buf := !buf ^ s ^ "\n"
+	done
+with
+	End_of_file -> print_endline "Exit."

libs/xml-light/xml.dsp

@@ -0,0 +1,102 @@
+# Microsoft Developer Studio Project File - Name="xml" - Package Owner=<4>
+# Microsoft Developer Studio Generated Build File, Format Version 6.00
+# ** DO NOT EDIT **
+
+# TARGTYPE "Win32 (x86) External Target" 0x0106
+
+CFG=xml - Win32 Bytecode
+!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 "xml.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 "xml.mak" CFG="xml - Win32 Bytecode"
+!MESSAGE 
+!MESSAGE Possible choices for configuration are:
+!MESSAGE 
+!MESSAGE "xml - Win32 Bytecode" (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 1
+# PROP BASE Output_Dir ""
+# PROP BASE Intermediate_Dir ""
+# PROP BASE Cmd_Line "ocamake xml.dsp"
+# PROP BASE Rebuild_Opt "-all"
+# PROP BASE Target_File "xml.exe"
+# PROP BASE Bsc_Name ""
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 1
+# PROP Output_Dir ""
+# PROP Intermediate_Dir ""
+# PROP Cmd_Line "ocamake xml.dsp -P xml_parser.ml -P xml_lexer.ml -P dtd.ml -P xmlParser.ml"
+# PROP Rebuild_Opt "-all"
+# PROP Target_File "xml.exe"
+# PROP Bsc_Name ""
+# PROP Target_Dir ""
+# Begin Target
+
+# Name "xml - Win32 Bytecode"
+
+!IF  "$(CFG)" == "xml - Win32 Bytecode"
+
+!ENDIF 
+
+# Begin Group "ML Files"
+
+# PROP Default_Filter "ml;mly;mll"
+# Begin Source File
+
+SOURCE=.\dtd.ml
+# End Source File
+# Begin Source File
+
+SOURCE=.\test.ml
+# End Source File
+# Begin Source File
+
+SOURCE=.\xml.ml
+# End Source File
+# Begin Source File
+
+SOURCE=.\xml_lexer.mll
+# End Source File
+# Begin Source File
+
+SOURCE=.\xml_parser.mly
+# End Source File
+# Begin Source File
+
+SOURCE=.\xmlParser.ml
+# End Source File
+# End Group
+# Begin Group "MLI Files"
+
+# PROP Default_Filter "mli"
+# Begin Source File
+
+SOURCE=.\dtd.mli
+# End Source File
+# Begin Source File
+
+SOURCE=.\xml.mli
+# End Source File
+# Begin Source File
+
+SOURCE=.\xml_lexer.mli
+# End Source File
+# Begin Source File
+
+SOURCE=.\xmlParser.mli
+# End Source File
+# End Group
+# End Target
+# End Project

libs/xml-light/xml.dsw

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

libs/xml-light/xml.ml

@@ -0,0 +1,268 @@
+(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse ([email protected])
+ *
+ * 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 has the special exception on linking described in file
+ * README.
+ *
+ * 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 Printf
+
+type xml = 
+	| Element of (string * (string * string) list * xml list)
+	| PCData of string
+
+type error_pos = {
+	eline : int;
+	eline_start : int;
+	emin : int;
+	emax : int;
+}
+
+type error_msg =
+	| UnterminatedComment
+	| UnterminatedString
+	| UnterminatedEntity
+	| IdentExpected
+	| CloseExpected
+	| NodeExpected
+	| AttributeNameExpected
+	| AttributeValueExpected
+	| EndOfTagExpected of string
+	| EOFExpected
+
+type error = error_msg * error_pos
+
+exception Error of error
+exception File_not_found of string
+
+exception Not_element of xml
+exception Not_pcdata of xml
+exception No_attribute of string
+
+let default_parser = XmlParser.make()
+
+let pos source =
+	let line, lstart, min, max = Xml_lexer.pos source in
+	{
+		eline = line;
+		eline_start = lstart;
+		emin = min;
+		emax = max;
+	}
+
+let parse (p:XmlParser.t) (source:XmlParser.source) =
+	(* local cast Xml.xml -> xml *)
+	(Obj.magic XmlParser.parse p source : xml)
+
+let parse_in ch = parse default_parser (XmlParser.SChannel ch)
+let parse_string str = parse default_parser (XmlParser.SString str)
+
+let parse_file f =
+	let p = XmlParser.make() in
+	let path = Filename.dirname f in
+	XmlParser.resolve p (fun file -> 
+		let name = (match path with "." -> file | _ -> path ^ "/" ^ file) in
+		Dtd.check (Dtd.parse_file name)
+	);
+	parse p (XmlParser.SFile f)
+
+let error_msg = function
+	| UnterminatedComment -> "Unterminated comment"
+	| UnterminatedString -> "Unterminated string"
+	| UnterminatedEntity -> "Unterminated entity"
+	| IdentExpected -> "Ident expected"
+	| CloseExpected -> "Element close expected"
+	| NodeExpected -> "Xml node expected"
+	| AttributeNameExpected -> "Attribute name expected"
+	| AttributeValueExpected -> "Attribute value expected"
+	| EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag
+	| EOFExpected -> "End of file expected"
+
+let error (msg,pos) =
+	if pos.emin = pos.emax then
+		sprintf "%s line %d character %d" (error_msg msg) pos.eline (pos.emin - pos.eline_start)
+	else
+		sprintf "%s line %d characters %d-%d" (error_msg msg) pos.eline (pos.emin - pos.eline_start) (pos.emax - pos.eline_start)
+	
+let line e = e.eline
+
+let range e = 
+	e.emin - e.eline_start , e.emax - e.eline_start
+
+let abs_range e =
+	e.emin , e.emax
+
+let tag = function
+	| Element (tag,_,_) -> tag
+	| x -> raise (Not_element x)
+
+let pcdata = function 
+	| PCData text -> text
+	| x -> raise (Not_pcdata x)
+
+let attribs = function 
+	| Element (_,attr,_) -> attr
+	| x -> raise (Not_element x)
+
+let attrib x att =
+	match x with
+	| Element (_,attr,_) ->
+		(try
+			let att = String.lowercase att in
+			snd (List.find (fun (n,_) -> String.lowercase n = att) attr)
+		with
+			Not_found ->
+				raise (No_attribute att))
+	| x ->
+		raise (Not_element x)
+
+let children = function
+	| Element (_,_,clist) -> clist
+	| x -> raise (Not_element x)
+
+(*let enum = function
+	| Element (_,_,clist) -> List.to_enum clist
+	| x -> raise (Not_element x)
+*)
+
+let iter f = function
+	| Element (_,_,clist) -> List.iter f clist
+	| x -> raise (Not_element x)
+
+let map f = function
+	| Element (_,_,clist) -> List.map f clist
+	| x -> raise (Not_element x)
+
+let fold f v = function
+	| Element (_,_,clist) -> List.fold_left f v clist
+	| x -> raise (Not_element x)
+
+let tmp = Buffer.create 200
+
+let buffer_pcdata text =
+	let l = String.length text in
+	for p = 0 to l-1 do 
+		match text.[p] with
+		| '>' -> Buffer.add_string tmp ">"
+		| '<' -> Buffer.add_string tmp "&lt;"
+		| '&' ->
+			if p < l-1 && text.[p+1] = '#' then
+				Buffer.add_char tmp '&'
+			else
+				Buffer.add_string tmp "&amp;"
+		| '\'' -> Buffer.add_string tmp "&apos;"
+		| '"' -> Buffer.add_string tmp "&quot;"
+		| c -> Buffer.add_char tmp c
+	done
+
+let buffer_attr (n,v) =
+	Buffer.add_char tmp ' ';
+	Buffer.add_string tmp n;
+	Buffer.add_string tmp "=\"";
+	let l = String.length v in
+	for p = 0 to l-1 do
+		match v.[p] with
+		| '\\' -> Buffer.add_string tmp "\\\\"
+		| '"' -> Buffer.add_string tmp "\\\""
+		| c -> Buffer.add_char tmp c
+	done;
+	Buffer.add_char tmp '"'
+
+let to_string x = 
+	let pcdata = ref false in
+	let rec loop = function
+		| Element (tag,alist,[]) ->
+			Buffer.add_char tmp '<';
+			Buffer.add_string tmp tag;
+			List.iter buffer_attr alist;
+			Buffer.add_string tmp "/>";
+			pcdata := false;
+		| Element (tag,alist,l) ->
+			Buffer.add_char tmp '<';
+			Buffer.add_string tmp tag;
+			List.iter buffer_attr alist;
+			Buffer.add_char tmp '>';
+			pcdata := false;
+			List.iter loop l;
+			Buffer.add_string tmp "</";
+			Buffer.add_string tmp tag;
+			Buffer.add_char tmp '>';
+			pcdata := false;
+		| PCData text ->
+			if !pcdata then Buffer.add_char tmp ' ';
+			buffer_pcdata text;
+			pcdata := true;
+	in
+	Buffer.reset tmp;
+	loop x;
+	let s = Buffer.contents tmp in
+	Buffer.reset tmp;
+	s
+
+let to_string_fmt x =
+	let rec loop ?(newl=false) tab = function
+		| Element (tag,alist,[]) ->
+			Buffer.add_string tmp tab;
+			Buffer.add_char tmp '<';
+			Buffer.add_string tmp tag;
+			List.iter buffer_attr alist;
+			Buffer.add_string tmp "/>";
+			if newl then Buffer.add_char tmp '\n';
+		| Element (tag,alist,[PCData text]) ->
+			Buffer.add_string tmp tab;
+			Buffer.add_char tmp '<';
+			Buffer.add_string tmp tag;
+			List.iter buffer_attr alist;
+			Buffer.add_string tmp ">";
+			buffer_pcdata text;
+			Buffer.add_string tmp "</";
+			Buffer.add_string tmp tag;
+			Buffer.add_char tmp '>';
+			if newl then Buffer.add_char tmp '\n';
+		| Element (tag,alist,l) ->
+			Buffer.add_string tmp tab;
+			Buffer.add_char tmp '<';
+			Buffer.add_string tmp tag;
+			List.iter buffer_attr alist;
+			Buffer.add_string tmp ">\n";
+			List.iter (loop ~newl:true (tab^"  ")) l;
+			Buffer.add_string tmp tab;
+			Buffer.add_string tmp "</";
+			Buffer.add_string tmp tag;
+			Buffer.add_char tmp '>';
+			if newl then Buffer.add_char tmp '\n';
+		| PCData text ->
+			buffer_pcdata text;
+			if newl then Buffer.add_char tmp '\n';
+	in
+	Buffer.reset tmp;
+	loop "" x;
+	let s = Buffer.contents tmp in
+	Buffer.reset tmp;
+	s
+
+;;
+XmlParser._raises (fun x p -> 
+	(* local cast : Xml.error_msg -> error_msg *)
+	Error ((Obj.magic x : error_msg),pos p))
+	(fun f -> File_not_found f)
+	(fun x p -> Dtd.Parse_error (x,
+	(* local cast : Xml.error_pos -> error_pos *)
+		(Obj.magic (pos p))));
+Dtd._raises (fun f -> File_not_found f);

libs/xml-light/xml.mli

@@ -0,0 +1,170 @@
+(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse ([email protected])
+ *
+ * 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 has the special exception on linking described in file
+ * README.
+ *
+ * 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
+ *)
+
+(** Xml Light
+ 
+  Xml Light is a minimal Xml parser & printer for OCaml.
+  It provide few functions to parse a basic Xml document into
+  an OCaml data structure and to print back the data structures
+  to an Xml document.
+
+  Xml Light has also support for {b DTD} (Document Type Definition).
+
+  {i (c)Copyright 2002-2003 Nicolas Cannasse}
+*)
+
+(** {6 Xml Data Structure} *)
+
+(** An Xml node is either
+	[Element (tag-name, attributes, children)] or [PCData text] *)
+type xml = 
+	| Element of (string * (string * string) list * xml list)
+	| PCData of string
+
+(** {6 Xml Parsing} *)
+
+(** For easily parsing an Xml data source into an xml data structure,
+	you can use theses functions. But if you want advanced parsing usage,
+	please look at the {!XmlParser} module.
+	All the parsing functions can raise some exceptions, see the
+	{{:#exc}Exceptions} section for more informations. *)
+
+(** Parse the named file into an Xml data structure. *)
+val parse_file : string -> xml
+
+(** Read the content of the in_channel and parse it into an Xml data
+ structure. *)
+val parse_in : in_channel -> xml
+
+(** Parse the string containing an Xml document into an Xml data
+ structure. *)
+val parse_string : string -> xml
+
+(** {6:exc Xml Exceptions} *)
+
+(** Several exceptions can be raised when parsing an Xml document : {ul
+	{li {!Xml.Error} is raised when an xml parsing error occurs. the
+		{!Xml.error_msg} tells you which error occured during parsing
+		and the {!Xml.error_pos} can be used to retreive the document
+		location where the error occured at.}
+	{li {!Xml.File_not_found} is raised when and error occured while
+		opening a file with the {!Xml.parse_file} function or when a
+		DTD file declared by the Xml document is not found {i (see the
+		{!XmlParser} module for more informations on how to handle the
+		DTD file loading)}.}
+	}
+	If the Xml document is containing a DTD, then some other exceptions
+	can be raised, see the module {!Dtd} for more informations.
+ *)
+
+type error_pos
+
+type error_msg =
+	| UnterminatedComment
+	| UnterminatedString
+	| UnterminatedEntity
+	| IdentExpected
+	| CloseExpected
+	| NodeExpected
+	| AttributeNameExpected
+	| AttributeValueExpected
+	| EndOfTagExpected of string
+	| EOFExpected
+
+type error = error_msg * error_pos
+
+exception Error of error
+
+exception File_not_found of string
+
+(** Get a full error message from an Xml error. *)
+val error : error -> string
+
+(** Get the Xml error message as a string. *)
+val error_msg : error_msg -> string 
+
+(** Get the line the error occured at. *)
+val line : error_pos -> int
+
+(** Get the relative character range (in current line) the error occured at.*)
+val range : error_pos -> int * int
+
+(** Get the absolute character range the error occured at. *)
+val abs_range : error_pos -> int * int
+
+(** {6 Xml Functions} *)
+
+exception Not_element of xml
+exception Not_pcdata of xml
+exception No_attribute of string
+
+(** [tag xdata] returns the tag value of the xml node.
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val tag : xml -> string
+
+(** [pcdata xdata] returns the PCData value of the xml node.
+ Raise {!Xml.Not_pcdata} if the xml is not a PCData *)
+val pcdata : xml -> string
+
+(** [attribs xdata] returns the attribute list of the xml node.
+ First string if the attribute name, second string is attribute value.
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val attribs : xml -> (string * string) list 
+
+(** [attrib xdata "href"] returns the value of the ["href"]
+ attribute of the xml node (attribute matching is case-insensitive).
+ Raise {!Xml.No_attribute} if the attribute does not exists in the node's
+ attribute list 
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val attrib : xml -> string -> string
+
+(** [children xdata] returns the children list of the xml node
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val children : xml -> xml list
+
+(*** [enum xdata] returns the children enumeration of the xml node
+ Raise {!Xml.Not_element} if the xml is not an element *)
+(* val enum : xml -> xml Enum.t *)
+
+(** [iter f xdata] calls f on all children of the xml node.
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val iter : (xml -> unit) -> xml -> unit
+
+(** [map f xdata] is equivalent to [List.map f (Xml.children xdata)]
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val map : (xml -> 'a) -> xml -> 'a list
+
+(** [fold f init xdata] is equivalent to
+ [List.fold_left f init (Xml.children xdata)]
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val fold : ('a -> xml -> 'a) -> 'a -> xml -> 'a
+
+(** {6 Xml Printing} *)
+
+(** Print the xml data structure into a compact xml string (without
+ any user-readable formating ). *)
+val to_string : xml -> string
+
+(** Print the xml data structure into an user-readable string with
+ tabs and lines break between different nodes. *)
+val to_string_fmt : xml -> string

libs/xml-light/xmlParser.ml

@@ -0,0 +1,185 @@
+(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse ([email protected])
+ * Copyright (C) 2003 Jacques Garrigue
+ *
+ * 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 has the special exception on linking described in file
+ * README.
+ *
+ * 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 Printf
+open Dtd
+open Xml
+
+type t = {
+	mutable prove : bool;
+	mutable check_eof : bool;
+	mutable concat_pcdata : bool;
+	mutable resolve : (string -> checked);
+}
+
+type source = 
+	| SFile of string
+	| SChannel of in_channel
+	| SString of string
+	| SLexbuf of Lexing.lexbuf
+
+type state = {
+	source : Lexing.lexbuf;
+	stack : Xml_lexer.token Stack.t;
+	xparser : t;
+}
+
+exception Internal_error of Xml.error_msg
+exception NoMoreData
+
+let xml_error = ref (fun _ -> assert false)
+let dtd_error = ref (fun _ -> assert false)
+let file_not_found = ref (fun _ -> assert false)
+
+let _raises e f d =
+	xml_error := e;
+	file_not_found := f;
+	dtd_error := d
+
+let make () =
+	{
+		prove = true;
+		check_eof = true;
+		concat_pcdata = true;
+		resolve = (fun file -> raise (!file_not_found file))
+	}
+
+let prove p v = p.prove <- v
+let resolve p f = p.resolve <- f
+let check_eof p v = p.check_eof <- v
+let concat_pcdata p v = p.concat_pcdata <- v
+
+let pop s =
+	try
+		Stack.pop s.stack
+	with
+		Stack.Empty ->
+			Xml_lexer.token s.source
+
+let push t s =
+	Stack.push t s.stack
+
+let rec read_node s =
+	match pop s with
+	| Xml_lexer.PCData s -> PCData s
+	| Xml_lexer.Tag (tag, attr, true) -> Element (tag, attr, [])
+	| Xml_lexer.Tag (tag, attr, false) -> Element (tag, attr, read_elems ~tag s)
+	| t ->
+		push t s;
+		raise NoMoreData
+and
+	read_elems ?tag s =
+		let elems = ref [] in
+		(try
+			while true do
+				match s.xparser.concat_pcdata , read_node s , !elems with
+				| true , PCData c , (PCData c2) :: q ->
+					elems := PCData (sprintf "%s\n%s" c2 c) :: q
+				| _ , x , l ->
+					elems := x :: l
+			done
+		with
+			NoMoreData -> ());
+		match pop s with
+		| Xml_lexer.Endtag s when Some s = tag -> List.rev !elems
+		| Xml_lexer.Eof when tag = None -> List.rev !elems
+		| t ->
+			match tag with
+			| None -> raise (Internal_error EOFExpected)
+			| Some s -> raise (Internal_error (EndOfTagExpected s))
+
+let read_xml s =
+	match s.xparser.prove, pop s with
+	| true, Xml_lexer.DocType (root, Xml_lexer.DTDFile file) ->
+		let pos = Xml_lexer.pos s.source in
+		let dtd = s.xparser.resolve file in
+		Xml_lexer.restore pos;
+		let x = read_node s in
+		Dtd.prove dtd root x
+	| true, Xml_lexer.DocType (root, Xml_lexer.DTDData dtd) ->
+		let dtd = Dtd.check dtd in
+		let x = read_node s in
+		Dtd.prove dtd root x
+	| false, Xml_lexer.DocType _ ->
+		read_node s
+	| _, t ->
+		push t s;
+		read_node s
+
+let convert = function
+	| Xml_lexer.EUnterminatedComment -> UnterminatedComment
+	| Xml_lexer.EUnterminatedString -> UnterminatedString
+	| Xml_lexer.EIdentExpected -> IdentExpected
+	| Xml_lexer.ECloseExpected -> CloseExpected
+	| Xml_lexer.ENodeExpected -> NodeExpected
+	| Xml_lexer.EAttributeNameExpected -> AttributeNameExpected
+	| Xml_lexer.EAttributeValueExpected -> AttributeValueExpected
+	| Xml_lexer.EUnterminatedEntity -> 	UnterminatedEntity
+
+let dtd_convert = function
+	| Xml_lexer.EInvalidDTDDecl -> InvalidDTDDecl
+	| Xml_lexer.EInvalidDTDTag -> InvalidDTDTag
+	| Xml_lexer.EDTDItemExpected -> DTDItemExpected
+	| Xml_lexer.EInvalidDTDElement -> InvalidDTDElement
+	| Xml_lexer.EInvalidDTDAttribute -> InvalidDTDAttribute
+
+let do_parse xparser source =
+	try
+		Xml_lexer.init source;
+		let s = { source = source; xparser = xparser; stack = Stack.create(); } in
+		let tk = pop s in
+		(* skip UTF8 BOM *)
+		if tk <> Xml_lexer.PCData "\239\187\191" then push tk s;
+		let x = read_xml s in
+		if xparser.check_eof && pop s <> Xml_lexer.Eof then raise (Internal_error EOFExpected);
+		Xml_lexer.close source;
+		x
+	with
+		| NoMoreData ->
+			Xml_lexer.close source;
+			raise (!xml_error NodeExpected source)
+		| Internal_error e ->
+			Xml_lexer.close source;
+			raise (!xml_error e source)
+		| Xml_lexer.Error e ->
+			Xml_lexer.close source;
+			raise (!xml_error (convert e) source)
+		| Xml_lexer.DTDError e ->
+			Xml_lexer.close source;
+			raise (!dtd_error (dtd_convert e) source)
+
+let parse p = function
+	| SChannel ch -> do_parse p (Lexing.from_channel ch)
+	| SString str -> do_parse p (Lexing.from_string str)
+	| SLexbuf lex -> do_parse p lex
+	| SFile fname ->
+		let ch = (try open_in fname with Sys_error _ -> raise (!file_not_found fname)) in
+		try
+			let x = do_parse p (Lexing.from_channel ch) in
+			close_in ch;
+			x
+		with
+			e ->
+				close_in ch;
+				raise e

libs/xml-light/xmlParser.mli

@@ -0,0 +1,82 @@
+(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse ([email protected])
+ *
+ * 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 has the special exception on linking described in file
+ * README.
+ *
+ * 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
+ *)
+
+(** Xml Light Parser
+
+ While basic parsing functions can be used in the {!Xml} module, this module
+ is providing a way to create, configure and run an Xml parser.
+
+*)
+
+(** Abstract type for an Xml parser. *)
+type t
+
+(** Several kind of resources can contain Xml documents. *)
+type source = 
+	| SFile of string
+	| SChannel of in_channel
+	| SString of string
+	| SLexbuf of Lexing.lexbuf
+
+(** This function returns a new parser with default options. *)
+val make : unit -> t
+
+(** This function enable or disable automatic DTD proving with the parser. 
+ Note that Xml documents having no reference to a DTD are never proved
+ when parsed (but you can prove them later using the {!Dtd} module
+ {i (by default, prove is true)}. *)
+val prove : t -> bool -> unit
+
+(** When parsing an Xml document from a file using the {!Xml.parse_file}
+ function, the DTD file if declared by the Xml document has to be in the
+ same directory as the xml file. When using other parsing functions, 
+ such as on a string or on a channel, the parser will raise everytime
+ {!Xml.File_not_found} if a DTD file is needed and prove enabled. To enable
+ the DTD loading of the file, the user have to configure the Xml parser
+ with a [resolve] function which is taking as argument the DTD filename and
+ is returning a checked DTD. The user can then implement any kind of DTD
+ loading strategy, and can use the {!Dtd} module functions to parse and check
+ the DTD file {i (by default, the resolve function is raising}
+ {!Xml.File_not_found}). *)
+val resolve : t -> (string -> Dtd.checked) -> unit
+
+(** When a Xml document is parsed, the parser will check that the end of the
+ document is reached, so for example parsing ["<A/><B/>"] will fail instead
+ of returning only the A element. You can turn off this check by setting
+ [check_eof] to [false] {i (by default, check_eof is true)}. *)
+val check_eof : t -> bool -> unit
+
+(** Once the parser is configurated, you can run the parser on a any kind
+ of xml document source to parse its contents into an Xml data structure. *)
+val parse :  t -> source -> Xml.xml
+
+(** When several PCData elements are separed by a \n (or \r\n), you can
+ either split the PCData in two distincts PCData or merge them with \n
+ as seperator into one PCData. The default behavior is to concat the
+ PCData, but this can be changed for a given parser with this flag. *)
+val concat_pcdata : t -> bool -> unit
+
+(**/**)
+
+(* internal usage only... *)
+val _raises : (Xml.error_msg -> Lexing.lexbuf -> exn) -> (string -> exn) -> (Dtd.parse_error_msg -> Lexing.lexbuf -> exn) -> unit

libs/xml-light/xml_lexer.mli

@@ -0,0 +1,62 @@
+(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse ([email protected])
+ *
+ * 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 has the special exception on linking described in file
+ * README.
+ *
+ * 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 error =
+	| EUnterminatedComment
+	| EUnterminatedString
+	| EIdentExpected
+	| ECloseExpected
+	| ENodeExpected
+	| EAttributeNameExpected
+	| EAttributeValueExpected
+	| EUnterminatedEntity
+
+type dtd_error =
+	| EInvalidDTDDecl
+	| EInvalidDTDTag
+	| EDTDItemExpected
+	| EInvalidDTDElement
+	| EInvalidDTDAttribute
+
+exception Error of error
+exception DTDError of dtd_error
+
+type dtd_decl =
+	| DTDFile of string
+	| DTDData of Dtd.dtd
+
+type token =
+	| Tag of string * (string * string) list * bool
+	| PCData of string
+	| Endtag of string
+	| DocType of (string * dtd_decl)
+	| Eof
+
+type pos = int * int * int * int
+
+val init : Lexing.lexbuf -> unit 
+val close : Lexing.lexbuf -> unit
+val token : Lexing.lexbuf -> token
+val dtd : Lexing.lexbuf -> Dtd.dtd
+val pos : Lexing.lexbuf -> pos
+val restore : pos -> unit

libs/xml-light/xml_lexer.mll

@@ -0,0 +1,673 @@
+{(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse ([email protected])
+ *
+ * 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 has the special exception on linking described in file
+ * README.
+ *
+ * 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 Lexing
+open Xml_parser
+open Dtd
+
+type error =
+	| EUnterminatedComment
+	| EUnterminatedString
+	| EIdentExpected
+	| ECloseExpected
+	| ENodeExpected
+	| EAttributeNameExpected
+	| EAttributeValueExpected
+	| EUnterminatedEntity
+
+type dtd_error =
+	| EInvalidDTDDecl
+	| EInvalidDTDTag
+	| EDTDItemExpected
+	| EInvalidDTDElement
+	| EInvalidDTDAttribute
+
+exception Error of error
+exception DTDError of dtd_error
+
+type pos = int * int * int * int
+
+type dtd_decl =
+	| DTDFile of string
+	| DTDData of dtd
+
+type dtd_item_type =
+	| TElement
+	| TAttribute
+
+type token =
+	| Tag of string * (string * string) list * bool
+	| PCData of string
+	| Endtag of string
+	| DocType of (string * dtd_decl)
+	| Eof
+
+let last_pos = ref 0
+and current_line = ref 0
+and current_line_start = ref 0
+
+let tmp = Buffer.create 200
+
+let idents = Hashtbl.create 0
+
+let _ = begin
+	Hashtbl.add idents "gt;" ">";
+	Hashtbl.add idents "lt;" "<";
+	Hashtbl.add idents "amp;" "&";
+	Hashtbl.add idents "apos;" "'";
+	Hashtbl.add idents "quot;" "\"";
+end
+
+let init lexbuf =
+	current_line := 1;
+	current_line_start := lexeme_start lexbuf;
+	last_pos := !current_line_start
+
+let close lexbuf =
+	Buffer.reset tmp
+
+let pos lexbuf =
+	!current_line ,	!current_line_start ,
+	!last_pos ,
+	lexeme_start lexbuf
+
+let restore (cl,cls,lp,_) =
+	current_line := cl;
+	current_line_start := cls;
+	last_pos := lp
+
+let newline lexbuf =
+	incr current_line;
+	last_pos := lexeme_end lexbuf;
+	current_line_start := !last_pos
+
+let error lexbuf e =
+	last_pos := lexeme_start lexbuf;
+	raise (Error e)
+
+let dtd_error lexbuf e =
+	last_pos := lexeme_start lexbuf;
+	raise (DTDError e)
+}
+
+let newline = ['\n']
+let break = ['\r']
+let space = [' ' '\t']
+let identchar =  ['A'-'Z' 'a'-'z' '_' '0'-'9' ':' '-']
+let entitychar = ['A'-'Z' 'a'-'z']
+let pcchar = [^ '\r' '\n' '<' '>' '&']
+let cdata_start = ['c''C']['d''D']['a''A']['t''T']['a''A']
+
+rule token = parse
+	| newline
+		{
+			newline lexbuf;
+			token lexbuf
+		}
+	| (space | break) +
+		{
+			last_pos := lexeme_end lexbuf;
+			token lexbuf
+		}
+	| "<!DOCTYPE"
+		{
+			last_pos := lexeme_start lexbuf;
+			ignore_spaces lexbuf;
+			let root = ident_name lexbuf in
+			ignore_spaces lexbuf;
+			let data = dtd_data lexbuf in
+			DocType (root, data)
+		}
+	| "<![" cdata_start '['
+		{
+			last_pos := lexeme_start lexbuf;
+			Buffer.reset tmp;
+			PCData (cdata lexbuf)
+		}		
+	| "<!--"
+		{
+			last_pos := lexeme_start lexbuf;
+			comment lexbuf;
+			token lexbuf
+		}
+	| "<?"
+		{
+			last_pos := lexeme_start lexbuf;
+			header lexbuf;
+			token lexbuf;
+		}
+	| '<' space* '/' space*
+		{
+			last_pos := lexeme_start lexbuf;
+			let tag = ident_name lexbuf in
+			ignore_spaces lexbuf;
+			close_tag lexbuf;
+			Endtag tag
+		}
+	| '<' space*
+		{
+			last_pos := lexeme_start lexbuf;
+			let tag = ident_name lexbuf in
+			ignore_spaces lexbuf;
+			let attribs, closed = attributes lexbuf in
+			Tag(tag, attribs, closed)
+		}
+	| "&#"
+		{
+			last_pos := lexeme_start lexbuf;
+			Buffer.reset tmp;
+			Buffer.add_string tmp (lexeme lexbuf);
+			PCData (pcdata lexbuf)
+		}
+	| '&'
+		{
+			last_pos := lexeme_start lexbuf;
+			Buffer.reset tmp;
+			Buffer.add_string tmp (entity lexbuf);
+			PCData (pcdata lexbuf)
+		}
+	| space* pcchar+
+		{
+			last_pos := lexeme_start lexbuf;
+			Buffer.reset tmp;
+			Buffer.add_string tmp (lexeme lexbuf);
+			PCData (pcdata lexbuf)
+		}
+	| eof { Eof }
+	| _
+		{ error lexbuf ENodeExpected }
+
+and ignore_spaces = parse
+	| newline
+		{
+			newline lexbuf;
+			ignore_spaces lexbuf
+		}
+	| (space | break) +
+		{ ignore_spaces lexbuf }
+	| ""
+		{ () }
+
+and comment = parse
+	| newline
+		{
+			newline lexbuf;
+			comment lexbuf
+		}
+	| "-->"
+		{ () }
+	| eof
+		{ raise (Error EUnterminatedComment) }
+	| _
+		{ comment lexbuf }
+
+and header = parse
+	| newline
+		{
+			newline lexbuf;
+			header lexbuf
+		}
+	| "?>"
+		{ () }
+	| eof
+		{ error lexbuf ECloseExpected }
+	| _
+		{ header lexbuf }		
+
+and cdata = parse
+	| [^ ']' '\n']+
+		{
+			Buffer.add_string tmp (lexeme lexbuf);
+			cdata lexbuf
+		}
+	| newline 
+		{
+			newline lexbuf;
+			Buffer.add_string tmp (lexeme lexbuf);
+			cdata lexbuf
+		}
+	| "]]>"
+		{ Buffer.contents tmp }
+	| ']'
+		{
+			Buffer.add_string tmp (lexeme lexbuf);
+			cdata lexbuf
+		}
+	| eof
+		{ error lexbuf ECloseExpected }
+
+and pcdata = parse
+	| pcchar+
+		{
+			Buffer.add_string tmp (lexeme lexbuf);
+			pcdata lexbuf
+		}
+	| "&#"
+		{
+			Buffer.add_string tmp (lexeme lexbuf);
+			pcdata lexbuf;
+		}
+	| '&'
+		{
+			Buffer.add_string tmp (entity lexbuf);
+			pcdata lexbuf
+		}
+	| ""
+		{ Buffer.contents tmp }
+
+and entity = parse
+	| entitychar+ ';'
+		{
+			let ident = lexeme lexbuf in
+			try
+				Hashtbl.find idents (String.lowercase ident)
+			with
+				Not_found -> "&" ^ ident
+		}
+	| _ | eof
+		{ raise (Error EUnterminatedEntity) }
+
+and ident_name = parse
+	| identchar+
+		{ lexeme lexbuf }
+	| _ | eof
+		{ error lexbuf EIdentExpected }
+
+and close_tag = parse
+	| '>'
+		{ () }
+	| _ | eof
+		{ error lexbuf ECloseExpected }
+
+and attributes = parse
+	| '>'
+		{ [], false }
+	| "/>"
+		{ [], true }
+	| "" (* do not read a char ! *)
+		{
+			let key = attribute lexbuf in
+			let data = attribute_data lexbuf in
+			ignore_spaces lexbuf;
+			let others, closed = attributes lexbuf in
+			(key, data) :: others, closed
+		}
+
+and attribute = parse
+	| identchar+
+		{ lexeme lexbuf }
+	| _ | eof
+		{ error lexbuf EAttributeNameExpected }
+
+and attribute_data = parse
+	| space* '=' space* '"'
+		{
+			Buffer.reset tmp;
+			last_pos := lexeme_end lexbuf;
+			dq_string lexbuf
+		}
+	| space* '=' space* '\''
+		{
+			Buffer.reset tmp;
+			last_pos := lexeme_end lexbuf;
+			q_string lexbuf
+		}
+	| _ | eof
+		{ error lexbuf EAttributeValueExpected }
+
+and dq_string = parse
+	| '"'
+		{ Buffer.contents tmp }
+	| '\\' [ '"' '\\' ]
+		{
+			Buffer.add_char tmp (lexeme_char lexbuf 1);
+			dq_string lexbuf
+		}
+	| eof
+		{ raise (Error EUnterminatedString) }
+	| _
+		{ 
+			Buffer.add_char tmp (lexeme_char lexbuf 0);
+			dq_string lexbuf
+		}
+
+and q_string = parse
+	| '\''
+		{ Buffer.contents tmp }
+	| '\\' [ '\'' '\\' ]
+		{
+			Buffer.add_char tmp (lexeme_char lexbuf 1);
+			q_string lexbuf
+		}
+	| eof
+		{ raise (Error EUnterminatedString) }
+	| _
+		{ 
+			Buffer.add_char tmp (lexeme_char lexbuf 0);
+			q_string lexbuf
+		}
+
+and dtd_data = parse
+	| "PUBLIC"
+		{
+			ignore_spaces lexbuf;
+			(* skipping Public ID *)
+			let _ = dtd_file lexbuf in
+			let file = dtd_file lexbuf in
+			dtd_end_decl lexbuf;
+			DTDFile file
+		}
+	| "SYSTEM"
+		{
+			ignore_spaces lexbuf;
+			let file = dtd_file lexbuf in
+			dtd_end_decl lexbuf;
+			DTDFile file
+		}
+	| '['
+		{
+			ignore_spaces lexbuf;
+			let data = dtd_intern lexbuf in
+			dtd_end_decl lexbuf;
+			DTDData data
+		}
+	| _ | eof
+		{ dtd_error lexbuf EInvalidDTDDecl }
+
+and dtd_file = parse
+	| '"'
+		{
+			Buffer.reset tmp;
+			let s = dq_string lexbuf in
+			ignore_spaces lexbuf;
+			s
+		}
+	| '\''
+		{
+			Buffer.reset tmp;
+			let s = q_string lexbuf in
+			ignore_spaces lexbuf;
+			s
+		}
+	| _ | eof
+		{ dtd_error lexbuf EInvalidDTDDecl }
+
+and dtd_intern = parse
+	| ']'
+		{ 
+			ignore_spaces lexbuf;
+			[]
+		}
+	| ""
+		{
+			let l = dtd_item lexbuf in
+			l @ (dtd_intern lexbuf)
+		}
+
+and dtd = parse
+	| eof
+		{ [] }
+	| newline
+		{
+			newline lexbuf;
+			dtd lexbuf
+		}
+	| (space | break)+
+		{ dtd lexbuf }
+	| ""
+		{
+			let l = dtd_item lexbuf in
+			l @ (dtd lexbuf)
+		}
+
+and dtd_end_decl = parse
+	| '>'
+		{ ignore_spaces lexbuf }
+	| _ | eof
+		{ dtd_error lexbuf EInvalidDTDDecl }
+
+and dtd_item = parse
+	| "<!--"
+		{
+			comment lexbuf;
+			[];
+		}
+	| "<!"
+		{
+			ignore_spaces lexbuf;
+			let t = dtd_item_type lexbuf in
+			let name = (try ident_name lexbuf with Error EIdentExpected -> raise (DTDError EInvalidDTDDecl)) in
+			ignore_spaces lexbuf;
+			match t with
+			| TElement -> [ DTDElement (name , (dtd_element_type lexbuf)) ]
+			| TAttribute -> List.map (fun (attrname,atype,adef) -> DTDAttribute (name, attrname, atype, adef)) (dtd_attributes lexbuf)
+		}
+	| _ | eof
+		{  dtd_error lexbuf EDTDItemExpected }
+
+and dtd_attributes = parse
+	| '>'
+		{
+			ignore_spaces lexbuf;
+			[]
+		}
+	| ""
+		{
+			let attrname = (try ident_name lexbuf with Error EIdentExpected -> raise (DTDError EInvalidDTDAttribute)) in
+			ignore_spaces lexbuf;
+			let atype = dtd_attr_type lexbuf in
+			let adef = dtd_attr_default lexbuf in
+			let a = (attrname, atype, adef) in
+			a :: (dtd_attributes lexbuf)
+		}
+
+and dtd_item_type = parse
+	| "ELEMENT"
+		{
+			ignore_spaces lexbuf;
+			TElement
+		}
+	| "ATTLIST"
+		{
+			ignore_spaces lexbuf;
+			TAttribute
+		} 
+	| _ | eof
+		{ dtd_error lexbuf EInvalidDTDTag }
+
+and dtd_element_type = parse
+	| "ANY"
+		{ 
+			ignore_spaces lexbuf;
+			dtd_end_element lexbuf;
+			DTDAny
+		}
+	| "EMPTY"
+		{ 
+			ignore_spaces lexbuf;
+			dtd_end_element lexbuf;
+			DTDEmpty
+		}
+	| '('
+		{
+			try
+				let item = Xml_parser.dtd_element dtd_element_token lexbuf in
+				ignore_spaces lexbuf;
+				DTDChild item
+			with
+				Parsing.Parse_error -> dtd_error lexbuf EInvalidDTDElement
+		}
+	| _ | eof
+		{ dtd_error lexbuf EInvalidDTDElement }
+
+and dtd_end_element = parse
+	| '>' 
+		{ ignore_spaces lexbuf }
+	| _ | eof
+		{ dtd_error lexbuf EInvalidDTDElement }
+
+and dtd_end_attribute = parse
+	| '>' 
+		{ ignore_spaces lexbuf }
+	| _ | eof
+		{ dtd_error lexbuf EInvalidDTDAttribute }
+
+and dtd_element_token = parse
+	| newline
+		{
+			newline lexbuf;
+			dtd_element_token lexbuf
+		}
+	| (space | break) +
+		{ dtd_element_token lexbuf }
+	| '('
+		{ OPEN }
+	| ')'
+		{ CLOSE }
+	| ','
+		{ NEXT }
+	| '>'
+		{ END }
+	| '|'
+		{ OR }
+	| "#PCDATA"
+		{ PCDATA }
+	| '*'
+		{ STAR }
+	| '+'
+		{ PLUS }
+	| '?'
+		{ QUESTION }
+	| identchar+
+		{ IDENT (lexeme lexbuf) }
+	| _ | eof
+		{ dtd_error lexbuf EInvalidDTDElement }
+
+and dtd_attr_type = parse
+	| "CDATA"
+		{
+			ignore_spaces lexbuf;
+			DTDCData
+		}
+	| "NMTOKEN"
+		{
+			ignore_spaces lexbuf;
+			DTDNMToken
+		}
+	| "ID"
+		{
+			ignore_spaces lexbuf;
+		 	DTDID
+		}
+	| "IDREF"
+		{
+			ignore_spaces lexbuf;
+			DTDIDRef
+		}
+	| '('
+		{
+			ignore_spaces lexbuf;
+			DTDEnum (dtd_attr_enum lexbuf)
+		}
+	| _ | eof
+		{ dtd_error lexbuf EInvalidDTDAttribute }
+	
+and dtd_attr_enum = parse
+	| identchar+
+		{
+			let v = lexeme lexbuf in
+			ignore_spaces lexbuf;
+			v :: (dtd_attr_enum_next lexbuf)
+		}
+	| _ | eof
+		{ dtd_error lexbuf EInvalidDTDAttribute }
+
+and dtd_attr_enum_next = parse
+	| ')'
+		{
+			ignore_spaces lexbuf;
+			[]
+		}
+	| '|'
+		{
+			ignore_spaces lexbuf;
+			dtd_attr_enum lexbuf
+		}
+	| _ | eof
+		{ dtd_error lexbuf EInvalidDTDAttribute }
+
+and dtd_attr_default = parse
+	| '"'
+		{
+			Buffer.reset tmp;
+			let v = (try dq_string lexbuf with Error EUnterminatedString -> raise (DTDError EInvalidDTDAttribute)) in
+			ignore_spaces lexbuf;
+			DTDDefault v
+		}
+	| '\''
+		{
+			Buffer.reset tmp;
+			let v = (try q_string lexbuf with Error EUnterminatedString -> raise (DTDError EInvalidDTDAttribute)) in
+			ignore_spaces lexbuf;
+			DTDDefault v
+		}
+	| "#REQUIRED"
+		{
+			ignore_spaces lexbuf;
+			DTDRequired
+		}
+	| "#IMPLIED"
+		{
+			ignore_spaces lexbuf;
+			DTDImplied
+		}
+	| "#FIXED"
+		{
+			ignore_spaces lexbuf;
+			DTDFixed (dtd_attr_string lexbuf)
+		}
+	| "#DEFAULT"
+		{
+			ignore_spaces lexbuf;
+			DTDDefault (dtd_attr_string lexbuf)
+		}
+	| _ | eof
+		{ dtd_error lexbuf EInvalidDTDAttribute }
+
+and dtd_attr_string = parse
+	| '"'
+		{
+			Buffer.reset tmp;
+			let v = (try dq_string lexbuf with Error EUnterminatedString -> raise (DTDError EInvalidDTDAttribute)) in
+			ignore_spaces lexbuf;
+			v
+		}
+	| '\''
+		{
+			Buffer.reset tmp;
+			let v = (try q_string lexbuf with Error EUnterminatedString -> raise (DTDError EInvalidDTDAttribute)) in
+			ignore_spaces lexbuf;
+			v
+		}
+	| _ | eof
+		{ dtd_error lexbuf EInvalidDTDAttribute }

libs/xml-light/xml_parser.mly

@@ -0,0 +1,96 @@
+%{(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse ([email protected])
+ *
+ * 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 has the special exception on linking described in file
+ * README.
+ *
+ * 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
+ *)	
+%}
+%token NEXT OR
+%token <string>IDENT
+%token PCDATA
+%token STAR QUESTION PLUS
+%token OPEN CLOSE
+%token END
+
+%right STAR QUESTION PLUS
+
+%start dtd_element
+%type <Dtd.dtd_child> dtd_element
+%%
+
+dtd_element:
+	| dtd_full_seq END
+		{ $1 }
+;
+dtd_full_seq:
+	| dtd_seq CLOSE dtd_op
+		{ $3 $1 }
+	| dtd_seq CLOSE
+		{ $1 }
+;
+dtd_seq:
+	| dtd_item NEXT dtd_children
+		{ Dtd.DTDChildren ($1 :: $3) }
+	| dtd_item OR dtd_choice
+		{ Dtd.DTDChoice ($1 :: $3) }
+	| dtd_item
+		{ $1 }
+;
+dtd_children:
+	| dtd_item NEXT dtd_children
+		{ $1 :: $3 }
+	| dtd_item
+		{ [$1] }
+;
+dtd_choice:
+	| dtd_item OR dtd_choice
+		{ $1 :: $3 }
+	| dtd_item
+		{ [$1] }
+;
+dtd_item:
+	| OPEN dtd_full_seq
+		{ $2 }
+	| dtd_member
+		{ $1 }
+;
+dtd_member:
+	| IDENT dtd_op
+		{ $2 (Dtd.DTDTag $1) }
+	| PCDATA dtd_op
+		{ $2 Dtd.DTDPCData }
+	| IDENT
+		{ Dtd.DTDTag $1 }
+	| PCDATA
+		{ Dtd.DTDPCData }
+;
+dtd_op:
+	| dtd_op_item dtd_op
+		{ (fun x -> $2 ($1 x)) }
+	| dtd_op_item 
+		{ $1 }
+;
+dtd_op_item:
+	| STAR
+		{ (fun x -> Dtd.DTDZeroOrMore x) }
+	| QUESTION
+		{ (fun x -> Dtd.DTDOptional x) }
+	| PLUS
+		{ (fun x -> Dtd.DTDOneOrMore x) }
+;

libs/ziplib/Makefile

@@ -0,0 +1,5 @@
+all:
+	ocamlopt -g -I ../extlib -I ../extc -a -o zip.cmxa zlib.mli zlib.ml zip.mli zip.ml
+	
+clean:
+	rm -rf zip.cmxa zip.lib zip.a $(wildcard *.cmx) $(wildcard *.obj) $(wildcard *.o) $(wildcard *.cmi)

libs/ziplib/test/Makefile

@@ -0,0 +1,5 @@
+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)