This commit was manufactured by cvs2svn to create branch 'poly_meth2'.

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/poly_meth2@4215 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

140 files changed, 21108 insertions, 0 deletions

diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
new file mode 100644
index 0000000000..a5ac8c719d
--- /dev/null
+++ b/bytecomp/bytegen.ml
@@ -0,0 +1,824 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(*  bytegen.ml : translation of lambda terms to lists of instructions. *)
+
+open Misc
+open Asttypes
+open Primitive
+open Types
+open Lambda
+open Switch
+open Instruct
+
+(**** Label generation ****)
+
+let label_counter = ref 0
+
+let new_label () =
+  incr label_counter; !label_counter
+
+(**** Operations on compilation environments. ****)
+
+let empty_env =
+  { ce_stack = Ident.empty; ce_heap = Ident.empty; ce_rec = Ident.empty }
+
+(* Add a stack-allocated variable *)
+
+let add_var id pos env =
+  { ce_stack = Ident.add id pos env.ce_stack;
+    ce_heap = env.ce_heap;
+    ce_rec = env.ce_rec }
+
+let rec add_vars idlist pos env =
+  match idlist with
+    [] -> env
+  | id :: rem -> add_vars rem (pos + 1) (add_var id pos env)
+
+(**** Examination of the continuation ****)
+
+(* Return a label to the beginning of the given continuation.
+   If the sequence starts with a branch, use the target of that branch
+   as the label, thus avoiding a jump to a jump. *)
+
+let label_code = function
+    Kbranch lbl :: _ as cont -> (lbl, cont)
+  | Klabel lbl :: _ as cont -> (lbl, cont)
+  | cont -> let lbl = new_label() in (lbl, Klabel lbl :: cont)
+
+(* Return a branch to the continuation. That is, an instruction that,
+   when executed, branches to the continuation or performs what the
+   continuation performs. We avoid generating branches to branches and
+   branches to returns. *)
+
+let rec make_branch_2 lbl n cont =
+  function
+    Kreturn m :: _ -> (Kreturn (n + m), cont)
+  | Klabel _ :: c  -> make_branch_2 lbl n cont c
+  | Kpop m :: c    -> make_branch_2 lbl (n + m) cont c
+  | _              ->
+      match lbl with
+        Some lbl -> (Kbranch lbl, cont)
+      | None     -> let lbl = new_label() in (Kbranch lbl, Klabel lbl :: cont)
+
+let make_branch cont =
+  match cont with
+    (Kbranch _ as branch) :: _ -> (branch, cont)
+  | (Kreturn _ as return) :: _ -> (return, cont)
+  | Kraise :: _ -> (Kraise, cont)
+  | Klabel lbl :: _ -> make_branch_2 (Some lbl) 0 cont cont
+  | _ ->  make_branch_2 (None) 0 cont cont
+
+(* Avoid a branch to a label that follows immediately *)
+
+let branch_to label cont = match cont with
+| Klabel label0::_ when label = label0 -> cont
+| _ -> Kbranch label::cont
+
+(* Discard all instructions up to the next label.
+   This function is to be applied to the continuation before adding a
+   non-terminating instruction (branch, raise, return) in front of it. *)
+
+let rec discard_dead_code = function
+    [] -> []
+  | (Klabel _ | Krestart | Ksetglobal _) :: _ as cont -> cont
+  | _ :: cont -> discard_dead_code cont
+
+(* Check if we're in tailcall position *)
+
+let rec is_tailcall = function
+    Kreturn _ :: _ -> true
+  | Klabel _ :: c -> is_tailcall c
+  | Kpop _ :: c -> is_tailcall c
+  | _ -> false
+
+(* Add a Kpop N instruction in front of a continuation *)
+
+let rec add_pop n cont =
+  if n = 0 then cont else
+    match cont with
+      Kpop m :: cont -> add_pop (n + m) cont
+    | Kreturn m :: cont -> Kreturn(n + m) :: cont
+    | Kraise :: _ -> cont
+    | _ -> Kpop n :: cont
+
+(* Add the constant "unit" in front of a continuation *)
+
+let add_const_unit = function
+    (Kacc _ | Kconst _ | Kgetglobal _ | Kpush_retaddr _) :: _ as cont -> cont
+  | cont -> Kconst const_unit :: cont
+
+let rec push_dummies n k = match n with
+| 0 -> k
+| _ -> Kconst const_unit::Kpush::push_dummies (n-1) k
+
+
+(**** Auxiliary for compiling "let rec" ****)
+
+let rec size_of_lambda = function
+  | Lfunction(kind, params, body) as funct ->
+      1 + IdentSet.cardinal(free_variables funct)
+  | Lprim(Pmakeblock(tag, mut), args) -> List.length args
+  | Lprim(Pmakearray kind, args) -> List.length args
+  | Llet(str, id, arg, body) -> size_of_lambda body
+  | Lletrec(bindings, body) -> size_of_lambda body
+  | Levent (lam, _) -> size_of_lambda lam
+  | Lsequence (lam, lam') -> size_of_lambda lam'
+  | _ -> fatal_error "Bytegen.size_of_lambda"
+
+(**** Merging consecutive events ****)
+
+let copy_event ev kind info repr =
+  { ev_pos = 0;                   (* patched in emitcode *)
+    ev_module = ev.ev_module;
+    ev_char = ev.ev_char;
+    ev_kind = kind;
+    ev_info = info;
+    ev_typenv = ev.ev_typenv;
+    ev_compenv = ev.ev_compenv;
+    ev_stacksize = ev.ev_stacksize;
+    ev_repr = repr }
+
+let merge_infos ev ev' =
+  match ev.ev_info, ev'.ev_info with
+    Event_other, info -> info
+  | info, Event_other -> info
+  | _                 -> fatal_error "Bytegen.merge_infos"
+
+let merge_repr ev ev' =
+  match ev.ev_repr, ev'.ev_repr with
+    Event_none, x -> x
+  | x, Event_none -> x
+  | Event_parent r, Event_child r' when r == r' && !r = 1 -> Event_none
+  | Event_child r, Event_parent r' when r == r' -> Event_parent r
+  | _, _          -> fatal_error "Bytegen.merge_repr"
+
+let merge_events ev ev' =
+  let (maj, min) =
+    match ev.ev_kind, ev'.ev_kind with
+    (* Discard pseudo-events *)    
+      Event_pseudo,  _                              -> ev', ev
+    | _,             Event_pseudo                   -> ev,  ev'
+    (* Keep following event, supposedly more informative *)
+    | Event_before,  (Event_after _ | Event_before) -> ev',  ev
+    (* Discard following events, supposedly less informative *)
+    | Event_after _, (Event_after _ | Event_before) -> ev, ev'
+  in
+  copy_event maj maj.ev_kind (merge_infos maj min) (merge_repr maj min)
+
+let weaken_event ev cont =
+  match ev.ev_kind with
+    Event_after _ ->
+      begin match cont with
+        Kpush :: Kevent ({ev_repr = Event_none} as ev') :: c ->
+          begin match ev.ev_info with
+            Event_return _ ->
+              (* Weaken event *)
+              let repr = ref 1 in
+              let ev =
+                copy_event ev Event_pseudo ev.ev_info (Event_parent repr)
+              and ev' =
+                copy_event ev' ev'.ev_kind ev'.ev_info (Event_child repr)
+              in
+              Kevent ev :: Kpush :: Kevent ev' :: c
+          | _ ->
+              (* Only keep following event, equivalent *)
+              cont
+          end
+      | _ ->
+          Kevent ev :: cont
+      end
+  | _ ->
+      Kevent ev :: cont
+  
+let add_event ev =
+  function
+    Kevent ev' :: cont -> weaken_event (merge_events ev ev') cont
+  | cont               -> weaken_event ev cont
+
+(**** Compilation of a lambda expression ****)
+
+(* association staticraise numbers -> (lbl,size of stack *)
+
+let sz_static_raises = ref []
+let find_raise_label i =
+  try
+    List.assoc i !sz_static_raises
+  with
+  | Not_found ->
+      Misc.fatal_error
+        ("exit("^string_of_int i^") outside appropriated catch")
+
+(* Will the translation of l lead to a jump to label ? *)
+let code_as_jump l sz = match l with
+| Lstaticraise (i,[]) ->
+    let label,size = find_raise_label i in
+    if sz = size then
+      Some label
+    else
+      None
+| _ -> None
+
+(* Function bodies that remain to be compiled *)
+
+type function_to_compile =
+  { params: Ident.t list;               (* function parameters *)
+    body: lambda;                       (* the function body *)
+    label: label;                       (* the label of the function entry *)
+    free_vars: Ident.t list;            (* free variables of the function *)
+    num_defs: int;            (* number of mutually recursive definitions *)
+    rec_vars: Ident.t list;             (* mutually recursive fn names *)
+    rec_pos: int }                      (* rank in recursive definition *)
+
+let functions_to_compile  = (Stack.create () : function_to_compile Stack.t)
+
+(* Name of current compilation unit (for debugging events) *)
+
+let compunit_name = ref ""
+
+(* Maximal stack size reached during the current function body *)
+
+let max_stack_used = ref 0
+
+(* Translate a primitive to a bytecode instruction (possibly a call to a C
+   function) *)
+
+let comp_bint_primitive bi suff args =
+  let pref =
+    match bi with Pnativeint -> "nativeint_"
+                | Pint32 -> "int32_"
+                | Pint64 -> "int64_" in
+  Kccall(pref ^ suff, List.length args)
+
+let comp_primitive p args =
+  match p with
+    Pgetglobal id -> Kgetglobal id
+  | Psetglobal id -> Ksetglobal id
+  | Pintcomp cmp -> Kintcomp cmp
+  | Pmakeblock(tag, mut) -> Kmakeblock(List.length args, tag)
+  | Pfield n -> Kgetfield n
+  | Psetfield(n, ptr) -> Ksetfield n
+  | Pfloatfield n -> Kgetfloatfield n
+  | Psetfloatfield n -> Ksetfloatfield n
+  | Pccall p -> Kccall(p.prim_name, p.prim_arity)
+  | Pnegint -> Knegint
+  | Paddint -> Kaddint
+  | Psubint -> Ksubint
+  | Pmulint -> Kmulint
+  | Pdivint -> Kdivint
+  | Pmodint -> Kmodint
+  | Pandint -> Kandint
+  | Porint -> Korint
+  | Pxorint -> Kxorint
+  | Plslint -> Klslint
+  | Plsrint -> Klsrint
+  | Pasrint -> Kasrint
+  | Poffsetint n -> Koffsetint n
+  | Poffsetref n -> Koffsetref n
+  | Pintoffloat -> Kccall("int_of_float", 1)
+  | Pfloatofint -> Kccall("float_of_int", 1)
+  | Pnegfloat -> Kccall("neg_float", 1)
+  | Pabsfloat -> Kccall("abs_float", 1)
+  | Paddfloat -> Kccall("add_float", 2)
+  | Psubfloat -> Kccall("sub_float", 2)
+  | Pmulfloat -> Kccall("mul_float", 2)
+  | Pdivfloat -> Kccall("div_float", 2)
+  | Pfloatcomp Ceq -> Kccall("eq_float", 2)
+  | Pfloatcomp Cneq -> Kccall("neq_float", 2)
+  | Pfloatcomp Clt -> Kccall("lt_float", 2)
+  | Pfloatcomp Cgt -> Kccall("gt_float", 2)
+  | Pfloatcomp Cle -> Kccall("le_float", 2)
+  | Pfloatcomp Cge -> Kccall("ge_float", 2)
+  | Pstringlength -> Kccall("ml_string_length", 1)
+  | Pstringrefs -> Kccall("string_get", 2)
+  | Pstringsets -> Kccall("string_set", 3)
+  | Pstringrefu -> Kgetstringchar
+  | Pstringsetu -> Ksetstringchar
+  | Parraylength kind -> Kvectlength
+  | Parrayrefs Pgenarray -> Kccall("array_get", 2)
+  | Parrayrefs Pfloatarray -> Kccall("array_get_float", 2)
+  | Parrayrefs _ -> Kccall("array_get_addr", 2)
+  | Parraysets Pgenarray -> Kccall("array_set", 3)
+  | Parraysets Pfloatarray -> Kccall("array_set_float", 3)
+  | Parraysets _ -> Kccall("array_set_addr", 3)
+  | Parrayrefu Pgenarray -> Kccall("array_unsafe_get", 2)
+  | Parrayrefu Pfloatarray -> Kccall("array_unsafe_get_float", 2)
+  | Parrayrefu _ -> Kgetvectitem
+  | Parraysetu Pgenarray -> Kccall("array_unsafe_set", 3)
+  | Parraysetu Pfloatarray -> Kccall("array_unsafe_set_float", 3)
+  | Parraysetu _ -> Ksetvectitem
+  | Pisint -> Kisint
+  | Pisout -> Kisout
+  | Pbittest -> Kccall("bitvect_test", 2)
+  | Pbintofint bi -> comp_bint_primitive bi "of_int" args
+  | Pintofbint bi -> comp_bint_primitive bi "to_int" args
+  | Pcvtbint(Pint32, Pnativeint) -> Kccall("nativeint_of_int32", 1)
+  | Pcvtbint(Pnativeint, Pint32) -> Kccall("nativeint_to_int32", 1)
+  | Pcvtbint(Pint32, Pint64) -> Kccall("int64_of_int32", 1)
+  | Pcvtbint(Pint64, Pint32) -> Kccall("int64_to_int32", 1)
+  | Pcvtbint(Pnativeint, Pint64) -> Kccall("int64_of_nativeint", 1)
+  | Pcvtbint(Pint64, Pnativeint) -> Kccall("int64_to_nativeint", 1)
+  | Pnegbint bi -> comp_bint_primitive bi "neg" args
+  | Paddbint bi -> comp_bint_primitive bi "add" args
+  | Psubbint bi -> comp_bint_primitive bi "sub" args
+  | Pmulbint bi -> comp_bint_primitive bi "mul" args
+  | Pdivbint bi -> comp_bint_primitive bi "div" args
+  | Pmodbint bi -> comp_bint_primitive bi "mod" args
+  | Pandbint bi -> comp_bint_primitive bi "and" args
+  | Porbint bi -> comp_bint_primitive bi "or" args
+  | Pxorbint bi -> comp_bint_primitive bi "xor" args
+  | Plslbint bi -> comp_bint_primitive bi "shift_left" args
+  | Plsrbint bi -> comp_bint_primitive bi "shift_right_unsigned" args
+  | Pasrbint bi -> comp_bint_primitive bi "shift_right" args
+  | Pbintcomp(bi, Ceq) -> Kccall("equal", 2)
+  | Pbintcomp(bi, Cneq) -> Kccall("notequal", 2)
+  | Pbintcomp(bi, Clt) -> Kccall("lessthan", 2)
+  | Pbintcomp(bi, Cgt) -> Kccall("greaterthan", 2)
+  | Pbintcomp(bi, Cle) -> Kccall("lessequal", 2)
+  | Pbintcomp(bi, Cge) -> Kccall("greaterequal", 2)
+  | Pbigarrayref(n, _, _) -> Kccall("bigarray_get_" ^ string_of_int n, n + 1)
+  | Pbigarrayset(n, _, _) -> Kccall("bigarray_set_" ^ string_of_int n, n + 2)
+  | _ -> fatal_error "Bytegen.comp_primitive"
+
+let is_immed n = immed_min <= n && n <= immed_max
+
+let explode_isout arg l h =
+  Lprim
+    (Psequor,
+    [Lprim (Pintcomp Clt,[arg ; Lconst (Const_base (Const_int 0))]) ;
+     Lprim (Pintcomp Cgt,[arg ; Lconst (Const_base (Const_int h))])])
+
+(* Compile an expression.
+   The value of the expression is left in the accumulator.
+   env = compilation environment
+   exp = the lambda expression to compile
+   sz = current size of the stack frame
+   cont = list of instructions to execute afterwards
+   Result = list of instructions that evaluate exp, then perform cont. *)
+
+let rec comp_expr env exp sz cont =
+  if sz > !max_stack_used then max_stack_used := sz;
+  match exp with
+    Lvar id ->
+      begin try
+        let pos = Ident.find_same id env.ce_stack in
+        Kacc(sz - pos) :: cont
+      with Not_found ->
+      try
+        let pos = Ident.find_same id env.ce_heap in
+        Kenvacc(pos) :: cont
+      with Not_found ->
+      try
+        let ofs = Ident.find_same id env.ce_rec in
+        Koffsetclosure(ofs) :: cont
+      with Not_found ->
+        Format.eprintf "%a@." Ident.print id;
+        fatal_error ("Bytegen.comp_expr: var " ^ Ident.unique_name id)
+      end
+  | Lconst cst ->
+      Kconst cst :: cont
+  | Lapply(func, args) ->
+      let nargs = List.length args in
+      if is_tailcall cont then
+        comp_args env args sz
+          (Kpush :: comp_expr env func (sz + nargs)
+            (Kappterm(nargs, sz + nargs) :: discard_dead_code cont))
+      else
+        if nargs < 4 then
+          comp_args env args sz
+            (Kpush :: comp_expr env func (sz + nargs) (Kapply nargs :: cont))
+        else begin
+          let (lbl, cont1) = label_code cont in
+          Kpush_retaddr lbl ::
+          comp_args env args (sz + 3)
+            (Kpush :: comp_expr env func (sz + 3 + nargs)
+                      (Kapply nargs :: cont1))
+        end
+  | Lsend(met, obj, args) ->
+      let nargs = List.length args + 1 in
+      if is_tailcall cont then
+        comp_args env (met::obj::args) sz
+          (Kgetmethod :: Kappterm(nargs, sz + nargs) :: discard_dead_code cont)
+      else
+        if nargs < 4 then
+          comp_args env (met::obj::args) sz
+            (Kgetmethod :: Kapply nargs :: cont)
+        else begin
+          let (lbl, cont1) = label_code cont in
+          Kpush_retaddr lbl ::
+          comp_args env (met::obj::args) (sz + 3)
+            (Kgetmethod :: Kapply nargs :: cont1)
+        end
+  | Lfunction(kind, params, body) -> (* assume kind = Curried *)
+      let lbl = new_label() in
+      let fv = IdentSet.elements(free_variables exp) in
+      let to_compile =
+        { params = params; body = body; label = lbl;
+          free_vars = fv; num_defs = 1; rec_vars = []; rec_pos = 0 } in
+      Stack.push to_compile functions_to_compile;
+      comp_args env (List.map (fun n -> Lvar n) fv) sz
+        (Kclosure(lbl, List.length fv) :: cont)
+  | Llet(str, id, arg, body) ->
+      comp_expr env arg sz
+        (Kpush :: comp_expr (add_var id (sz+1) env) body (sz+1)
+          (add_pop 1 cont))
+  | Lletrec(decl, body) ->
+      let ndecl = List.length decl in
+      if List.for_all (function (_, Lfunction(_,_,_)) -> true | _ -> false)
+                      decl then begin
+        (* let rec of functions *)
+        let fv =
+          IdentSet.elements (free_variables (Lletrec(decl, lambda_unit))) in
+        let rec_idents = List.map (fun (id, lam) -> id) decl in
+        let rec comp_fun pos = function
+            [] -> []
+          | (id, Lfunction(kind, params, body)) :: rem ->
+              let lbl = new_label() in
+              let to_compile =
+                { params = params; body = body; label = lbl; free_vars = fv;
+                  num_defs = ndecl; rec_vars = rec_idents; rec_pos = pos} in
+              Stack.push to_compile functions_to_compile;
+              lbl :: comp_fun (pos + 1) rem
+          | _ -> assert false in
+        let lbls = comp_fun 0 decl in
+        comp_args env (List.map (fun n -> Lvar n) fv) sz
+          (Kclosurerec(lbls, List.length fv) ::
+            (comp_expr (add_vars rec_idents (sz+1) env) body (sz + ndecl)
+                       (add_pop ndecl cont)))
+      end else begin
+        let decl_size =
+          List.map (fun (id, exp) -> (id, exp, size_of_lambda exp)) decl in
+        let rec comp_decl new_env sz i = function
+            [] ->
+              comp_expr new_env body sz (add_pop ndecl cont)
+          | (id, exp, blocksize) :: rem ->
+              comp_expr new_env exp sz
+                (Kpush :: Kacc i :: Kccall("update_dummy", 2) ::
+                 comp_decl new_env sz (i-1) rem) in
+        let rec comp_init new_env sz = function
+            [] ->
+              comp_decl new_env sz ndecl decl_size
+          | (id, exp, blocksize) :: rem ->
+              Kconst(Const_base(Const_int blocksize)) ::
+              Kccall("alloc_dummy", 1) :: Kpush ::
+              comp_init (add_var id (sz+1) new_env) (sz+1) rem in
+        comp_init env sz decl_size
+      end
+  | Lprim(Pidentity, [arg]) ->
+      comp_expr env arg sz cont
+  | Lprim(Pignore, [arg]) ->
+      comp_expr env arg sz (add_const_unit cont)
+  | Lprim(Pnot, [arg]) ->
+      let newcont =
+        match cont with
+          Kbranchif lbl :: cont1 -> Kbranchifnot lbl :: cont1
+        | Kbranchifnot lbl :: cont1 -> Kbranchif lbl :: cont1
+        | _ -> Kboolnot :: cont in
+      comp_expr env arg sz newcont
+  | Lprim(Psequand, [exp1; exp2]) ->
+      begin match cont with
+        Kbranchifnot lbl :: _ ->
+          comp_expr env exp1 sz (Kbranchifnot lbl ::
+            comp_expr env exp2 sz cont)
+      | Kbranchif lbl :: cont1 ->
+          let (lbl2, cont2) = label_code cont1 in
+          comp_expr env exp1 sz (Kbranchifnot lbl2 ::
+            comp_expr env exp2 sz (Kbranchif lbl :: cont2))
+      | _ ->
+          let (lbl, cont1) = label_code cont in
+          comp_expr env exp1 sz (Kstrictbranchifnot lbl ::
+            comp_expr env exp2 sz cont1)
+      end
+  | Lprim(Psequor, [exp1; exp2]) ->
+      begin match cont with
+        Kbranchif lbl :: _ ->
+          comp_expr env exp1 sz (Kbranchif lbl ::
+            comp_expr env exp2 sz cont)
+      | Kbranchifnot lbl :: cont1 ->
+          let (lbl2, cont2) = label_code cont1 in
+          comp_expr env exp1 sz (Kbranchif lbl2 ::
+            comp_expr env exp2 sz (Kbranchifnot lbl :: cont2))
+      | _ ->
+          let (lbl, cont1) = label_code cont in
+          comp_expr env exp1 sz (Kstrictbranchif lbl ::
+            comp_expr env exp2 sz cont1)
+      end
+  | Lprim(Praise, [arg]) ->
+      comp_expr env arg sz (Kraise :: discard_dead_code cont)
+  | Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))])
+    when is_immed n ->
+      comp_expr env arg sz (Koffsetint n :: cont)
+  | Lprim(Psubint, [arg; Lconst(Const_base(Const_int n))])
+    when is_immed (-n) ->
+      comp_expr env arg sz (Koffsetint (-n) :: cont)
+  | Lprim (Poffsetint n, [arg])
+    when not (is_immed n) ->
+      comp_expr env arg sz
+        (Kpush::
+         Kconst (Const_base (Const_int n))::
+         Kaddint::cont)
+  | Lprim(Pmakearray kind, args) ->
+      begin match kind with
+        Pintarray | Paddrarray ->
+          comp_args env args sz (Kmakeblock(List.length args, 0) :: cont)
+      | Pfloatarray ->
+          comp_args env args sz (Kmakefloatblock(List.length args) :: cont)
+      | Pgenarray ->
+          if args = []
+          then Kmakeblock(0, 0) :: cont
+          else comp_args env args sz
+                 (Kmakeblock(List.length args, 0) ::
+                  Kccall("make_array", 1) :: cont)
+      end
+(* Integer first for enabling futher optimization (cf. emitcode.ml)  *)
+  | Lprim (Pintcomp c, [arg ; (Lconst _ as k)]) ->
+      let p = Pintcomp (commute_comparison c)
+      and args = [k ; arg] in
+      comp_args env args sz (comp_primitive p args :: cont)
+  | Lprim(p, args) ->
+      comp_args env args sz (comp_primitive p args :: cont)
+   | Lstaticcatch (body, (i, vars) , handler) ->      
+      let nvars = List.length vars in
+      let branch1, cont1 = make_branch cont in
+      let r = 
+        if nvars <> 1 then begin (* general case *)
+          let lbl_handler, cont2 =
+            label_code
+              (comp_expr
+                (add_vars vars (sz+1) env)
+                handler (sz+nvars) (add_pop nvars cont1)) in
+          sz_static_raises :=
+            (i, (lbl_handler, sz+nvars)) :: !sz_static_raises ;
+          push_dummies nvars
+            (comp_expr env body (sz+nvars)
+            (add_pop nvars (branch1 :: cont2)))
+        end else begin (* small optimization for nvars = 1 *)
+          let var = match vars with [var] -> var | _ -> assert false in
+          let lbl_handler, cont2 =
+            label_code
+              (Kpush::comp_expr
+                (add_var var (sz+1) env)
+                handler (sz+1) (add_pop 1 cont1)) in
+          sz_static_raises :=
+            (i, (lbl_handler, sz)) :: !sz_static_raises ;
+          comp_expr env body sz (branch1 :: cont2)
+        end in
+      sz_static_raises := List.tl !sz_static_raises ;
+      r
+  | Lstaticraise (i, args) ->
+      let cont = discard_dead_code cont in
+      let label,size = find_raise_label i in
+      begin match args with
+      | [arg] -> (* optim, argument passed in accumulator *)
+          comp_expr env arg sz
+            (add_pop (sz-size) (branch_to label cont))
+      | _ ->
+          comp_exit_args env args sz size
+            (add_pop (sz-size) (branch_to label cont))
+      end
+  | Ltrywith(body, id, handler) ->
+      let (branch1, cont1) = make_branch cont in
+      let lbl_handler = new_label() in
+      Kpushtrap lbl_handler :: 
+        comp_expr env body (sz+4) (Kpoptrap :: branch1 :: 
+          Klabel lbl_handler :: Kpush ::
+            comp_expr (add_var id (sz+1) env) handler (sz+1) (add_pop 1 cont1))
+  | Lifthenelse(cond, ifso, ifnot) ->
+      comp_binary_test env cond ifso ifnot sz cont
+  | Lsequence(exp1, exp2) ->
+      comp_expr env exp1 sz (comp_expr env exp2 sz cont)
+  | Lwhile(cond, body) ->
+      let lbl_loop = new_label() in
+      let lbl_test = new_label() in
+      Kbranch lbl_test :: Klabel lbl_loop :: Kcheck_signals ::
+        comp_expr env body sz
+          (Klabel lbl_test ::
+            comp_expr env cond sz (Kbranchif lbl_loop :: add_const_unit cont))
+  | Lfor(param, start, stop, dir, body) ->
+      let lbl_loop = new_label() in
+      let lbl_test = new_label() in
+      let offset = match dir with Upto -> 1 | Downto -> -1 in
+      let comp = match dir with Upto -> Cle | Downto -> Cge in
+      comp_expr env start sz
+        (Kpush :: comp_expr env stop (sz+1)
+          (Kpush :: Kbranch lbl_test ::
+           Klabel lbl_loop :: Kcheck_signals ::
+           comp_expr (add_var param (sz+1) env) body (sz+2)
+             (Kacc 1 :: Koffsetint offset :: Kassign 1 ::
+              Klabel lbl_test ::
+              Kacc 0 :: Kpush :: Kacc 2 :: Kintcomp comp ::
+              Kbranchif lbl_loop ::
+              add_const_unit (add_pop 2 cont))))
+  | Lswitch(arg, sw) ->
+      let (branch, cont1) = make_branch cont in
+      let c = ref (discard_dead_code cont1) in
+(* Build indirection vectors *)      
+      let store = mk_store (=) in
+      let act_consts = Array.create sw.sw_numconsts 0
+      and act_blocks = Array.create sw.sw_numblocks 0 in
+      begin match sw.sw_failaction with (* default is index 0 *)
+      | Some fail -> ignore (store.act_store fail)
+      | None      -> ()
+      end ;
+      List.iter
+        (fun (n, act) -> act_consts.(n) <- store.act_store act) sw.sw_consts;
+      List.iter
+        (fun (n, act) -> act_blocks.(n) <- store.act_store act) sw.sw_blocks;
+
+(* Compile and label actions *)
+      let acts = store.act_get () in
+      let lbls = Array.create (Array.length acts) 0 in
+      for i = Array.length acts-1 downto 0 do
+        let lbl,c1 = label_code (comp_expr env acts.(i) sz (branch :: !c)) in
+        lbls.(i) <- lbl ;
+        c := discard_dead_code c1
+      done ;
+
+(* Build label vectors *)
+      let lbl_blocks = Array.create sw.sw_numblocks 0 in
+      for i = sw.sw_numblocks - 1 downto 0 do
+        lbl_blocks.(i) <- lbls.(act_blocks.(i))
+      done;
+      let lbl_consts = Array.create sw.sw_numconsts 0 in
+      for i = sw.sw_numconsts - 1 downto 0 do
+        lbl_consts.(i) <- lbls.(act_consts.(i))
+      done;
+      comp_expr env arg sz (Kswitch(lbl_consts, lbl_blocks) :: !c)
+  | Lassign(id, expr) ->
+      begin try
+        let pos = Ident.find_same id env.ce_stack in
+        comp_expr env expr sz (Kassign(sz - pos) :: cont)
+      with Not_found ->
+        fatal_error "Bytegen.comp_expr: assign"
+      end
+  | Levent(lam, lev) ->
+      let event kind info =
+        { ev_pos = 0;                   (* patched in emitcode *)
+          ev_module = !compunit_name;
+          ev_char = lev.lev_loc;
+          ev_kind = kind;
+          ev_info = info;
+          ev_typenv = lev.lev_env;
+          ev_compenv = env;
+          ev_stacksize = sz;
+          ev_repr =
+            begin match lev.lev_repr with
+              None ->
+                Event_none
+            | Some ({contents = 1} as repr) when lev.lev_kind = Lev_function ->
+                Event_child repr
+            | Some ({contents = 1} as repr) ->
+                Event_parent repr
+            | Some repr when lev.lev_kind = Lev_function ->
+                Event_parent repr
+            | Some repr ->
+                Event_child repr
+            end }
+      in
+      begin match lev.lev_kind with
+        Lev_before ->
+          let c = comp_expr env lam sz cont in
+          let ev = event Event_before Event_other in
+          add_event ev c
+      | Lev_function ->
+          let c = comp_expr env lam sz cont in
+          let ev = event Event_pseudo Event_function in
+          add_event ev c
+      | Lev_after _ when is_tailcall cont -> (* don't destroy tail call opt *)
+          comp_expr env lam sz cont
+      | Lev_after ty ->
+          let info =
+            match lam with
+              Lapply(_, args)   -> Event_return (List.length args)
+            | Lsend(_, _, args) -> Event_return (List.length args + 1)
+            | _                 -> Event_other
+          in
+          let ev = event (Event_after ty) info in
+          let cont1 = add_event ev cont in
+          comp_expr env lam sz cont1
+      end
+  | Lifused (_, exp) ->
+      comp_expr env exp sz cont
+
+(* Compile a list of arguments [e1; ...; eN] to a primitive operation.
+   The values of eN ... e2 are pushed on the stack, e2 at top of stack,
+   then e3, then ... The value of e1 is left in the accumulator. *)
+
+and comp_args env argl sz cont =
+  comp_expr_list env (List.rev argl) sz cont
+
+and comp_expr_list env exprl sz cont = match exprl with
+    [] -> cont
+  | [exp] -> comp_expr env exp sz cont
+  | exp :: rem ->
+      comp_expr env exp sz (Kpush :: comp_expr_list env rem (sz+1) cont)
+
+and comp_exit_args  env argl sz pos cont =
+   comp_expr_list_assign env (List.rev argl) sz pos cont
+
+and comp_expr_list_assign env exprl sz pos cont = match exprl with
+  | [] -> cont
+  | exp :: rem ->
+      comp_expr env exp sz
+        (Kassign (sz-pos)::comp_expr_list_assign env rem sz (pos-1) cont)
+
+(* Compile an if-then-else test. *)
+
+and comp_binary_test env cond ifso ifnot sz cont =
+  let cont_cond =
+    if ifnot = Lconst const_unit then begin
+      let (lbl_end, cont1) = label_code cont in
+      Kstrictbranchifnot lbl_end :: comp_expr env ifso sz cont1
+    end else
+    match code_as_jump ifso sz with
+    | Some label ->
+      let cont = comp_expr env ifnot sz cont in
+      Kbranchif label :: cont
+    | _ ->
+        match code_as_jump ifnot sz with
+        | Some label ->
+            let cont = comp_expr env ifso sz cont in
+            Kbranchifnot label :: cont
+        | _ ->
+            let (branch_end, cont1) = make_branch cont in
+            let (lbl_not, cont2) = label_code(comp_expr env ifnot sz cont1) in
+            Kbranchifnot lbl_not ::
+            comp_expr env ifso sz (branch_end :: cont2) in
+
+  comp_expr env cond sz cont_cond
+
+(**** Compilation of a code block (with tracking of stack usage) ****)
+
+let comp_block env exp sz cont =
+  max_stack_used := 0;
+  let code = comp_expr env exp sz cont in
+  (* +1 because comp_expr may have pushed one more word *)
+  if !max_stack_used + 1 > Config.stack_threshold then
+    Kconst(Const_base(Const_int(!max_stack_used + 1))) ::
+    Kccall("ensure_stack_capacity", 1) ::
+    code
+  else
+    code
+
+(**** Compilation of functions ****)
+
+let comp_function tc cont =
+  let arity = List.length tc.params in
+  let rec positions pos delta = function
+      [] -> Ident.empty
+    | id :: rem -> Ident.add id pos (positions (pos + delta) delta rem) in
+  let env =
+    { ce_stack = positions arity (-1) tc.params;
+      ce_heap = positions (2 * (tc.num_defs - tc.rec_pos) - 1) 1 tc.free_vars;
+      ce_rec = positions (-2 * tc.rec_pos) 2 tc.rec_vars } in
+  let cont =
+    comp_block env tc.body arity (Kreturn arity :: cont) in
+  if arity > 1 then
+    Krestart :: Klabel tc.label :: Kgrab(arity - 1) :: cont
+  else
+    Klabel tc.label :: cont
+
+let comp_remainder cont =
+  let c = ref cont in
+  begin try
+    while true do
+      c := comp_function (Stack.pop functions_to_compile) !c
+    done
+  with Stack.Empty ->
+    ()
+  end;
+  !c
+
+(**** Compilation of a lambda phrase ****)
+
+let compile_implementation modulename expr =
+  Stack.clear functions_to_compile;
+  label_counter := 0;
+  sz_static_raises := [] ;
+  compunit_name := modulename;
+  let init_code = comp_block empty_env expr 0 [] in
+  if Stack.length functions_to_compile > 0 then begin
+    let lbl_init = new_label() in
+    Kbranch lbl_init :: comp_remainder (Klabel lbl_init :: init_code)
+  end else
+    init_code
+
+let compile_phrase expr =
+  Stack.clear functions_to_compile;
+  label_counter := 0;
+  sz_static_raises := [] ;
+  let init_code = comp_block empty_env expr 1 [Kreturn 1] in
+  let fun_code = comp_remainder [] in
+  (init_code, fun_code)
+
diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
new file mode 100644
index 0000000000..4613241fcf
--- /dev/null
+++ b/bytecomp/emitcode.ml
@@ -0,0 +1,427 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Generation of bytecode + relocation information *)
+
+open Config
+open Misc
+open Asttypes
+open Lambda
+open Instruct
+open Opcodes
+
+
+(* Relocation information *)
+
+type reloc_info =
+    Reloc_literal of structured_constant    (* structured constant *)
+  | Reloc_getglobal of Ident.t             (* reference to a global *)
+  | Reloc_setglobal of Ident.t             (* definition of a global *)
+  | Reloc_primitive of string               (* C primitive number *)
+
+(* Descriptor for compilation units *)
+
+type compilation_unit =
+  { cu_name: string;                    (* Name of compilation unit *)
+    mutable cu_pos: int;                (* Absolute position in file *)
+    cu_codesize: int;                   (* Size of code block *)
+    cu_reloc: (reloc_info * int) list;  (* Relocation information *)
+    cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *)
+    cu_primitives: string list;         (* Primitives declared inside *)
+    mutable cu_force_link: bool;        (* Must be linked even if unref'ed *)
+    mutable cu_debug: int;              (* Position of debugging info, or 0 *)
+    cu_debugsize: int }                 (* Length of debugging info *)
+
+(* Descriptor for libraries *)
+
+type library =
+  { lib_units: compilation_unit list;   (* List of compilation units *)
+    lib_custom: bool;                   (* Requires custom mode linking? *)
+    lib_ccobjs: string list;            (* C object files needed for -custom *)
+    lib_ccopts: string list;            (* Extra opts to C compiler *)
+    lib_dllibs: string list }           (* DLLs needed *)
+
+(* Buffering of bytecode *)
+
+let out_buffer = ref(String.create 1024)
+and out_position = ref 0
+
+let out_word b1 b2 b3 b4 =
+  let p = !out_position in
+  if p >= String.length !out_buffer then begin
+    let len = String.length !out_buffer in
+    let new_buffer = String.create (2 * len) in
+    String.blit !out_buffer 0 new_buffer 0 len;
+    out_buffer := new_buffer
+  end;
+  String.unsafe_set !out_buffer p (Char.unsafe_chr b1);
+  String.unsafe_set !out_buffer (p+1) (Char.unsafe_chr b2);
+  String.unsafe_set !out_buffer (p+2) (Char.unsafe_chr b3);
+  String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4);
+  out_position := p + 4
+
+let out opcode =
+  out_word opcode 0 0 0
+
+
+exception AsInt
+
+let const_as_int = function
+  | Const_base(Const_int i) -> i
+  | Const_base(Const_char c) -> Char.code c
+  | Const_pointer i -> i
+  | _ -> raise AsInt
+
+let is_immed i = immed_min <= i && i <= immed_max
+let is_immed_const k =
+  try
+    is_immed (const_as_int k)
+  with
+  | AsInt -> false
+
+
+let out_int n =
+  out_word n (n asr 8) (n asr 16) (n asr 24)
+
+let out_const c =
+  try
+    out_int (const_as_int c)
+  with
+  | AsInt -> Misc.fatal_error "Emitcode.const_as_int"
+  
+
+(* Handling of local labels and backpatching *)
+
+type label_definition =
+    Label_defined of int
+  | Label_undefined of (int * int) list
+
+let label_table  = ref ([| |] : label_definition array)
+
+let extend_label_table needed =
+  let new_size = ref(Array.length !label_table) in
+  while needed >= !new_size do new_size := 2 * !new_size done;
+  let new_table = Array.create !new_size (Label_undefined []) in
+  Array.blit !label_table 0 new_table 0 (Array.length !label_table);
+  label_table := new_table
+
+let backpatch (pos, orig) =
+  let displ = (!out_position - orig) asr 2 in
+  !out_buffer.[pos] <- Char.unsafe_chr displ;
+  !out_buffer.[pos+1] <- Char.unsafe_chr (displ asr 8);
+  !out_buffer.[pos+2] <- Char.unsafe_chr (displ asr 16);
+  !out_buffer.[pos+3] <- Char.unsafe_chr (displ asr 24)
+
+let define_label lbl =
+  if lbl >= Array.length !label_table then extend_label_table lbl;
+  match (!label_table).(lbl) with
+    Label_defined _ ->
+      fatal_error "Emitcode.define_label"
+  | Label_undefined patchlist ->
+      List.iter backpatch patchlist;
+      (!label_table).(lbl) <- Label_defined !out_position
+
+let out_label_with_orig orig lbl =
+  if lbl >= Array.length !label_table then extend_label_table lbl;
+  match (!label_table).(lbl) with
+    Label_defined def ->
+      out_int((def - orig) asr 2)
+  | Label_undefined patchlist ->
+      (!label_table).(lbl) <-
+         Label_undefined((!out_position, orig) :: patchlist);
+      out_int 0
+
+let out_label l = out_label_with_orig !out_position l
+
+(* Relocation information *)
+
+let reloc_info = ref ([] : (reloc_info * int) list)
+
+let enter info =
+  reloc_info := (info, !out_position) :: !reloc_info
+
+let slot_for_literal sc =
+  enter (Reloc_literal sc);
+  out_int 0
+and slot_for_getglobal id =
+  enter (Reloc_getglobal id);
+  out_int 0
+and slot_for_setglobal id =
+  enter (Reloc_setglobal id);
+  out_int 0
+and slot_for_c_prim name =
+  enter (Reloc_primitive name);
+  out_int 0
+
+(* Debugging events *)
+
+let events = ref ([] : debug_event list)
+
+let record_event ev =
+  ev.ev_pos <- !out_position;
+  events := ev :: !events
+
+(* Initialization *)
+
+let init () =
+  out_position := 0;
+  label_table := Array.create 16 (Label_undefined []);
+  reloc_info := [];
+  events := []
+
+(* Emission of one instruction *)
+
+let emit_comp = function
+| Ceq -> out opEQ    | Cneq -> out opNEQ
+| Clt -> out opLTINT | Cle -> out opLEINT
+| Cgt -> out opGTINT | Cge -> out opGEINT
+
+and emit_branch_comp = function
+| Ceq -> out opBEQ    | Cneq -> out opBNEQ
+| Clt -> out opBLTINT | Cle -> out opBLEINT
+| Cgt -> out opBGTINT | Cge -> out opBGEINT
+
+let emit_instr = function
+    Klabel lbl -> define_label lbl
+  | Kacc n ->
+      if n < 8 then out(opACC0 + n) else (out opACC; out_int n)
+  | Kenvacc n ->
+      if n >= 1 && n <= 4
+      then out(opENVACC1 + n - 1)
+      else (out opENVACC; out_int n)
+  | Kpush ->
+      out opPUSH
+  | Kpop n ->
+      out opPOP; out_int n
+  | Kassign n ->
+      out opASSIGN; out_int n
+  | Kpush_retaddr lbl -> out opPUSH_RETADDR; out_label lbl
+  | Kapply n ->
+      if n < 4 then out(opAPPLY1 + n - 1) else (out opAPPLY; out_int n)
+  | Kappterm(n, sz) ->
+      if n < 4 then (out(opAPPTERM1 + n - 1); out_int sz)
+               else (out opAPPTERM; out_int n; out_int sz)
+  | Kreturn n -> out opRETURN; out_int n
+  | Krestart -> out opRESTART
+  | Kgrab n -> out opGRAB; out_int n
+  | Kclosure(lbl, n) -> out opCLOSURE; out_int n; out_label lbl
+  | Kclosurerec(lbls, n) ->
+      out opCLOSUREREC; out_int (List.length lbls); out_int n;
+      let org = !out_position in
+      List.iter (out_label_with_orig org) lbls
+  | Koffsetclosure ofs ->
+      if ofs = -2 || ofs = 0 || ofs = 2
+      then out (opOFFSETCLOSURE0 + ofs / 2)
+      else (out opOFFSETCLOSURE; out_int ofs)
+  | Kgetglobal q -> out opGETGLOBAL; slot_for_getglobal q
+  | Ksetglobal q -> out opSETGLOBAL; slot_for_setglobal q
+  | Kconst sc ->
+      begin match sc with
+        Const_base(Const_int i) when is_immed i ->
+          if i >= 0 && i <= 3
+          then out (opCONST0 + i)
+          else (out opCONSTINT; out_int i)
+      | Const_base(Const_char c) ->
+          out opCONSTINT; out_int (Char.code c)
+      | Const_pointer i ->
+          if i >= 0 && i <= 3
+          then out (opCONST0 + i)
+          else (out opCONSTINT; out_int i)
+      | Const_block(t, []) ->
+          if t = 0 then out opATOM0 else (out opATOM; out_int t)
+      | _ ->
+          out opGETGLOBAL; slot_for_literal sc
+      end
+  | Kmakeblock(n, t) ->
+      if n = 0 then
+        if t = 0 then out opATOM0 else (out opATOM; out_int t)
+      else if n < 4 then (out(opMAKEBLOCK1 + n - 1); out_int t)
+      else (out opMAKEBLOCK; out_int n; out_int t)
+  | Kgetfield n ->
+      if n < 4 then out(opGETFIELD0 + n) else (out opGETFIELD; out_int n)
+  | Ksetfield n ->
+      if n < 4 then out(opSETFIELD0 + n) else (out opSETFIELD; out_int n)
+  | Kmakefloatblock(n) ->
+      if n = 0 then out opATOM0 else (out opMAKEFLOATBLOCK; out_int n)
+  | Kgetfloatfield n -> out opGETFLOATFIELD; out_int n
+  | Ksetfloatfield n -> out opSETFLOATFIELD; out_int n
+  | Kvectlength -> out opVECTLENGTH
+  | Kgetvectitem -> out opGETVECTITEM
+  | Ksetvectitem -> out opSETVECTITEM
+  | Kgetstringchar -> out opGETSTRINGCHAR
+  | Ksetstringchar -> out opSETSTRINGCHAR
+  | Kbranch lbl -> out opBRANCH; out_label lbl
+  | Kbranchif lbl -> out opBRANCHIF; out_label lbl
+  | Kbranchifnot lbl -> out opBRANCHIFNOT; out_label lbl
+  | Kstrictbranchif lbl -> out opBRANCHIF; out_label lbl
+  | Kstrictbranchifnot lbl -> out opBRANCHIFNOT; out_label lbl
+  | Kswitch(tbl_const, tbl_block) ->
+      out opSWITCH;
+      out_int (Array.length tbl_const + (Array.length tbl_block lsl 16));
+      let org = !out_position in
+      Array.iter (out_label_with_orig org) tbl_const;
+      Array.iter (out_label_with_orig org) tbl_block
+  | Kboolnot -> out opBOOLNOT
+  | Kpushtrap lbl -> out opPUSHTRAP; out_label lbl
+  | Kpoptrap -> out opPOPTRAP
+  | Kraise -> out opRAISE
+  | Kcheck_signals -> out opCHECK_SIGNALS
+  | Kccall(name, n) ->
+      if n <= 5
+      then (out (opC_CALL1 + n - 1); slot_for_c_prim name)
+      else (out opC_CALLN; out_int n; slot_for_c_prim name)
+  | Knegint -> out opNEGINT  | Kaddint -> out opADDINT
+  | Ksubint -> out opSUBINT  | Kmulint -> out opMULINT
+  | Kdivint -> out opDIVINT  | Kmodint -> out opMODINT
+  | Kandint -> out opANDINT  | Korint -> out opORINT
+  | Kxorint -> out opXORINT  | Klslint -> out opLSLINT
+  | Klsrint -> out opLSRINT  | Kasrint -> out opASRINT
+  | Kintcomp c -> emit_comp c
+  | Koffsetint n -> out opOFFSETINT; out_int n
+  | Koffsetref n -> out opOFFSETREF; out_int n
+  | Kisint -> out opISINT
+  | Kisout -> out opULTINT
+  | Kgetmethod -> out opGETMETHOD
+  | Kevent ev -> record_event ev
+  | Kstop -> out opSTOP
+
+(* Emission of a list of instructions. Include some peephole optimization. *)
+
+let rec emit = function
+    [] -> ()
+  (* Peephole optimizations *)
+(* optimization of integer tests *)
+  | Kpush::Kconst k::Kintcomp c::Kbranchif lbl::rem
+      when is_immed_const k ->
+        emit_branch_comp c ;
+        out_const k ;
+        out_label lbl ;
+        emit rem
+  | Kpush::Kconst k::Kintcomp c::Kbranchifnot lbl::rem
+      when is_immed_const k ->
+        emit_branch_comp (negate_comparison c) ;
+        out_const k ;
+        out_label lbl ;
+        emit rem
+(* same for range tests *)
+  | Kpush::Kconst k::Kisout::Kbranchif lbl::rem
+      when is_immed_const k ->
+        out opBULTINT ;
+        out_const k ;
+        out_label lbl ;
+        emit rem
+  | Kpush::Kconst k::Kisout::Kbranchifnot lbl::rem
+      when is_immed_const k ->
+        out opBUGEINT ;
+        out_const k ;
+        out_label lbl ;
+        emit rem
+(* Some special case of push ; i ; ret generated by the match compiler *)
+  | Kpush :: Kacc 0 :: Kreturn m :: c ->
+      emit (Kreturn (m-1) :: c)
+(* General push then access scheme *)
+  | Kpush :: Kacc n :: c ->
+      if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n);
+      emit c
+  | Kpush :: Kenvacc n :: c ->
+      if n >= 1 && n < 4
+      then out(opPUSHENVACC1 + n - 1)
+      else (out opPUSHENVACC; out_int n);
+      emit c
+  | Kpush :: Koffsetclosure ofs :: c ->
+      if ofs = -2 || ofs = 0 || ofs = 2
+      then out(opPUSHOFFSETCLOSURE0 + ofs / 2)
+      else (out opPUSHOFFSETCLOSURE; out_int ofs);
+      emit c
+  | Kpush :: Kgetglobal id :: Kgetfield n :: c ->
+      out opPUSHGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c
+  | Kpush :: Kgetglobal id :: c ->
+      out opPUSHGETGLOBAL; slot_for_getglobal id; emit c
+  | Kpush :: Kconst sc :: c ->
+      begin match sc with
+        Const_base(Const_int i) when is_immed i ->
+          if i >= 0 && i <= 3
+          then out (opPUSHCONST0 + i)
+          else (out opPUSHCONSTINT; out_int i)
+      | Const_base(Const_char c) ->
+          out opPUSHCONSTINT; out_int(Char.code c)
+      | Const_pointer i ->
+          if i >= 0 && i <= 3
+          then out (opPUSHCONST0 + i)
+          else (out opPUSHCONSTINT; out_int i)
+      | Const_block(t, []) ->
+          if t = 0 then out opPUSHATOM0 else (out opPUSHATOM; out_int t)
+      | _ ->
+          out opPUSHGETGLOBAL; slot_for_literal sc
+      end;
+      emit c
+  | Kpush :: (Kevent {ev_kind = Event_before} as ev) ::
+    (Kgetglobal _ as instr1) :: (Kgetfield _ as instr2) :: c ->
+      emit (Kpush :: instr1 :: instr2 :: ev :: c)
+  | Kpush :: (Kevent {ev_kind = Event_before} as ev) ::
+    (Kacc _ | Kenvacc _ | Koffsetclosure _ | Kgetglobal _ | Kconst _ as instr) :: c ->
+      emit (Kpush :: instr :: ev :: c)
+  | Kgetglobal id :: Kgetfield n :: c ->
+      out opGETGLOBALFIELD; slot_for_getglobal id; out_int n; emit c
+  (* Default case *)
+  | instr :: c ->
+      emit_instr instr; emit c
+
+(* Emission to a file *)
+
+let to_file outchan unit_name code =
+  init();
+  output_string outchan cmo_magic_number;
+  let pos_depl = pos_out outchan in
+  output_binary_int outchan 0;
+  let pos_code = pos_out outchan in
+  emit code;
+  output outchan !out_buffer 0 !out_position;
+  let (pos_debug, size_debug) =
+    if !Clflags.debug then begin
+      let p = pos_out outchan in
+      output_value outchan !events;
+      (p, pos_out outchan - p)
+    end else
+      (0, 0) in
+  let compunit =
+    { cu_name = unit_name;
+      cu_pos = pos_code;
+      cu_codesize = !out_position;
+      cu_reloc = List.rev !reloc_info;
+      cu_imports = Env.imported_units();
+      cu_primitives = !Translmod.primitive_declarations;
+      cu_force_link = false;
+      cu_debug = pos_debug;
+      cu_debugsize = size_debug } in
+  init();                               (* Free out_buffer and reloc_info *)
+  Btype.cleanup_abbrev ();              (* Remove any cached abbreviation
+                                           expansion before saving *)
+  let pos_compunit = pos_out outchan in
+  output_value outchan compunit;
+  seek_out outchan pos_depl;
+  output_binary_int outchan pos_compunit
+
+(* Emission to a memory block *)
+
+let to_memory init_code fun_code =
+  init();
+  emit init_code;
+  emit fun_code;
+  let code = Meta.static_alloc !out_position in
+  String.unsafe_blit !out_buffer 0 code 0 !out_position;
+  let reloc = List.rev !reloc_info
+  and code_size = !out_position in
+  init();
+  (code, code_size, reloc)
diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml
new file mode 100644
index 0000000000..7aed995ad0
--- /dev/null
+++ b/bytecomp/instruct.ml
@@ -0,0 +1,108 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open Lambda
+
+type compilation_env =
+  { ce_stack: int Ident.tbl;
+    ce_heap: int Ident.tbl;
+    ce_rec: int Ident.tbl }
+
+type debug_event =
+  { mutable ev_pos: int;                (* Position in bytecode *)
+    ev_module: string;                  (* Name of defining module *)
+    ev_char: int;                       (* Location in source file *)
+    ev_kind: debug_event_kind;          (* Before/after event *)
+    ev_info: debug_event_info;          (* Extra information *)
+    ev_typenv: Env.summary;             (* Typing environment *)
+    ev_compenv: compilation_env;        (* Compilation environment *)
+    ev_stacksize: int;                  (* Size of stack frame *)
+    ev_repr: debug_event_repr }         (* Position of the representative *)
+
+and debug_event_kind =
+    Event_before
+  | Event_after of Types.type_expr
+  | Event_pseudo
+
+and debug_event_info =
+    Event_function
+  | Event_return of int
+  | Event_other
+
+and debug_event_repr =
+    Event_none
+  | Event_parent of int ref
+  | Event_child of int ref
+
+type label = int                     (* Symbolic code labels *)
+
+type instruction =
+    Klabel of label
+  | Kacc of int
+  | Kenvacc of int
+  | Kpush
+  | Kpop of int
+  | Kassign of int
+  | Kpush_retaddr of label
+  | Kapply of int                       (* number of arguments *)
+  | Kappterm of int * int               (* number of arguments, slot size *)
+  | Kreturn of int                      (* slot size *)
+  | Krestart
+  | Kgrab of int                        (* number of arguments *)
+  | Kclosure of label * int
+  | Kclosurerec of label list * int
+  | Koffsetclosure of int
+  | Kgetglobal of Ident.t
+  | Ksetglobal of Ident.t
+  | Kconst of structured_constant
+  | Kmakeblock of int * int             (* size, tag *)
+  | Kmakefloatblock of int
+  | Kgetfield of int
+  | Ksetfield of int
+  | Kgetfloatfield of int
+  | Ksetfloatfield of int
+  | Kvectlength
+  | Kgetvectitem
+  | Ksetvectitem
+  | Kgetstringchar
+  | Ksetstringchar
+  | Kbranch of label
+  | Kbranchif of label
+  | Kbranchifnot of label
+  | Kstrictbranchif of label
+  | Kstrictbranchifnot of label
+  | Kswitch of label array * label array
+  | Kboolnot
+  | Kpushtrap of label
+  | Kpoptrap
+  | Kraise
+  | Kcheck_signals
+  | Kccall of string * int
+  | Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint
+  | Kandint | Korint | Kxorint | Klslint | Klsrint | Kasrint
+  | Kintcomp of comparison
+  | Koffsetint of int
+  | Koffsetref of int
+  | Kisint
+  | Kisout
+  | Kgetmethod
+  | Kevent of debug_event
+  | Kstop
+
+let immed_min = -0x40000000
+and immed_max = 0x3FFFFFFF
+
+(* Actually the abstract machine accomodates -0x80000000 to 0x7FFFFFFF,
+   but these numbers overflow the Caml type int if the compiler runs on
+   a 32-bit processor. *)
diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli
new file mode 100644
index 0000000000..6fb979f4d9
--- /dev/null
+++ b/bytecomp/instruct.mli
@@ -0,0 +1,123 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* The type of the instructions of the abstract machine *)
+
+open Lambda
+
+(* Structure of compilation environments *)
+
+type compilation_env =
+  { ce_stack: int Ident.tbl; (* Positions of variables in the stack *)
+    ce_heap: int Ident.tbl;  (* Structure of the heap-allocated env *)
+    ce_rec: int Ident.tbl }  (* Functions bound by the same let rec *)
+
+(* The ce_stack component gives locations of variables residing 
+   in the stack. The locations are offsets w.r.t. the origin of the
+   stack frame.
+   The ce_heap component gives the positions of variables residing in the
+   heap-allocated environment.
+   The ce_rec component associate offsets to identifiers for functions
+   bound by the same let rec as the current function.  The offsets
+   are used by the OFFSETCLOSURE instruction to recover the closure
+   pointer of the desired function from the env register (which
+   points to the closure for the current function). *)
+
+(* Debugging events *)
+
+type debug_event =
+  { mutable ev_pos: int;                (* Position in bytecode *)
+    ev_module: string;                  (* Name of defining module *)
+    ev_char: int;                       (* Location in source file *)
+    ev_kind: debug_event_kind;          (* Before/after event *)
+    ev_info: debug_event_info;          (* Extra information *)
+    ev_typenv: Env.summary;             (* Typing environment *)
+    ev_compenv: compilation_env;        (* Compilation environment *)
+    ev_stacksize: int;                  (* Size of stack frame *)
+    ev_repr: debug_event_repr }         (* Position of the representative *)
+
+and debug_event_kind =
+    Event_before
+  | Event_after of Types.type_expr
+  | Event_pseudo
+
+and debug_event_info =
+    Event_function
+  | Event_return of int
+  | Event_other
+
+and debug_event_repr =
+    Event_none
+  | Event_parent of int ref
+  | Event_child of int ref
+
+(* Abstract machine instructions *)
+
+type label = int                        (* Symbolic code labels *)
+
+type instruction =
+    Klabel of label
+  | Kacc of int
+  | Kenvacc of int
+  | Kpush
+  | Kpop of int
+  | Kassign of int
+  | Kpush_retaddr of label
+  | Kapply of int                       (* number of arguments *)
+  | Kappterm of int * int               (* number of arguments, slot size *)
+  | Kreturn of int                      (* slot size *)
+  | Krestart
+  | Kgrab of int                        (* number of arguments *)
+  | Kclosure of label * int
+  | Kclosurerec of label list * int
+  | Koffsetclosure of int
+  | Kgetglobal of Ident.t
+  | Ksetglobal of Ident.t
+  | Kconst of structured_constant
+  | Kmakeblock of int * int             (* size, tag *)
+  | Kmakefloatblock of int
+  | Kgetfield of int
+  | Ksetfield of int
+  | Kgetfloatfield of int
+  | Ksetfloatfield of int
+  | Kvectlength
+  | Kgetvectitem
+  | Ksetvectitem
+  | Kgetstringchar
+  | Ksetstringchar
+  | Kbranch of label
+  | Kbranchif of label
+  | Kbranchifnot of label
+  | Kstrictbranchif of label
+  | Kstrictbranchifnot of label
+  | Kswitch of label array * label array
+  | Kboolnot
+  | Kpushtrap of label
+  | Kpoptrap
+  | Kraise
+  | Kcheck_signals
+  | Kccall of string * int
+  | Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint
+  | Kandint | Korint | Kxorint | Klslint | Klsrint | Kasrint
+  | Kintcomp of comparison
+  | Koffsetint of int
+  | Koffsetref of int
+  | Kisint
+  | Kisout
+  | Kgetmethod
+  | Kevent of debug_event
+  | Kstop
+
+val immed_min: int
+val immed_max: int
diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml
new file mode 100644
index 0000000000..d175cf1856
--- /dev/null
+++ b/bytecomp/printinstr.ml
@@ -0,0 +1,110 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Pretty-print lists of instructions *)
+
+open Format
+open Lambda
+open Instruct
+
+let instruction ppf = function
+  | Klabel lbl -> fprintf ppf "L%i:" lbl
+  | Kacc n -> fprintf ppf "\tacc %i" n
+  | Kenvacc n -> fprintf ppf "\tenvacc %i" n
+  | Kpush -> fprintf ppf "\tpush"
+  | Kpop n -> fprintf ppf "\tpop %i" n
+  | Kassign n -> fprintf ppf "\tassign %i" n
+  | Kpush_retaddr lbl -> fprintf ppf "\tpush_retaddr L%i" lbl
+  | Kapply n -> fprintf ppf "\tapply %i" n
+  | Kappterm(n, m) ->
+      fprintf ppf "\tappterm %i, %i" n m
+  | Kreturn n -> fprintf ppf "\treturn %i" n
+  | Krestart -> fprintf ppf "\trestart"
+  | Kgrab n -> fprintf ppf "\tgrab %i" n
+  | Kclosure(lbl, n) ->
+      fprintf ppf "\tclosure L%i, %i" lbl n
+  | Kclosurerec(lbls, n) ->
+      fprintf ppf "\tclosurerec";
+      List.iter (fun lbl -> fprintf ppf " %i" lbl) lbls;
+      fprintf ppf ", %i" n
+  | Koffsetclosure n -> fprintf ppf "\toffsetclosure %i" n
+  | Kgetglobal id -> fprintf ppf "\tgetglobal %a" Ident.print id
+  | Ksetglobal id -> fprintf ppf "\tsetglobal %a" Ident.print id
+  | Kconst cst ->
+      fprintf ppf "@[<10>\tconst@ %a@]" Printlambda.structured_constant cst
+  | Kmakeblock(n, m) ->
+      fprintf ppf "\tmakeblock %i, %i" n m
+  | Kmakefloatblock(n) ->
+      fprintf ppf "\tmakefloatblock %i" n
+  | Kgetfield n -> fprintf ppf "\tgetfield %i" n
+  | Ksetfield n -> fprintf ppf "\tsetfield %i" n
+  | Kgetfloatfield n -> fprintf ppf "\tgetfloatfield %i" n
+  | Ksetfloatfield n -> fprintf ppf "\tsetfloatfield %i" n
+  | Kvectlength -> fprintf ppf "\tvectlength"
+  | Kgetvectitem -> fprintf ppf "\tgetvectitem"
+  | Ksetvectitem -> fprintf ppf "\tsetvectitem"
+  | Kgetstringchar -> fprintf ppf "\tgetstringchar"
+  | Ksetstringchar -> fprintf ppf "\tsetstringchar"
+  | Kbranch lbl -> fprintf ppf "\tbranch L%i" lbl
+  | Kbranchif lbl -> fprintf ppf "\tbranchif L%i" lbl
+  | Kbranchifnot lbl -> fprintf ppf "\tbranchifnot L%i" lbl
+  | Kstrictbranchif lbl -> fprintf ppf "\tstrictbranchif L%i" lbl
+  | Kstrictbranchifnot lbl ->
+      fprintf ppf "\tstrictbranchifnot L%i" lbl
+  | Kswitch(consts, blocks) ->
+      let labels ppf labs =
+        Array.iter (fun lbl -> fprintf ppf "@ %i" lbl) labs in
+      fprintf ppf "@[<10>\tswitch%a/%a@]" labels consts labels blocks
+  | Kboolnot -> fprintf ppf "\tboolnot"
+  | Kpushtrap lbl -> fprintf ppf "\tpushtrap L%i" lbl
+  | Kpoptrap -> fprintf ppf "\tpoptrap"
+  | Kraise -> fprintf ppf "\traise"
+  | Kcheck_signals -> fprintf ppf "\tcheck_signals"
+  | Kccall(s, n) ->
+      fprintf ppf "\tccall %s, %i" s n
+  | Knegint -> fprintf ppf "\tnegint"
+  | Kaddint -> fprintf ppf "\taddint"
+  | Ksubint -> fprintf ppf "\tsubint"
+  | Kmulint -> fprintf ppf "\tmulint"
+  | Kdivint -> fprintf ppf "\tdivint"
+  | Kmodint -> fprintf ppf "\tmodint"
+  | Kandint -> fprintf ppf "\tandint"
+  | Korint -> fprintf ppf "\torint"
+  | Kxorint -> fprintf ppf "\txorint"
+  | Klslint -> fprintf ppf "\tlslint"
+  | Klsrint -> fprintf ppf "\tlsrint"
+  | Kasrint -> fprintf ppf "\tasrint"
+  | Kintcomp Ceq -> fprintf ppf "\teqint"
+  | Kintcomp Cneq -> fprintf ppf "\tneqint"
+  | Kintcomp Clt -> fprintf ppf "\tltint"
+  | Kintcomp Cgt -> fprintf ppf "\tgtint"
+  | Kintcomp Cle -> fprintf ppf "\tleint"
+  | Kintcomp Cge -> fprintf ppf "\tgeint"
+  | Koffsetint n -> fprintf ppf "\toffsetint %i" n
+  | Koffsetref n -> fprintf ppf "\toffsetref %i" n
+  | Kisint -> fprintf ppf "\tisint"
+  | Kisout -> fprintf ppf "\tisout"
+  | Kgetmethod -> fprintf ppf "\tgetmethod"
+  | Kstop -> fprintf ppf "\tstop"
+  | Kevent ev -> fprintf ppf "\tevent %i" ev.ev_char
+
+let rec instruction_list ppf = function
+    [] -> ()
+  | Klabel lbl :: il ->
+      fprintf ppf "L%i:%a" lbl instruction_list il
+  | instr :: il ->
+      fprintf ppf "%a@ %a" instruction instr instruction_list il
+ 
+let instrlist ppf il =
+  fprintf ppf "@[<v 0>%a@]" instruction_list il
diff --git a/byterun/Makefile b/byterun/Makefile
new file mode 100644
index 0000000000..901f04e650
--- /dev/null
+++ b/byterun/Makefile
@@ -0,0 +1,113 @@
+#########################################################################
+#                                                                       #
+#                            Objective Caml                             #
+#                                                                       #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 1999 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../LICENSE.      #
+#                                                                       #
+#########################################################################
+
+# $Id$
+
+include ../config/Makefile
+
+CC=$(BYTECC)
+CFLAGS=-O $(BYTECCCOMPOPTS)
+DFLAGS=-g -DDEBUG $(BYTECCCOMPOPTS)
+
+OBJS=interp.o misc.o stacks.o fix_code.o startup.o main.o \
+  freelist.o major_gc.o minor_gc.o memory.o alloc.o roots.o globroots.o \
+  fail.o signals.o printexc.o backtrace.o \
+  compare.o ints.o floats.o str.o array.o io.o extern.o intern.o \
+  hash.o sys.o meta.o parsing.o gc_ctrl.o terminfo.o md5.o obj.o \
+  lexing.o callback.o debugger.o weak.o compact.o finalise.o custom.o \
+  dynlink.o unix.o
+
+DOBJS=$(OBJS:.o=.d.o) instrtrace.d.o
+
+PRIMS=alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \
+  intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c \
+  signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c stacks.c \
+  dynlink.c
+
+PUBLIC_INCLUDES=mlvalues.h alloc.h misc.h callback.h fail.h custom.h intext.h
+
+all: ocamlrun$(EXE)
+
+ocamlrun$(EXE): libcamlrun.a prims.o
+	$(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) -o ocamlrun$(EXE) \
+	          prims.o libcamlrun.a $(BYTECCLIBS)
+
+ocamlrund$(EXE): libcamlrund.a prims.o
+	$(BYTECC) -g $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) -o ocamlrund$(EXE) \
+	          prims.o libcamlrund.a $(BYTECCLIBS)
+
+install:
+	cp ocamlrun$(EXE) $(BINDIR)/ocamlrun$(EXE)
+	cp libcamlrun.a $(LIBDIR)/libcamlrun.a
+	cd $(LIBDIR); $(RANLIB) libcamlrun.a
+	if test -d $(LIBDIR)/caml; then : ; else mkdir $(LIBDIR)/caml; fi
+	cp $(PUBLIC_INCLUDES) $(LIBDIR)/caml
+	sed -e '/#include ".*\/m.h/r ../config/m.h' \
+            -e '/#include ".*\/s.h/r ../config/s.h' \
+            -e '/#include "/d' config.h > $(LIBDIR)/caml/config.h
+	sed -e '/#include ".*gc\.h"/d' \
+	    -e '/#define Alloc_small/,/^}/d' \
+	    -e '/Modify/,/^}/d' memory.h > $(LIBDIR)/caml/memory.h
+
+libcamlrun.a: $(OBJS)
+	ar rc libcamlrun.a $(OBJS)
+	$(RANLIB) libcamlrun.a
+
+libcamlrund.a: $(DOBJS)
+	ar rc libcamlrund.a $(DOBJS)
+	$(RANLIB) libcamlrund.a
+
+clean:
+	rm -f ocamlrun$(EXE) ocamlrund$(EXE) *.o lib*.a
+	rm -f primitives prims.c opnames.h jumptbl.h
+
+primitives : $(PRIMS)
+	sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" \
+	    $(PRIMS) > primitives
+
+prims.c : primitives
+	(echo '#include "mlvalues.h"'; \
+	 echo '#include "prims.h"'; \
+	 sed -e 's/.*/extern value &();/' primitives; \
+	 echo 'c_primitive builtin_cprim[] = {'; \
+	 sed -e 's/.*/	&,/' primitives; \
+	 echo '	 0 };'; \
+	 echo 'char * names_of_builtin_cprim[] = {'; \
+	 sed -e 's/.*/	"&",/' primitives; \
+	 echo '	 0 };') > prims.c
+
+opnames.h : instruct.h
+	sed -e '/\/\*/d' \
+	    -e '/^#/d' \
+	    -e 's/enum /char * names_of_/' \
+	    -e 's/{$$/[] = {/' \
+	    -e 's/\([A-Z][A-Z_0-9]*\)/"\1"/g' instruct.h > opnames.h
+
+# jumptbl.h is required only if you have GCC 2.0 or later
+jumptbl.h : instruct.h
+	sed -n -e '/^  /s/ \([A-Z]\)/ \&\&lbl_\1/gp' \
+	       -e '/^}/q' instruct.h > jumptbl.h
+
+.SUFFIXES: .d.o
+
+.c.d.o:
+	@ if test -f $*.o; then mv $*.o $*.f.o; else :; fi
+	$(CC) -c $(DFLAGS) $<
+	mv $*.o $*.d.o
+	@ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi
+
+depend : prims.c opnames.h jumptbl.h
+	gcc -MM *.c > .depend
+	gcc -MM -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend
+
+include .depend
diff --git a/byterun/Makefile.Mac b/byterun/Makefile.Mac
new file mode 100644
index 0000000000..1c1126c6ec
--- /dev/null
+++ b/byterun/Makefile.Mac
@@ -0,0 +1,118 @@
+#########################################################################
+#                                                                       #
+#                            Objective Caml                             #
+#                                                                       #
+#            Damien Doligez, projet Para, INRIA Rocquencourt            #
+#                                                                       #
+#   Copyright 1999 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../LICENSE.      #
+#                                                                       #
+#########################################################################
+
+# $Id$
+
+PPCC = mrc
+PPCCOptions = -w 29,30,35 -i ::config: {cdbgflag}
+PPCLinkOptions = -d {ldbgflag}
+PPCLibs = "{sharedlibraries}MathLib" "{ppclibraries}PPCCRuntime.o" ¶
+          "{ppclibraries}PPCToolLibs.o" "{sharedlibraries}StdCLib" ¶
+          "{ppclibraries}StdCRuntime.o" "{sharedlibraries}InterfaceLib"
+
+PPCOBJS = :interp.c.x :misc.c.x :stacks.c.x ¶
+  :fix_code.c.x :startup.c.x :main.c.x ¶
+  :freelist.c.x :major_gc.c.x :minor_gc.c.x :memory.c.x :alloc.c.x :roots.c.x ¶
+  :fail.c.x :signals.c.x ¶
+  :compare.c.x :ints.c.x :floats.c.x :str.c.x :array.c.x :io.c.x :extern.c.x ¶
+  :intern.c.x ¶
+  :hash.c.x :sys.c.x :meta.c.x :parsing.c.x ¶
+  :gc_ctrl.c.x :terminfo.c.x :md5.c.x ¶
+  :obj.c.x :lexing.c.x :macintosh.c.x ¶
+  :rotatecursor.c.x :printexc.c.x :callback.c.x ¶
+  :debugger.c.x :weak.c.x :compact.c.x ¶
+  :instrtrace.c.x :finalise.c.x :custom.c.x :backtrace.c.x :globroots.c.x
+
+PRIMS = alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c ¶
+  intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c ¶
+  signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c stacks.c ¶
+  dynlink.c
+
+PUBLIC_INCLUDES = mlvalues.h alloc.h misc.h callback.h fail.h custom.h
+
+all Ä libcamlrun-gui.x libcamlrun.x ocamlrun
+
+libcamlrun-gui.x Ä {PPCOBJS} 
+    ppclink {PPCLinkOptions} -xm library -o libcamlrun-gui.x {PPCOBJS}
+
+libcamlrun.x Ä libcamlrun-gui.x mpwtool.c.x
+    ppclink {PPCLinkOptions} -xm library -o libcamlrun.x libcamlrun-gui.x mpwtool.c.x
+
+ocamlrun Ä libcamlrun.x :prims.c.x
+    ppclink -c 'MPS ' -t MPST {PPCLinkOptions} -o ocamlrun prims.c.x ¶
+            libcamlrun.x {PPCLibs}
+
+install Ä
+    duplicate -y ocamlrun "{BINDIR}ocamlrun"
+    duplicate -y libcamlrun.x libcamlrun-gui.x "{LIBDIR}"
+    if "`exists -d "{LIBDIR}caml:"`" == ""
+      newfolder "{LIBDIR}caml:"
+    end
+    duplicate -y {PUBLIC_INCLUDES} "{LIBDIR}caml:"
+    duplicate -y config.h "{LIBDIR}caml:"
+    open -t "{LIBDIR}caml:config.h"
+    find ¥ "{LIBDIR}caml:config.h"
+    find /Å'#include <m.h>'Å°/ "{LIBDIR}caml:config.h"
+    catenate ::config:m.h > "{LIBDIR}caml:config.h".¤
+    find ¥ "{LIBDIR}caml:config.h"
+    find /Å'#include <s.h>'Å°/ "{LIBDIR}caml:config.h"
+    catenate ::config:s.h > "{LIBDIR}caml:config.h".¤
+    find ¥ "{LIBDIR}caml:config.h"
+    clear -c ° /Å'#include "'Å/  "{LIBDIR}caml:config.h"
+    close -y "{LIBDIR}caml:config.h"
+    duplicate -y memory.h "{LIBDIR}caml:"
+    open -t "{LIBDIR}caml:memory.h"
+    find ¥ "{LIBDIR}caml:memory.h"
+    clear -c ° /Å'#include "'Å'gc.h'Å/ "{LIBDIR}caml:memory.h"
+    find ¥ "{LIBDIR}caml:memory.h"
+    clear /'#define Alloc_small'/:/¥}/ "{LIBDIR}caml:memory.h"
+    find ¥ "{LIBDIR}caml:memory.h"
+    clear /'#define Modify'/:/¥}/ "{LIBDIR}caml:memory.h"
+    close -y "{LIBDIR}caml:memory.h"
+
+clean Ä
+    delete -i Å.[ox] || set status 0
+    delete -i ocamlrun primitives prims.c opnames.h interp.a.lst
+    delete -i ocamlrun.xcoff ocamlrun.dbg
+
+primitives Ä {PRIMS}
+    streamedit -d -e "/CAMLprim value ([a-z0-9_]+)¨0Å/ print ¨0" {PRIMS} ¶
+               > primitives
+
+:prims.c Ä primitives
+    begin
+      echo '#include "mlvalues.h"'
+      echo '#include "prims.h"'
+      streamedit -e '1,$ change "extern value " . "();"' primitives
+      echo 'c_primitive builtin_cprim [] = {'
+      streamedit -e '1,$ change "  " . ","' primitives
+      echo '0 };'
+      echo 'char * names_of_builtin_cprim [] = {'
+      streamedit -e '1,$ change "  ¶"" . "¶","' primitives
+      echo '0 };'
+    end > prims.c
+
+:opnames.h Ä :instruct.h
+    streamedit -e "/¶¶/'*'/ delete" ¶
+               -e "/enum / replace // 'char * names_of_'" ¶
+               -e '/{°/ replace // "[] = {"' ¶
+               -e "1,$ replace /�([A-Z][A-Z_0-9]*)¨0/ '¶"' ¨0 '¶"' -c °" ¶
+               instruct.h > opnames.h
+
+:md5.c.x Ä
+    {PPCC} :md5.c -o :md5.c.x -opt off {PPCCOptions} -opt off
+
+depend Ä :prims.c :opnames.h
+    begin
+      makedepend -w -objext .x Å.c
+    end | streamedit -e "/¶t/ replace // ' ' -c °" > Makefile.Mac.depend
diff --git a/byterun/Makefile.nt b/byterun/Makefile.nt
new file mode 100644
index 0000000000..51881c64a9
--- /dev/null
+++ b/byterun/Makefile.nt
@@ -0,0 +1,108 @@
+#########################################################################
+#                                                                       #
+#                            Objective Caml                             #
+#                                                                       #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 1999 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../LICENSE.      #
+#                                                                       #
+#########################################################################
+
+# $Id$
+
+!include ..\config\Makefile.nt
+
+CC=$(BYTECC)
+CFLAGS=-DIN_OCAMLRUN -DOCAML_STDLIB_DIR="\"$(LIBDIR:\=\\)\""
+
+OBJS=interp.obj misc.obj stacks.obj fix_code.obj startup.obj main.obj \
+  fail.obj signals.obj freelist.obj major_gc.obj minor_gc.obj \
+  memory.obj alloc.obj roots.obj compare.obj ints.obj floats.obj \
+  str.obj array.obj io.obj extern.obj intern.obj hash.obj sys.obj \
+  meta.obj parsing.obj gc_ctrl.obj terminfo.obj md5.obj obj.obj lexing.obj \
+  win32.obj printexc.obj callback.obj debugger.obj weak.obj compact.obj \
+  finalise.obj custom.obj backtrace.obj globroots.obj dynlink.obj
+
+PRIMS=alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \
+  intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c \
+  signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c stacks.c \
+  dynlink.c
+
+PUBLIC_INCLUDES=mlvalues.h alloc.h misc.h callback.h fail.h custom.h intext.h
+
+all: ocamlrun.exe libcamlrun.lib
+	if not exist ..\stdlib\caml mkdir ..\stdlib\caml
+	cp $(PUBLIC_INCLUDES) ..\stdlib\caml
+	sed -e "/#include .*\/m.h/r ..\config\m.h" \
+            -e "/#include .*\/s.h/r ..\config\s.h" \
+            -e "/#include /d" config.h > ..\stdlib\caml\config.h
+	sed -e "/#include .*gc\.h/d" \
+	    -e "/#define Alloc_small/,/^}/d" \
+	    -e "/Modify/,/^}/d" memory.h > ..\stdlib\caml\memory.h
+
+ocamlrun.exe: $(OBJS:.obj=.dobj) prims.dobj
+	link /nologo /out:ocamlrun.exe $(OBJS:.obj=.dobj) prims.dobj $(CCLIBS)
+
+libcamlrun.lib: $(OBJS:.obj=.sobj)
+	$(MKLIB)libcamlrun.lib $(OBJS:.obj=.sobj)
+
+install:
+	cp ocamlrun.exe $(BINDIR)\ocamlrun.exe
+	cp ocamlrun.lib $(LIBDIR)\ocamlrun.lib
+	cp libcamlrun.lib $(LIBDIR)\libcamlrun.lib
+	if not exist $(LIBDIR)\caml mkdir $(LIBDIR)\caml
+	cp $(PUBLIC_INCLUDES) $(LIBDIR)\caml
+	sed -e "/#include .*\/m.h/r ..\config\m.h" \
+            -e "/#include .*\/s.h/r ..\config\s.h" \
+            -e "/#include /d" config.h > $(LIBDIR)\caml\config.h
+	sed -e "/#include .*gc\.h/d" \
+	    -e "/#define Alloc_small/,/^}/d" \
+	    -e "/Modify/,/^}/d" memory.h > $(LIBDIR)\caml\memory.h
+
+clean:
+	rm -f *.exe *.dobj *.sobj *.lib
+	rm -f primitives prims.c opnames.h jumptbl.h
+
+primitives : $(PRIMS)
+	sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" \
+	    $(PRIMS) > primitives
+
+prims.c : primitives
+        echo #include "mlvalues.h" > prims.c
+        echo #include "prims.h" >> prims.c
+        sed -e "s/.*/extern value &();/" primitives >> prims.c
+        echo c_primitive builtin_cprim[] = { >> prims.c
+        sed -e "s/.*/   &,/" primitives >> prims.c
+        echo     0 }; >> prims.c
+        echo char * names_of_builtin_cprim[] = { >> prims.c
+        sed -e "s/.*/   \"^&\",/" primitives >> prims.c
+        echo     0 }; >> prims.c
+
+opnames.h : instruct.h
+	sed -e "/\/\*/d" \
+	    -e "s\enum /char * names_of_/" \
+	    -e "s/{$$/[] = {/" \
+	    -e "s/\([A-Z][A-Z_0-9]*\)/"\1"/g" instruct.h > opnames.h
+
+# jumptbl.h is required only if you have GCC 2.0 or later
+jumptbl.h : instruct.h
+	sed -n -e "/^  /s/ \([A-Z]\)/ \&\&lbl_\1/gp" \
+	       -e "/^}/q" instruct.h > jumptbl.h
+
+.SUFFIXES: .dobj .sobj
+
+.c.dobj:
+	$(CC) $(CFLAGS) $(DLLCCCOMPOPTS) -c $<
+	mv $*.obj $*.dobj
+.c.sobj:
+	$(CC) $(CFLAGS) $(BYTECCCOMPOPTS) -c $<
+	mv $*.obj $*.sobj
+
+depend:
+	sed -e "s/\.o/.dobj/g" .depend > .depend.nt
+	sed -e "s/\.o/.sobj/g" .depend >> .depend.nt
+
+!include .depend.nt
diff --git a/byterun/alloc.h b/byterun/alloc.h
new file mode 100644
index 0000000000..0a12114176
--- /dev/null
+++ b/byterun/alloc.h
@@ -0,0 +1,44 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#ifndef _alloc_
+#define _alloc_
+
+
+#include "misc.h"
+#include "mlvalues.h"
+
+CAMLextern value alloc (mlsize_t, tag_t);
+CAMLextern value alloc_small (mlsize_t, tag_t);
+CAMLextern value alloc_tuple (mlsize_t);
+CAMLextern value alloc_string (mlsize_t);
+CAMLextern value copy_string (char const *);
+CAMLextern value copy_string_array (char const **);
+CAMLextern value copy_double (double);
+CAMLextern value copy_int32 (int32);       /* defined in [ints.c] */
+CAMLextern value copy_int64 (int64);       /* defined in [ints.c] */
+CAMLextern value copy_nativeint (long);    /* defined in [ints.c] */
+CAMLextern value alloc_array (value (*funct) (char const *),
+                              char const ** array);
+
+typedef void (*final_fun)(value);
+CAMLextern value alloc_final (mlsize_t /*size in words*/,
+                              final_fun, /*finalization function*/
+                              mlsize_t, /*resources consumed*/
+                              mlsize_t  /*max resources*/);
+
+CAMLextern int convert_flag_list (value, int *);
+
+#endif /* _alloc_ */
diff --git a/byterun/array.c b/byterun/array.c
new file mode 100644
index 0000000000..6f3195fc4c
--- /dev/null
+++ b/byterun/array.c
@@ -0,0 +1,197 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Operations on arrays */
+
+#include "alloc.h"
+#include "fail.h"
+#include "memory.h"
+#include "misc.h"
+#include "mlvalues.h"
+
+#ifndef NATIVE_CODE
+
+CAMLprim value array_get_addr(value array, value index)
+{
+  long idx = Long_val(index);
+  if (idx < 0 || idx >= Wosize_val(array)) invalid_argument("Array.get");
+  return Field(array, idx);
+}
+
+CAMLprim value array_get_float(value array, value index)
+{
+  long idx = Long_val(index);
+  double d;
+  value res;
+
+  if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
+    invalid_argument("Array.get");
+  d = Double_field(array, idx);
+#define Setup_for_gc
+#define Restore_after_gc
+  Alloc_small(res, Double_wosize, Double_tag);
+#undef Setup_for_gc
+#undef Restore_after_gc
+  Store_double_val(res, d);
+  return res;
+}
+
+CAMLprim value array_get(value array, value index)
+{
+  if (Tag_val(array) == Double_array_tag)
+    return array_get_float(array, index);
+  else
+    return array_get_addr(array, index);
+}
+
+CAMLprim value array_set_addr(value array, value index, value newval)
+{
+  long idx = Long_val(index);
+  if (idx < 0 || idx >= Wosize_val(array)) invalid_argument("Array.set");
+  Modify(&Field(array, idx), newval);
+  return Val_unit;
+}
+
+CAMLprim value array_set_float(value array, value index, value newval)
+{
+  long idx = Long_val(index);
+  if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
+    invalid_argument("Array.set");
+  Store_double_field(array, idx, Double_val(newval));
+  return Val_unit;
+}
+
+CAMLprim value array_set(value array, value index, value newval)
+{
+  if (Tag_val(array) == Double_array_tag)
+    return array_set_float(array, index, newval);
+  else
+    return array_set_addr(array, index, newval);
+}
+
+CAMLprim value array_unsafe_get_float(value array, value index)
+{
+  double d;
+  value res;
+
+  d = Double_field(array, Long_val(index));
+#define Setup_for_gc
+#define Restore_after_gc
+  Alloc_small(res, Double_wosize, Double_tag);
+#undef Setup_for_gc
+#undef Restore_after_gc
+  Store_double_val(res, d);
+  return res;
+}
+
+CAMLprim value array_unsafe_get(value array, value index)
+{
+  if (Tag_val(array) == Double_array_tag)
+    return array_unsafe_get_float(array, index);
+  else
+    return Field(array, Long_val(index));
+}
+
+CAMLprim value array_unsafe_set_addr(value array, value index, value newval)
+{
+  long idx = Long_val(index);
+  Modify(&Field(array, idx), newval);
+  return Val_unit;
+}
+
+CAMLprim value array_unsafe_set_float(value array, value index, value newval)
+{
+  Store_double_field(array, Long_val(index), Double_val(newval));
+  return Val_unit;
+}
+
+CAMLprim value array_unsafe_set(value array, value index, value newval)
+{
+  if (Tag_val(array) == Double_array_tag)
+    return array_unsafe_set_float(array, index, newval);
+  else
+    return array_unsafe_set_addr(array, index, newval);
+}
+
+#endif
+
+CAMLprim value make_vect(value len, value init)
+{
+  CAMLparam2 (len, init);
+  CAMLlocal1 (res);
+  mlsize_t size, wsize, i;
+  double d;
+
+  size = Long_val(len);
+  if (size == 0) {
+    res = Atom(0);
+  }
+  else if (Is_block(init)
+           && (Is_atom(init) || Is_young(init) || Is_in_heap(init))
+           && Tag_val(init) == Double_tag) {
+    d = Double_val(init);
+    wsize = size * Double_wosize;
+    if (wsize > Max_wosize) invalid_argument("Array.make");
+    res = alloc(wsize, Double_array_tag);
+    for (i = 0; i < size; i++) {
+      Store_double_field(res, i, d);
+    }
+  } else {
+    if (size > Max_wosize) invalid_argument("Array.make");
+    if (size < Max_young_wosize) {
+      res = alloc_small(size, 0);
+      for (i = 0; i < size; i++) Field(res, i) = init;
+    }
+    else if (Is_block(init) && Is_young(init)) {
+      minor_collection();
+      res = alloc_shr(size, 0);
+      for (i = 0; i < size; i++) Field(res, i) = init;
+      res = check_urgent_gc (res);
+    }
+    else {
+      res = alloc_shr(size, 0);
+      for (i = 0; i < size; i++) initialize(&Field(res, i), init);
+      res = check_urgent_gc (res);
+    }
+  }
+  CAMLreturn (res);
+}
+
+CAMLprim value make_array(value init)
+{
+  CAMLparam1 (init);
+  mlsize_t wsize, size, i;
+  CAMLlocal2 (v, res);
+
+  size = Wosize_val(init);
+  if (size == 0) {
+    CAMLreturn (init);
+  } else {
+    v = Field(init, 0);
+    if (Is_long(v)
+        || (!Is_atom(v) && !Is_young(v) && !Is_in_heap(v))
+        || Tag_val(v) != Double_tag) {
+      CAMLreturn (init);
+    } else {
+      Assert(size < Max_young_wosize);
+      wsize = size * Double_wosize;
+      res = alloc_small(wsize, Double_array_tag);
+      for (i = 0; i < size; i++) {
+        Store_double_field(res, i, Double_val(Field(init, i)));
+      }
+      CAMLreturn (res);
+    }
+  }
+}
diff --git a/byterun/backtrace.h b/byterun/backtrace.h
new file mode 100644
index 0000000000..8040627bf7
--- /dev/null
+++ b/byterun/backtrace.h
@@ -0,0 +1,15 @@
+#ifndef _backtrace_
+#define _backtrace_
+
+#include "mlvalues.h"
+
+CAMLextern int backtrace_active;
+CAMLextern int backtrace_pos;
+CAMLextern code_t * backtrace_buffer;
+CAMLextern value backtrace_last_exn;
+
+extern void init_backtrace(void);
+extern void stash_backtrace(value exn, code_t pc, value * sp);
+CAMLextern void print_exception_backtrace(void);
+
+#endif
diff --git a/byterun/callback.c b/byterun/callback.c
new file mode 100644
index 0000000000..e5f0d27af3
--- /dev/null
+++ b/byterun/callback.c
@@ -0,0 +1,208 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Callbacks from C to Caml */
+
+#include <string.h>
+#include "callback.h"
+#include "fail.h"
+#include "memory.h"
+#include "mlvalues.h"
+
+#ifndef NATIVE_CODE
+
+/* Bytecode callbacks */
+
+#include "interp.h"
+#include "instruct.h"
+#include "fix_code.h"
+#include "stacks.h"
+
+int callback_depth = 0;
+
+static opcode_t callback_code[] = { ACC, 0, APPLY, 0, POP, 1, STOP };
+
+#ifdef THREADED_CODE
+
+static int callback_code_threaded = 0;
+
+static void thread_callback(void)
+{
+  thread_code(callback_code, sizeof(callback_code));
+  callback_code_threaded = 1;
+}
+
+#define Init_callback() if (!callback_code_threaded) thread_callback()
+
+#else
+
+#define Init_callback()
+
+#endif
+
+CAMLexport value callbackN_exn(value closure, int narg, value args[])
+{
+  int i;
+
+  Assert(narg + 4 <= 256);
+  Init_callback();
+  extern_sp -= narg + 4;
+  for (i = 0; i < narg; i++) extern_sp[i] = args[i]; /* arguments */
+  extern_sp[narg] = (value) (callback_code + 4); /* return address */
+  extern_sp[narg + 1] = Val_unit;    /* environment */
+  extern_sp[narg + 2] = Val_long(0); /* extra args */
+  extern_sp[narg + 3] = closure;
+  callback_code[1] = narg + 3;
+  callback_code[3] = narg;
+  return interprete(callback_code, sizeof(callback_code));
+}
+
+CAMLexport value callback_exn(value closure, value arg1)
+{
+  value arg[1];
+  arg[0] = arg1;
+  return callbackN_exn(closure, 1, arg);
+}
+
+CAMLexport value callback2_exn(value closure, value arg1, value arg2)
+{
+  value arg[2];
+  arg[0] = arg1;
+  arg[1] = arg2;
+  return callbackN_exn(closure, 2, arg);
+}
+
+CAMLexport value callback3_exn(value closure,
+                               value arg1, value arg2, value arg3)
+{
+  value arg[3];
+  arg[0] = arg1;
+  arg[1] = arg2;
+  arg[2] = arg3;
+  return callbackN_exn(closure, 3, arg);
+}
+
+#else
+
+/* Native-code callbacks.  callback[123]_exn are implemented in asm. */
+
+CAMLexport value callbackN_exn(value closure, int narg, value args[])
+{
+  CAMLparam1 (closure);
+  CAMLxparamN (args, narg);
+  CAMLlocal1 (res);
+  int i;
+
+  res = closure;
+  for (i = 0; i < narg; /*nothing*/) {
+    /* Pass as many arguments as possible */
+    switch (narg - i) {
+    case 1:
+      res = callback_exn(res, args[i]);
+      if (Is_exception_result(res)) CAMLreturn (res);
+      i += 1;
+      break;
+    case 2:
+      res = callback2_exn(res, args[i], args[i + 1]);
+      if (Is_exception_result(res)) CAMLreturn (res);
+      i += 2;
+      break;
+    default:
+      res = callback3_exn(res, args[i], args[i + 1], args[i + 2]);
+      if (Is_exception_result(res)) CAMLreturn (res);
+      i += 3;
+      break;
+    }
+  }
+  CAMLreturn (res);
+}
+
+#endif
+
+/* Exception-propagating variants of the above */
+
+CAMLexport value callback (value closure, value arg)
+{
+  value res = callback_exn(closure, arg);
+  if (Is_exception_result(res)) mlraise(Extract_exception(res));
+  return res;
+}
+
+CAMLexport value callback2 (value closure, value arg1, value arg2)
+{
+  value res = callback2_exn(closure, arg1, arg2);
+  if (Is_exception_result(res)) mlraise(Extract_exception(res));
+  return res;
+}
+
+CAMLexport value callback3 (value closure, value arg1, value arg2, value arg3)
+{
+  value res = callback3_exn(closure, arg1, arg2, arg3);
+  if (Is_exception_result(res)) mlraise(Extract_exception(res));
+  return res;
+}
+
+CAMLexport value callbackN (value closure, int narg, value args[])
+{
+  value res = callbackN_exn(closure, narg, args);
+  if (Is_exception_result(res)) mlraise(Extract_exception(res));
+  return res;
+}
+
+/* Naming of Caml values */
+
+struct named_value {
+  value val;
+  struct named_value * next;
+  char name[1];
+};
+
+#define Named_value_size 13
+
+static struct named_value * named_value_table[Named_value_size] = { NULL, };
+
+static unsigned int hash_value_name(char *name)
+{
+  unsigned int h;
+  for (h = 0; *name != 0; name++) h = h * 19 + *name;
+  return h % Named_value_size;
+}
+
+CAMLprim value register_named_value(value vname, value val)
+{
+  struct named_value * nv;
+  char * name = String_val(vname);
+  unsigned int h = hash_value_name(name);
+
+  nv = (struct named_value *)
+         stat_alloc(sizeof(struct named_value) + strlen(name));
+  strcpy(nv->name, name);
+  nv->val = val;
+  nv->next = named_value_table[h];
+  named_value_table[h] = nv;
+  register_global_root(&nv->val);
+  return Val_unit;
+}
+
+CAMLexport value * caml_named_value(char *name)
+{
+  struct named_value * nv;
+  for (nv = named_value_table[hash_value_name(name)];
+       nv != NULL;
+       nv = nv->next) {
+    if (strcmp(name, nv->name) == 0) return &nv->val;
+  }
+  return NULL;
+}
diff --git a/byterun/callback.h b/byterun/callback.h
new file mode 100644
index 0000000000..20c704b264
--- /dev/null
+++ b/byterun/callback.h
@@ -0,0 +1,47 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Callbacks from C to Caml */
+
+#ifndef _callback_
+#define _callback_
+
+#include "mlvalues.h"
+
+CAMLextern value callback (value closure, value arg);
+CAMLextern value callback2 (value closure, value arg1, value arg2);
+CAMLextern value callback3 (value closure, value arg1, value arg2, value arg3);
+CAMLextern value callbackN (value closure, int narg, value args[]);
+
+CAMLextern value callback_exn (value closure, value arg);
+CAMLextern value callback2_exn (value closure, value arg1, value arg2);
+CAMLextern value callback3_exn (value closure,
+                                value arg1, value arg2, value arg3);
+CAMLextern value callbackN_exn (value closure, int narg, value args[]);
+
+#define Make_exception_result(v) ((v) | 2)
+#define Is_exception_result(v) (((v) & 3) == 2)
+#define Extract_exception(v) ((v) & ~3)
+
+CAMLextern char * format_caml_exception(value exn); /* in [printexc.c] */
+
+CAMLextern value * caml_named_value (char * name);
+
+CAMLextern void caml_main (char ** argv);
+CAMLextern void caml_startup (char ** argv);
+
+CAMLextern int callback_depth;
+
+#endif
diff --git a/byterun/compact.c b/byterun/compact.c
new file mode 100644
index 0000000000..6962d54150
--- /dev/null
+++ b/byterun/compact.c
@@ -0,0 +1,420 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*             Damien Doligez, projet Para, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#include <string.h>
+
+#include "config.h"
+#include "finalise.h"
+#include "freelist.h"
+#include "gc.h"
+#include "gc_ctrl.h"
+#include "major_gc.h"
+#include "memory.h"
+#include "mlvalues.h"
+#include "roots.h"
+#include "weak.h"
+
+extern unsigned long percent_free;             /* major_gc.c */
+extern void shrink_heap (char *);              /* memory.c */
+
+/* Encoded headers: the color is stored in the 2 least significant bits.
+   (For pointer inversion, we need to distinguish headers from pointers.)
+   s is a Wosize, t is a tag, and c is a color (a two-bit number)
+
+   For the purpose of compaction, "colors" are:
+   0: pointers (direct or inverted)
+   1: integer or (unencoded) infix header
+   2: inverted pointer for infix header
+   3: integer or encoded (noninfix) header
+   
+  XXX Should be fixed:
+  XXX The above assumes that all roots are aligned on a 4-byte boundary,
+  XXX which is not always guaranteed by C.
+  XXX (see [register_global_roots] and [init_exceptions])
+  XXX Should be able to fix it to only assume 2-byte alignment.
+*/
+#define Make_ehd(s,t,c) (((s) << 10) | (t) << 2 | (c))
+#define Whsize_ehd(h) Whsize_hd (h)
+#define Wosize_ehd(h) Wosize_hd (h)
+#define Tag_ehd(h) (((h) >> 2) & 0xFF)
+#define Ecolor(w) ((w) & 3)
+
+typedef unsigned long word;
+
+static void invert_pointer_at (word *p)
+{
+  word q = *p;
+                                              Assert (Ecolor ((long) p) == 0);
+
+  /* Use Ecolor (q) == 0 instead of Is_block (q) because q could be an
+     inverted pointer for an infix header (with Ecolor == 2). */
+  if (Ecolor (q) == 0 && Is_in_heap (q)){
+    switch (Ecolor (Hd_val (q))){
+    case 0:
+    case 3: /* Pointer or header: insert in inverted list. */
+      *p = Hd_val (q);
+      Hd_val (q) = (header_t) p;
+      break;
+    case 1: /* Infix header: make inverted infix list. */
+      /* Double inversion: the last of the inverted infix list points to
+         the next infix header in this block.  The last of the last list
+         contains the original block header. */
+      {
+        /* This block as a value. */
+        value val = (value) q - Infix_offset_val (q);
+        /* Get the block header. */
+        word *hp = (word *) Hp_val (val);
+
+        while (Ecolor (*hp) == 0) hp = (word *) *hp;
+                                                   Assert (Ecolor (*hp) == 3);
+        if (Tag_ehd (*hp) == Closure_tag){
+          /* This is the first infix found in this block. */
+          /* Save original header. */
+          *p = *hp;
+          /* Link inverted infix list. */
+          Hd_val (q) = (header_t) ((word) p | 2);
+          /* Change block header's tag to Infix_tag, and change its size
+             to point to the infix list. */
+          *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3);
+        }else{                            Assert (Tag_ehd (*hp) == Infix_tag);
+          /* Point the last of this infix list to the current first infix
+             list of the block. */
+          *p = (word) &Field (val, Wosize_ehd (*hp)) | 1;
+          /* Point the head of this infix list to the above. */
+          Hd_val (q) = (header_t) ((word) p | 2);
+          /* Change block header's size to point to this infix list. */
+          *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3);
+        }
+      }
+      break;
+    case 2: /* Inverted infix list: insert. */
+      *p = Hd_val (q);
+      Hd_val (q) = (header_t) ((word) p | 2);
+      break;
+    }
+  }
+}
+
+static void invert_root (value v, value *p)
+{
+  invert_pointer_at ((word *) p);
+}
+
+static char *compact_fl;
+
+static void init_compact_allocate (void)
+{
+  char *ch = heap_start;
+  while (ch != NULL){
+    Chunk_alloc (ch) = 0;
+    ch = Chunk_next (ch);
+  }
+  compact_fl = heap_start;
+}
+
+static char *compact_allocate (mlsize_t size)
+                                      /* in bytes, including header */
+{
+  char *chunk, *adr;
+
+  while (Chunk_size (compact_fl) - Chunk_alloc (compact_fl) <= Bhsize_wosize (3)
+         && Chunk_size (Chunk_next (compact_fl))
+            - Chunk_alloc (Chunk_next (compact_fl))
+            <= Bhsize_wosize (3)){
+    compact_fl = Chunk_next (compact_fl);
+  }
+  chunk = compact_fl;
+  while (Chunk_size (chunk) - Chunk_alloc (chunk) < size){
+    chunk = Chunk_next (chunk);                         Assert (chunk != NULL);
+  }
+  adr = chunk + Chunk_alloc (chunk);
+  Chunk_alloc (chunk) += size;
+  return adr;
+}
+
+void compact_heap (void)
+{
+  char *ch, *chend;
+                                               Assert (gc_phase == Phase_idle);
+  gc_message (0x10, "Compacting heap...\n", 0);
+
+#ifdef DEBUG
+  heap_check ();
+#endif
+
+  /* First pass: encode all noninfix headers. */
+  {
+    ch = heap_start;
+    while (ch != NULL){
+      header_t *p = (header_t *) ch;
+
+      chend = ch + Chunk_size (ch);
+      while ((char *) p < chend){
+        header_t hd = Hd_hp (p);
+        mlsize_t sz = Wosize_hd (hd);
+
+        if (Is_blue_hd (hd)){
+          /* Free object.  Give it a string tag. */
+          Hd_hp (p) = Make_ehd (sz, String_tag, 3);
+        }else{                                      Assert (Is_white_hd (hd));
+          /* Live object.  Keep its tag. */
+          Hd_hp (p) = Make_ehd (sz, Tag_hd (hd), 3);
+        }
+        p += Whsize_wosize (sz);
+      }
+      ch = Chunk_next (ch);
+    }
+  }
+
+
+  /* Second pass: invert pointers.
+     Link infix headers in each block in an inverted list of inverted lists.
+     Don't forget roots and weak pointers. */
+  {
+    /* Invert roots first because the threads library needs some heap
+       data structures to find its roots.  Fortunately, it doesn't need
+       the headers (see above). */
+    do_roots (invert_root);
+    final_do_weak_roots (invert_root);
+
+    ch = heap_start;
+    while (ch != NULL){
+      word *p = (word *) ch;
+      chend = ch + Chunk_size (ch);
+
+      while ((char *) p < chend){
+        word q = *p;
+        size_t sz, i;
+        tag_t t;
+        word *infixes;
+
+        while (Ecolor (q) == 0) q = * (word *) q;
+        sz = Whsize_ehd (q);
+        t = Tag_ehd (q);
+        
+        if (t == Infix_tag){
+          /* Get the original header of this block. */
+          infixes = p + sz;
+          q = *infixes;
+          while (Ecolor (q) != 3) q = * (word *) (q & ~(unsigned long)3);
+          sz = Whsize_ehd (q);
+          t = Tag_ehd (q);
+        }
+
+        if (t < No_scan_tag){
+          for (i = 1; i < sz; i++) invert_pointer_at (&(p[i]));
+        }
+        p += sz;
+      }
+      ch = Chunk_next (ch);
+    }
+    /* Invert weak pointers. */
+    {
+      value *pp = &weak_list_head;
+      value p;
+      word q;
+      size_t sz, i;
+
+      while (1){
+        p = *pp;
+        if (p == (value) NULL) break;
+        q = Hd_val (p);
+        while (Ecolor (q) == 0) q = * (word *) q;
+        sz = Wosize_ehd (q);
+        for (i = 1; i < sz; i++){
+          if (Field (p,i) != 0) invert_pointer_at ((word *) &(Field (p,i)));
+        }
+        invert_pointer_at ((word *) pp);
+        pp = &Field (p, 0);
+      }
+    }
+  }
+
+
+  /* Third pass: reallocate virtually; revert pointers; decode headers.
+     Rebuild infix headers. */
+  {
+    init_compact_allocate ();
+    ch = heap_start;
+    while (ch != NULL){
+      word *p = (word *) ch;
+      
+      chend = ch + Chunk_size (ch);
+      while ((char *) p < chend){
+        word q = *p;
+        
+        if (Ecolor (q) == 0 || Tag_ehd (q) == Infix_tag){
+          /* There were (normal or infix) pointers to this block. */
+          size_t sz;
+          tag_t t;
+          char *newadr;
+          word *infixes = NULL;
+          
+          while (Ecolor (q) == 0) q = * (word *) q;
+          sz = Whsize_ehd (q);
+          t = Tag_ehd (q);
+
+          if (t == Infix_tag){
+            /* Get the original header of this block. */
+            infixes = p + sz;
+            q = *infixes;                             Assert (Ecolor (q) == 2);
+            while (Ecolor (q) != 3) q = * (word *) (q & ~(unsigned long)3);
+            sz = Whsize_ehd (q);
+            t = Tag_ehd (q);
+          }
+
+          newadr = compact_allocate (Bsize_wsize (sz));
+          q = *p;
+          while (Ecolor (q) == 0){
+            word next = * (word *) q;
+            * (word *) q = (word) Val_hp (newadr);
+            q = next;
+          }
+          *p = Make_header (Wosize_whsize (sz), t, Caml_white);
+
+          if (infixes != NULL){
+            /* Rebuild the infix headers and revert the infix pointers. */
+            while (Ecolor ((word) infixes) != 3){
+              infixes = (word *) ((word) infixes & ~(unsigned long) 3);
+              q = *infixes;
+              while (Ecolor (q) == 2){
+                word next;
+                q = (word) q & ~(unsigned long) 3;
+                next = * (word *) q;
+                * (word *) q = (word) Val_hp ((word *) newadr + (infixes - p));
+                q = next;
+              }                    Assert (Ecolor (q) == 1 || Ecolor (q) == 3);
+              *infixes = Make_header (infixes - p, Infix_tag, Caml_white);
+              infixes = (word *) q;
+            }
+          }
+          p += sz;
+        }else{                                        Assert (Ecolor (q) == 3);
+          /* This is guaranteed only if compact_heap was called after a
+             nonincremental major GC:       Assert (Tag_ehd (q) == String_tag);
+          */
+          /* No pointers to the header and no infix header:
+             the object was free. */
+          *p = Make_header (Wosize_ehd (q), Tag_ehd (q), Caml_blue);
+          p += Whsize_ehd (q);
+        }
+      }
+      ch = Chunk_next (ch);
+    }
+  }
+
+
+  /* Fourth pass: reallocate and move objects.
+     Use the exact same allocation algorithm as pass 3. */
+  {
+    init_compact_allocate ();
+    ch = heap_start;
+    while (ch != NULL){
+      word *p = (word *) ch;
+
+      chend = ch + Chunk_size (ch);
+      while ((char *) p < chend){
+        word q = *p;
+        if (Color_hd (q) == Caml_white){
+          size_t sz = Bhsize_hd (q);
+          char *newadr = compact_allocate (sz);  Assert (newadr <= (char *)p);
+          memmove (newadr, p, sz);
+          p += Wsize_bsize (sz);
+        }else{
+          Assert (Color_hd (q) == Caml_blue);
+          p += Whsize_hd (q);
+        }
+      }
+      ch = Chunk_next (ch);
+    }
+  }
+
+  /* Shrink the heap if needed. */
+  {
+    /* Find the amount of live data and the unshrinkable free space. */
+    asize_t live = 0;
+    asize_t free = 0;
+    asize_t wanted;
+
+    ch = heap_start;
+    while (ch != NULL){
+      if (Chunk_alloc (ch) != 0){
+        live += Wsize_bsize (Chunk_alloc (ch));
+        free += Wsize_bsize (Chunk_size (ch) - Chunk_alloc (ch));
+      }
+      ch = Chunk_next (ch);
+    }
+
+    /* Add up the empty chunks until there are enough, then remove the
+       other empty chunks. */
+    wanted = percent_free * (live / 100 + 1);
+    ch = heap_start;
+    while (ch != NULL){
+      char *next_chunk = Chunk_next (ch);  /* Chunk_next (ch) will be erased */
+
+      if (Chunk_alloc (ch) == 0){
+        if (free < wanted){
+          free += Wsize_bsize (Chunk_size (ch));
+        }else{
+          shrink_heap (ch);
+        }
+      }
+      ch = next_chunk;
+    }
+  }
+
+  /* Rebuild the free list. */
+  {
+    ch = heap_start;
+    fl_reset ();
+    while (ch != NULL){
+      if (Chunk_size (ch) > Chunk_alloc (ch)){
+        header_t *p = (header_t *) (ch + Chunk_alloc (ch));
+        *p = Make_header (Wosize_bhsize (Chunk_size (ch) - Chunk_alloc (ch)),
+                          0, Caml_white);
+        fl_merge_block (Bp_hp (p));
+      }
+      ch = Chunk_next (ch);
+    }
+  }
+  ++ stat_compactions;
+  gc_message (0x10, "done.\n", 0);
+}
+
+unsigned long percent_max;
+
+void compact_heap_maybe (void)
+{
+  /* Estimated free words in the heap: FW = 1.5 * fl_cur_size
+     Estimated live words: LW = stat_heap_size - FW
+     We compact the heap if FW > percent_max / 100 * LW
+  */
+  float fw;
+                                               Assert (gc_phase == Phase_idle);
+  if (percent_max >= 1000000) return;
+  switch (percent_max){
+  case 0:
+    finish_major_cycle ();
+    compact_heap ();
+    break;
+  default:
+    fw = 1.5 * fl_cur_size;
+    if (fw > 0.01 * percent_max * (Wsize_bsize (stat_heap_size) - fw)){
+      finish_major_cycle ();
+      compact_heap ();
+    }
+    break;
+  }
+}
diff --git a/byterun/compact.h b/byterun/compact.h
new file mode 100644
index 0000000000..1c03d9d9c6
--- /dev/null
+++ b/byterun/compact.h
@@ -0,0 +1,27 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*             Damien Doligez, projet Para, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#ifndef _compact_
+#define _compact_
+
+
+#include "config.h"
+#include "misc.h"
+
+extern void compact_heap (void);
+extern void compact_heap_maybe (void);
+
+
+#endif /* _compact_ */
diff --git a/byterun/custom.c b/byterun/custom.c
new file mode 100644
index 0000000000..4e616b4ce4
--- /dev/null
+++ b/byterun/custom.c
@@ -0,0 +1,117 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*         Manuel Serrano and Xavier Leroy, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 2000 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#include <string.h>
+
+#include "alloc.h"
+#include "custom.h"
+#include "fail.h"
+#include "memory.h"
+#include "mlvalues.h"
+
+CAMLextern value alloc_custom(struct custom_operations * ops,
+                              unsigned long size,
+                              mlsize_t mem,
+                              mlsize_t max)
+{
+  mlsize_t wosize;
+  value result;
+
+  wosize = 1 + (size + sizeof(value) - 1) / sizeof(value);
+  if (ops->finalize == NULL && wosize <= Max_young_wosize) {
+    result = alloc_small(wosize, Custom_tag);
+    Custom_ops_val(result) = ops;
+  } else {
+    result = alloc_shr(wosize, Custom_tag);
+    Custom_ops_val(result) = ops;
+    adjust_gc_speed(mem, max);
+    result = check_urgent_gc(result);
+  }
+  return result;
+}
+
+CAMLextern int custom_compare_default(value v1, value v2)
+{
+  failwith("equal: abstract value");
+  return 0;
+}
+
+CAMLextern void custom_serialize_default(value v, unsigned long * wsize_32,
+                                         unsigned long * wsize_64)
+{
+  failwith("output_value: abstract value");
+}
+
+struct custom_operations_list {
+  struct custom_operations * ops;
+  struct custom_operations_list * next;
+};
+
+static struct custom_operations_list * custom_ops_table = NULL;
+
+CAMLextern void register_custom_operations(struct custom_operations * ops)
+{
+  struct custom_operations_list * l =
+    stat_alloc(sizeof(struct custom_operations_list));
+  Assert(ops->identifier != NULL);
+  Assert(ops->deserialize != NULL);
+  l->ops = ops;
+  l->next = custom_ops_table;
+  custom_ops_table = l;
+}
+
+struct custom_operations * find_custom_operations(char * ident)
+{
+  struct custom_operations_list * l;
+  for (l = custom_ops_table; l != NULL; l = l->next)
+    if (strcmp(l->ops->identifier, ident) == 0) return l->ops;
+  return NULL;
+}
+
+static struct custom_operations_list * custom_ops_final_table = NULL;
+
+struct custom_operations * final_custom_operations(final_fun fn)
+{
+  struct custom_operations_list * l;
+  struct custom_operations * ops;
+  for (l = custom_ops_final_table; l != NULL; l = l->next)
+    if (l->ops->finalize == fn) return l->ops;
+  ops = stat_alloc(sizeof(struct custom_operations));
+  ops->identifier = "_final";
+  ops->finalize = fn;
+  ops->compare = custom_compare_default;
+  ops->hash = custom_hash_default;
+  ops->serialize = custom_serialize_default;
+  ops->deserialize = custom_deserialize_default;
+  l = stat_alloc(sizeof(struct custom_operations_list));
+  l->ops = ops;
+  l->next = custom_ops_final_table;
+  custom_ops_final_table = l;
+  return ops;
+}
+
+extern struct custom_operations int32_ops, nativeint_ops;
+#ifdef ARCH_INT64_TYPE
+extern struct custom_operations int64_ops;
+#endif
+
+void init_custom_operations(void)
+{
+  register_custom_operations(&int32_ops);
+  register_custom_operations(&nativeint_ops);
+#ifdef ARCH_INT64_TYPE
+  register_custom_operations(&int64_ops);
+#endif
+}
diff --git a/byterun/custom.h b/byterun/custom.h
new file mode 100644
index 0000000000..2cb50b0f45
--- /dev/null
+++ b/byterun/custom.h
@@ -0,0 +1,53 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*         Manuel Serrano and Xavier Leroy, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 2000 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#ifndef _custom_
+#define _custom_
+
+
+#include "mlvalues.h"
+
+struct custom_operations {
+  char *identifier;
+  void (*finalize)(value v);
+  int (*compare)(value v1, value v2);
+  long (*hash)(value v);
+  void (*serialize)(value v, 
+                    /*out*/ unsigned long * wsize_32 /*size in bytes*/,
+                    /*out*/ unsigned long * wsize_64 /*size in bytes*/);
+  unsigned long (*deserialize)(void * dst);
+};
+
+#define custom_finalize_default NULL
+CAMLextern int custom_compare_default(value v1, value v2);
+#define custom_hash_default NULL
+CAMLextern void custom_serialize_default(value v, unsigned long * wsize_32,
+                                         unsigned long * wsize_64);
+#define custom_deserialize_default NULL
+
+#define Custom_ops_val(v) (*((struct custom_operations **) (v)))
+
+CAMLextern value alloc_custom(struct custom_operations * ops,
+                              unsigned long size, /*size in bytes*/
+                              mlsize_t mem, /*resources consumed*/
+                              mlsize_t max  /*max resources*/);
+
+CAMLextern void register_custom_operations(struct custom_operations * ops);
+extern struct custom_operations * find_custom_operations(char * ident);
+extern struct custom_operations * final_custom_operations(void (*fn)(value));
+
+extern void init_custom_operations(void);
+
+#endif
diff --git a/byterun/debugger.c b/byterun/debugger.c
new file mode 100644
index 0000000000..d650f2a7b8
--- /dev/null
+++ b/byterun/debugger.c
@@ -0,0 +1,334 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Interface with the debugger */
+
+#include <string.h>
+
+#include "config.h"
+#include "debugger.h"
+#include "fail.h"
+#include "fix_code.h"
+#include "instruct.h"
+#include "intext.h"
+#include "io.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "stacks.h"
+#include "sys.h"
+
+int debugger_in_use = 0;
+unsigned long event_count;
+
+#if !defined(HAS_SOCKETS) || defined(_WIN32)
+
+void debugger_init(void)
+{
+}
+
+void debugger(enum event_kind event)
+{
+}
+
+#else
+
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#include <sys/types.h>
+#include <sys/wait.h>
+#include <sys/socket.h>
+#include <sys/un.h>
+#include <netinet/in.h>
+#include <arpa/inet.h>
+#include <netdb.h>
+
+static int sock_domain;         /* Socket domain for the debugger */
+static union {                  /* Socket address for the debugger */
+  struct sockaddr s_gen;
+  struct sockaddr_un s_unix;
+  struct sockaddr_in s_inet;
+} sock_addr;
+static int sock_addr_len;       /* Length of sock_addr */
+
+static int dbg_socket = -1;     /* The socket connected to the debugger */
+static struct channel * dbg_in; /* Input channel on the socket */
+static struct channel * dbg_out;/* Output channel on the socket */
+
+static void open_connection(void)
+{
+  dbg_socket = socket(sock_domain, SOCK_STREAM, 0);
+  if (dbg_socket == -1 ||
+      connect(dbg_socket, &sock_addr.s_gen, sock_addr_len) == -1)
+    fatal_error("cannot connect to debugger");
+  dbg_in = open_descriptor_in(dbg_socket);
+  dbg_out = open_descriptor_out(dbg_socket);
+  if (!debugger_in_use) putword(dbg_out, -1); /* first connection */
+  putword(dbg_out, getpid());
+  flush(dbg_out);
+}
+
+static void close_connection(void)
+{
+  close_channel(dbg_in);
+  close_channel(dbg_out);
+  dbg_socket = -1;              /* was closed by close_channel */
+}
+
+void debugger_init(void)
+{
+  char * address;
+  char * port, * p;
+  struct hostent * host;
+  int n;
+
+  address = getenv("CAML_DEBUG_SOCKET");
+  if (address == NULL) return;
+
+  /* Parse the address */
+  port = NULL;
+  for (p = address; *p != 0; p++) {
+    if (*p == ':') { *p = 0; port = p+1; break; }
+  }
+  if (port == NULL) {
+    /* Unix domain */
+    sock_domain = PF_UNIX;
+    sock_addr.s_unix.sun_family = AF_UNIX;
+    strncpy(sock_addr.s_unix.sun_path, address,
+            sizeof(sock_addr.s_unix.sun_path));
+    sock_addr_len = 
+      ((char *)&(sock_addr.s_unix.sun_path) - (char *)&(sock_addr.s_unix))
+        + strlen(address);
+  } else {
+    /* Internet domain */
+    sock_domain = PF_INET;
+    for (p = (char *) &sock_addr.s_inet, n = sizeof(sock_addr.s_inet);
+         n > 0; n--) *p++ = 0;
+    sock_addr.s_inet.sin_family = AF_INET;
+    sock_addr.s_inet.sin_addr.s_addr = inet_addr(address);
+    if (sock_addr.s_inet.sin_addr.s_addr == -1) {
+      host = gethostbyname(address);
+      if (host == NULL)
+        fatal_error_arg("Unknown debugging host %s\n", address);
+      memmove(&sock_addr.s_inet.sin_addr, host->h_addr, host->h_length);
+    }
+    sock_addr.s_inet.sin_port = htons(atoi(port));
+    sock_addr_len = sizeof(sock_addr.s_inet);
+  }
+  open_connection();
+  debugger_in_use = 1;
+  trap_barrier = stack_high;
+}
+
+static value getval(struct channel *chan)
+{
+  value res;
+  if (really_getblock(chan, (char *) &res, sizeof(res)) == 0)
+    raise_end_of_file(); /* Bad, but consistent with getword */
+  return res;
+}
+
+static void putval(struct channel *chan, value val)
+{
+  really_putblock(chan, (char *) &val, sizeof(val));
+}
+
+static void safe_output_value(struct channel *chan, value val)
+{
+  struct longjmp_buffer raise_buf, * saved_external_raise;
+
+  /* Catch exceptions raised by output_val */
+  saved_external_raise = external_raise;
+  if (sigsetjmp(raise_buf.buf, 0) == 0) {
+    external_raise = &raise_buf;
+    output_val(chan, val, Val_unit);
+  } else {
+    /* Send wrong magic number, will cause input_value to fail */
+    really_putblock(chan, "\000\000\000\000", 4);
+  }
+  external_raise = saved_external_raise;
+}
+
+#define Pc(sp) ((code_t)((sp)[0]))
+#define Env(sp) ((sp)[1])
+#define Extra_args(sp) (Long_val(((sp)[2])))
+#define Locals(sp) ((sp) + 3)
+
+void debugger(enum event_kind event)
+{
+  int frame_number;
+  value * frame;
+  long i, pos;
+  value val;
+
+  if (dbg_socket == -1) return;  /* Not connected to a debugger. */
+
+  /* Reset current frame */
+  frame_number = 0;
+  frame = extern_sp + 1;
+
+  /* Report the event to the debugger */
+  switch(event) {
+  case PROGRAM_START:           /* Nothing to report */
+    goto command_loop;
+  case EVENT_COUNT:
+    putch(dbg_out, REP_EVENT);
+    break;
+  case BREAKPOINT:
+    putch(dbg_out, REP_BREAKPOINT);
+    break;
+  case PROGRAM_EXIT:
+    putch(dbg_out, REP_EXITED);
+    break;
+  case TRAP_BARRIER:
+    putch(dbg_out, REP_TRAP);
+    break;
+  case UNCAUGHT_EXC:
+    putch(dbg_out, REP_UNCAUGHT_EXC);
+    break;
+  }
+  putword(dbg_out, event_count);
+  if (event == EVENT_COUNT || event == BREAKPOINT) {
+    putword(dbg_out, stack_high - frame);
+    putword(dbg_out, (Pc(frame) - start_code) * sizeof(opcode_t));
+  } else {
+    /* No PC and no stack frame associated with other events */
+    putword(dbg_out, 0);
+    putword(dbg_out, 0);
+  }
+  flush(dbg_out);
+
+ command_loop:
+  
+  /* Read and execute the commands sent by the debugger */
+  while(1) {
+    switch(getch(dbg_in)) {
+    case REQ_SET_EVENT:
+      pos = getword(dbg_in);
+      Assert (pos >= 0);
+      Assert (pos < code_size);
+      set_instruction(start_code + pos / sizeof(opcode_t), EVENT);
+      break;
+    case REQ_SET_BREAKPOINT:
+      pos = getword(dbg_in);
+      Assert (pos >= 0);
+      Assert (pos < code_size);
+      set_instruction(start_code + pos / sizeof(opcode_t), BREAK);
+      break;
+    case REQ_RESET_INSTR:
+      pos = getword(dbg_in);
+      Assert (pos >= 0);
+      Assert (pos < code_size);
+      pos = pos / sizeof(opcode_t);
+      set_instruction(start_code + pos, saved_code[pos]);
+      break;
+    case REQ_CHECKPOINT:
+      i = fork();
+      if (i == 0) {
+        close_connection();     /* Close parent connection. */
+        open_connection();      /* Open new connection with debugger */
+      } else {
+        putword(dbg_out, i);
+        flush(dbg_out);
+      }
+      break;
+    case REQ_GO:
+      event_count = getword(dbg_in);
+      return;
+    case REQ_STOP:
+      exit(0);
+      break;
+    case REQ_WAIT:
+      wait(NULL);
+      break;
+    case REQ_INITIAL_FRAME:
+      frame = extern_sp + 1;
+      /* Fall through */
+    case REQ_GET_FRAME:
+      putword(dbg_out, stack_high - frame);
+      putword(dbg_out, (Pc(frame) - start_code) * sizeof(opcode_t));
+      flush(dbg_out);
+      break;
+    case REQ_SET_FRAME:
+      i = getword(dbg_in);
+      frame = stack_high - i;
+      break;
+    case REQ_UP_FRAME:
+      i = getword(dbg_in);
+      if (frame + Extra_args(frame) + i + 3 >= stack_high) {
+        putword(dbg_out, -1);
+      } else {
+        frame += Extra_args(frame) + i + 3;
+        putword(dbg_out, stack_high - frame);
+        putword(dbg_out, (Pc(frame) - start_code) * sizeof(opcode_t));
+      }
+      flush(dbg_out);
+      break;
+    case REQ_SET_TRAP_BARRIER:
+      i = getword(dbg_in);
+      trap_barrier = stack_high - i;
+      break;
+    case REQ_GET_LOCAL:
+      i = getword(dbg_in);
+      putval(dbg_out, Locals(frame)[i]);
+      flush(dbg_out);
+      break;
+    case REQ_GET_ENVIRONMENT:
+      i = getword(dbg_in);
+      putval(dbg_out, Field(Env(frame), i));
+      flush(dbg_out);
+      break;
+    case REQ_GET_GLOBAL:
+      i = getword(dbg_in);
+      putval(dbg_out, Field(global_data, i));
+      flush(dbg_out);
+      break;
+    case REQ_GET_ACCU:
+      putval(dbg_out, *extern_sp);
+      flush(dbg_out);
+      break;
+    case REQ_GET_HEADER:
+      val = getval(dbg_in);
+      putword(dbg_out, Hd_val(val));
+      flush(dbg_out);
+      break;
+    case REQ_GET_FIELD:
+      val = getval(dbg_in);
+      i = getword(dbg_in);
+      if (Tag_val(val) != Double_array_tag) {
+        putch(dbg_out, 0);
+        putval(dbg_out, Field(val, i));
+      } else {
+        double d = Double_field(val, i);
+        putch(dbg_out, 1);
+        really_putblock(dbg_out, (char *) &d, 8);
+      }
+      flush(dbg_out);
+      break;
+    case REQ_MARSHAL_OBJ:
+      val = getval(dbg_in);
+      safe_output_value(dbg_out, val);
+      flush(dbg_out);
+      break;
+    case REQ_GET_CLOSURE_CODE:
+      val = getval(dbg_in);
+      putword(dbg_out, (Code_val(val) - start_code) * sizeof(opcode_t));
+      flush(dbg_out);
+      break;
+    }
+  }
+}
+
+#endif
diff --git a/byterun/debugger.h b/byterun/debugger.h
new file mode 100644
index 0000000000..a91f0d33a8
--- /dev/null
+++ b/byterun/debugger.h
@@ -0,0 +1,112 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Interface with the debugger */
+
+#ifndef _debugger_
+#define _debugger_
+
+#include "misc.h"
+#include "mlvalues.h"
+
+extern int debugger_in_use;
+extern int running;
+extern unsigned long event_count;
+
+enum event_kind {
+  EVENT_COUNT, BREAKPOINT, PROGRAM_START, PROGRAM_EXIT,
+  TRAP_BARRIER, UNCAUGHT_EXC
+};
+
+void debugger_init (void);
+void debugger (enum event_kind event);
+
+/* Communication protocol */
+
+/* Requests from the debugger to the runtime system */
+
+enum debugger_request {
+  REQ_SET_EVENT = 'e',          /* uint32 pos */
+  /* Set an event on the instruction at position pos */
+  REQ_SET_BREAKPOINT = 'B',     /* uint32 pos, (char k) */
+  /* Set a breakpoint at position pos */
+  /* In profiling mode, the breakpoint kind is set to k */
+  REQ_RESET_INSTR = 'i',        /* uint32 pos */
+  /* Clear an event or breapoint at position pos, restores initial instr. */
+  REQ_CHECKPOINT = 'c',         /* no args */
+  /* Checkpoint the runtime system by forking a child process. 
+     Reply is pid of child process or -1 if checkpoint failed. */
+  REQ_GO = 'g',                 /* uint32 n */
+  /* Run the program for n events.
+     Reply is one of debugger_reply described below. */
+  REQ_STOP = 's',               /* no args */
+  /* Terminate the runtime system */
+  REQ_WAIT = 'w',               /* no args */
+  /* Reap one dead child (a discarded checkpoint). */
+  REQ_INITIAL_FRAME = '0',      /* no args */
+  /* Set current frame to bottom frame (the one currently executing).
+     Reply is stack offset and current pc. */
+  REQ_GET_FRAME = 'f',          /* no args */
+  /* Return current frame location (stack offset + current pc). */
+  REQ_SET_FRAME = 'S',          /* uint32 stack_offset */
+  /* Set current frame to given stack offset. No reply. */
+  REQ_UP_FRAME = 'U',           /* uint32 n */
+  /* Move one frame up. Argument n is size of current frame (in words).
+     Reply is stack offset and current pc, or -1 if top of stack reached. */
+  REQ_SET_TRAP_BARRIER = 'b',   /* uint32 offset */
+  /* Set the trap barrier at the given offset. */
+  REQ_GET_LOCAL = 'L',          /* uint32 slot_number */
+  /* Return the local variable at the given slot in the current frame.
+     Reply is one value. */
+  REQ_GET_ENVIRONMENT = 'E',    /* uint32 slot_number */
+  /* Return the local variable at the given slot in the heap environment
+     of the current frame. Reply is one value. */
+  REQ_GET_GLOBAL = 'G',         /* uint32 global_number */
+  /* Return the specified global variable. Reply is one value. */
+  REQ_GET_ACCU = 'A',           /* no args */
+  /* Return the current contents of the accumulator. Reply is one value. */
+  REQ_GET_HEADER = 'H',         /* mlvalue v */
+  /* As REQ_GET_OBJ, but sends only the header. */
+  REQ_GET_FIELD = 'F',          /* mlvalue v, uint32 fieldnum */
+  /* As REQ_GET_OBJ, but sends only one field. */
+  REQ_MARSHAL_OBJ = 'M',        /* mlvalue v */
+  /* Send a copy of the data structure rooted at v, using the same
+     format as output_value. */
+  REQ_GET_CLOSURE_CODE = 'C'    /* mlvalue v */
+  /* Send the code address of the given closure.
+     Reply is one uint32. */
+};
+
+/* Replies to a REQ_GO request. All replies are followed by three uint32:
+   - the value of the event counter
+   - the position of the stack
+   - the current pc. */
+
+enum debugger_reply {
+  REP_EVENT = 'e',
+  /* Event counter reached 0. */
+  REP_BREAKPOINT = 'b',
+  /* Breakpoint hit. */
+  REP_EXITED = 'x',
+  /* Program exited by calling exit or reaching the end of the source. */
+  REP_TRAP = 's',
+  /* Trap barrier crossed. */
+  REP_UNCAUGHT_EXC = 'u'
+  /* Program exited due to a stray exception. */
+};
+
+#endif
+
+
diff --git a/byterun/dynlink.c b/byterun/dynlink.c
new file mode 100644
index 0000000000..907de1a3ce
--- /dev/null
+++ b/byterun/dynlink.c
@@ -0,0 +1,240 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 2000 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Dynamic loading of C primitives. */
+
+#include <stddef.h>
+#include <stdlib.h>
+#include <string.h>
+#include <fcntl.h>
+#include <sys/stat.h>
+#include "config.h"
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#include "alloc.h"
+#include "dynlink.h"
+#include "fail.h"
+#include "mlvalues.h"
+#include "memory.h"
+#include "misc.h"
+#include "osdeps.h"
+#include "prims.h"
+
+#ifndef NATIVE_CODE
+
+/* The table of primitives */
+struct ext_table prim_table;
+
+/* The table of shared libraries currently opened */
+static struct ext_table shared_libs;
+
+/* The search path for shared libraries */
+struct ext_table shared_libs_path;
+
+/* Look up the given primitive name in the built-in primitive table,
+   then in the opened shared libraries (shared_libs) */
+static c_primitive lookup_primitive(char * name)
+{
+  int i;
+  void * res;
+
+  for (i = 0; names_of_builtin_cprim[i] != NULL; i++) {
+    if (strcmp(name, names_of_builtin_cprim[i]) == 0)
+      return builtin_cprim[i];
+  }
+  for (i = 0; i < shared_libs.size; i++) {
+    res = caml_dlsym(shared_libs.contents[i], name);
+    if (res != NULL) return (c_primitive) res;
+  }
+  return NULL;
+}
+
+/* Parse the OCAML_STDLIB_DIR/ld.conf file and add the directories
+   listed there to the search path */
+
+#define LD_CONF_NAME "ld.conf"
+
+static char * parse_ld_conf(void)
+{
+  char * stdlib, * ldconfname, * config, * p, * q;
+  struct stat st;
+  int ldconf, nread;
+
+  stdlib = getenv("OCAMLLIB");
+  if (stdlib == NULL) stdlib = getenv("CAMLLIB");
+  if (stdlib == NULL) stdlib = OCAML_STDLIB_DIR;
+  ldconfname = stat_alloc(strlen(stdlib) + 2 + sizeof(LD_CONF_NAME));
+  strcpy(ldconfname, stdlib);
+  strcat(ldconfname, "/" LD_CONF_NAME);
+  if (stat(ldconfname, &st) == -1) {
+    stat_free(ldconfname);
+    return NULL;
+  }
+  ldconf = open(ldconfname, O_RDONLY, 0);
+  if (ldconf == -1)
+    fatal_error_arg("Fatal error: cannot read loader config file %s\n",
+                    ldconfname);
+  config = stat_alloc(st.st_size + 1);
+  nread = read(ldconf, config, st.st_size);
+  if (nread == -1) 
+    fatal_error_arg("Fatal error: error while reading loader config file %s\n",
+                    ldconfname);
+  config[nread] = 0;
+  q = config;
+  for (p = config; *p != 0; p++) {
+    if (*p == '\n') {
+      *p = 0;
+      ext_table_add(&shared_libs_path, q);
+      q = p + 1;
+    }
+  }
+  if (q < p) ext_table_add(&shared_libs_path, q);
+  close(ldconf);
+  stat_free(ldconfname);
+  return config;
+}
+
+/* Open the given shared library and add it to shared_libs.
+   Abort on error. */
+static void open_shared_lib(char * name)
+{
+  char * realname;
+  void * handle;
+
+  realname = search_dll_in_path(&shared_libs_path, name);
+  gc_message(0x100, "Loading shared library %s\n", (unsigned long) realname);
+  handle = caml_dlopen(realname);
+  if (handle == NULL)
+    fatal_error_arg2("Fatal error: cannot load shared library %s\n", name,
+                     "Reason: %s\n", caml_dlerror());
+  ext_table_add(&shared_libs, handle);
+  stat_free(realname);
+}
+
+/* Build the table of primitives, given a search path and a list
+   of shared libraries (both 0-separated in a char array).
+   Abort the runtime system on error. */
+void build_primitive_table(char * lib_path,
+                           char * libs,
+                           char * req_prims)
+{
+  char * tofree1, * tofree2;
+  char * p;
+
+  /* Initialize the search path for dynamic libraries:
+     - directories specified on the command line with the -I option
+     - directories specified in the CAML_LD_LIBRARY_PATH
+     - directories specified in the executable
+     - directories specified in the file <stdlib>/ld.conf */
+  tofree1 = decompose_path(&shared_libs_path, getenv("CAML_LD_LIBRARY_PATH"));
+  if (lib_path != NULL)
+    for (p = lib_path; *p != 0; p += strlen(p) + 1)
+      ext_table_add(&shared_libs_path, p);
+  tofree2 = parse_ld_conf();
+  /* Open the shared libraries */
+  ext_table_init(&shared_libs, 8);
+  if (libs != NULL)
+    for (p = libs; *p != 0; p += strlen(p) + 1)
+      open_shared_lib(p);
+  /* Build the primitive table */
+  ext_table_init(&prim_table, 0x180);
+  for (p = req_prims; *p != 0; p += strlen(p) + 1) {
+    c_primitive prim = lookup_primitive(p);
+    if (prim == NULL)
+      fatal_error_arg("Fatal error: unknown C primitive `%s'\n", p);
+    ext_table_add(&prim_table, (void *) prim);
+  }
+  /* Clean up */
+  stat_free(tofree1);
+  stat_free(tofree2);
+  ext_table_free(&shared_libs_path, 0);
+}
+
+#endif
+
+/** dlopen interface for the bytecode linker **/
+
+#define Handle_val(v) (*((void **) (v)))
+
+CAMLprim value dynlink_open_lib(value filename)
+{
+  void * handle;
+  value result;
+
+  handle = caml_dlopen(String_val(filename));
+  if (handle == NULL) failwith(caml_dlerror());
+  result = alloc_small(1, Abstract_tag);
+  Handle_val(result) = handle;
+  return result;
+}
+
+CAMLprim value dynlink_close_lib(value handle)
+{
+  caml_dlclose(Handle_val(handle));
+  return Val_unit;
+}
+
+#include <stdio.h>
+CAMLprim value dynlink_lookup_symbol(value handle, value symbolname)
+{
+  void * symb;
+  value result;
+  symb = caml_dlsym(Handle_val(handle), String_val(symbolname));
+  /* printf("%s = 0x%lx\n", String_val(symbolname), symb);
+     fflush(stdout); */
+  if (symb == NULL) return Val_unit /*failwith(caml_dlerror())*/;
+  result = alloc_small(1, Abstract_tag);
+  Handle_val(result) = symb;
+  return result;
+}
+
+#ifndef NATIVE_CODE
+
+CAMLprim value dynlink_add_primitive(value handle)
+{
+  return Val_int(ext_table_add(&prim_table, Handle_val(handle)));
+}
+
+CAMLprim value dynlink_get_current_libs(value unit)
+{
+  CAMLparam0();
+  CAMLlocal1(res);
+  int i;
+
+  res = alloc_tuple(shared_libs.size);
+  for (i = 0; i < shared_libs.size; i++) {
+    value v = alloc_small(1, Abstract_tag);
+    Handle_val(v) = shared_libs.contents[i];
+    Store_field(res, i, v);
+  }
+  CAMLreturn(res);
+}
+
+#else
+
+value dynlink_add_primitive(value handle)
+{
+  invalid_argument("dynlink_add_primitive");
+  return Val_unit; /* not reached */
+}
+
+value dynlink_get_current_libs(value unit)
+{
+  invalid_argument("dynlink_get_current_libs");
+  return Val_unit; /* not reached */
+}
+
+#endif
diff --git a/byterun/dynlink.h b/byterun/dynlink.h
new file mode 100644
index 0000000000..df0ce7dfe2
--- /dev/null
+++ b/byterun/dynlink.h
@@ -0,0 +1,34 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 2000 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Dynamic loading of C primitives. */
+
+#ifndef _dynlink_
+#define _dynlink_
+
+#include "misc.h"
+
+/* Build the table of primitives, given a search path, a list
+   of shared libraries, and a list of primitive names
+   (all three 0-separated in char arrays).
+   Abort the runtime system on error. */
+extern void build_primitive_table(char * lib_path,
+                                  char * libs,
+                                  char * req_prims);
+
+/* The search path for shared libraries */
+extern struct ext_table shared_libs_path;
+
+#endif
diff --git a/byterun/exec.h b/byterun/exec.h
new file mode 100644
index 0000000000..c131d7b128
--- /dev/null
+++ b/byterun/exec.h
@@ -0,0 +1,62 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* exec.h : format of executable bytecode files */
+
+#ifndef _exec_
+#define _exec_
+
+/* Executable bytecode files are composed of a number of sections,
+   identified by 4-character names.  A table of contents at the
+   end of the file lists the section names along with their sizes,
+   in the order in which they appear in the file:
+
+   offset 0 --->  initial junk
+                  data for section 1
+                  data for section 2
+                  ...
+                  data for section N
+                  table of contents:
+                    descriptor for section 1
+                    ...
+                    descriptor for section N
+                  trailer
+ end of file --->
+*/
+
+/* Structure of t.o.c. entries
+   Numerical quantities are 32-bit unsigned integers, big endian */
+
+struct section_descriptor {
+  char name[4];                 /* Section name */
+  uint32 len;                   /* Length of data in bytes */
+};
+
+/* Structure of the trailer. */
+
+struct exec_trailer {
+  uint32 num_sections;          /* Number of sections */
+  char magic[12];               /* The magic number */
+  struct section_descriptor * section; /* Not part of file */
+};
+
+#define TRAILER_SIZE (4+12)
+
+/* Magic number for this release */
+
+#define EXEC_MAGIC "Caml1999X007"
+
+
+#endif
diff --git a/byterun/fail.c b/byterun/fail.c
new file mode 100644
index 0000000000..18a40e05c4
--- /dev/null
+++ b/byterun/fail.c
@@ -0,0 +1,137 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Raising exceptions from C. */
+
+#include "alloc.h"
+#include "fail.h"
+#include "io.h"
+#include "gc.h"
+#include "memory.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "printexc.h"
+#include "signals.h"
+#include "stacks.h"
+
+struct longjmp_buffer * external_raise = NULL;
+value exn_bucket;
+
+CAMLexport void mlraise(value v)
+{
+#ifdef DEBUG
+  extern int volatile async_signal_mode;  /* from signals.c */
+  Assert(! async_signal_mode);
+#endif
+  Unlock_exn();
+  exn_bucket = v;
+  if (external_raise == NULL) fatal_uncaught_exception(v);
+  siglongjmp(external_raise->buf, 1);
+}
+
+CAMLexport void raise_constant(value tag)
+{
+  CAMLparam1 (tag);
+  CAMLlocal1 (bucket);
+
+  bucket = alloc_small (1, 0);
+  Field(bucket, 0) = tag;
+  mlraise(bucket);
+}
+
+CAMLexport void raise_with_arg(value tag, value arg)
+{
+  CAMLparam2 (tag, arg);
+  CAMLlocal1 (bucket);
+
+  bucket = alloc_small (2, 0);
+  Field(bucket, 0) = tag;
+  Field(bucket, 1) = arg;
+  mlraise(bucket);
+}
+
+CAMLexport void raise_with_string(value tag, char *msg)
+{
+  CAMLparam1 (tag);
+  CAMLlocal1 (vmsg);
+
+  vmsg = copy_string(msg);
+  raise_with_arg(tag, vmsg);
+}
+
+CAMLexport void failwith (char *msg)
+{
+  raise_with_string(Field(global_data, FAILURE_EXN), msg);
+}
+
+CAMLexport void invalid_argument (char *msg)
+{
+  raise_with_string(Field(global_data, INVALID_EXN), msg);
+}
+
+/* Problem: we can't use raise_constant, because it allocates and
+   we're out of memory... Here, we allocate statically the exn bucket
+   for Out_of_memory. */
+
+static struct {
+  header_t hdr;
+  value exn;
+} out_of_memory_bucket = { 0, 0 };
+
+CAMLexport void raise_out_of_memory(void)
+{
+  if (out_of_memory_bucket.exn == 0) 
+    fatal_error("Fatal error: out of memory while raising Out_of_memory\n");
+  mlraise((value) &(out_of_memory_bucket.exn));
+}
+
+CAMLexport void raise_stack_overflow(void)
+{
+  raise_constant(Field(global_data, STACK_OVERFLOW_EXN));
+}
+
+CAMLexport void raise_sys_error(value msg)
+{
+  raise_with_arg(Field(global_data, SYS_ERROR_EXN), msg);
+}
+
+CAMLexport void raise_end_of_file(void)
+{
+  raise_constant(Field(global_data, END_OF_FILE_EXN));
+}
+
+CAMLexport void raise_zero_divide(void)
+{
+  raise_constant(Field(global_data, ZERO_DIVIDE_EXN));
+}
+
+CAMLexport void raise_not_found(void)
+{
+  raise_constant(Field(global_data, NOT_FOUND_EXN));
+}
+
+CAMLexport void raise_sys_blocked_io(void)
+{
+  raise_constant(Field(global_data, SYS_BLOCKED_IO));
+}
+
+/* Initialization of statically-allocated exception buckets */
+
+void init_exceptions(void)
+{
+  out_of_memory_bucket.hdr = Make_header(1, 0, Caml_white);
+  out_of_memory_bucket.exn = Field(global_data, OUT_OF_MEMORY_EXN);
+  register_global_root(&out_of_memory_bucket.exn);
+}
diff --git a/byterun/fail.h b/byterun/fail.h
new file mode 100644
index 0000000000..478a2076b0
--- /dev/null
+++ b/byterun/fail.h
@@ -0,0 +1,69 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#ifndef _fail_
+#define _fail_
+
+
+#include <setjmp.h>
+#include "misc.h"
+#include "mlvalues.h"
+
+#define OUT_OF_MEMORY_EXN 0     /* "Out_of_memory" */
+#define SYS_ERROR_EXN 1         /* "Sys_error" */
+#define FAILURE_EXN 2           /* "Failure" */
+#define INVALID_EXN 3           /* "Invalid_argument" */
+#define END_OF_FILE_EXN 4       /* "End_of_file" */
+#define ZERO_DIVIDE_EXN 5       /* "Division_by_zero" */
+#define NOT_FOUND_EXN 6         /* "Not_found" */
+#define MATCH_FAILURE_EXN 7     /* "Match_failure" */
+#define STACK_OVERFLOW_EXN 8    /* "Stack_overflow" */
+#define SYS_BLOCKED_IO 9        /* "Sys_blocked_io" */
+#define ASSERT_FAILURE_EXN 10   /* "Assert_failure" */
+
+#ifdef POSIX_SIGNALS
+struct longjmp_buffer {
+  sigjmp_buf buf;
+};
+#else
+struct longjmp_buffer {
+  jmp_buf buf;
+};
+#define sigsetjmp(buf,save) setjmp(buf)
+#define siglongjmp(buf,val) longjmp(buf,val)
+#endif
+
+CAMLextern struct longjmp_buffer * external_raise;
+extern value exn_bucket;
+
+CAMLextern void mlraise (value bucket) Noreturn;
+CAMLextern void raise_constant (value tag) Noreturn;
+CAMLextern void raise_with_arg (value tag, value arg) Noreturn;
+CAMLextern void raise_with_string (value tag, char * msg) Noreturn;
+CAMLextern void failwith (char *) Noreturn;
+CAMLextern void invalid_argument (char *) Noreturn;
+CAMLextern void raise_out_of_memory (void) Noreturn;
+CAMLextern void raise_stack_overflow (void) Noreturn;
+CAMLextern void raise_sys_error (value) Noreturn;
+CAMLextern void raise_end_of_file (void) Noreturn;
+CAMLextern void raise_zero_divide (void) Noreturn;
+CAMLextern void raise_not_found (void) Noreturn;
+CAMLextern void init_exceptions (void);
+CAMLextern void array_bound_error (void) Noreturn;
+CAMLextern void raise_sys_blocked_io (void) Noreturn;
+
+CAMLextern void (*caml_reset_sigmask)(void);
+
+#endif /* _fail_ */
diff --git a/byterun/finalise.h b/byterun/finalise.h
new file mode 100644
index 0000000000..52cb0caa8e
--- /dev/null
+++ b/byterun/finalise.h
@@ -0,0 +1,24 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*          Damien Doligez, projet Moscova, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 2000 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#include "roots.h"
+
+void final_update (void);
+void final_do_calls (void);
+void final_do_strong_roots (scanning_action f);
+void final_do_weak_roots (scanning_action f);
+void final_do_young_roots (scanning_action f);
+void final_empty_young (void);
+value final_register (value f, value v);
diff --git a/byterun/fix_code.c b/byterun/fix_code.c
new file mode 100644
index 0000000000..749bb0237c
--- /dev/null
+++ b/byterun/fix_code.c
@@ -0,0 +1,160 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Handling of blocks of bytecode (endianness switch, threading). */
+
+#include "config.h"
+#include "debugger.h"
+#include "fix_code.h"
+#include "instruct.h"
+#include "md5.h"
+#include "memory.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "reverse.h"
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+
+code_t start_code;
+asize_t code_size;
+unsigned char * saved_code;
+unsigned char code_md5[16];
+
+/* Read the main bytecode block from a file */
+
+void load_code(int fd, asize_t len)
+{
+  int i;
+  struct MD5Context ctx;
+
+  code_size = len;
+  start_code = (code_t) stat_alloc(code_size);
+  if (read(fd, (char *) start_code, code_size) != code_size)
+    fatal_error("Fatal error: truncated bytecode file.\n");
+  MD5Init(&ctx);
+  MD5Update(&ctx, (unsigned char *) start_code, code_size);
+  MD5Final(code_md5, &ctx);
+#ifdef ARCH_BIG_ENDIAN
+  fixup_endianness(start_code, code_size);
+#endif
+  if (debugger_in_use) {
+    len /= sizeof(opcode_t);
+    saved_code = (unsigned char *) stat_alloc(len);
+    for (i = 0; i < len; i++) saved_code[i] = start_code[i];
+  }
+#ifdef THREADED_CODE
+  /* Better to thread now than at the beginning of interprete(),
+     since the debugger interface needs to perform SET_EVENT requests
+     on the code. */
+  thread_code(start_code, code_size);
+#endif
+}
+
+/* This code is needed only if the processor is big endian */
+
+#ifdef ARCH_BIG_ENDIAN
+
+void fixup_endianness(code_t code, asize_t len)
+{
+  code_t p;
+  len /= sizeof(opcode_t);
+  for (p = code; p < code + len; p++) {
+    Reverse_32(p, p);
+  }
+}
+
+#endif
+
+/* This code is needed only if we're using threaded code */
+
+#ifdef THREADED_CODE
+
+char ** instr_table;
+char * instr_base;
+
+void thread_code (code_t code, asize_t len)
+{
+  code_t p;
+  int l [STOP + 1];
+  int i;
+  
+  for (i = 0; i <= STOP; i++) {
+    l [i] = 0;
+  }
+  /* Instructions with one operand */
+  l[PUSHACC] = l[ACC] = l[POP] = l[ASSIGN] =
+  l[PUSHENVACC] = l[ENVACC] = l[PUSH_RETADDR] = l[APPLY] =
+  l[APPTERM1] = l[APPTERM2] = l[APPTERM3] = l[RETURN] =
+  l[GRAB] = l[PUSHGETGLOBAL] = l[GETGLOBAL] = l[SETGLOBAL] =
+  l[PUSHATOM] = l[ATOM] = l[MAKEBLOCK1] = l[MAKEBLOCK2] =
+  l[MAKEBLOCK3] = l[MAKEFLOATBLOCK] = l[GETFIELD] =
+  l[GETFLOATFIELD] = l[SETFIELD] = l[SETFLOATFIELD] =
+  l[BRANCH] = l[BRANCHIF] = l[BRANCHIFNOT] = l[PUSHTRAP] =
+  l[C_CALL1] = l[C_CALL2] = l[C_CALL3] = l[C_CALL4] = l[C_CALL5] =
+  l[CONSTINT] = l[PUSHCONSTINT] = l[OFFSETINT] =
+  l[OFFSETREF] = l[OFFSETCLOSURE] = l[PUSHOFFSETCLOSURE] = 1;
+
+  /* Instructions with two operands */
+  l[APPTERM] = l[CLOSURE] = l[PUSHGETGLOBALFIELD] =
+  l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] =
+  l[BEQ] = l[BNEQ] = l[BLTINT] = l[BLEINT] = l[BGTINT] = l[BGEINT] =
+  l[BULTINT] = l[BUGEINT] = 2;
+  len /= sizeof(opcode_t);
+  for (p = code; p < code + len; /*nothing*/) {
+    opcode_t instr = *p;
+    if (instr < 0 || instr > STOP){
+      /*
+      fatal_error_arg ("Fatal error in fix_code: bad opcode (%lx)\n",
+                       (char *)(long)instr);
+      */
+      instr = STOP;
+    }
+    *p++ = (opcode_t)(instr_table[instr] - instr_base);
+    if (instr == SWITCH) {
+      uint32 sizes = *p++;
+      uint32 const_size = sizes & 0xFFFF;
+      uint32 block_size = sizes >> 16;
+      p += const_size + block_size;
+    } else if (instr == CLOSUREREC) {
+      uint32 nfuncs = *p++;
+      p++;                      /* skip nvars */
+      p += nfuncs;
+    } else {
+      p += l[instr];
+    }
+  }
+  Assert(p == code + len);
+}
+
+#endif /* THREADED_CODE */
+
+void set_instruction(code_t pos, opcode_t instr)
+{
+#ifdef THREADED_CODE
+  *pos = (opcode_t)(instr_table[instr] - instr_base);
+#else
+  *pos = instr;
+#endif
+}
+
+int is_instruction(opcode_t instr1, opcode_t instr2)
+{
+#ifdef THREADED_CODE
+  return instr1 == (opcode_t)(instr_table[instr2] - instr_base);
+#else
+  return instr1 == instr2;
+#endif
+}
diff --git a/byterun/fix_code.h b/byterun/fix_code.h
new file mode 100644
index 0000000000..463eff1ad0
--- /dev/null
+++ b/byterun/fix_code.h
@@ -0,0 +1,42 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Handling of blocks of bytecode (endianness switch, threading). */
+
+#ifndef _fix_code_
+#define _fix_code_
+
+
+#include "config.h"
+#include "misc.h"
+#include "mlvalues.h"
+
+extern code_t start_code;
+extern asize_t code_size;
+extern unsigned char * saved_code;
+extern unsigned char code_md5[16];
+
+void load_code (int fd, asize_t len);
+void fixup_endianness (code_t code, asize_t len);
+void set_instruction (code_t pos, opcode_t instr);
+int is_instruction (opcode_t instr1, opcode_t instr2);
+
+#ifdef THREADED_CODE
+extern char ** instr_table;
+extern char * instr_base;
+void thread_code (code_t code, asize_t len);
+#endif
+
+#endif
diff --git a/byterun/freelist.c b/byterun/freelist.c
new file mode 100644
index 0000000000..af103baf8c
--- /dev/null
+++ b/byterun/freelist.c
@@ -0,0 +1,275 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*             Damien Doligez, projet Para, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#include "config.h"
+#include "freelist.h"
+#include "gc.h"
+#include "gc_ctrl.h"
+#include "major_gc.h"
+#include "misc.h"
+#include "mlvalues.h"
+
+/* The free-list is kept sorted by increasing addresses.
+   This makes the merging of adjacent free blocks possible.
+   (See [fl_merge_block].)
+*/
+
+typedef struct {
+  char *next_bp;   /* Pointer to the first byte of the next block. */
+} block;
+
+/* The sentinel can be located anywhere in memory, but it must not be
+   adjacent to any heap object. */
+static struct {
+  value filler1; /* Make sure the sentinel is never adjacent to any block. */
+  header_t h;
+  value first_bp;
+  value filler2; /* Make sure the sentinel is never adjacent to any block. */
+} sentinel = {0, Make_header (0, 0, Caml_blue), 0, 0};
+
+#define Fl_head ((char *) (&(sentinel.first_bp)))
+static char *fl_prev = Fl_head;  /* Current allocation pointer. */
+static char *fl_last = NULL;     /* Last block in the list.  Only valid
+                                    just after fl_allocate returned NULL. */
+char *fl_merge = Fl_head;        /* Current insertion pointer.  Managed
+                                    jointly with [sweep_slice]. */
+asize_t fl_cur_size = 0;         /* How many free words were added since
+                                    the latest fl_init_merge. */
+
+#define Next(b) (((block *) (b))->next_bp)
+
+#ifdef DEBUG
+void fl_check (void)
+{
+  char *cur, *prev;
+  int prev_found = 0, merge_found = 0;
+
+  prev = Fl_head;
+  cur = Next (prev);
+  while (cur != NULL){
+    Assert (Is_in_heap (cur));
+    if (cur == fl_prev) prev_found = 1;
+    if (cur == fl_merge) merge_found = 1;
+    prev = cur;
+    cur = Next (prev);
+  }
+  Assert (prev_found || fl_prev == Fl_head);
+  Assert (merge_found || fl_merge == Fl_head);
+}
+#endif
+
+/* [allocate_block] is called by [fl_allocate].  Given a suitable free
+   block and the desired size, it allocates a new block from the free
+   block.  There are three cases:
+   0. The free block has the desired size.  Detach the block from the
+      free-list and return it.
+   1. The free block is 1 word longer than the desired size.  Detach
+      the block from the free list.  The remaining word cannot be linked:
+      turn it into an empty block (header only), and return the rest.
+   2. The free block is big enough.  Split it in two and return the right
+      block.
+   In all cases, the allocated block is right-justified in the free block:
+   it is located in the high-address words of the free block.  This way,
+   the linking of the free-list does not change in case 2.
+*/
+static char *allocate_block (mlsize_t wh_sz, char *prev, char *cur)
+{
+  header_t h = Hd_bp (cur);
+                                             Assert (Whsize_hd (h) >= wh_sz);
+  if (Wosize_hd (h) < wh_sz + 1){                        /* Cases 0 and 1. */
+    Next (prev) = Next (cur);
+                    Assert (Is_in_heap (Next (prev)) || Next (prev) == NULL);
+    if (fl_merge == cur) fl_merge = prev;
+#ifdef DEBUG
+    fl_last = NULL;
+#endif
+      /* In case 1, the following creates the empty block correctly.
+         In case 0, it gives an invalid header to the block.  The function
+         calling [fl_allocate] will overwrite it. */
+    Hd_op (cur) = Make_header (0, 0, Caml_white);
+  }else{                                                        /* Case 2. */
+    Hd_op (cur) = Make_header (Wosize_hd (h) - wh_sz, 0, Caml_blue);
+  }
+  fl_prev = prev;
+  return cur + Bosize_hd (h) - Bsize_wsize (wh_sz);
+}  
+
+/* [fl_allocate] does not set the header of the newly allocated block.
+   The calling function must do it before any GC function gets called.
+   [fl_allocate] returns a head pointer.
+*/
+char *fl_allocate (mlsize_t wo_sz)
+{
+  char *cur, *prev;
+                                  Assert (sizeof (char *) == sizeof (value));
+                                  Assert (fl_prev != NULL);
+                                  Assert (wo_sz >= 1);
+    /* Search from [fl_prev] to the end of the list. */
+  prev = fl_prev;
+  cur = Next (prev);
+  while (cur != NULL){                             Assert (Is_in_heap (cur));
+    if (Wosize_bp (cur) >= wo_sz){
+      return allocate_block (Whsize_wosize (wo_sz), prev, cur);
+    }
+    prev = cur;
+    cur = Next (prev);
+  }
+  fl_last = prev;
+    /* Search from the start of the list to [fl_prev]. */
+  prev = Fl_head;
+  cur = Next (prev);
+  while (prev != fl_prev){
+    if (Wosize_bp (cur) >= wo_sz){
+      return allocate_block (Whsize_wosize (wo_sz), prev, cur);
+    }
+    prev = cur;
+    cur = Next (prev);
+  }
+    /* No suitable block was found. */
+  return NULL;
+}
+
+static char *last_fragment;
+
+void fl_init_merge (void)
+{
+  last_fragment = NULL;
+  fl_merge = Fl_head;
+  fl_cur_size = 0;
+#ifdef DEBUG
+  fl_check ();
+#endif
+}
+
+/* This is called by compact_heap. */
+void fl_reset (void)
+{
+  Next (Fl_head) = 0;
+  fl_prev = Fl_head;
+  fl_init_merge ();
+}
+
+/* [fl_merge_block] returns the head pointer of the next block after [bp],
+   because merging blocks may change the size of [bp]. */
+char *fl_merge_block (char *bp)
+{
+  char *prev, *cur, *adj;
+  header_t hd = Hd_bp (bp);
+
+  fl_cur_size += Whsize_hd (hd);
+  
+#ifdef DEBUG
+  {
+    mlsize_t i;
+    for (i = 0; i < Wosize_hd (hd); i++){
+      Field (Val_bp (bp), i) = Debug_free_major;
+    }
+  }
+#endif
+  prev = fl_merge;
+  cur = Next (prev);
+  /* The sweep code makes sure that this is the right place to insert
+     this block: */
+  Assert (prev < bp || prev == Fl_head);
+  Assert (cur > bp || cur == NULL);
+
+  /* If [last_fragment] and [bp] are adjacent, merge them. */
+  if (last_fragment == Hp_bp (bp)){
+    hd = Make_header (Whsize_bp (bp), 0, Caml_white);
+    bp = last_fragment;
+    Hd_bp (bp) = hd;
+    fl_cur_size += Whsize_wosize (0);
+  }
+
+  /* If [bp] and [cur] are adjacent, remove [cur] from the free-list
+     and merge them. */
+  adj = bp + Bosize_hd (hd);
+  if (adj == Hp_bp (cur)){
+    char *next_cur = Next (cur);
+    long cur_whsz = Whsize_bp (cur);
+
+    Next (prev) = next_cur;
+    if (fl_prev == cur) fl_prev = prev;
+    hd = Make_header (Wosize_hd (hd) + cur_whsz, 0, Caml_blue);
+    Hd_bp (bp) = hd;
+    adj = bp + Bosize_hd (hd);
+#ifdef DEBUG
+    fl_last = NULL;
+    Next (cur) = (char *) Debug_free_major;
+    Hd_bp (cur) = Debug_free_major;
+#endif
+    cur = next_cur;
+  }
+  /* If [prev] and [bp] are adjacent merge them, else insert [bp] into
+     the free-list if it is big enough. */
+  if (prev + Bosize_bp (prev) == Hp_bp (bp)){
+    Hd_bp (prev) = Make_header (Wosize_bp (prev) + Whsize_hd (hd), 0,Caml_blue);
+#ifdef DEBUG
+    Hd_bp (bp) = Debug_free_major;
+#endif
+    Assert (fl_merge == prev);
+  }else if (Wosize_hd (hd) != 0){
+    Hd_bp (bp) = Bluehd_hd (hd);
+    Next (bp) = cur;
+    Next (prev) = bp;
+    fl_merge = bp;
+  }else{
+    /* This is a fragment.  Leave it in white but remember it for eventual
+       merging with the next block. */
+    last_fragment = bp;
+  }
+  return adj;
+}
+
+/* This is a heap extension.  We have to insert it in the right place
+   in the free-list.
+   [fl_add_block] can only be called just after a call to [fl_allocate]
+   that returned NULL.
+   Most of the heap extensions are expected to be at the end of the
+   free list.  (This depends on the implementation of [malloc].)
+*/
+void fl_add_block (char *bp)
+{
+                                                   Assert (fl_last != NULL);
+                                            Assert (Next (fl_last) == NULL);
+#ifdef DEBUG
+  {
+    mlsize_t i;
+    for (i = 0; i < Wosize_bp (bp); i++){
+      Field (Val_bp (bp), i) = Debug_free_major;
+    }
+  }
+#endif
+  if (bp > fl_last){
+    Next (fl_last) = bp;
+    Next (bp) = NULL;
+  }else{
+    char *cur, *prev;
+
+    prev = Fl_head;
+    cur = Next (prev);
+    while (cur != NULL && cur < bp){   Assert (prev < bp || prev == Fl_head);
+      prev = cur;
+      cur = Next (prev);
+    }                                  Assert (prev < bp || prev == Fl_head);
+                                            Assert (cur > bp || cur == NULL);
+    Next (bp) = cur;
+    Next (prev) = bp;
+    /* When inserting a block between fl_merge and gc_sweep_hp, we must
+       advance fl_merge to the new block, so that fl_merge is always the
+       last free-list block before gc_sweep_hp. */
+    if (prev == fl_merge && bp <= gc_sweep_hp) fl_merge = bp;
+  }
+}
diff --git a/byterun/freelist.h b/byterun/freelist.h
new file mode 100644
index 0000000000..4d5dc3fbbb
--- /dev/null
+++ b/byterun/freelist.h
@@ -0,0 +1,34 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*             Damien Doligez, projet Para, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Free lists of heap blocks. */
+
+#ifndef _freelist_
+#define _freelist_
+
+
+#include "misc.h"
+#include "mlvalues.h"
+
+extern asize_t fl_cur_size;
+
+char *fl_allocate (mlsize_t);
+void fl_init_merge (void);
+void fl_reset (void);
+char *fl_merge_block (char *);
+void fl_add_block (char *);
+
+
+#endif /* _freelist_ */
diff --git a/byterun/gc.h b/byterun/gc.h
new file mode 100644
index 0000000000..5cafcd630b
--- /dev/null
+++ b/byterun/gc.h
@@ -0,0 +1,53 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*             Damien Doligez, projet Para, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#ifndef _gc_
+#define _gc_
+
+
+#include "mlvalues.h"
+
+#define Caml_white (0 << 8)
+#define Caml_gray  (1 << 8)
+#define Caml_blue  (2 << 8)
+#define Caml_black (3 << 8)
+
+#define Color_hd(hd) ((color_t) ((hd) & Caml_black))
+#define Color_hp(hp) Color_hd (Hd_hp (hp))
+#define Color_val(val) (Color_hd (Hd_val (val)))
+
+#define Is_white_hd(hd) (Color_hd (hd) == Caml_white)
+#define Is_gray_hd(hd) (Color_hd (hd) == Caml_gray)
+#define Is_blue_hd(hd) (Color_hd (hd) == Caml_blue)
+#define Is_black_hd(hd) (Color_hd (hd) == Caml_black)
+
+#define Whitehd_hd(hd) (((hd)  & ~Caml_black)/*| Caml_white*/)
+#define Grayhd_hd(hd)  (((hd)  & ~Caml_black)  | Caml_gray)
+#define Blackhd_hd(hd) (((hd)/*& ~Caml_black*/)| Caml_black)
+#define Bluehd_hd(hd)  (((hd)  & ~Caml_black)  | Caml_blue)
+
+/* This depends on the layout of the header.  See [mlvalues.h]. */
+#define Make_header(wosize, tag, color)                                       \
+       ((header_t) (((header_t) (wosize) << 10)                               \
+                    + (color)                                                 \
+                    + (tag_t) (tag)))
+
+#define Is_white_val(val) (Color_val(val) == Caml_white)
+#define Is_gray_val(val) (Color_val(val) == Caml_gray)
+#define Is_blue_val(val) (Color_val(val) == Caml_blue)
+#define Is_black_val(val) (Color_val(val) == Caml_black)
+
+
+#endif /* _gc_ */
diff --git a/byterun/globroots.c b/byterun/globroots.c
new file mode 100644
index 0000000000..2dc55c317d
--- /dev/null
+++ b/byterun/globroots.c
@@ -0,0 +1,129 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*           Xavier Leroy, projet Cristal, INRIA Rocquencourt          */
+/*                                                                     */
+/*  Copyright 2001 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Registration of global memory roots */
+
+#include "memory.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "globroots.h"
+
+/* The set of global memory roots is represented as a skip list
+   (see William Pugh, "Skip lists: a probabilistic alternative to
+   balanced binary trees", Comm. ACM 33(6), 1990). */
+
+/* Generate a random level for a new node: 0 with probability 3/4,
+   1 with probability 3/16, 2 with probability 3/64, etc.
+   We use a simple linear congruential PRNG (see Knuth vol 2) instead
+   of random(), because we need exactly 32 bits of pseudo-random data
+   (i.e. 2 * (MAX_LEVEL + 1)).  Moreover, the congruential PRNG 
+   is faster and guaranteed to be deterministic (to reproduce bugs). */
+
+static uint32 random_seed = 0;
+
+static int random_level(void)
+{
+  uint32 r;
+  int level = 0;
+
+  /* Linear congruence with modulus = 2^32, multiplier = 69069
+     (Knuth vol 2 p. 106, line 15 of table 1), additive = 25173. */
+  r = random_seed = random_seed * 69069 + 25173;
+  /* Knuth (vol 2 p. 13) shows that the least significant bits are
+     "less random" than the most significant bits with a modulus of 2^m,
+     so consume most significant bits first */
+  while ((r & 0xC0000000U) == 0xC0000000U) { level++; r = r << 2; }
+  Assert(level <= MAX_LEVEL);
+  return level;
+}
+
+/* The initial global root list */
+
+struct global_root_list caml_global_roots = { NULL, { NULL, }, 0 };
+
+/* Register a global C root */
+
+void register_global_root(value *r)
+{
+  struct global_root * update[MAX_LEVEL];
+  struct global_root * e, * f;
+  int i, new_level;
+  
+  Assert (((long) r & 3) == 0);  /* compact.c demands this (for now) */
+
+  /* Init "cursor" to list head */
+  e = (struct global_root *) &caml_global_roots;
+  /* Find place to insert new node */
+  for (i = caml_global_roots.level; i >= 0; i--) {
+    while (1) {
+      f = e->forward[i];
+      if (f == NULL || f->root >= r) break;
+      e = f;
+    }
+    update[i] = e;
+  }
+  e = e->forward[0];
+  /* If already present, don't do anything */
+  if (e != NULL && e->root == r) return;
+  /* Insert additional element, updating list level if necessary */
+  new_level = random_level();
+  if (new_level > caml_global_roots.level) {
+    for (i = caml_global_roots.level + 1; i <= new_level; i++)
+      update[i] = (struct global_root *) &caml_global_roots;
+    caml_global_roots.level = new_level;
+  }
+  e = stat_alloc(sizeof(struct global_root) +
+                 new_level * sizeof(struct global_root *));
+  e->root = r;
+  for (i = 0; i <= new_level; i++) {
+    e->forward[i] = update[i]->forward[i];
+    update[i]->forward[i] = e;
+  }
+}
+
+/* Un-register a global C root */
+
+void remove_global_root(value *r)
+{
+  struct global_root * update[MAX_LEVEL];
+  struct global_root * e, * f;
+  int i;
+
+  /* Init "cursor" to list head */
+  e = (struct global_root *) &caml_global_roots;
+  /* Find element in list */
+  for (i = caml_global_roots.level; i >= 0; i--) {
+    while (1) {
+      f = e->forward[i];
+      if (f == NULL || f->root >= r) break;
+      e = f;
+    }
+    update[i] = e;
+  }
+  e = e->forward[0];
+  /* If not found, nothing to do */
+  if (e == NULL || e->root != r) return;
+  /* Rebuild list without node */
+  for (i = 0; i <= caml_global_roots.level; i++) {
+    if (update[i]->forward[i] == e)
+      update[i]->forward[i] = e->forward[i];
+  }
+  /* Reclaim list element */
+  stat_free(e);
+  /* Down-correct list level */
+  while (caml_global_roots.level > 0 && 
+         caml_global_roots.forward[caml_global_roots.level] == NULL)
+    caml_global_roots.level--;
+}
diff --git a/byterun/globroots.h b/byterun/globroots.h
new file mode 100644
index 0000000000..f3c68a4b75
--- /dev/null
+++ b/byterun/globroots.h
@@ -0,0 +1,40 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*           Xavier Leroy, projet Cristal, INRIA Rocquencourt          */
+/*                                                                     */
+/*  Copyright 2001 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Registration of global memory roots */
+
+#ifndef _globroots_
+#define _globroots_
+
+#include "mlvalues.h"
+
+/* Skip list structure */
+
+struct global_root {
+  value * root;                    /* the address of the root */
+  struct global_root * forward[1]; /* variable-length array */
+};
+
+#define MAX_LEVEL 15
+
+struct global_root_list {
+  value * root;                 /* dummy value for layout compatibility */
+  struct global_root * forward[MAX_LEVEL]; /* forward chaining */
+  int level;                    /* max used level */
+};
+
+extern struct global_root_list caml_global_roots;
+
+#endif /* _globroots */
diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c
new file mode 100644
index 0000000000..e684fd5761
--- /dev/null
+++ b/byterun/instrtrace.c
@@ -0,0 +1,72 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Trace the instructions executed */
+
+#ifdef DEBUG
+
+#include <stdio.h>
+#include "instruct.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "opnames.h"
+
+extern code_t start_code;
+extern char * names_of_builtin_cprim[];
+
+long icount = 0;
+
+void stop_here () {}
+
+int trace_flag = 0;
+
+void disasm_instr(pc)
+     code_t pc;
+{
+  int instr = *pc;
+  printf("%6ld  %s", (long) (pc - start_code),
+         instr < 0 || instr > STOP ? "???" : names_of_instructions[instr]);
+  pc++;
+  switch(instr) {
+    /* Instructions with one integer operand */
+  case PUSHACC: case ACC: case POP: case ASSIGN:
+  case PUSHENVACC: case ENVACC: case PUSH_RETADDR: case APPLY:
+  case APPTERM1: case APPTERM2: case APPTERM3: case RETURN:
+  case GRAB: case PUSHGETGLOBAL: case GETGLOBAL: case SETGLOBAL:
+  case PUSHATOM: case ATOM: case MAKEBLOCK1: case MAKEBLOCK2:
+  case MAKEBLOCK3: case MAKEFLOATBLOCK:
+  case GETFIELD: case SETFIELD: case GETFLOATFIELD: case SETFLOATFIELD:
+  case BRANCH: case BRANCHIF: case BRANCHIFNOT: case PUSHTRAP:
+  case CONSTINT: case PUSHCONSTINT: case OFFSETINT: case OFFSETREF:
+  case OFFSETCLOSURE: case PUSHOFFSETCLOSURE:
+    printf(" %d\n", pc[0]); break;
+    /* Instructions with two operands */
+  case APPTERM: case CLOSURE: case CLOSUREREC: case PUSHGETGLOBALFIELD:
+  case GETGLOBALFIELD: case MAKEBLOCK:
+  case BEQ: case BNEQ: case BLTINT: case BLEINT: case BGTINT: case BGEINT: 
+  case BULTINT: case BUGEINT:
+    printf(" %d, %d\n", pc[0], pc[1]); break;
+    /* Instructions with a C primitive as operand */
+  case C_CALL1: case C_CALL2: case C_CALL3: case C_CALL4: case C_CALL5:
+    printf(" %s\n", names_of_builtin_cprim[pc[0]]); break; /* REVISE */
+  case C_CALLN:
+    printf(" %d, %s\n", pc[0], names_of_builtin_cprim[pc[1]]); break;
+  default:
+    printf("\n");
+  }
+  fflush (stdout);
+}
+
+#endif
diff --git a/byterun/instrtrace.h b/byterun/instrtrace.h
new file mode 100644
index 0000000000..b65aca87b1
--- /dev/null
+++ b/byterun/instrtrace.h
@@ -0,0 +1,31 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Trace the instructions executed */
+
+#ifndef _instrtrace_
+#define _instrtrace_
+
+
+#include "mlvalues.h"
+#include "misc.h"
+
+extern int trace_flag;
+extern long icount;
+void stop_here (void);
+void disasm_instr (code_t pc);
+
+
+#endif
diff --git a/byterun/instruct.h b/byterun/instruct.h
new file mode 100644
index 0000000000..222d3c6f13
--- /dev/null
+++ b/byterun/instruct.h
@@ -0,0 +1,55 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* The instruction set. */
+
+enum instructions {
+  ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7,
+  ACC, PUSH,
+  PUSHACC0, PUSHACC1, PUSHACC2, PUSHACC3,
+  PUSHACC4, PUSHACC5, PUSHACC6, PUSHACC7,
+  PUSHACC, POP, ASSIGN,
+  ENVACC1, ENVACC2, ENVACC3, ENVACC4, ENVACC,
+  PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC4, PUSHENVACC,
+  PUSH_RETADDR, APPLY, APPLY1, APPLY2, APPLY3,
+  APPTERM, APPTERM1, APPTERM2, APPTERM3, 
+  RETURN, RESTART, GRAB,
+  CLOSURE, CLOSUREREC,
+  OFFSETCLOSUREM2, OFFSETCLOSURE0, OFFSETCLOSURE2, OFFSETCLOSURE,
+  PUSHOFFSETCLOSUREM2, PUSHOFFSETCLOSURE0,
+  PUSHOFFSETCLOSURE2, PUSHOFFSETCLOSURE,
+  GETGLOBAL, PUSHGETGLOBAL, GETGLOBALFIELD, PUSHGETGLOBALFIELD, SETGLOBAL,
+  ATOM0, ATOM, PUSHATOM0, PUSHATOM,
+  MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3, MAKEFLOATBLOCK,
+  GETFIELD0, GETFIELD1, GETFIELD2, GETFIELD3, GETFIELD, GETFLOATFIELD,
+  SETFIELD0, SETFIELD1, SETFIELD2, SETFIELD3, SETFIELD, SETFLOATFIELD,
+  VECTLENGTH, GETVECTITEM, SETVECTITEM,
+  GETSTRINGCHAR, SETSTRINGCHAR,
+  BRANCH, BRANCHIF, BRANCHIFNOT, SWITCH, BOOLNOT,
+  PUSHTRAP, POPTRAP, RAISE, CHECK_SIGNALS,
+  C_CALL1, C_CALL2, C_CALL3, C_CALL4, C_CALL5, C_CALLN,
+  CONST0, CONST1, CONST2, CONST3, CONSTINT,
+  PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT,
+  NEGINT, ADDINT, SUBINT, MULINT, DIVINT, MODINT,
+  ANDINT, ORINT, XORINT, LSLINT, LSRINT, ASRINT,
+  EQ, NEQ, LTINT, LEINT, GTINT, GEINT,
+  OFFSETINT, OFFSETREF, ISINT, 
+  GETMETHOD,
+  BEQ, BNEQ,  BLTINT, BLEINT, BGTINT, BGEINT,
+  ULTINT, UGEINT,
+  BULTINT, BUGEINT,
+  STOP,
+  EVENT, BREAK
+};
diff --git a/byterun/interp.c b/byterun/interp.c
new file mode 100644
index 0000000000..599218e487
--- /dev/null
+++ b/byterun/interp.c
@@ -0,0 +1,1054 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* The bytecode interpreter */
+#include <stdio.h>
+#include "alloc.h"
+#include "backtrace.h"
+#include "callback.h"
+#include "debugger.h"
+#include "fail.h"
+#include "fix_code.h"
+#include "instrtrace.h"
+#include "instruct.h"
+#include "interp.h"
+#include "major_gc.h"
+#include "memory.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "prims.h"
+#include "signals.h"
+#include "stacks.h"
+
+/* Registers for the abstract machine:
+        pc         the code pointer
+        sp         the stack pointer (grows downward)
+        accu       the accumulator
+        env        heap-allocated environment
+        trapsp     pointer to the current trap frame
+        extra_args number of extra arguments provided by the caller
+
+sp is a local copy of the global variable extern_sp. */
+
+/* Instruction decoding */
+
+#ifdef THREADED_CODE
+#  define Instruct(name) lbl_##name
+#  if defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32)
+#    define Jumptbl_base ((char *) &&lbl_ACC0)
+#  else
+#    define Jumptbl_base ((char *) 0)
+#    define jumptbl_base ((char *) 0)
+#  endif
+#  ifdef DEBUG
+#    define Next goto next_instr
+#  else
+#    ifdef __ia64__
+#      define Next goto *(void *)(jumptbl_base + *((uint32 *) pc)++)
+#    else
+#      define Next goto *(void *)(jumptbl_base + *pc++)
+#    endif
+#  endif
+#else
+#  define Instruct(name) case name
+#  define Next break
+#endif
+
+/* GC interface */
+
+#define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = env; extern_sp = sp; }
+#define Restore_after_gc { accu = sp[0]; env = sp[1]; sp += 2; }
+#define Setup_for_c_call { *--sp = env; extern_sp = sp; }
+#define Restore_after_c_call { sp = extern_sp; env = *sp++; }
+
+/* An event frame must look like accu + a C_CALL frame + a RETURN 1 frame */
+#define Setup_for_event \
+  { sp -= 6; \
+    sp[0] = accu; /* accu */ \
+    sp[1] = Val_unit; /* C_CALL frame: dummy environment */ \
+    sp[2] = Val_unit; /* RETURN frame: dummy local 0 */ \
+    sp[3] = (value) pc; /* RETURN frame: saved return address */ \
+    sp[4] = env; /* RETURN frame: saved environment */ \
+    sp[5] = Val_long(extra_args); /* RETURN frame: saved extra args */ \
+    extern_sp = sp; }
+#define Restore_after_event \
+  { sp = extern_sp; accu = sp[0]; \
+    pc = (code_t) sp[3]; env = sp[4]; extra_args = Long_val(sp[5]); \
+    sp += 6; }
+
+/* Debugger interface */
+
+#define Setup_for_debugger \
+   { sp -= 4; \
+     sp[0] = accu; sp[1] = (value)(pc - 1); \
+     sp[2] = env; sp[3] = Val_long(extra_args); \
+     extern_sp = sp; }
+#define Restore_after_debugger { sp += 4; }
+
+#ifdef THREADED_CODE
+#define Restart_curr_instr \
+  goto *(jumptable[saved_code[pc - 1 - start_code]])
+#else
+#define Restart_curr_instr \
+  curr_instr = saved_code[pc - 1 - start_code]; \
+  goto dispatch_instr
+#endif
+
+/* Register optimization.
+   Some compilers underestimate the use of the local variables representing
+   the abstract machine registers, and don't put them in hardware registers,
+   which slows down the interpreter considerably.
+   For GCC, I have hand-assigned hardware registers for several architectures.
+*/
+
+#if defined(__GNUC__) && !defined(DEBUG)
+#ifdef __mips__
+#define PC_REG asm("$16")
+#define SP_REG asm("$17")
+#define ACCU_REG asm("$18")
+#endif
+#ifdef __sparc__
+#define PC_REG asm("%l0")
+#define SP_REG asm("%l1")
+#define ACCU_REG asm("%l2")
+#endif
+#ifdef __alpha__
+#ifdef __CRAY__
+#define PC_REG asm("r9")
+#define SP_REG asm("r10")
+#define ACCU_REG asm("r11")
+#define JUMPTBL_BASE_REG asm("r12")
+#else
+#define PC_REG asm("$9")
+#define SP_REG asm("$10")
+#define ACCU_REG asm("$11")
+#define JUMPTBL_BASE_REG asm("$12")
+#endif
+#endif
+#ifdef __i386__
+#define PC_REG asm("%esi")
+#define SP_REG asm("%edi")
+#define ACCU_REG
+#endif
+#if defined(PPC) || defined(_POWER) || defined(_IBMR2)
+#define PC_REG asm("26")
+#define SP_REG asm("27")
+#define ACCU_REG asm("28")
+#endif
+#ifdef __hppa__
+#define PC_REG asm("%r18")
+#define SP_REG asm("%r17")
+#define ACCU_REG asm("%r16")
+#endif
+#ifdef __mc68000__
+#define PC_REG asm("a5")
+#define SP_REG asm("a4")
+#define ACCU_REG asm("d7")
+#endif
+#ifdef __arm__
+#define PC_REG asm("r9")
+#define SP_REG asm("r8")
+#define ACCU_REG asm("r7")
+#endif
+#ifdef __ia64__
+#define PC_REG asm("36")
+#define SP_REG asm("37")
+#define ACCU_REG asm("38")
+#define JUMPTBL_BASE_REG asm("39")
+#endif
+#endif
+
+/* Division and modulus madness */
+
+#ifdef NONSTANDARD_DIV_MOD
+static long safe_div(long p, long q);
+static long safe_mod(long p, long q);
+#endif
+
+/* The interpreter itself */
+
+value interprete(code_t prog, asize_t prog_size)
+{
+#ifdef PC_REG
+  register code_t pc PC_REG;
+  register value * sp SP_REG;
+  register value accu ACCU_REG;
+#else
+  register code_t pc;
+  register value * sp;
+  register value accu;
+#endif
+#if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32)
+#ifdef JUMPTBL_BASE_REG
+  register char * jumptbl_base JUMPTBL_BASE_REG;
+#else
+  register char * jumptbl_base;
+#endif
+#endif
+  value env;
+  long extra_args;
+  struct longjmp_buffer * initial_external_raise;
+  int initial_sp_offset;
+  /* volatile prevents collapsing initial_local_roots with another
+     local variable, like Digital Unix 4.0 C compiler does (wrongly) */
+  struct caml__roots_block * volatile initial_local_roots;
+  struct longjmp_buffer raise_buf;
+  value * modify_dest, modify_newval;
+#ifndef THREADED_CODE
+  opcode_t curr_instr;
+#endif
+
+#ifdef THREADED_CODE
+  static void * jumptable[] = {
+#    include "jumptbl.h"
+  };
+#endif
+
+  if (prog == NULL) {           /* Interpreter is initializing */
+#ifdef THREADED_CODE
+    instr_table = (char **) jumptable;
+    instr_base = Jumptbl_base;
+#endif
+    return Val_unit;
+  }
+
+#if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32)
+  jumptbl_base = Jumptbl_base;
+#endif
+  initial_local_roots = local_roots;
+  initial_sp_offset = (char *) stack_high - (char *) extern_sp;
+  initial_external_raise = external_raise;
+  callback_depth++;
+
+  if (sigsetjmp(raise_buf.buf, 0)) {
+    local_roots = initial_local_roots;
+    sp = extern_sp;
+    accu = exn_bucket;
+    pc = NULL;
+    goto raise_exception;
+  }
+  external_raise = &raise_buf;
+
+  sp = extern_sp;
+  pc = prog;
+  extra_args = 0;
+  env = Atom(0);
+  accu = Val_int(0);
+
+#ifdef THREADED_CODE
+#ifdef DEBUG
+ next_instr:
+  if (icount-- == 0) stop_here ();
+  Assert(sp >= stack_low);
+  Assert(sp <= stack_high);
+#endif
+  goto *(void *)(jumptbl_base + *pc++); /* Jump to the first instruction */
+#else
+  while(1) {
+#ifdef DEBUG
+    if (icount-- == 0) stop_here ();
+    if (trace_flag) disasm_instr(pc);
+    Assert(sp >= stack_low);
+    Assert(sp <= stack_high);
+#endif
+    curr_instr = *pc++;
+
+  dispatch_instr:
+    switch(curr_instr) {
+#endif
+
+/* Basic stack operations */
+
+    Instruct(ACC0):
+      accu = sp[0]; Next;
+    Instruct(ACC1):
+      accu = sp[1]; Next;
+    Instruct(ACC2):
+      accu = sp[2]; Next;
+    Instruct(ACC3):
+      accu = sp[3]; Next;
+    Instruct(ACC4):
+      accu = sp[4]; Next;
+    Instruct(ACC5):
+      accu = sp[5]; Next;
+    Instruct(ACC6):
+      accu = sp[6]; Next;
+    Instruct(ACC7):
+      accu = sp[7]; Next;
+
+    Instruct(PUSH): Instruct(PUSHACC0):
+      *--sp = accu; Next;
+    Instruct(PUSHACC1):
+      *--sp = accu; accu = sp[1]; Next;
+    Instruct(PUSHACC2):
+      *--sp = accu; accu = sp[2]; Next;
+    Instruct(PUSHACC3):
+      *--sp = accu; accu = sp[3]; Next;
+    Instruct(PUSHACC4):
+      *--sp = accu; accu = sp[4]; Next;
+    Instruct(PUSHACC5):
+      *--sp = accu; accu = sp[5]; Next;
+    Instruct(PUSHACC6):
+      *--sp = accu; accu = sp[6]; Next;
+    Instruct(PUSHACC7):
+      *--sp = accu; accu = sp[7]; Next;
+
+    Instruct(PUSHACC):
+      *--sp = accu;
+      /* Fallthrough */
+    Instruct(ACC):
+      accu = sp[*pc++];
+      Next;
+
+    Instruct(POP):
+      sp += *pc++;
+      Next;
+    Instruct(ASSIGN):
+      sp[*pc++] = accu;
+      accu = Val_unit;
+      Next;
+
+/* Access in heap-allocated environment */
+
+    Instruct(ENVACC1):
+      accu = Field(env, 1); Next;
+    Instruct(ENVACC2):
+      accu = Field(env, 2); Next;
+    Instruct(ENVACC3):
+      accu = Field(env, 3); Next;
+    Instruct(ENVACC4):
+      accu = Field(env, 4); Next;
+
+    Instruct(PUSHENVACC1):
+      *--sp = accu; accu = Field(env, 1); Next;
+    Instruct(PUSHENVACC2):
+      *--sp = accu; accu = Field(env, 2); Next;
+    Instruct(PUSHENVACC3):
+      *--sp = accu; accu = Field(env, 3); Next;
+    Instruct(PUSHENVACC4):
+      *--sp = accu; accu = Field(env, 4); Next;
+
+    Instruct(PUSHENVACC):
+      *--sp = accu;
+      /* Fallthrough */
+    Instruct(ENVACC):
+      accu = Field(env, *pc++);
+      Next;
+
+/* Function application */
+
+    Instruct(PUSH_RETADDR): {
+      sp -= 3;
+      sp[0] = (value) (pc + *pc);
+      sp[1] = env;
+      sp[2] = Val_long(extra_args);
+      pc++;
+      Next;
+    }
+    Instruct(APPLY): {
+      extra_args = *pc - 1;
+      pc = Code_val(accu);
+      env = accu;
+      goto check_stacks;
+    }
+    Instruct(APPLY1): {
+      value arg1 = sp[0];
+      sp -= 3;
+      sp[0] = arg1;
+      sp[1] = (value)pc;
+      sp[2] = env;
+      sp[3] = Val_long(extra_args);
+      pc = Code_val(accu);
+      env = accu;
+      extra_args = 0;
+      goto check_stacks;
+    }
+    Instruct(APPLY2): {
+      value arg1 = sp[0];
+      value arg2 = sp[1];
+      sp -= 3;
+      sp[0] = arg1;
+      sp[1] = arg2;
+      sp[2] = (value)pc;
+      sp[3] = env;
+      sp[4] = Val_long(extra_args);
+      pc = Code_val(accu);
+      env = accu;
+      extra_args = 1;
+      goto check_stacks;
+    }
+    Instruct(APPLY3): {
+      value arg1 = sp[0];
+      value arg2 = sp[1];
+      value arg3 = sp[2];
+      sp -= 3;
+      sp[0] = arg1;
+      sp[1] = arg2;
+      sp[2] = arg3;
+      sp[3] = (value)pc;
+      sp[4] = env;
+      sp[5] = Val_long(extra_args);
+      pc = Code_val(accu);
+      env = accu;
+      extra_args = 2;
+      goto check_stacks;
+    }
+
+    Instruct(APPTERM): {
+      int nargs = *pc++;
+      int slotsize = *pc;
+      value * newsp;
+      int i;
+      /* Slide the nargs bottom words of the current frame to the top
+         of the frame, and discard the remainder of the frame */
+      newsp = sp + slotsize - nargs;
+      for (i = nargs - 1; i >= 0; i--) newsp[i] = sp[i];
+      sp = newsp;
+      pc = Code_val(accu);
+      env = accu;
+      extra_args += nargs - 1;
+      goto check_stacks;
+    }
+    Instruct(APPTERM1): {
+      value arg1 = sp[0];
+      sp = sp + *pc - 1;
+      sp[0] = arg1;
+      pc = Code_val(accu);
+      env = accu;
+      goto check_stacks;
+    }
+    Instruct(APPTERM2): {
+      value arg1 = sp[0];
+      value arg2 = sp[1];
+      sp = sp + *pc - 2;
+      sp[0] = arg1;
+      sp[1] = arg2;
+      pc = Code_val(accu);
+      env = accu;
+      extra_args += 1;
+      goto check_stacks;
+    }
+    Instruct(APPTERM3): {
+      value arg1 = sp[0];
+      value arg2 = sp[1];
+      value arg3 = sp[2];
+      sp = sp + *pc - 3;
+      sp[0] = arg1;
+      sp[1] = arg2;
+      sp[2] = arg3;
+      pc = Code_val(accu);
+      env = accu;
+      extra_args += 2;
+      goto check_stacks;
+    }
+
+    Instruct(RETURN): {
+      sp += *pc++;
+      if (extra_args > 0) {
+        extra_args--;
+        pc = Code_val(accu);
+        env = accu;
+      } else {
+        pc = (code_t)(sp[0]);
+        env = sp[1];
+        extra_args = Long_val(sp[2]);
+        sp += 3;
+      }
+      Next;
+    }
+
+    Instruct(RESTART): {
+      int num_args = Wosize_val(env) - 2;
+      int i;
+      sp -= num_args;
+      for (i = 0; i < num_args; i++) sp[i] = Field(env, i + 2);
+      env = Field(env, 1);
+      extra_args += num_args;
+      Next;
+    }
+
+    Instruct(GRAB): {
+      int required = *pc++;
+      if (extra_args >= required) {
+        extra_args -= required;
+      } else {
+        mlsize_t num_args, i;
+        num_args = 1 + extra_args; /* arg1 + extra args */
+        Alloc_small(accu, num_args + 2, Closure_tag);
+        Field(accu, 1) = env;
+        for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i];
+        Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */
+        sp += num_args;
+        pc = (code_t)(sp[0]);
+        env = sp[1];
+        extra_args = Long_val(sp[2]);
+        sp += 3;
+      }
+      Next;
+    }
+
+    Instruct(CLOSURE): {
+      int nvars = *pc++;
+      int i;
+      if (nvars > 0) *--sp = accu;
+      Alloc_small(accu, 1 + nvars, Closure_tag);
+      Code_val(accu) = pc + *pc;
+      pc++;
+      for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i];
+      sp += nvars;
+      Next;
+    }
+
+    Instruct(CLOSUREREC): {
+      int nfuncs = *pc++;
+      int nvars = *pc++;
+      int i;
+      value * p;
+      if (nvars > 0) *--sp = accu;
+      Alloc_small(accu, nfuncs * 2 - 1 + nvars, Closure_tag);
+      p = &Field(accu, nfuncs * 2 - 1);
+      for (i = 0; i < nvars; i++) {
+        *p++ = sp[i];
+      }
+      sp += nvars;
+      p = &Field(accu, 0);
+      *p = (value) (pc + pc[0]);
+      *--sp = accu;
+      p++;
+      for (i = 1; i < nfuncs; i++) {
+        *p = Make_header(i * 2, Infix_tag, Caml_white);  /* color irrelevant. */
+        p++;
+        *p = (value) (pc + pc[i]);
+        *--sp = (value) p;
+        p++;
+      }
+      pc += nfuncs;
+      Next;
+    }
+
+    Instruct(PUSHOFFSETCLOSURE):
+      *--sp = accu; /* fallthrough */
+    Instruct(OFFSETCLOSURE):
+      accu = env + *pc++ * sizeof(value); Next;
+
+    Instruct(PUSHOFFSETCLOSUREM2):
+      *--sp = accu; /* fallthrough */
+    Instruct(OFFSETCLOSUREM2):
+      accu = env - 2 * sizeof(value); Next;
+    Instruct(PUSHOFFSETCLOSURE0):
+      *--sp = accu; /* fallthrough */
+    Instruct(OFFSETCLOSURE0):
+      accu = env; Next;
+    Instruct(PUSHOFFSETCLOSURE2):
+      *--sp = accu; /* fallthrough */
+    Instruct(OFFSETCLOSURE2):
+      accu = env + 2 * sizeof(value); Next;
+
+
+/* Access to global variables */
+
+    Instruct(PUSHGETGLOBAL):
+      *--sp = accu;
+      /* Fallthrough */
+    Instruct(GETGLOBAL):
+      accu = Field(global_data, *pc);
+      pc++;
+      Next;
+
+    Instruct(PUSHGETGLOBALFIELD):
+      *--sp = accu;
+      /* Fallthrough */
+    Instruct(GETGLOBALFIELD): {
+      accu = Field(global_data, *pc);
+      pc++;
+      accu = Field(accu, *pc);
+      pc++;
+      Next;
+    }
+
+    Instruct(SETGLOBAL):
+      modify(&Field(global_data, *pc), accu);
+      accu = Val_unit;
+      pc++;
+      Next;
+
+/* Allocation of blocks */
+
+    Instruct(PUSHATOM0):
+      *--sp = accu;
+      /* Fallthrough */
+    Instruct(ATOM0):
+      accu = Atom(0); Next;
+
+    Instruct(PUSHATOM):
+      *--sp = accu;
+      /* Fallthrough */
+    Instruct(ATOM):
+      accu = Atom(*pc++); Next;
+
+    Instruct(MAKEBLOCK): {
+      mlsize_t wosize = *pc++;
+      tag_t tag = *pc++;
+      mlsize_t i;
+      value block;
+      Alloc_small(block, wosize, tag);
+      Field(block, 0) = accu;
+      for (i = 1; i < wosize; i++) Field(block, i) = *sp++;
+      accu = block;
+      Next;
+    }
+    Instruct(MAKEBLOCK1): {
+      tag_t tag = *pc++;
+      value block;
+      Alloc_small(block, 1, tag);
+      Field(block, 0) = accu;
+      accu = block;
+      Next;
+    }
+    Instruct(MAKEBLOCK2): {
+      tag_t tag = *pc++;
+      value block;
+      Alloc_small(block, 2, tag);
+      Field(block, 0) = accu;
+      Field(block, 1) = sp[0];
+      sp += 1;
+      accu = block;
+      Next;
+    }
+    Instruct(MAKEBLOCK3): {
+      tag_t tag = *pc++;
+      value block;
+      Alloc_small(block, 3, tag);
+      Field(block, 0) = accu;
+      Field(block, 1) = sp[0];
+      Field(block, 2) = sp[1];
+      sp += 2;
+      accu = block;
+      Next;
+    }
+    Instruct(MAKEFLOATBLOCK): {
+      mlsize_t size = *pc++;
+      mlsize_t i;
+      value block;
+      Alloc_small(block, size * Double_wosize, Double_array_tag);
+      Store_double_field(block, 0, Double_val(accu));
+      for (i = 1; i < size; i++){
+        Store_double_field(block, i, Double_val(*sp));
+        ++ sp;
+      }
+      accu = block;
+      Next;
+    }
+
+/* Access to components of blocks */
+
+    Instruct(GETFIELD0):
+      accu = Field(accu, 0); Next;
+    Instruct(GETFIELD1):
+      accu = Field(accu, 1); Next;
+    Instruct(GETFIELD2):
+      accu = Field(accu, 2); Next;
+    Instruct(GETFIELD3):
+      accu = Field(accu, 3); Next;
+    Instruct(GETFIELD):
+      accu = Field(accu, *pc); pc++; Next;
+    Instruct(GETFLOATFIELD): {
+      double d = Double_field(accu, *pc);
+      Alloc_small(accu, Double_wosize, Double_tag);
+      Store_double_val(accu, d);
+      pc++;
+      Next;
+    }
+
+    Instruct(SETFIELD0):
+      modify_dest = &Field(accu, 0);
+      modify_newval = *sp++;
+    modify:
+      Modify(modify_dest, modify_newval);
+      accu = Val_unit;
+      Next;
+    Instruct(SETFIELD1):
+      modify_dest = &Field(accu, 1);
+      modify_newval = *sp++;
+      goto modify;
+    Instruct(SETFIELD2):
+      modify_dest = &Field(accu, 2);
+      modify_newval = *sp++;
+      goto modify;
+    Instruct(SETFIELD3):
+      modify_dest = &Field(accu, 3);
+      modify_newval = *sp++;
+      goto modify;
+    Instruct(SETFIELD):
+      modify_dest = &Field(accu, *pc);
+      pc++;
+      modify_newval = *sp++;
+      goto modify;
+    Instruct(SETFLOATFIELD):
+      Store_double_field(accu, *pc, Double_val(*sp));
+      accu = Val_unit;
+      sp++;
+      pc++;
+      Next;
+
+/* Array operations */
+
+    Instruct(VECTLENGTH): {
+      mlsize_t size = Wosize_val(accu);
+      if (Tag_val(accu) == Double_array_tag) size = size / Double_wosize;
+      accu = Val_long(size);
+      Next;
+    }
+    Instruct(GETVECTITEM):
+      accu = Field(accu, Long_val(sp[0]));
+      sp += 1;
+      Next;
+    Instruct(SETVECTITEM):
+      modify_dest = &Field(accu, Long_val(sp[0]));
+      modify_newval = sp[1];
+      sp += 2;
+      goto modify;
+
+/* String operations */
+
+    Instruct(GETSTRINGCHAR):
+      accu = Val_int(Byte_u(accu, Long_val(sp[0])));
+      sp += 1;
+      Next;
+    Instruct(SETSTRINGCHAR):
+      Byte_u(accu, Long_val(sp[0])) = Int_val(sp[1]);
+      sp += 2;
+      accu = Val_unit;
+      Next;
+
+/* Branches and conditional branches */
+
+    Instruct(BRANCH):
+      pc += *pc;
+      Next;
+    Instruct(BRANCHIF):
+      if (accu != Val_false) pc += *pc; else pc++;
+      Next;
+    Instruct(BRANCHIFNOT):
+      if (accu == Val_false) pc += *pc; else pc++;
+      Next;
+    Instruct(SWITCH): {
+      uint32 sizes = *pc++;
+      if (Is_block(accu)) {
+        long index = Tag_val(accu);
+        Assert (index >= 0);
+        Assert (index < (sizes >> 16));
+        pc += pc[(sizes & 0xFFFF) + index];
+      } else {
+        long index = Long_val(accu);
+        Assert ((unsigned long) index < (sizes & 0xFFFF)) ;
+        pc += pc[index];
+      }
+      Next;
+    }
+    Instruct(BOOLNOT):
+      accu = Val_not(accu);
+      Next;
+
+/* Exceptions */
+
+    Instruct(PUSHTRAP):
+      sp -= 4;
+      Trap_pc(sp) = pc + *pc;
+      Trap_link(sp) = trapsp;
+      sp[2] = env;
+      sp[3] = Val_long(extra_args);
+      trapsp = sp;
+      pc++;
+      Next;
+
+    Instruct(POPTRAP):
+      if (something_to_do) {
+        /* We must check here so that if a signal is pending and its
+           handler triggers an exception, the exception is trapped
+           by the current try...with, not the enclosing one. */
+        pc--; /* restart the POPTRAP after processing the signal */
+        goto process_signal;
+      }
+      trapsp = Trap_link(sp);
+      sp += 4;
+      Next;
+
+    Instruct(RAISE):
+    raise_exception:
+      if (trapsp >= trap_barrier) debugger(TRAP_BARRIER);
+      if (backtrace_active) stash_backtrace(accu, pc, sp);
+      sp = trapsp;
+      if ((char *) sp >= (char *) stack_high - initial_sp_offset) {
+        external_raise = initial_external_raise;
+        extern_sp = sp;
+        callback_depth--;
+        return Make_exception_result(accu);
+      }
+      pc = Trap_pc(sp);
+      trapsp = Trap_link(sp);
+      env = sp[2];
+      extra_args = Long_val(sp[3]);
+      sp += 4;
+      Next;
+
+/* Stack checks */
+
+    check_stacks:
+      if (sp < stack_threshold) {
+        extern_sp = sp;
+        realloc_stack(Stack_threshold / sizeof(value));
+        sp = extern_sp;
+      }
+      /* Fall through CHECK_SIGNALS */
+
+/* Signal handling */
+
+    Instruct(CHECK_SIGNALS):    /* accu not preserved */
+      if (something_to_do) goto process_signal;
+      Next;
+
+    process_signal:
+      something_to_do = 0;
+      Setup_for_event;
+      process_event();
+      Restore_after_event;
+      Next;
+
+/* Calling C functions */
+
+    Instruct(C_CALL1):
+      Setup_for_c_call;
+      accu = Primitive(*pc)(accu);
+      Restore_after_c_call;
+      pc++;
+      Next;
+    Instruct(C_CALL2):
+      Setup_for_c_call;
+      accu = Primitive(*pc)(accu, sp[1]);
+      Restore_after_c_call;
+      sp += 1;
+      pc++;
+      Next;
+    Instruct(C_CALL3):
+      Setup_for_c_call;
+      accu = Primitive(*pc)(accu, sp[1], sp[2]);
+      Restore_after_c_call;
+      sp += 2;
+      pc++;
+      Next;
+    Instruct(C_CALL4):
+      Setup_for_c_call;
+      accu = Primitive(*pc)(accu, sp[1], sp[2], sp[3]);
+      Restore_after_c_call;
+      sp += 3;
+      pc++;
+      Next;
+    Instruct(C_CALL5):
+      Setup_for_c_call;
+      accu = Primitive(*pc)(accu, sp[1], sp[2], sp[3], sp[4]);
+      Restore_after_c_call;
+      sp += 4;
+      pc++;
+      Next;
+    Instruct(C_CALLN): {
+      int nargs = *pc++;
+      *--sp = accu;
+      Setup_for_c_call;
+      accu = Primitive(*pc)(sp + 1, nargs);
+      Restore_after_c_call;
+      sp += nargs;
+      pc++;
+      Next;
+    }
+
+/* Integer constants */
+
+    Instruct(CONST0):
+      accu = Val_int(0); Next;
+    Instruct(CONST1):
+      accu = Val_int(1); Next;
+    Instruct(CONST2):
+      accu = Val_int(2); Next;
+    Instruct(CONST3):
+      accu = Val_int(3); Next;
+
+    Instruct(PUSHCONST0):
+      *--sp = accu; accu = Val_int(0); Next;
+    Instruct(PUSHCONST1):
+      *--sp = accu; accu = Val_int(1); Next;
+    Instruct(PUSHCONST2):
+      *--sp = accu; accu = Val_int(2); Next;
+    Instruct(PUSHCONST3):
+      *--sp = accu; accu = Val_int(3); Next;
+
+    Instruct(PUSHCONSTINT):
+      *--sp = accu;
+      /* Fallthrough */
+    Instruct(CONSTINT):
+      accu = Val_int(*pc);
+      pc++;
+      Next;
+
+/* Integer arithmetic */
+
+    Instruct(NEGINT):
+      accu = (value)(2 - (long)accu); Next;
+    Instruct(ADDINT):
+      accu = (value)((long) accu + (long) *sp++ - 1); Next;
+    Instruct(SUBINT):
+      accu = (value)((long) accu - (long) *sp++ + 1); Next;
+    Instruct(MULINT):
+      accu = Val_long(Long_val(accu) * Long_val(*sp++)); Next;
+
+    Instruct(DIVINT): {
+      long divisor = Long_val(*sp++);
+      if (divisor == 0) { Setup_for_c_call; raise_zero_divide(); }
+#ifdef NONSTANDARD_DIV_MOD
+      accu = Val_long(safe_div(Long_val(accu), divisor));
+#else
+      accu = Val_long(Long_val(accu) / divisor);
+#endif
+      Next;
+    }
+    Instruct(MODINT): {
+      long divisor = Long_val(*sp++);
+      if (divisor == 0) { Setup_for_c_call; raise_zero_divide(); }
+#ifdef NONSTANDARD_DIV_MOD
+      accu = Val_long(safe_mod(Long_val(accu), divisor));
+#else
+      accu = Val_long(Long_val(accu) % divisor);
+#endif
+      Next;
+    }
+    Instruct(ANDINT):
+      accu = (value)((long) accu & (long) *sp++); Next;
+    Instruct(ORINT):
+      accu = (value)((long) accu | (long) *sp++); Next;
+    Instruct(XORINT):
+      accu = (value)(((long) accu ^ (long) *sp++) | 1); Next;
+    Instruct(LSLINT):
+      accu = (value)((((long) accu - 1) << Long_val(*sp++)) + 1); Next;
+    Instruct(LSRINT):
+      accu = (value)((((unsigned long) accu - 1) >> Long_val(*sp++)) | 1);
+      Next;
+    Instruct(ASRINT):
+      accu = (value)((((long) accu - 1) >> Long_val(*sp++)) | 1); Next;
+
+#define Integer_comparison(sign,opname,tst) \
+    Instruct(opname): \
+      accu = Val_int((sign long) accu tst (sign long) *sp++); Next;
+
+    Integer_comparison(signed,EQ, ==)
+    Integer_comparison(signed,NEQ, !=)
+    Integer_comparison(signed,LTINT, <)
+    Integer_comparison(signed,LEINT, <=)
+    Integer_comparison(signed,GTINT, >)
+    Integer_comparison(signed,GEINT, >=)
+    Integer_comparison(unsigned,ULTINT, <)
+    Integer_comparison(unsigned,UGEINT, >=)
+
+#define Integer_branch_comparison(sign,opname,tst,debug) \
+    Instruct(opname): \
+      if ( *pc++ tst ((sign long)Long_val(accu))) { \
+        pc += *pc ; \
+      } else { \
+        pc++ ; \
+      } ; Next;
+
+    Integer_branch_comparison(signed,BEQ, ==, "==")
+    Integer_branch_comparison(signed,BNEQ, !=, "!=")
+    Integer_branch_comparison(signed,BLTINT, <, "<")
+    Integer_branch_comparison(signed,BLEINT, <=, "<=")
+    Integer_branch_comparison(signed,BGTINT, >, ">")
+    Integer_branch_comparison(signed,BGEINT, >=, ">=")
+    Integer_branch_comparison(unsigned,BULTINT, <, "<")
+    Integer_branch_comparison(unsigned,BUGEINT, >=, ">=")
+
+    Instruct(OFFSETINT):
+      accu += *pc << 1;
+      pc++;
+      Next;
+    Instruct(OFFSETREF):
+      Field(accu, 0) += *pc << 1;
+      accu = Val_unit;
+      pc++;
+      Next;
+    Instruct(ISINT):
+      accu = Val_long(accu & 1);
+      Next;
+    
+/* Object-oriented operations */
+
+#define Lookup(obj, lab) \
+  Field (Field (Field (obj, 0), ((lab) >> 16) / sizeof (value)), \
+         ((lab) / sizeof (value)) & 0xFF)
+
+    Instruct(GETMETHOD):
+      accu = Lookup(sp[0], accu);
+      Next;
+
+/* Debugging and machine control */
+
+    Instruct(STOP):
+      external_raise = initial_external_raise;
+      extern_sp = sp;
+      callback_depth--;
+      return accu;
+
+    Instruct(EVENT):
+      if (--event_count == 0) {
+        Setup_for_debugger;
+        debugger(EVENT_COUNT);
+        Restore_after_debugger;
+      }
+      Restart_curr_instr;
+
+    Instruct(BREAK):
+      Setup_for_debugger;
+      debugger(BREAKPOINT);
+      Restore_after_debugger;
+      Restart_curr_instr;
+
+#ifndef THREADED_CODE
+    default:
+#if _MSC_VER >= 1200
+      __assume(0);
+#else
+      fatal_error_arg("Fatal error: bad opcode (%lx)\n",
+                      (char *)(long)(*(pc-1)));
+#endif
+    }
+  }
+#endif
+}
+
+#ifdef NONSTANDARD_DIV_MOD
+long safe_div(long p, long q)
+{
+  unsigned long ap = p >= 0 ? p : -p;
+  unsigned long aq = q >= 0 ? q : -q;
+  unsigned long ar = ap / aq;
+  return (p ^ q) >= 0 ? ar : -ar;
+}
+
+long safe_mod(long p, long q)
+{
+  unsigned long ap = p >= 0 ? p : -p;
+  unsigned long aq = q >= 0 ? q : -q;
+  unsigned long ar = ap % aq;
+  return p >= 0 ? ar : -ar;
+}
+#endif
diff --git a/byterun/interp.h b/byterun/interp.h
new file mode 100644
index 0000000000..81828b71a2
--- /dev/null
+++ b/byterun/interp.h
@@ -0,0 +1,28 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* The bytecode interpreter */
+
+#ifndef _interp_
+#define _interp_
+
+
+#include "misc.h"
+#include "mlvalues.h"
+
+value interprete (code_t prog, asize_t prog_size);
+
+
+#endif
diff --git a/byterun/intext.h b/byterun/intext.h
new file mode 100644
index 0000000000..3251a3e1f4
--- /dev/null
+++ b/byterun/intext.h
@@ -0,0 +1,159 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Structured input/output */
+
+#ifndef __intext__
+#define __intext__
+
+#include "misc.h"
+#include "mlvalues.h"
+#include "io.h"
+
+/* Magic number */
+
+#define Intext_magic_number 0x8495A6BE
+
+/* Codes for the compact format */
+
+#define PREFIX_SMALL_BLOCK 0x80
+#define PREFIX_SMALL_INT 0x40
+#define PREFIX_SMALL_STRING 0x20
+#define CODE_INT8 0x0
+#define CODE_INT16 0x1
+#define CODE_INT32 0x2
+#define CODE_INT64 0x3
+#define CODE_SHARED8 0x4
+#define CODE_SHARED16 0x5
+#define CODE_SHARED32 0x6
+#define CODE_BLOCK32 0x8
+#define CODE_STRING8 0x9
+#define CODE_STRING32 0xA
+#define CODE_DOUBLE_BIG 0xB
+#define CODE_DOUBLE_LITTLE 0xC
+#define CODE_DOUBLE_ARRAY8_BIG 0xD
+#define CODE_DOUBLE_ARRAY8_LITTLE 0xE
+#define CODE_DOUBLE_ARRAY32_BIG 0xF
+#define CODE_DOUBLE_ARRAY32_LITTLE 0x7
+#define CODE_CODEPOINTER 0x10
+#define CODE_INFIXPOINTER 0x11
+#define CODE_CUSTOM 0x12
+
+#ifdef ARCH_BIG_ENDIAN
+#define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG
+#define CODE_DOUBLE_ARRAY8_NATIVE CODE_DOUBLE_ARRAY8_BIG
+#define CODE_DOUBLE_ARRAY32_NATIVE CODE_DOUBLE_ARRAY32_BIG
+#else
+#define CODE_DOUBLE_NATIVE CODE_DOUBLE_LITTLE
+#define CODE_DOUBLE_ARRAY8_NATIVE CODE_DOUBLE_ARRAY8_LITTLE
+#define CODE_DOUBLE_ARRAY32_NATIVE CODE_DOUBLE_ARRAY32_LITTLE
+#endif
+
+/* Initial sizes of data structures for extern */
+
+#ifndef INITIAL_EXTERN_BLOCK_SIZE
+#define INITIAL_EXTERN_BLOCK_SIZE 8192
+#endif
+
+#ifndef INITIAL_EXTERN_TABLE_SIZE_LOG2
+#define INITIAL_EXTERN_TABLE_SIZE_LOG2 11
+#endif
+
+#define INITIAL_EXTERN_TABLE_SIZE (1UL << INITIAL_EXTERN_TABLE_SIZE_LOG2)
+
+/* Maximal value of initial_ofs above which we should start again with
+   initial_ofs = 1. Should be low enough to prevent rollover of initial_ofs
+   next time we extern a structure. Since a structure contains at most 
+   2^N / (2 * sizeof(value)) heap objects (N = 32 or 64 depending on target),
+   any value below 2^N - (2^N / (2 * sizeof(value))) suffices.
+   We just take 2^(N-1) for simplicity. */
+
+#define INITIAL_OFFSET_MAX (1UL << (8 * sizeof(value) - 1))
+
+/* The entry points */
+
+CAMLextern void output_val (struct channel * chan, value v, value flags);
+  /* Output [v] with flags [flags] on the channel [chan]. */
+CAMLextern void output_value_to_malloc(value v, value flags,
+                                       /*out*/ char ** buf,
+                                       /*out*/ long * len);
+  /* Output [v] with flags [flags] to a memory buffer allocated with
+     malloc.  On return, [*buf] points to the buffer and [*len]
+     contains the number of bytes in buffer. */
+CAMLextern long output_value_to_block(value v, value flags,
+                                      char * data, long len);
+  /* Output [v] with flags [flags] to a user-provided memory buffer.
+     [data] points to the start of this buffer, and [len] is its size
+     in bytes.  Return the number of bytes actually written in buffer.
+     Raise [Failure] if buffer is too short. */
+
+CAMLextern value input_val (struct channel * chan);
+  /* Read a structured value from the channel [chan]. */
+CAMLextern value input_val_from_string (value str, long ofs);
+  /* Read a structured value from the Caml string [str], starting
+     at offset [ofs]. */
+CAMLextern value input_value_from_malloc(char * data, long ofs);
+  /* Read a structured value from a malloced buffer.  [data] points
+     to the beginning of the buffer, and [ofs] is the offset of the
+     beginning of the externed data in this buffer.  The buffer is
+     deallocated with [free] on return, or if an exception is raised. */
+CAMLextern value input_value_from_block(char * data, long len);
+  /* Read a structured value from a user-provided buffer.  [data] points
+     to the beginning of the externed data in this buffer,
+     and [len] is the length in bytes of valid data in this buffer.
+     The buffer is never deallocated by this routine. */
+
+/* Functions for writing user-defined marshallers */
+
+CAMLextern void serialize_int_1(int i);
+CAMLextern void serialize_int_2(int i);
+CAMLextern void serialize_int_4(int32 i);
+CAMLextern void serialize_int_8(int64 i);
+CAMLextern void serialize_float_4(float f);
+CAMLextern void serialize_float_8(double f);
+CAMLextern void serialize_block_1(void * data, long len);
+CAMLextern void serialize_block_2(void * data, long len);
+CAMLextern void serialize_block_4(void * data, long len);
+CAMLextern void serialize_block_8(void * data, long len);
+
+CAMLextern int deserialize_uint_1(void);
+CAMLextern int deserialize_sint_1(void);
+CAMLextern int deserialize_uint_2(void);
+CAMLextern int deserialize_sint_2(void);
+CAMLextern uint32 deserialize_uint_4(void);
+CAMLextern int32 deserialize_sint_4(void);
+CAMLextern uint64 deserialize_uint_8(void);
+CAMLextern int64 deserialize_sint_8(void);
+CAMLextern float deserialize_float_4(void);
+CAMLextern double deserialize_float_8(void);
+CAMLextern void deserialize_block_1(void * data, long len);
+CAMLextern void deserialize_block_2(void * data, long len);
+CAMLextern void deserialize_block_4(void * data, long len);
+CAMLextern void deserialize_block_8(void * data, long len);
+CAMLextern void deserialize_error(char * msg);
+
+/* Auxiliary stuff for sending code pointers */
+unsigned char * code_checksum (void);
+
+#ifndef NATIVE_CODE
+#include "fix_code.h"
+#define code_area_start ((char *) start_code)
+#define code_area_end ((char *) start_code + code_size)
+#else
+extern char * code_area_start, * code_area_end;
+#endif
+
+#endif
+
diff --git a/byterun/io.c b/byterun/io.c
new file mode 100644
index 0000000000..595ff3ada9
--- /dev/null
+++ b/byterun/io.c
@@ -0,0 +1,666 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Buffered input/output. */
+
+#include <errno.h>
+#include <fcntl.h>
+#include <limits.h>
+#include <string.h>
+#include "config.h"
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#include "alloc.h"
+#include "custom.h"
+#include "fail.h"
+#include "io.h"
+#include "memory.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "signals.h"
+#include "sys.h"
+#ifdef HAS_UI
+#include "ui.h"
+#endif
+
+#ifndef SEEK_SET
+#define SEEK_SET 0
+#define SEEK_CUR 1
+#define SEEK_END 2
+#endif
+
+/* Hooks for locking channels */
+
+CAMLexport void (*channel_mutex_free) (struct channel *) = NULL;
+CAMLexport void (*channel_mutex_lock) (struct channel *) = NULL;
+CAMLexport void (*channel_mutex_unlock) (struct channel *) = NULL;
+CAMLexport void (*channel_mutex_unlock_exn) (void) = NULL;
+
+/* List of opened channels */
+CAMLexport struct channel * all_opened_channels = NULL;
+
+/* Basic functions over type struct channel *.
+   These functions can be called directly from C.
+   No locking is performed. */
+
+/* Functions shared between input and output */
+
+CAMLexport struct channel * open_descriptor_in(int fd)
+{
+  struct channel * channel;
+
+  channel = (struct channel *) stat_alloc(sizeof(struct channel));
+  channel->fd = fd;
+  channel->offset = 0;
+  channel->curr = channel->max = channel->buff;
+  channel->end = channel->buff + IO_BUFFER_SIZE;
+  channel->mutex = NULL;
+  channel->revealed = 0;
+  channel->old_revealed = 0;
+  channel->refcount = 0;
+  channel->next = all_opened_channels;
+  all_opened_channels = channel;
+  return channel;
+}
+
+CAMLexport struct channel * open_descriptor_out(int fd)
+{
+  struct channel * channel;
+
+  channel = open_descriptor_in(fd);
+  channel->max = NULL;
+  return channel;
+}
+
+static void unlink_channel(struct channel *channel)
+{
+  struct channel ** cp = &all_opened_channels;
+  
+  while (*cp != channel && *cp != NULL)
+    cp = &(*cp)->next;
+  if (*cp != NULL)
+    *cp = (*cp)->next;
+}
+
+CAMLexport void close_channel(struct channel *channel)
+{
+  close(channel->fd);
+  if (channel->refcount > 0) return;
+  if (channel_mutex_free != NULL) (*channel_mutex_free)(channel);
+  unlink_channel(channel);
+  stat_free(channel);
+}
+
+CAMLexport long channel_size(struct channel *channel)
+{
+  long end;
+
+  end = lseek(channel->fd, 0, SEEK_END);
+  if (end == -1 ||
+      lseek(channel->fd, channel->offset, SEEK_SET) != channel->offset) {
+    sys_error(NO_ARG);
+  }
+  return end;
+}
+
+CAMLexport int channel_binary_mode(struct channel *channel)
+{
+#ifdef _WIN32
+  int oldmode = setmode(channel->fd, O_BINARY);
+  if (oldmode == O_TEXT) setmode(channel->fd, O_TEXT);
+  return oldmode == O_BINARY;
+#else
+  return 1;
+#endif
+}
+
+/* Output */
+
+#ifndef EINTR
+#define EINTR (-1)
+#endif
+#ifndef EAGAIN
+#define EAGAIN (-1)
+#endif
+#ifndef EWOULDBLOCK
+#define EWOULDBLOCK (-1)
+#endif
+
+static int do_write(int fd, char *p, int n)
+{
+  int retcode;
+
+  Assert(!Is_young(p));
+#ifdef HAS_UI
+  retcode = ui_write(fd, p, n);
+#else
+again:
+  enter_blocking_section();
+  retcode = write(fd, p, n);
+  leave_blocking_section();
+  if (retcode == -1) {
+    if (errno == EINTR) goto again;
+    if ((errno == EAGAIN || errno == EWOULDBLOCK) && n > 1) {
+      /* We couldn't do a partial write here, probably because
+         n <= PIPE_BUF and POSIX says that writes of less than
+         PIPE_BUF characters must be atomic.
+         We first try again with a partial write of 1 character.
+         If that fails too, we'll raise Sys_blocked_io below. */
+      n = 1; goto again;
+    }
+  }
+#endif
+  if (retcode == -1) sys_error(NO_ARG);
+  return retcode;
+}
+
+/* Attempt to flush the buffer. This will make room in the buffer for
+   at least one character. Returns true if the buffer is empty at the
+   end of the flush, or false if some data remains in the buffer. */
+
+CAMLexport int flush_partial(struct channel *channel)
+{
+  int towrite, written;
+
+  towrite = channel->curr - channel->buff;
+  if (towrite > 0) {
+    written = do_write(channel->fd, channel->buff, towrite);
+    channel->offset += written;
+    if (written < towrite)
+      memmove(channel->buff, channel->buff + written, towrite - written);
+    channel->curr -= written;
+  }
+  return (channel->curr == channel->buff);
+}
+
+/* Flush completely the buffer. */
+
+CAMLexport void flush(struct channel *channel)
+{
+  while (! flush_partial(channel)) /*nothing*/;
+}
+
+/* Output data */
+
+CAMLexport void putword(struct channel *channel, uint32 w)
+{
+  if (! channel_binary_mode(channel))
+    failwith("output_binary_int: not a binary channel");
+  putch(channel, w >> 24);
+  putch(channel, w >> 16);
+  putch(channel, w >> 8);
+  putch(channel, w);
+}
+
+CAMLexport int putblock(struct channel *channel, char *p, long int len)
+{
+  int n, free, towrite, written;
+
+  n = len >= INT_MAX ? INT_MAX : (int) len;
+  free = channel->end - channel->curr;
+  if (n <= free) {
+    /* Write request small enough to fit in buffer: transfer to buffer. */
+    memmove(channel->curr, p, n);
+    channel->curr += n;
+    return n;
+  } else {
+    /* Write request overflows buffer: transfer whatever fits to buffer
+       and write the buffer */
+    memmove(channel->curr, p, free);
+    towrite = channel->end - channel->buff;
+    written = do_write(channel->fd, channel->buff, towrite);
+    if (written < towrite)
+      memmove(channel->buff, channel->buff + written, towrite - written);
+    channel->offset += written;
+    channel->curr = channel->end - written;
+    return free;
+  }
+}
+
+CAMLexport void really_putblock(struct channel *channel, char *p, long int len)
+{
+  int written;
+  while (len > 0) {
+    written = putblock(channel, p, len);
+    p += written;
+    len -= written;
+  }
+}
+
+CAMLexport void seek_out(struct channel *channel, long int dest)
+{
+  flush(channel);
+  if (lseek(channel->fd, dest, 0) != dest) sys_error(NO_ARG);
+  channel->offset = dest;
+}
+
+CAMLexport long pos_out(struct channel *channel)
+{
+  return channel->offset + channel->curr - channel->buff;
+}
+
+/* Input */
+
+CAMLexport int do_read(int fd, char *p, unsigned int n)
+{
+  int retcode;
+
+  Assert(!Is_young(p));
+  enter_blocking_section();
+#ifdef HAS_UI
+  retcode = ui_read(fd, p, n);
+#else
+#ifdef EINTR
+  do { retcode = read(fd, p, n); } while (retcode == -1 && errno == EINTR);
+#else
+  retcode = read(fd, p, n);
+#endif
+#endif
+  leave_blocking_section();
+  if (retcode == -1) sys_error(NO_ARG);
+  return retcode;
+}
+
+CAMLexport unsigned char refill(struct channel *channel)
+{
+  int n;
+
+  n = do_read(channel->fd, channel->buff, IO_BUFFER_SIZE);
+  if (n == 0) raise_end_of_file();
+  channel->offset += n;
+  channel->max = channel->buff + n;
+  channel->curr = channel->buff + 1;
+  return (unsigned char)(channel->buff[0]);
+}
+
+CAMLexport uint32 getword(struct channel *channel)
+{
+  int i;
+  uint32 res;
+
+  if (! channel_binary_mode(channel))
+    failwith("input_binary_int: not a binary channel");
+  res = 0;
+  for(i = 0; i < 4; i++) {
+    res = (res << 8) + getch(channel);
+  }
+  return res;
+}
+
+CAMLexport int getblock(struct channel *channel, char *p, long int len)
+{
+  int n, avail, nread;
+
+  n = len >= INT_MAX ? INT_MAX : (int) len;
+  avail = channel->max - channel->curr;
+  if (n <= avail) {
+    memmove(p, channel->curr, n);
+    channel->curr += n;
+    return n;
+  } else if (avail > 0) {
+    memmove(p, channel->curr, avail);
+    channel->curr += avail;
+    return avail;
+  } else {
+    nread = do_read(channel->fd, channel->buff, IO_BUFFER_SIZE);
+    channel->offset += nread;
+    channel->max = channel->buff + nread;
+    if (n > nread) n = nread;
+    memmove(p, channel->buff, n);
+    channel->curr = channel->buff + n;
+    return n;
+  }
+}
+
+CAMLexport int really_getblock(struct channel *chan, char *p, long int n)
+{
+  int r;
+  while (n > 0) {
+    r = getblock(chan, p, n);
+    if (r == 0) break;
+    p += r;
+    n -= r;
+  }
+  return (n == 0);
+}
+
+CAMLexport void seek_in(struct channel *channel, long int dest)
+{
+  if (dest >= channel->offset - (channel->max - channel->buff) &&
+      dest <= channel->offset) {
+    channel->curr = channel->max - (channel->offset - dest);
+  } else {
+    if (lseek(channel->fd, dest, SEEK_SET) != dest) sys_error(NO_ARG);
+    channel->offset = dest;
+    channel->curr = channel->max = channel->buff;
+  }
+}
+
+CAMLexport long pos_in(struct channel *channel)
+{
+  return channel->offset - (channel->max - channel->curr);
+}
+
+CAMLexport long input_scan_line(struct channel *channel)
+{
+  char * p;
+  int n;
+
+  p = channel->curr;
+  do {
+    if (p >= channel->max) {
+      /* No more characters available in the buffer */
+      if (channel->curr > channel->buff) {
+        /* Try to make some room in the buffer by shifting the unread
+           portion at the beginning */
+        memmove(channel->buff, channel->curr, channel->max - channel->curr);
+        n = channel->curr - channel->buff;
+        channel->curr -= n;
+        channel->max -= n;
+        p -= n;
+      }
+      if (channel->max >= channel->end) {
+        /* Buffer is full, no room to read more characters from the input.
+           Return the number of characters in the buffer, with negative
+           sign to indicate that no newline was encountered. */
+        return -(channel->max - channel->curr);
+      }
+      /* Fill the buffer as much as possible */
+      n = do_read(channel->fd, channel->max, channel->end - channel->max);
+      if (n == 0) {
+        /* End-of-file encountered. Return the number of characters in the
+           buffer, with negative sign since we haven't encountered
+           a newline. */
+        return -(channel->max - channel->curr);
+      }
+      channel->offset += n;
+      channel->max += n;
+    }
+  } while (*p++ != '\n');
+  /* Found a newline. Return the length of the line, newline included. */
+  return (p - channel->curr);
+}
+
+/* Caml entry points for the I/O functions.  Wrap struct channel *
+   objects into a heap-allocated object.  Perform locking
+   and unlocking around the I/O operations. */
+
+CAMLexport void finalize_channel(value vchan)
+{
+  struct channel * chan = Channel(vchan);
+  if (--chan->refcount > 0) return;
+  if (channel_mutex_free != NULL) (*channel_mutex_free)(chan);
+  unlink_channel(chan);
+  stat_free(chan);
+}
+
+static int compare_channel(value vchan1, value vchan2)
+{
+  struct channel * chan1 = Channel(vchan1);
+  struct channel * chan2 = Channel(vchan2);
+  return (chan1 == chan2) ? 0 : (chan1 < chan2) ? -1 : 1;
+}
+
+static struct custom_operations channel_operations = {
+  "_chan",
+  finalize_channel,
+  compare_channel,
+  custom_hash_default,
+  custom_serialize_default,
+  custom_deserialize_default
+};
+
+CAMLexport value alloc_channel(struct channel *chan)
+{
+  value res = alloc_custom(&channel_operations, sizeof(struct channel *),
+                           1, 1000);
+  Channel(res) = chan;
+  chan->refcount++;
+  return res;
+}
+
+CAMLprim value caml_open_descriptor_in(value fd)
+{
+  return alloc_channel(open_descriptor_in(Int_val(fd)));
+}
+
+CAMLprim value caml_open_descriptor_out(value fd)
+{
+  return alloc_channel(open_descriptor_out(Int_val(fd)));
+}
+
+#define Pair_tag 0
+
+CAMLprim value caml_out_channels_list (value unit)
+{
+  CAMLparam0 ();
+  CAMLlocal3 (res, tail, chan);
+  struct channel * channel;
+
+  res = Val_emptylist;
+  for (channel = all_opened_channels;
+       channel != NULL;
+       channel = channel->next) 
+    /* Testing channel->fd >= 0 looks unnecessary, as
+       caml_close_channel changes max when setting fd to -1. */
+    if (channel->max == NULL) {
+      chan = alloc_channel (channel);
+      tail = res;
+      res = alloc_small (2, Pair_tag);
+      Field (res, 0) = chan;
+      Field (res, 1) = tail;
+    }
+  CAMLreturn (res);
+}
+
+CAMLprim value channel_descriptor(value vchannel)
+{
+  int fd = Channel(vchannel)->fd;
+  if (fd == -1) { errno = EBADF; sys_error(NO_ARG); }
+  return Val_int(fd);
+}
+
+CAMLprim value caml_close_channel(value vchannel)
+{
+  /* For output channels, must have flushed before */
+  struct channel * channel = Channel(vchannel);
+  close(channel->fd);
+  channel->fd = -1;
+  /* Ensure that every read or write on the channel will cause an
+     immediate flush_partial or refill, thus raising a Sys_error
+     exception */
+  channel->curr = channel->max = channel->end;
+  return Val_unit;
+}
+
+CAMLprim value caml_channel_size(value vchannel)
+{
+  return Val_long(channel_size(Channel(vchannel)));
+}
+
+CAMLprim value caml_set_binary_mode(value vchannel, value mode)
+{
+#ifdef _WIN32
+  struct channel * channel = Channel(vchannel);
+  if (setmode(channel->fd, Bool_val(mode) ? O_BINARY : O_TEXT) == -1)
+    sys_error(NO_ARG);
+#endif
+  return Val_unit;
+}
+
+CAMLprim value caml_flush_partial(value vchannel)
+{
+  struct channel * channel = Channel(vchannel);
+  int res;
+
+  Lock(channel);
+  res = flush_partial(channel);
+  Unlock(channel);
+  return Val_bool(res);
+}
+
+CAMLprim value caml_flush(value vchannel)
+{
+  struct channel * channel = Channel(vchannel);
+
+  Lock(channel);
+  flush(channel);
+  Unlock(channel);
+  return Val_unit;
+}
+
+CAMLprim value caml_output_char(value vchannel, value ch)
+{
+  struct channel * channel = Channel(vchannel);
+  Lock(channel);
+  putch(channel, Long_val(ch));
+  Unlock(channel);
+  return Val_unit;
+}
+
+CAMLprim value caml_output_int(value vchannel, value w)
+{
+  struct channel * channel = Channel(vchannel);
+  Lock(channel);
+  putword(channel, Long_val(w));
+  Unlock(channel);
+  return Val_unit;
+}
+
+CAMLprim value caml_output_partial(value vchannel, value buff, value start, value length)
+{
+  CAMLparam4 (vchannel, buff, start, length);
+  struct channel * channel = Channel(vchannel);
+  int res;
+
+  Lock(channel);
+  res = putblock(channel, &Byte(buff, Long_val(start)), Long_val(length));
+  Unlock(channel);
+  CAMLreturn (Val_int(res));
+}
+
+CAMLprim value caml_output(value vchannel, value buff, value start, value length)
+{
+  CAMLparam4 (vchannel, buff, start, length);
+  struct channel * channel = Channel(vchannel);
+  long pos = Long_val(start);
+  long len = Long_val(length);
+
+  Lock(channel);
+    while (len > 0) {
+      int written = putblock(channel, &Byte(buff, pos), len);
+      pos += written;
+      len -= written;
+    }
+  Unlock(channel);
+  CAMLreturn (Val_unit);
+}
+
+CAMLprim value caml_seek_out(value vchannel, value pos)
+{
+  struct channel * channel = Channel(vchannel);
+  Lock(channel);
+  seek_out(channel, Long_val(pos));
+  Unlock(channel);
+  return Val_unit;
+}
+
+CAMLprim value caml_pos_out(value vchannel)
+{
+  return Val_long(pos_out(Channel(vchannel)));
+}
+
+CAMLprim value caml_input_char(value vchannel)
+{
+  struct channel * channel = Channel(vchannel);
+  unsigned char c;
+
+  Lock(channel);
+  c = getch(channel);
+  Unlock(channel);
+  return Val_long(c);
+}
+
+CAMLprim value caml_input_int(value vchannel)
+{
+  struct channel * channel = Channel(vchannel);
+  long i;
+
+  Lock(channel);
+  i = getword(channel);
+  Unlock(channel);
+#ifdef ARCH_SIXTYFOUR
+  i = (i << 32) >> 32;          /* Force sign extension */
+#endif
+  return Val_long(i);
+}
+
+CAMLprim value caml_input(value vchannel,value buff,value vstart,value vlength)
+{
+  CAMLparam4 (vchannel, buff, vstart, vlength);
+  struct channel * channel = Channel(vchannel);
+  long start, len;
+  int n, avail, nread;
+
+  Lock(channel);
+  /* We cannot call getblock here because buff may move during do_read */
+  start = Long_val(vstart);
+  len = Long_val(vlength);
+  n = len >= INT_MAX ? INT_MAX : (int) len;
+  avail = channel->max - channel->curr;
+  if (n <= avail) {
+    memmove(&Byte(buff, start), channel->curr, n);
+    channel->curr += n;
+  } else if (avail > 0) {
+    memmove(&Byte(buff, start), channel->curr, avail);
+    channel->curr += avail;
+    n = avail;
+  } else {
+    nread = do_read(channel->fd, channel->buff, IO_BUFFER_SIZE);
+    channel->offset += nread;
+    channel->max = channel->buff + nread;
+    if (n > nread) n = nread;
+    memmove(&Byte(buff, start), channel->buff, n);
+    channel->curr = channel->buff + n;
+  }
+  Unlock(channel);
+  CAMLreturn (Val_long(n));
+}
+
+CAMLprim value caml_seek_in(value vchannel, value pos)
+{
+  struct channel * channel = Channel(vchannel);
+  Lock(channel);
+  seek_in(channel, Long_val(pos));
+  Unlock(channel);
+  return Val_unit;
+}
+
+CAMLprim value caml_pos_in(value vchannel)
+{
+  return Val_long(pos_in(Channel(vchannel)));
+}
+
+CAMLprim value caml_input_scan_line(value vchannel)
+{
+  struct channel * channel = Channel(vchannel);
+  long res;
+
+  Lock(channel);
+  res = input_scan_line(channel);
+  Unlock(channel);
+  return Val_long(res);
+}
diff --git a/byterun/io.h b/byterun/io.h
new file mode 100644
index 0000000000..04bfd28c12
--- /dev/null
+++ b/byterun/io.h
@@ -0,0 +1,96 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Buffered input/output */
+
+#ifndef _io_
+#define _io_
+
+
+#include "misc.h"
+#include "mlvalues.h"
+
+#ifndef IO_BUFFER_SIZE
+#define IO_BUFFER_SIZE 4096
+#endif
+
+struct channel {
+  int fd;                       /* Unix file descriptor */
+  long offset;                  /* Absolute position of fd in the file */
+  char * end;                   /* Physical end of the buffer */
+  char * curr;                  /* Current position in the buffer */
+  char * max;                   /* Logical end of the buffer (for input) */
+  void * mutex;                 /* Placeholder for mutex (for systhreads) */
+  struct channel * next;        /* Linear chaining of channels (flush_all) */
+  int revealed;                 /* For Cash only */
+  int old_revealed;             /* For Cash only */
+  int refcount;                 /* For flush_all and for Cash */
+  char buff[IO_BUFFER_SIZE];    /* The buffer itself */
+};
+
+/* For an output channel:
+     [offset] is the absolute position of the beginning of the buffer [buff].
+   For an input channel:
+     [offset] is the absolute position of the logical end of the buffer, [max].
+*/
+
+/* Functions and macros that can be called from C.  Take arguments of
+   type struct channel *.  No locking is performed. */
+
+#define putch(channel, ch) do{                                            \
+  if ((channel)->curr >= (channel)->end) flush_partial(channel);          \
+  *((channel)->curr)++ = (ch);                                            \
+}while(0)
+
+#define getch(channel)                                                      \
+  ((channel)->curr >= (channel)->max                                        \
+   ? refill(channel)                                                        \
+   : (unsigned char) *((channel))->curr++)
+
+CAMLextern struct channel * open_descriptor_in (int);
+CAMLextern struct channel * open_descriptor_out (int);
+CAMLextern void close_channel (struct channel *);
+CAMLextern int channel_binary_mode (struct channel *);
+
+CAMLextern int flush_partial (struct channel *);
+CAMLextern void flush (struct channel *);
+CAMLextern void putword (struct channel *, uint32);
+CAMLextern int putblock (struct channel *, char *, long);
+CAMLextern void really_putblock (struct channel *, char *, long);
+
+CAMLextern unsigned char refill (struct channel *);
+CAMLextern uint32 getword (struct channel *);
+CAMLextern int getblock (struct channel *, char *, long);
+CAMLextern int really_getblock (struct channel *, char *, long);
+
+/* Extract a struct channel * from the heap object representing it */
+
+#define Channel(v) (*((struct channel **) (Data_custom_val(v))))
+
+/* The locking machinery */
+
+CAMLextern void (*channel_mutex_free) (struct channel *);
+CAMLextern void (*channel_mutex_lock) (struct channel *);
+CAMLextern void (*channel_mutex_unlock) (struct channel *);
+CAMLextern void (*channel_mutex_unlock_exn) (void);
+
+#define Lock(channel) \
+  if (channel_mutex_lock != NULL) (*channel_mutex_lock)(channel)
+#define Unlock(channel) \
+  if (channel_mutex_unlock != NULL) (*channel_mutex_unlock)(channel)
+#define Unlock_exn() \
+  if (channel_mutex_unlock_exn != NULL) (*channel_mutex_unlock_exn)()
+
+#endif /* _io_ */
diff --git a/byterun/lexing.c b/byterun/lexing.c
new file mode 100644
index 0000000000..dab0a962f8
--- /dev/null
+++ b/byterun/lexing.c
@@ -0,0 +1,107 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* The table-driven automaton for lexers generated by camllex. */
+
+#include "fail.h"
+#include "mlvalues.h"
+#include "stacks.h"
+
+struct lexer_buffer {
+  value refill_buff;
+  value lex_buffer;
+  value lex_buffer_len;
+  value lex_abs_pos;
+  value lex_start_pos;
+  value lex_curr_pos;
+  value lex_last_pos;
+  value lex_last_action;
+  value lex_eof_reached;
+};
+
+struct lexing_table {
+  value lex_base;
+  value lex_backtrk;
+  value lex_default;
+  value lex_trans;
+  value lex_check;
+};
+
+#if defined(ARCH_BIG_ENDIAN) || SIZEOF_SHORT != 2
+#define Short(tbl,n) \
+  (*((unsigned char *)((tbl) + (n) * 2)) + \
+          (*((schar *)((tbl) + (n) * 2 + 1)) << 8))
+#else
+#define Short(tbl,n) (((short *)(tbl))[(n)])
+#endif
+
+CAMLprim value lex_engine(struct lexing_table *tbl, value start_state,
+                          struct lexer_buffer *lexbuf)
+{
+  int state, base, backtrk, c;
+
+  state = Int_val(start_state);
+  if (state >= 0) {
+    /* First entry */
+    lexbuf->lex_last_pos = lexbuf->lex_start_pos = lexbuf->lex_curr_pos;
+    lexbuf->lex_last_action = Val_int(-1);
+  } else {
+    /* Reentry after refill */
+    state = -state - 1;
+  }
+  while(1) {
+    /* Lookup base address or action number for current state */
+    base = Short(tbl->lex_base, state);
+    if (base < 0) return Val_int(-base-1);
+    /* See if it's a backtrack point */
+    backtrk = Short(tbl->lex_backtrk, state);
+    if (backtrk >= 0) {
+      lexbuf->lex_last_pos = lexbuf->lex_curr_pos;
+      lexbuf->lex_last_action = Val_int(backtrk);
+    }
+    /* See if we need a refill */
+    if (lexbuf->lex_curr_pos >= lexbuf->lex_buffer_len){
+      if (lexbuf->lex_eof_reached == Val_bool (0)){
+        return Val_int(-state - 1);
+      }else{
+        c = 256;
+      }
+    }else{
+      /* Read next input char */
+      c = Byte_u(lexbuf->lex_buffer, Long_val(lexbuf->lex_curr_pos));
+      lexbuf->lex_curr_pos += 2;
+    }
+    /* Determine next state */
+    if (Short(tbl->lex_check, base + c) == state)
+      state = Short(tbl->lex_trans, base + c);
+    else
+      state = Short(tbl->lex_default, state);
+    /* If no transition on this char, return to last backtrack point */
+    if (state < 0) {
+      lexbuf->lex_curr_pos = lexbuf->lex_last_pos;
+      if (lexbuf->lex_last_action == Val_int(-1)) {
+        failwith("lexing: empty token");
+      } else {
+        return lexbuf->lex_last_action;
+      }
+    }else{
+      /* Erase the EOF condition only if the EOF pseudo-character was
+         consumed by the automaton (i.e. there was no backtrack above)
+       */
+      if (c == 256) lexbuf->lex_eof_reached = Val_bool (0);
+    }
+  }
+}
+
diff --git a/byterun/macintosh.c b/byterun/macintosh.c
new file mode 100644
index 0000000000..c4171ea78d
--- /dev/null
+++ b/byterun/macintosh.c
@@ -0,0 +1,319 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Damien Doligez, projet Para, INRIA Rocquencourt          */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* MacOS-specific stuff */
+
+#include <stdio.h>
+#include <stdlib.h>
+
+#include <AppleEvents.h>
+#include <CursorCtl.h>
+#include <Errors.h>
+#include <Files.h>
+#include <IntEnv.h>
+#include <MacTypes.h>
+#include <QuickDraw.h>
+#include <TextUtils.h>
+
+#include "misc.h"
+#include "rotatecursor.h"
+
+/* Unix emulation stuff */
+
+static short prevdir = 0;
+
+int chdir (char *dir)
+{
+  WDPBRec pb;
+  int result;
+  short curdir;
+
+  pb.ioCompletion = NULL;
+  pb.ioNamePtr = c2pstr (dir);
+  pb.ioVRefNum = 0;
+  pb.ioWDProcID = 'Caml';
+  pb.ioWDDirID = 0;
+  result = PBOpenWDSync (&pb);
+  p2cstr ((unsigned char *) dir);
+  if (result != noErr) return -1;
+  curdir = pb.ioVRefNum;
+  result = SetVol (NULL, curdir);
+  if (result != noErr) return -1;
+  if (prevdir != 0){
+    pb.ioVRefNum = prevdir;
+    PBCloseWDSync (&pb);
+  }
+  prevdir = curdir;
+  return 0;
+}
+
+Handle macos_getfullpathname (short vrefnum, long dirid)
+{
+  Handle result = NewHandle (0);
+  CInfoPBRec mypb;
+  Str255 dirname;
+  OSErr err;
+
+  if (result == NULL) goto failed;
+
+  mypb.dirInfo.ioNamePtr = dirname;
+  mypb.dirInfo.ioVRefNum = vrefnum;
+  mypb.dirInfo.ioDrParID = dirid;
+  mypb.dirInfo.ioFDirIndex = -1;
+
+  do{
+    mypb.dirInfo.ioDrDirID = mypb.dirInfo.ioDrParID;
+    err = PBGetCatInfo (&mypb, false);
+    if (err) goto failed;
+    Munger (result, 0, NULL, 0, ":", 1);
+    Munger (result, 0, NULL, 0, dirname+1, dirname[0]);
+    /* XXX out of memory ?! */
+  }while (mypb.dirInfo.ioDrDirID != fsRtDirID);
+  return result;
+
+  failed:
+    if (result != NULL) DisposeHandle (result);
+    return NULL;
+}
+
+char *getcwd (char *buf, size_t size)
+{
+  size_t len;
+
+  Handle path = macos_getfullpathname (0, 0);
+  if (path == NULL) return NULL;
+
+  len = GetHandleSize (path);
+
+  if (len+1 >= size){
+    DisposeHandle (path);
+    return NULL;
+  }
+  if (buf == NULL){
+    buf = malloc (len+1);
+    if (buf == NULL) return NULL;
+  }
+  memcpy (buf, *path, len);
+  buf [len] = '\000';
+  DisposeHandle (path);
+  return buf;
+}
+
+pascal Boolean system_idleproc (const EventRecord *event, long *sleepTime,
+                                RgnHandle *mouseRgn)
+{
+  static RgnHandle myregion = NULL;
+  EventRecord evt;
+  
+  if (myregion == NULL){
+    myregion = NewRgn ();
+    SetRectRgn (myregion, -32000, -32000, 32000, 32000);
+  }
+
+  /* XXX standalone appli: process event */
+  *mouseRgn = myregion;
+  *sleepTime = 3;
+  if (EventAvail (keyDownMask, &evt)
+      && (evt.modifiers & cmdKey)
+      && ((evt.message & charCodeMask) == '.')){
+    return true;
+  }else{
+    return false;
+  }
+}
+
+void quote (char *buf, long buflen)
+{
+  long i, j;
+
+  j = 2;
+  for (i = 0; buf[i] != '\0'; i++){
+    if (buf[i] == '\'') j += 3;
+    ++ j;
+  }
+  if (j >= buflen) return;
+
+  buf[j--] = '\0';
+  buf[j--] = '\'';
+  while (i > 0){
+    -- i;
+    buf[j--] = buf[i];
+    if (buf[i] == '\''){
+      buf[j--] = '\'';
+      buf[j--] = '\266';
+      buf[j--] = '\'';
+    }
+  }
+  buf[j] = '\'';                   Assert (j == 0);
+}
+
+int system (char const *cmd)
+{
+  char *fmt = "directory %s; %s";
+  char *cmdline;
+  char *buf;
+  #define buf_size 66000
+
+  static AEIdleUPP myIdleProcUPP = NULL;
+  AEAddressDesc serveraddr;
+  AppleEvent myevent, reply;
+  OSType toolserver_sig = 'MPSX';
+  DescType ret_type;
+  OSErr err = noErr;
+  long event_status = 0, ret_size;
+  int result;
+
+  /* once only */
+  if (myIdleProcUPP == NULL) myIdleProcUPP = NewAEIdleProc (system_idleproc);
+
+  SetCursor (*GetCursor (watchCursor));
+  
+  buf = malloc (buf_size);
+  if (buf == NULL) goto failed_malloc_buf;
+
+  /* Create the command line */
+  getcwd (buf, buf_size);
+  quote (buf, buf_size);
+  cmdline = malloc (strlen (fmt) + strlen (cmd) + strlen (buf) + 1);
+  if (cmdline == NULL) goto failed_malloc_cmdline;
+  sprintf (cmdline, fmt, buf, cmd);
+  
+  /* Send the event and get the reply */
+  err = AECreateDesc (typeApplSignature, &toolserver_sig,
+                      sizeof (toolserver_sig), &serveraddr);
+  if (err != noErr) goto failed_AECreateDesc;
+  err = AECreateAppleEvent ('misc', 'dosc', &serveraddr, kAutoGenerateReturnID,
+                            kAnyTransactionID, &myevent);
+  if (err != noErr) goto failed_AECreateAppleEvent;
+  err = AEPutParamPtr (&myevent, '----', 'TEXT', cmdline, strlen (cmdline));
+  if (err != noErr) goto failed_AEPutParamPtr;
+  err = AESend (&myevent, &reply, kAEWaitReply + kAENeverInteract,
+                kAENormalPriority, kNoTimeOut, myIdleProcUPP, NULL);
+  if (err != noErr) goto failed_AESend;
+  err = AEGetParamPtr (&reply, 'errn', typeLongInteger, &ret_type,
+                       &event_status, sizeof (event_status), &ret_size);
+  if (err != noErr || event_status != noErr) goto failed_script;
+  err = AEGetParamPtr (&reply, 'stat', typeLongInteger, &ret_type,
+                       &event_status, sizeof (event_status), &ret_size);
+  if (err != noErr || event_status != noErr) goto failed_script;
+
+  /* forward stdout and stderr */
+  err = AEGetParamPtr (&reply, 'diag', typeChar, &ret_type,
+                       buf, buf_size, &ret_size);
+  if (err == noErr) write (2, buf, ret_size);
+  err = AEGetParamPtr (&reply, '----', typeChar, &ret_type,
+                       buf, buf_size, &ret_size);
+  if (err == noErr) write (1, buf, ret_size);
+  
+  AEDisposeDesc (&reply);
+  AEDisposeDesc (&myevent);
+  AEDisposeDesc (&serveraddr);
+  free (cmdline);
+  free (buf);
+  RotateCursor (32);
+  return 0;
+
+  failed_script:
+    AEDisposeDesc (&reply);
+  failed_AESend:
+  failed_AEPutParamPtr:
+    AEDisposeDesc (&myevent);
+  failed_AECreateAppleEvent:
+    AEDisposeDesc (&serveraddr);
+  failed_AECreateDesc:
+    free (cmdline);
+  failed_malloc_cmdline:
+    free (buf);
+  failed_malloc_buf:
+    if (err != noErr) result = err;
+    else if (event_status != 0) result = event_status;
+    else result = 1;
+    if (result == 0 || result == -1) result = 1;
+    RotateCursor (32);
+    return result;
+}
+
+/* We don't need search_exe_in_path on MacOS 9 because there
+   are no #! scripts */
+
+char *search_exe_in_path (char * name)
+{
+  return name;
+}
+
+
+/* O'Caml's use use of dynamic linking is Unix-specific, these are functions
+   from dynlink.c without the dynamic linking stuff.
+*/
+
+#include "misc.h"
+#include "mlvalues.h"
+#include "prims.h"
+
+struct ext_table shared_libs_path;
+struct ext_table prim_table;
+
+static c_primitive lookup_primitive(char * name)
+{
+  int i;
+  void * res;
+
+  for (i = 0; names_of_builtin_cprim[i] != NULL; i++) {
+    if (strcmp(name, names_of_builtin_cprim[i]) == 0)
+      return builtin_cprim[i];
+  }
+  return NULL;
+}
+
+void build_primitive_table(char * lib_path,
+                           char * libs,
+                           char * req_prims)
+{
+  char * p;
+
+  ext_table_init(&prim_table, 0x180);
+  for (p = req_prims; *p != 0; p += strlen(p) + 1) {
+    c_primitive prim = lookup_primitive(p);
+    if (prim == NULL)
+      fatal_error_arg("Fatal error: unknown C primitive `%s'\n", p);
+    ext_table_add(&prim_table, (void *) prim);
+  }
+}
+
+value dynlink_open_lib (value filename)
+{
+  return Val_unit;
+}
+
+value dynlink_close_lib(value handle)
+{
+  return Val_unit;
+}
+
+value dynlink_lookup_symbol(value handle, value symbolname)
+{
+  return Val_unit;
+}
+
+value dynlink_add_primitive(value handle)
+{
+  invalid_argument("dynlink_add_primitive");
+  return Val_unit; /* not reached */
+}
+
+value dynlink_get_current_libs(value unit)
+{
+  return Atom (0);
+}
diff --git a/byterun/macintosh.h b/byterun/macintosh.h
new file mode 100644
index 0000000000..21410aee1b
--- /dev/null
+++ b/byterun/macintosh.h
@@ -0,0 +1,19 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Damien Doligez, projet Para, INRIA Rocquencourt          */
+/*                                                                     */
+/*  Copyright 1999 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* MacOS-specific stuff */
+
+#define WIFEXITED(x) 1
+#define WEXITSTATUS(x) (x)
diff --git a/byterun/md5.c b/byterun/md5.c
new file mode 100644
index 0000000000..9acff124ec
--- /dev/null
+++ b/byterun/md5.c
@@ -0,0 +1,300 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#include <string.h>
+#include "alloc.h"
+#include "fail.h"
+#include "md5.h"
+#include "mlvalues.h"
+#include "io.h"
+#include "reverse.h"
+
+/* MD5 message digest */
+
+CAMLprim value md5_string(value str, value ofs, value len)
+{
+  struct MD5Context ctx;
+  value res;
+  MD5Init(&ctx);
+  MD5Update(&ctx, &Byte_u(str, Long_val(ofs)), Long_val(len));
+  res = alloc_string(16);
+  MD5Final(&Byte_u(res, 0), &ctx);
+  return res;
+}
+
+CAMLprim value md5_chan(value vchan, value len)
+{
+  struct channel * chan = Channel(vchan);
+  struct MD5Context ctx;
+  value res;
+  long toread, read;
+  char buffer[4096];
+
+  Lock(chan);
+  MD5Init(&ctx);
+  toread = Long_val(len);
+  while (toread > 0) {
+    read = getblock(chan, buffer,
+                    toread > sizeof(buffer) ? sizeof(buffer) : toread);
+    if (read == 0) raise_end_of_file();
+    MD5Update(&ctx, (unsigned char *) buffer, read);
+    toread -= read;
+  }
+  res = alloc_string(16);
+  MD5Final(&Byte_u(res, 0), &ctx);
+  Unlock(chan);
+  return res;
+}
+
+/*
+ * This code implements the MD5 message-digest algorithm.
+ * The algorithm is due to Ron Rivest.  This code was
+ * written by Colin Plumb in 1993, no copyright is claimed.
+ * This code is in the public domain; do with it what you wish.
+ *
+ * Equivalent code is available from RSA Data Security, Inc.
+ * This code has been tested against that, and is equivalent,
+ * except that you don't need to include two pages of legalese
+ * with every copy.
+ *
+ * To compute the message digest of a chunk of bytes, declare an
+ * MD5Context structure, pass it to MD5Init, call MD5Update as
+ * needed on buffers full of bytes, and then call MD5Final, which
+ * will fill a supplied 16-byte array with the digest.
+ */
+
+#ifndef ARCH_BIG_ENDIAN
+#define byteReverse(buf, len)   /* Nothing */
+#else
+static void byteReverse(unsigned char * buf, unsigned longs)
+{
+    uint32 t;
+    do {
+        t = (uint32) ((unsigned) buf[3] << 8 | buf[2]) << 16 |
+            ((unsigned) buf[1] << 8 | buf[0]);
+        *(uint32 *) buf = t;
+        buf += 4;
+    } while (--longs);
+}
+#endif
+
+/*
+ * Start MD5 accumulation.  Set bit count to 0 and buffer to mysterious
+ * initialization constants.
+ */
+void MD5Init(struct MD5Context *ctx)
+{
+    ctx->buf[0] = 0x67452301;
+    ctx->buf[1] = 0xefcdab89;
+    ctx->buf[2] = 0x98badcfe;
+    ctx->buf[3] = 0x10325476;
+
+    ctx->bits[0] = 0;
+    ctx->bits[1] = 0;
+}
+
+/*
+ * Update context to reflect the concatenation of another buffer full
+ * of bytes.
+ */
+void MD5Update(struct MD5Context *ctx, unsigned char *buf, unsigned int len)
+{
+    uint32 t;
+
+    /* Update bitcount */
+
+    t = ctx->bits[0];
+    if ((ctx->bits[0] = t + ((uint32) len << 3)) < t)
+        ctx->bits[1]++;         /* Carry from low to high */
+    ctx->bits[1] += len >> 29;
+
+    t = (t >> 3) & 0x3f;        /* Bytes already in shsInfo->data */
+
+    /* Handle any leading odd-sized chunks */
+
+    if (t) {
+        unsigned char *p = (unsigned char *) ctx->in + t;
+
+        t = 64 - t;
+        if (len < t) {
+            memcpy(p, buf, len);
+            return;
+        }
+        memcpy(p, buf, t);
+        byteReverse(ctx->in, 16);
+        MD5Transform(ctx->buf, (uint32 *) ctx->in);
+        buf += t;
+        len -= t;
+    }
+    /* Process data in 64-byte chunks */
+
+    while (len >= 64) {
+        memcpy(ctx->in, buf, 64);
+        byteReverse(ctx->in, 16);
+        MD5Transform(ctx->buf, (uint32 *) ctx->in);
+        buf += 64;
+        len -= 64;
+    }
+
+    /* Handle any remaining bytes of data. */
+
+    memcpy(ctx->in, buf, len);
+}
+
+/*
+ * Final wrapup - pad to 64-byte boundary with the bit pattern 
+ * 1 0* (64-bit count of bits processed, MSB-first)
+ */
+void MD5Final(unsigned char *digest, struct MD5Context *ctx)
+{
+    unsigned count;
+    unsigned char *p;
+
+    /* Compute number of bytes mod 64 */
+    count = (ctx->bits[0] >> 3) & 0x3F;
+
+    /* Set the first char of padding to 0x80.  This is safe since there is
+       always at least one byte free */
+    p = ctx->in + count;
+    *p++ = 0x80;
+
+    /* Bytes of padding needed to make 64 bytes */
+    count = 64 - 1 - count;
+
+    /* Pad out to 56 mod 64 */
+    if (count < 8) {
+        /* Two lots of padding:  Pad the first block to 64 bytes */
+        memset(p, 0, count);
+        byteReverse(ctx->in, 16);
+        MD5Transform(ctx->buf, (uint32 *) ctx->in);
+
+        /* Now fill the next block with 56 bytes */
+        memset(ctx->in, 0, 56);
+    } else {
+        /* Pad block to 56 bytes */
+        memset(p, 0, count - 8);
+    }
+    byteReverse(ctx->in, 14);
+
+    /* Append length in bits and transform */
+    ((uint32 *) ctx->in)[14] = ctx->bits[0];
+    ((uint32 *) ctx->in)[15] = ctx->bits[1];
+
+    MD5Transform(ctx->buf, (uint32 *) ctx->in);
+    byteReverse((unsigned char *) ctx->buf, 4);
+    memcpy(digest, ctx->buf, 16);
+    memset(ctx, 0, sizeof(ctx));        /* In case it's sensitive */
+}
+
+/* The four core functions - F1 is optimized somewhat */
+
+/* #define F1(x, y, z) (x & y | ~x & z) */
+#define F1(x, y, z) (z ^ (x & (y ^ z)))
+#define F2(x, y, z) F1(z, x, y)
+#define F3(x, y, z) (x ^ y ^ z)
+#define F4(x, y, z) (y ^ (x | ~z))
+
+/* This is the central step in the MD5 algorithm. */
+#define MD5STEP(f, w, x, y, z, data, s) \
+        ( w += f(x, y, z) + data,  w = w<<s | w>>(32-s),  w += x )
+
+/*
+ * The core of the MD5 algorithm, this alters an existing MD5 hash to
+ * reflect the addition of 16 longwords of new data.  MD5Update blocks
+ * the data and converts bytes into longwords for this routine.
+ */
+void MD5Transform(uint32 *buf, uint32 *in)
+{
+    register uint32 a, b, c, d;
+
+    a = buf[0];
+    b = buf[1];
+    c = buf[2];
+    d = buf[3];
+
+    MD5STEP(F1, a, b, c, d, in[0] + 0xd76aa478, 7);
+    MD5STEP(F1, d, a, b, c, in[1] + 0xe8c7b756, 12);
+    MD5STEP(F1, c, d, a, b, in[2] + 0x242070db, 17);
+    MD5STEP(F1, b, c, d, a, in[3] + 0xc1bdceee, 22);
+    MD5STEP(F1, a, b, c, d, in[4] + 0xf57c0faf, 7);
+    MD5STEP(F1, d, a, b, c, in[5] + 0x4787c62a, 12);
+    MD5STEP(F1, c, d, a, b, in[6] + 0xa8304613, 17);
+    MD5STEP(F1, b, c, d, a, in[7] + 0xfd469501, 22);
+    MD5STEP(F1, a, b, c, d, in[8] + 0x698098d8, 7);
+    MD5STEP(F1, d, a, b, c, in[9] + 0x8b44f7af, 12);
+    MD5STEP(F1, c, d, a, b, in[10] + 0xffff5bb1, 17);
+    MD5STEP(F1, b, c, d, a, in[11] + 0x895cd7be, 22);
+    MD5STEP(F1, a, b, c, d, in[12] + 0x6b901122, 7);
+    MD5STEP(F1, d, a, b, c, in[13] + 0xfd987193, 12);
+    MD5STEP(F1, c, d, a, b, in[14] + 0xa679438e, 17);
+    MD5STEP(F1, b, c, d, a, in[15] + 0x49b40821, 22);
+
+    MD5STEP(F2, a, b, c, d, in[1] + 0xf61e2562, 5);
+    MD5STEP(F2, d, a, b, c, in[6] + 0xc040b340, 9);
+    MD5STEP(F2, c, d, a, b, in[11] + 0x265e5a51, 14);
+    MD5STEP(F2, b, c, d, a, in[0] + 0xe9b6c7aa, 20);
+    MD5STEP(F2, a, b, c, d, in[5] + 0xd62f105d, 5);
+    MD5STEP(F2, d, a, b, c, in[10] + 0x02441453, 9);
+    MD5STEP(F2, c, d, a, b, in[15] + 0xd8a1e681, 14);
+    MD5STEP(F2, b, c, d, a, in[4] + 0xe7d3fbc8, 20);
+    MD5STEP(F2, a, b, c, d, in[9] + 0x21e1cde6, 5);
+    MD5STEP(F2, d, a, b, c, in[14] + 0xc33707d6, 9);
+    MD5STEP(F2, c, d, a, b, in[3] + 0xf4d50d87, 14);
+    MD5STEP(F2, b, c, d, a, in[8] + 0x455a14ed, 20);
+    MD5STEP(F2, a, b, c, d, in[13] + 0xa9e3e905, 5);
+    MD5STEP(F2, d, a, b, c, in[2] + 0xfcefa3f8, 9);
+    MD5STEP(F2, c, d, a, b, in[7] + 0x676f02d9, 14);
+    MD5STEP(F2, b, c, d, a, in[12] + 0x8d2a4c8a, 20);
+
+    MD5STEP(F3, a, b, c, d, in[5] + 0xfffa3942, 4);
+    MD5STEP(F3, d, a, b, c, in[8] + 0x8771f681, 11);
+    MD5STEP(F3, c, d, a, b, in[11] + 0x6d9d6122, 16);
+    MD5STEP(F3, b, c, d, a, in[14] + 0xfde5380c, 23);
+    MD5STEP(F3, a, b, c, d, in[1] + 0xa4beea44, 4);
+    MD5STEP(F3, d, a, b, c, in[4] + 0x4bdecfa9, 11);
+    MD5STEP(F3, c, d, a, b, in[7] + 0xf6bb4b60, 16);
+    MD5STEP(F3, b, c, d, a, in[10] + 0xbebfbc70, 23);
+    MD5STEP(F3, a, b, c, d, in[13] + 0x289b7ec6, 4);
+    MD5STEP(F3, d, a, b, c, in[0] + 0xeaa127fa, 11);
+    MD5STEP(F3, c, d, a, b, in[3] + 0xd4ef3085, 16);
+    MD5STEP(F3, b, c, d, a, in[6] + 0x04881d05, 23);
+    MD5STEP(F3, a, b, c, d, in[9] + 0xd9d4d039, 4);
+    MD5STEP(F3, d, a, b, c, in[12] + 0xe6db99e5, 11);
+    MD5STEP(F3, c, d, a, b, in[15] + 0x1fa27cf8, 16);
+    MD5STEP(F3, b, c, d, a, in[2] + 0xc4ac5665, 23);
+
+    MD5STEP(F4, a, b, c, d, in[0] + 0xf4292244, 6);
+    MD5STEP(F4, d, a, b, c, in[7] + 0x432aff97, 10);
+    MD5STEP(F4, c, d, a, b, in[14] + 0xab9423a7, 15);
+    MD5STEP(F4, b, c, d, a, in[5] + 0xfc93a039, 21);
+    MD5STEP(F4, a, b, c, d, in[12] + 0x655b59c3, 6);
+    MD5STEP(F4, d, a, b, c, in[3] + 0x8f0ccc92, 10);
+    MD5STEP(F4, c, d, a, b, in[10] + 0xffeff47d, 15);
+    MD5STEP(F4, b, c, d, a, in[1] + 0x85845dd1, 21);
+    MD5STEP(F4, a, b, c, d, in[8] + 0x6fa87e4f, 6);
+    MD5STEP(F4, d, a, b, c, in[15] + 0xfe2ce6e0, 10);
+    MD5STEP(F4, c, d, a, b, in[6] + 0xa3014314, 15);
+    MD5STEP(F4, b, c, d, a, in[13] + 0x4e0811a1, 21);
+    MD5STEP(F4, a, b, c, d, in[4] + 0xf7537e82, 6);
+    MD5STEP(F4, d, a, b, c, in[11] + 0xbd3af235, 10);
+    MD5STEP(F4, c, d, a, b, in[2] + 0x2ad7d2bb, 15);
+    MD5STEP(F4, b, c, d, a, in[9] + 0xeb86d391, 21);
+
+    buf[0] += a;
+    buf[1] += b;
+    buf[2] += c;
+    buf[3] += d;
+}
+
diff --git a/byterun/md5.h b/byterun/md5.h
new file mode 100644
index 0000000000..05c9226ec9
--- /dev/null
+++ b/byterun/md5.h
@@ -0,0 +1,40 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1999 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* MD5 message digest */
+
+#ifndef _md5
+#define _md5
+
+
+#include "mlvalues.h"
+#include "io.h"
+
+CAMLextern value md5_string (value str, value ofs, value len);
+CAMLextern value md5_chan (value vchan, value len);
+
+struct MD5Context {
+        uint32 buf[4];
+        uint32 bits[2];
+        unsigned char in[64];
+};
+
+void MD5Init (struct MD5Context *context);
+void MD5Update (struct MD5Context *context, unsigned char *buf, unsigned len);
+void MD5Final (unsigned char *digest, struct MD5Context *ctx);
+void MD5Transform (uint32 *buf, uint32 *in);
+
+
+#endif
diff --git a/byterun/memory.h b/byterun/memory.h
new file mode 100644
index 0000000000..f3017caacb
--- /dev/null
+++ b/byterun/memory.h
@@ -0,0 +1,370 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*             Damien Doligez, projet Para, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Allocation macros and functions */
+
+#ifndef _memory_
+#define _memory_
+
+
+#include "config.h"
+#include "gc.h"
+#include "major_gc.h"
+#include "minor_gc.h"
+#include "misc.h"
+#include "mlvalues.h"
+
+CAMLextern value alloc_shr (mlsize_t, tag_t);
+void adjust_gc_speed (mlsize_t, mlsize_t);
+CAMLextern void modify (value *, value);
+CAMLextern void initialize (value *, value);
+CAMLextern value check_urgent_gc (value);
+CAMLextern void * stat_alloc (asize_t);              /* Size in bytes. */
+CAMLextern void stat_free (void *);
+CAMLextern void * stat_resize (void *, asize_t);     /* Size in bytes. */
+header_t *alloc_for_heap (asize_t request);   /* Size in bytes. */
+void free_for_heap (header_t *mem);
+int add_to_heap (header_t *mem);
+color_t allocation_color (void *hp);
+
+/* void shrink_heap (char *);        Only used in compact.c */
+
+#ifdef DEBUG
+#define DEBUG_clear(result, wosize) do{ \
+  unsigned long caml__DEBUG_i; \
+  for (caml__DEBUG_i = 0; caml__DEBUG_i < (wosize); ++ caml__DEBUG_i){ \
+    Field ((result), caml__DEBUG_i) = Debug_uninit_minor; \
+  } \
+}while(0)
+#else
+#define DEBUG_clear(result, wosize)
+#endif
+
+#define Alloc_small(result, wosize, tag) do{      CAMLassert (wosize >= 1); \
+                                            CAMLassert ((tag_t) tag < 256); \
+  young_ptr -= Bhsize_wosize (wosize);                                      \
+  if (young_ptr < young_limit){                                             \
+    young_ptr += Bhsize_wosize (wosize);                                    \
+    Setup_for_gc;                                                           \
+    minor_collection ();                                                    \
+    Restore_after_gc;                                                       \
+    young_ptr -= Bhsize_wosize (wosize);                                    \
+  }                                                                         \
+  Hd_hp (young_ptr) = Make_header ((wosize), (tag), Caml_black);            \
+  (result) = Val_hp (young_ptr);                                            \
+  DEBUG_clear ((result), (wosize));                                         \
+}while(0)
+
+/* You must use [Modify] to change a field of an existing shared block,
+   unless you are sure the value being overwritten is not a shared block and
+   the value being written is not a young block. */
+/* [Modify] never calls the GC. */
+/* [Modify] can also be used to do assignment on data structures that are
+   not in the (major) heap.  In this case, it is a bit slower than
+   simple assignment.
+   In particular, you can use [Modify] when you don't know whether the
+   block being changed is in the minor heap or the major heap.
+*/
+
+#define Modify(fp, val) do{                                                 \
+  value _old_ = *(fp);                                                      \
+  *(fp) = (val);                                                            \
+  if (Is_in_heap (fp)){                                                     \
+    if (gc_phase == Phase_mark) darken (_old_, NULL);                       \
+    if (Is_block (val) && Is_young (val)                                    \
+        && ! (Is_block (_old_) && Is_young (_old_))){                       \
+      *ref_table_ptr++ = (fp);                                              \
+      if (ref_table_ptr >= ref_table_limit){                                \
+        CAMLassert (ref_table_ptr == ref_table_limit);                      \
+        realloc_ref_table ();                                               \
+      }                                                                     \
+    }                                                                       \
+  }                                                                         \
+}while(0)
+
+struct caml__roots_block {
+  struct caml__roots_block *next;
+  long ntables;
+  long nitems;
+  value *tables [5];
+};
+
+CAMLextern struct caml__roots_block *local_roots;  /* defined in roots.c */
+
+/* The following macros are used to declare C local variables and
+   function parameters of type [value].
+
+   The function body must start with one of the [CAMLparam] macros.
+   If the function has no parameter of type [value], use [CAMLparam0].
+   If the function has 1 to 5 [value] parameters, use the corresponding
+   [CAMLparam] with the parameters as arguments.
+   If the function has more than 5 [value] parameters, use [CAMLparam5]
+   for the first 5 parameters, and one or more calls to the [CAMLxparam]
+   macros for the others.
+   If the function takes an array of [value]s as argument, use
+   [CAMLparamN] to declare it (or [CAMLxparamN] if you already have a
+   call to [CAMLparam] for some other arguments).
+
+   If you need local variables of type [value], declare them with one
+   or more calls to the [CAMLlocal] macros.
+   Use [CAMLlocalN] to declare an array of [value]s.
+
+   Your function may raise and exception or return a [value] with the
+   [CAMLreturn1] macro.  Its argument is simply the [value] returned by
+   your function.  Do NOT directly return a [value] with the [return]
+   keyword.  If your function returns void, use [CAMLreturn0].
+
+   All the identifiers beginning with "caml__" are reserved by Caml.
+   Do not use them for anything (local or global variables, struct or
+   union tags, macros, etc.)
+*/
+
+#define CAMLparam0() \
+  struct caml__roots_block *caml__frame = local_roots
+
+#define CAMLparam1(x) \
+  CAMLparam0 (); \
+  CAMLxparam1 (x)
+
+#define CAMLparam2(x, y) \
+  CAMLparam0 (); \
+  CAMLxparam2 (x, y)
+
+#define CAMLparam3(x, y, z) \
+  CAMLparam0 (); \
+  CAMLxparam3 (x, y, z)
+
+#define CAMLparam4(x, y, z, t) \
+  CAMLparam0 (); \
+  CAMLxparam4 (x, y, z, t)
+
+#define CAMLparam5(x, y, z, t, u) \
+  CAMLparam0 (); \
+  CAMLxparam5 (x, y, z, t, u)
+
+#define CAMLparamN(x, size) \
+  CAMLparam0 (); \
+  CAMLxparamN (x, (size))
+
+
+#define CAMLxparam1(x) \
+  struct caml__roots_block caml__roots_##x; \
+  int caml__dummy_##x = ( \
+    (caml__roots_##x.next = local_roots), \
+    (local_roots = &caml__roots_##x), \
+    (caml__roots_##x.nitems = 1), \
+    (caml__roots_##x.ntables = 1), \
+    (caml__roots_##x.tables [0] = &x), \
+    0)
+
+#define CAMLxparam2(x, y) \
+  struct caml__roots_block caml__roots_##x; \
+  int caml__dummy_##x = ( \
+    (caml__roots_##x.next = local_roots), \
+    (local_roots = &caml__roots_##x), \
+    (caml__roots_##x.nitems = 1), \
+    (caml__roots_##x.ntables = 2), \
+    (caml__roots_##x.tables [0] = &x), \
+    (caml__roots_##x.tables [1] = &y), \
+    0)
+
+#define CAMLxparam3(x, y, z) \
+  struct caml__roots_block caml__roots_##x; \
+  int caml__dummy_##x = ( \
+    (caml__roots_##x.next = local_roots), \
+    (local_roots = &caml__roots_##x), \
+    (caml__roots_##x.nitems = 1), \
+    (caml__roots_##x.ntables = 3), \
+    (caml__roots_##x.tables [0] = &x), \
+    (caml__roots_##x.tables [1] = &y), \
+    (caml__roots_##x.tables [2] = &z), \
+    0)
+
+#define CAMLxparam4(x, y, z, t) \
+  struct caml__roots_block caml__roots_##x; \
+  int caml__dummy_##x = ( \
+    (caml__roots_##x.next = local_roots), \
+    (local_roots = &caml__roots_##x), \
+    (caml__roots_##x.nitems = 1), \
+    (caml__roots_##x.ntables = 4), \
+    (caml__roots_##x.tables [0] = &x), \
+    (caml__roots_##x.tables [1] = &y), \
+    (caml__roots_##x.tables [2] = &z), \
+    (caml__roots_##x.tables [3] = &t), \
+    0)
+
+#define CAMLxparam5(x, y, z, t, u) \
+  struct caml__roots_block caml__roots_##x; \
+  int caml__dummy_##x = ( \
+    (caml__roots_##x.next = local_roots), \
+    (local_roots = &caml__roots_##x), \
+    (caml__roots_##x.nitems = 1), \
+    (caml__roots_##x.ntables = 5), \
+    (caml__roots_##x.tables [0] = &x), \
+    (caml__roots_##x.tables [1] = &y), \
+    (caml__roots_##x.tables [2] = &z), \
+    (caml__roots_##x.tables [3] = &t), \
+    (caml__roots_##x.tables [4] = &u), \
+    0)
+
+#define CAMLxparamN(x, size) \
+  struct caml__roots_block caml__roots_##x; \
+  int caml__dummy_##x = ( \
+    (caml__roots_##x.next = local_roots), \
+    (local_roots = &caml__roots_##x), \
+    (caml__roots_##x.nitems = (size)), \
+    (caml__roots_##x.ntables = 1), \
+    (caml__roots_##x.tables[0] = &(x[0])), \
+    0)
+
+#define CAMLlocal1(x) \
+  value x = 0; \
+  CAMLxparam1 (x)
+
+#define CAMLlocal2(x, y) \
+  value x = 0, y = 0; \
+  CAMLxparam2 (x, y)
+
+#define CAMLlocal3(x, y, z) \
+  value x = 0, y = 0, z = 0; \
+  CAMLxparam3 (x, y, z)
+
+#define CAMLlocal4(x, y, z, t) \
+  value x = 0, y = 0, z = 0, t = 0; \
+  CAMLxparam4 (x, y, z, t)
+
+#define CAMLlocal5(x, y, z, t, u) \
+  value x = 0, y = 0, z = 0, t = 0, u = 0; \
+  CAMLxparam5 (x, y, z, t, u)
+
+#define CAMLlocalN(x, size) \
+  value x [(size)] = { 0, /* 0, 0, ... */ }; \
+  CAMLxparamN (x, (size))
+
+
+#define CAMLreturn0 do{ \
+  local_roots = caml__frame; \
+  return; \
+}while (0)
+
+#define CAMLreturn(result) do{ \
+  local_roots = caml__frame; \
+  return (result); \
+}while(0)
+
+/* convenience macro */
+#define Store_field(block, offset, val) do{ \
+  mlsize_t caml__temp_offset = (offset); \
+  value caml__temp_val = (val); \
+  modify (&Field ((block), caml__temp_offset), caml__temp_val); \
+}while(0)
+
+/*
+   NOTE: [Begin_roots] and [End_roots] are superseded by [CAMLparam]*,
+   [CAMLxparam]*, [CAMLlocal]*, [CAMLreturn].
+
+   [Begin_roots] and [End_roots] are used for C variables that are GC roots.
+   It must contain all values in C local variables and function parameters
+   at the time the minor GC is called.
+   Usage:
+   After initialising your local variables to legal Caml values, but before
+   calling allocation functions, insert [Begin_roots_n(v1, ... vn)], where
+   v1 ... vn are your variables of type [value] that you want to be updated
+   across allocations.
+   At the end, insert [End_roots()].
+
+   Note that [Begin_roots] opens a new block, and [End_roots] closes it.
+   Thus they must occur in matching pairs at the same brace nesting level.
+
+   You can use [Val_unit] as a dummy initial value for your variables.
+*/
+
+#define Begin_root Begin_roots1
+
+#define Begin_roots1(r0) { \
+  struct caml__roots_block caml__roots_block; \
+  caml__roots_block.next = local_roots; \
+  local_roots = &caml__roots_block; \
+  caml__roots_block.nitems = 1; \
+  caml__roots_block.ntables = 1; \
+  caml__roots_block.tables[0] = &(r0);
+
+#define Begin_roots2(r0, r1) { \
+  struct caml__roots_block caml__roots_block; \
+  caml__roots_block.next = local_roots; \
+  local_roots = &caml__roots_block; \
+  caml__roots_block.nitems = 1; \
+  caml__roots_block.ntables = 2; \
+  caml__roots_block.tables[0] = &(r0); \
+  caml__roots_block.tables[1] = &(r1);
+
+#define Begin_roots3(r0, r1, r2) { \
+  struct caml__roots_block caml__roots_block; \
+  caml__roots_block.next = local_roots; \
+  local_roots = &caml__roots_block; \
+  caml__roots_block.nitems = 1; \
+  caml__roots_block.ntables = 3; \
+  caml__roots_block.tables[0] = &(r0); \
+  caml__roots_block.tables[1] = &(r1); \
+  caml__roots_block.tables[2] = &(r2);
+
+#define Begin_roots4(r0, r1, r2, r3) { \
+  struct caml__roots_block caml__roots_block; \
+  caml__roots_block.next = local_roots; \
+  local_roots = &caml__roots_block; \
+  caml__roots_block.nitems = 1; \
+  caml__roots_block.ntables = 4; \
+  caml__roots_block.tables[0] = &(r0); \
+  caml__roots_block.tables[1] = &(r1); \
+  caml__roots_block.tables[2] = &(r2); \
+  caml__roots_block.tables[3] = &(r3);
+
+#define Begin_roots5(r0, r1, r2, r3, r4) { \
+  struct caml__roots_block caml__roots_block; \
+  caml__roots_block.next = local_roots; \
+  local_roots = &caml__roots_block; \
+  caml__roots_block.nitems = 1; \
+  caml__roots_block.ntables = 5; \
+  caml__roots_block.tables[0] = &(r0); \
+  caml__roots_block.tables[1] = &(r1); \
+  caml__roots_block.tables[2] = &(r2); \
+  caml__roots_block.tables[3] = &(r3); \
+  caml__roots_block.tables[4] = &(r4);
+
+#define Begin_roots_block(table, size) { \
+  struct caml__roots_block caml__roots_block; \
+  caml__roots_block.next = local_roots; \
+  local_roots = &caml__roots_block; \
+  caml__roots_block.nitems = (size); \
+  caml__roots_block.ntables = 1; \
+  caml__roots_block.tables[0] = (table);
+
+#define End_roots() local_roots = caml__roots_block.next; }
+
+
+/* [register_global_root] registers a global C variable as a memory root
+   for the duration of the program, or until [remove_global_root] is
+   called. */
+
+CAMLextern void register_global_root (value *);
+
+/* [remove_global_root] removes a memory root registered on a global C
+   variable with [register_global_root]. */
+
+CAMLextern void remove_global_root (value *);
+
+
+#endif /* _memory_ */
+
diff --git a/byterun/meta.c b/byterun/meta.c
new file mode 100644
index 0000000000..8968498d32
--- /dev/null
+++ b/byterun/meta.c
@@ -0,0 +1,145 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Primitives for the toplevel */
+
+#include "alloc.h"
+#include "config.h"
+#include "fail.h"
+#include "fix_code.h"
+#include "interp.h"
+#include "major_gc.h"
+#include "memory.h"
+#include "minor_gc.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "prims.h"
+#include "stacks.h"
+
+#ifndef NATIVE_CODE
+
+CAMLprim value get_global_data(value unit)
+{
+  return global_data;
+}
+
+CAMLprim value reify_bytecode(value prog, value len)
+{
+  value clos;
+#ifdef ARCH_BIG_ENDIAN
+  fixup_endianness((code_t) prog, (asize_t) Long_val(len));
+#endif
+#ifdef THREADED_CODE
+  thread_code((code_t) prog, (asize_t) Long_val(len));
+#endif
+  clos = alloc_small (1, Closure_tag);
+  Code_val(clos) = (code_t) prog;
+  return clos;
+}
+
+CAMLprim value realloc_global(value size)
+{
+  mlsize_t requested_size, actual_size, i;
+  value new_global_data;
+
+  requested_size = Long_val(size);
+  actual_size = Wosize_val(global_data);
+  if (requested_size >= actual_size) {
+    requested_size = (requested_size + 0x100) & 0xFFFFFF00;
+    gc_message (0x08, "Growing global data to %lu entries\n", requested_size);
+    new_global_data = alloc_shr(requested_size, 0);
+    for (i = 0; i < actual_size; i++)
+      initialize(&Field(new_global_data, i), Field(global_data, i));
+    for (i = actual_size; i < requested_size; i++){
+      Field (new_global_data, i) = Val_long (0);
+    }
+    global_data = new_global_data;
+  }
+  return Val_unit;
+}
+    
+CAMLprim value get_current_environment(value unit)
+{
+  return *extern_sp;
+}
+
+CAMLprim value invoke_traced_function(value codeptr, value env, value arg)
+{
+  /* Stack layout on entry:
+       return frame into instrument_closure function
+       arg3 to call_original_code (arg)
+       arg2 to call_original_code (env)
+       arg1 to call_original_code (codeptr)
+       arg3 to call_original_code (arg)
+       arg2 to call_original_code (env)
+       saved env */
+
+  /* Stack layout on exit:
+       return frame into instrument_closure function
+       actual arg to code (arg)
+       pseudo return frame into codeptr:
+         extra_args = 0
+         environment = env
+         PC = codeptr
+       arg3 to call_original_code (arg)                   same 6 bottom words as
+       arg2 to call_original_code (env)                   on entrance, but
+       arg1 to call_original_code (codeptr)               shifted down 4 words
+       arg3 to call_original_code (arg)
+       arg2 to call_original_code (env)
+       saved env */
+
+  value * osp, * nsp;
+  int i;
+
+  osp = extern_sp;
+  extern_sp -= 4;
+  nsp = extern_sp;
+  for (i = 0; i < 6; i++) nsp[i] = osp[i];
+  nsp[6] = codeptr;
+  nsp[7] = env;
+  nsp[8] = Val_int(0);
+  nsp[9] = arg;
+  return Val_unit;
+}
+
+#else
+
+/* Dummy definitions to support compilation of ocamlc.opt */
+
+value get_global_data(value unit)
+{
+  invalid_argument("Meta.get_global_data");
+  return Val_unit; /* not reached */
+}
+
+value realloc_global(value size)
+{
+  invalid_argument("Meta.realloc_global");
+  return Val_unit; /* not reached */
+}
+    
+value available_primitives(value unit)
+{
+  invalid_argument("Meta.available_primitives");
+  return Val_unit; /* not reached */
+}
+
+value invoke_traced_function(value codeptr, value env, value arg)
+{
+  invalid_argument("Meta.invoke_traced_function");
+  return Val_unit; /* not reached */
+}
+
+#endif
diff --git a/byterun/mpwtool.c b/byterun/mpwtool.c
new file mode 100644
index 0000000000..3c45a685e1
--- /dev/null
+++ b/byterun/mpwtool.c
@@ -0,0 +1,39 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Damien Doligez, projet Para, INRIA Rocquencourt          */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* glue code for MPW tools */
+
+#include <stdio.h>
+#include <stdlib.h>
+
+int ui_read (int fd, char *p, unsigned int n)
+{
+  return read (fd, p, n);
+}
+
+int ui_write (int fd, char *p, unsigned int n)
+{
+  return write (fd, p, n);
+}
+
+void ui_print_stderr (char *msg, void *arg)
+{
+  fprintf (stderr, msg, arg);
+}
+
+void ui_exit (int retcode)
+{
+  exit (retcode);
+}
diff --git a/byterun/osdeps.h b/byterun/osdeps.h
new file mode 100644
index 0000000000..cac3e71666
--- /dev/null
+++ b/byterun/osdeps.h
@@ -0,0 +1,54 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*           Xavier Leroy, projet Cristal, INRIA Rocquencourt          */
+/*                                                                     */
+/*  Copyright 2001 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Operating system - specific stuff */
+
+#ifndef _osdeps_
+
+#define _osdeps_
+
+#include "misc.h"
+
+/* Decompose the given path into a list of directories, and add them
+   to the given table.  Return the block to be freed later. */
+extern char * decompose_path(struct ext_table * tbl, char * path);
+
+/* Search the given file in the given list of directories.
+   If not found, return a copy of [name].  Result is allocated with
+   [stat_alloc]. */
+extern char * search_in_path(struct ext_table * path, char * name);
+
+/* Same, but search an executable name in the system path for executables. */
+CAMLextern char * search_exe_in_path(char * name);
+
+/* Same, but search a shared library in the given path. */
+extern char * search_dll_in_path(struct ext_table * path, char * name);
+
+/* Open a shared library and return a handle on it.
+   Return [NULL] on error. */
+extern void * caml_dlopen(char * libname);
+
+/* Close a shared library handle */
+extern void caml_dlclose(void * handle);
+
+/* Look up the given symbol in the given shared library.
+   Return [NULL] if not found, or symbol value if found. */
+extern void * caml_dlsym(void * handle, char * name);
+
+/* Return an error message describing the most recent dynlink failure. */
+extern char * caml_dlerror(void);
+
+#endif
+
diff --git a/byterun/parsing.c b/byterun/parsing.c
new file mode 100644
index 0000000000..be902c314f
--- /dev/null
+++ b/byterun/parsing.c
@@ -0,0 +1,290 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* The PDA automaton for parsers generated by camlyacc */
+
+#include <stdio.h>
+#include <string.h>
+#include "config.h"
+#include "mlvalues.h"
+#include "memory.h"
+#include "alloc.h"
+
+#define ERRCODE 256
+
+struct parser_tables {    /* Mirrors parse_tables in ../stdlib/parsing.mli */
+  value actions;
+  value transl_const;
+  value transl_block;
+  char * lhs;
+  char * len;
+  char * defred;
+  char * dgoto;
+  char * sindex;
+  char * rindex;
+  char * gindex;
+  value tablesize;
+  char * table;
+  char * check;
+  value error_function;
+  char * names_const;
+  char * names_block;
+};
+
+struct parser_env {       /* Mirrors parser_env in ../stdlib/parsing.ml */
+  value s_stack;
+  value v_stack;
+  value symb_start_stack;
+  value symb_end_stack;
+  value stacksize;
+  value stackbase;
+  value curr_char;
+  value lval;
+  value symb_start;
+  value symb_end;
+  value asp;
+  value rule_len;
+  value rule_number;
+  value sp;
+  value state;
+  value errflag;
+};
+
+#if defined(ARCH_BIG_ENDIAN) || SIZEOF_SHORT != 2
+#define Short(tbl,n) \
+  (*((unsigned char *)((tbl) + (n) * 2)) + \
+          (*((schar *)((tbl) + (n) * 2 + 1)) << 8))
+#else
+#define Short(tbl,n) (((short *)(tbl))[n])
+#endif
+
+int parser_trace = 0;
+
+/* Input codes */
+/* Mirrors parser_input in ../stdlib/parsing.ml */
+#define START 0
+#define TOKEN_READ 1
+#define STACKS_GROWN_1 2
+#define STACKS_GROWN_2 3
+#define SEMANTIC_ACTION_COMPUTED 4
+#define ERROR_DETECTED 5
+
+/* Output codes */
+/* Mirrors parser_output in ../stdlib/parsing.ml */
+#define READ_TOKEN Val_int(0) 
+#define RAISE_PARSE_ERROR Val_int(1)
+#define GROW_STACKS_1 Val_int(2)
+#define GROW_STACKS_2 Val_int(3)
+#define COMPUTE_SEMANTIC_ACTION Val_int(4)
+#define CALL_ERROR_FUNCTION Val_int(5)
+
+/* To preserve local variables when communicating with the ML code */
+
+#define SAVE \
+  env->sp = Val_int(sp), \
+  env->state = Val_int(state), \
+  env->errflag = Val_int(errflag)
+
+#define RESTORE \
+  sp = Int_val(env->sp), \
+  state = Int_val(env->state), \
+  errflag = Int_val(env->errflag)
+
+/* Auxiliary for printing token just read */
+
+static char * token_name(char * names, int number)
+{
+  for (/*nothing*/; number > 0; number--) {
+    if (names[0] == 0) return "<unknown token>";
+    names += strlen(names) + 1;
+  }
+  return names;
+}
+
+static void print_token(struct parser_tables *tables, int state, value tok)
+{
+  mlsize_t i;
+  value v;
+
+  if (Is_long(tok)) {
+    fprintf(stderr, "State %d: read token %s\n",
+            state, token_name(tables->names_const, Int_val(tok)));
+  } else {
+    fprintf(stderr, "State %d: read token %s(",
+            state, token_name(tables->names_block, Tag_val(tok)));
+    v = Field(tok, 0);
+    if (Is_long(v))
+      fprintf(stderr, "%ld", Long_val(v));
+    else if (Tag_val(v) == String_tag)
+      fprintf(stderr, "%s", String_val(v));
+    else if (Tag_val(v) == Double_tag)
+      fprintf(stderr, "%g", Double_val(v));
+    else
+      fprintf(stderr, "_");
+    fprintf(stderr, ")\n");
+  }          
+}      
+
+/* The pushdown automata */
+
+CAMLprim value parse_engine(struct parser_tables *tables,
+                            struct parser_env *env, value cmd, value arg)
+{
+  int state;
+  mlsize_t sp, asp;
+  int errflag;
+  int n, n1, n2, m, state1;
+
+  switch(Int_val(cmd)) {
+
+  case START:
+    state = 0;
+    sp = Int_val(env->sp);
+    errflag = 0;
+
+  loop:
+    n = Short(tables->defred, state);
+    if (n != 0) goto reduce;
+    if (Int_val(env->curr_char) >= 0) goto testshift;
+    SAVE;
+    return READ_TOKEN;
+                                /* The ML code calls the lexer and updates */
+                                /* symb_start and symb_end */
+  case TOKEN_READ:
+    RESTORE;
+    if (Is_block(arg)) {
+      env->curr_char = Field(tables->transl_block, Tag_val(arg));
+      modify(&env->lval, Field(arg, 0));
+    } else {
+      env->curr_char = Field(tables->transl_const, Int_val(arg));
+      modify(&env->lval, Val_long(0));
+    }
+    if (parser_trace) print_token(tables, state, arg);
+    
+  testshift:
+    n1 = Short(tables->sindex, state);
+    n2 = n1 + Int_val(env->curr_char);
+    if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
+        Short(tables->check, n2) == Int_val(env->curr_char)) goto shift;
+    n1 = Short(tables->rindex, state);
+    n2 = n1 + Int_val(env->curr_char);
+    if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
+        Short(tables->check, n2) == Int_val(env->curr_char)) {
+      n = Short(tables->table, n2);
+      goto reduce;
+    }
+    if (errflag > 0) goto recover;
+    SAVE;
+    return CALL_ERROR_FUNCTION;
+                                /* The ML code calls the error function */
+  case ERROR_DETECTED:
+    RESTORE;
+  recover:
+    if (errflag < 3) {
+      errflag = 3;
+      while (1) {
+        state1 = Int_val(Field(env->s_stack, sp));
+        n1 = Short(tables->sindex, state1);
+        n2 = n1 + ERRCODE;
+        if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
+            Short(tables->check, n2) == ERRCODE) {
+          if (parser_trace) 
+            fprintf(stderr, "Recovering in state %d\n", state1);
+          goto shift_recover;
+        } else {
+          if (parser_trace) fprintf(stderr, "Discarding state %d\n", state1);
+          if (sp <= Int_val(env->stackbase)) {
+            if (parser_trace) fprintf(stderr, "No more states to discard\n");
+            return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */
+          }
+          sp--;
+        }
+      }
+    } else {
+      if (Int_val(env->curr_char) == 0)
+        return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */
+      if (parser_trace) fprintf(stderr, "Discarding last token read\n");
+      env->curr_char = Val_int(-1);
+      goto loop;
+    }
+    
+  shift:
+    env->curr_char = Val_int(-1);
+    if (errflag > 0) errflag--;
+  shift_recover:
+    if (parser_trace)
+      fprintf(stderr, "State %d: shift to state %d\n",
+              state, Short(tables->table, n2));
+    state = Short(tables->table, n2);
+    sp++;
+    if (sp < Long_val(env->stacksize)) goto push;
+    SAVE;
+    return GROW_STACKS_1;
+                                 /* The ML code resizes the stacks */
+  case STACKS_GROWN_1:
+    RESTORE;
+  push:
+    Field(env->s_stack, sp) = Val_int(state);
+    modify(&Field(env->v_stack, sp), env->lval);
+    Field(env->symb_start_stack, sp) = env->symb_start;
+    Field(env->symb_end_stack, sp) = env->symb_end;
+    goto loop;
+
+  reduce:
+    if (parser_trace)
+      fprintf(stderr, "State %d: reduce by rule %d\n", state, n);
+    m = Short(tables->len, n);
+    env->asp = Val_int(sp);
+    env->rule_number = Val_int(n);
+    env->rule_len = Val_int(m);
+    sp = sp - m + 1;
+    m = Short(tables->lhs, n);
+    state1 = Int_val(Field(env->s_stack, sp - 1));
+    n1 = Short(tables->gindex, m);
+    n2 = n1 + state1;
+    if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
+        Short(tables->check, n2) == state1) {
+      state = Short(tables->table, n2);
+    } else {
+      state = Short(tables->dgoto, m);
+    }
+    if (sp < Long_val(env->stacksize)) goto semantic_action;
+    SAVE;
+    return GROW_STACKS_2;
+                                /* The ML code resizes the stacks */
+  case STACKS_GROWN_2:
+    RESTORE;
+  semantic_action:
+    SAVE;
+    return COMPUTE_SEMANTIC_ACTION;
+                                /* The ML code calls the semantic action */
+  case SEMANTIC_ACTION_COMPUTED:
+    RESTORE;
+    Field(env->s_stack, sp) = Val_int(state);
+    modify(&Field(env->v_stack, sp), arg);
+    asp = Int_val(env->asp);
+    Field(env->symb_end_stack, sp) = Field(env->symb_end_stack, asp);
+    if (sp > asp) {
+      /* This is an epsilon production. Take symb_start equal to symb_end. */
+      Field(env->symb_start_stack, sp) = Field(env->symb_end_stack, asp);
+    }
+    goto loop;
+
+  default:                      /* Should not happen */
+    Assert(0);
+    return RAISE_PARSE_ERROR;   /* Keeps gcc -Wall happy */
+  }
+  
+}
diff --git a/byterun/prims.h b/byterun/prims.h
new file mode 100644
index 0000000000..22468d4b27
--- /dev/null
+++ b/byterun/prims.h
@@ -0,0 +1,30 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Interface with C primitives. */
+
+#ifndef _prims_
+#define _prims_
+
+typedef value (*c_primitive)();
+
+extern c_primitive builtin_cprim[];
+extern char * names_of_builtin_cprim[];
+
+extern struct ext_table prim_table;
+
+#define Primitive(n) ((c_primitive)(prim_table.contents[n]))
+
+#endif /* _prims_ */
diff --git a/byterun/printexc.c b/byterun/printexc.c
new file mode 100644
index 0000000000..79ff8fbe48
--- /dev/null
+++ b/byterun/printexc.c
@@ -0,0 +1,138 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Print an uncaught exception and abort */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include "backtrace.h"
+#include "callback.h"
+#include "debugger.h"
+#include "fail.h"
+#include "misc.h"
+#include "mlvalues.h"
+#ifdef HAS_UI
+#include "ui.h"
+#endif
+#include "printexc.h"
+
+struct stringbuf {
+  char * ptr;
+  char * end;
+  char data[256];
+};
+
+static void add_char(struct stringbuf *buf, char c)
+{
+  if (buf->ptr < buf->end) *(buf->ptr++) = c;
+}
+
+static void add_string(struct stringbuf *buf, char *s)
+{
+  int len = strlen(s);
+  if (buf->ptr + len > buf->end) len = buf->end - buf->ptr;
+  if (len > 0) memmove(buf->ptr, s, len);
+  buf->ptr += len;
+}
+  
+CAMLexport char * format_caml_exception(value exn)
+{
+  mlsize_t start, i;
+  value bucket, v;
+  struct stringbuf buf;
+  char intbuf[64];
+  char * res;
+
+  buf.ptr = buf.data;
+  buf.end = buf.data + sizeof(buf.data) - 1;
+  add_string(&buf, String_val(Field(Field(exn, 0), 0)));
+  if (Wosize_val(exn) >= 2) {
+    /* Check for exceptions in the style of Match_failure and Assert_failure */
+    if (Wosize_val(exn) == 2 &&
+        Is_block(Field(exn, 1)) &&
+        Tag_val(Field(exn, 1)) == 0) {
+      bucket = Field(exn, 1);
+      start = 0;
+    } else {
+      bucket = exn;
+      start = 1;
+    }
+    add_char(&buf, '(');
+    for (i = start; i < Wosize_val(bucket); i++) {
+      if (i > start) add_string(&buf, ", ");
+      v = Field(bucket, i);
+      if (Is_long(v)) {
+        sprintf(intbuf, "%ld", Long_val(v));
+        add_string(&buf, intbuf);
+      } else if (Tag_val(v) == String_tag) {
+        add_char(&buf, '"');
+        add_string(&buf, String_val(v));
+        add_char(&buf, '"');
+      } else {
+        add_char(&buf, '_');
+      }
+    }
+    add_char(&buf, ')');
+  }
+  *buf.ptr = 0;              /* Terminate string */
+  i = buf.ptr - buf.data + 1;
+  res = malloc(i);
+  if (res == NULL) return NULL;
+  memmove(res, buf.data, i);
+  return res;
+}
+
+
+void fatal_uncaught_exception(value exn)
+{
+  char * msg;
+  value * at_exit;
+#ifndef NATIVE_CODE
+  int saved_backtrace_active, saved_backtrace_pos;
+#endif
+  /* Build a string representation of the exception */
+  msg = format_caml_exception(exn);
+  /* Perform "at_exit" processing, ignoring all exceptions that may
+     be triggered by this */
+#ifndef NATIVE_CODE
+  saved_backtrace_active = backtrace_active;
+  saved_backtrace_pos = backtrace_pos;
+  backtrace_active = 0;
+#endif
+  at_exit = caml_named_value("Pervasives.do_at_exit");
+  if (at_exit != NULL) callback_exn(*at_exit, Val_unit);
+#ifndef NATIVE_CODE
+  backtrace_active = saved_backtrace_active;
+  backtrace_pos = saved_backtrace_pos;
+#endif
+  /* Display the uncaught exception */
+#ifdef HAS_UI
+  ui_print_stderr("Fatal error: exception %s\n", msg);
+#else
+  fprintf(stderr, "Fatal error: exception %s\n", msg);
+#endif
+  free(msg);
+  /* Display the backtrace if available */
+#ifndef NATIVE_CODE
+  if (backtrace_active && !debugger_in_use) print_exception_backtrace();
+#endif
+  /* Terminate the process */
+#ifdef HAS_UI
+  ui_exit(2);
+#else
+  exit(2);
+#endif
+}
diff --git a/byterun/printexc.h b/byterun/printexc.h
new file mode 100644
index 0000000000..1cd3381736
--- /dev/null
+++ b/byterun/printexc.h
@@ -0,0 +1,27 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 2001 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#ifndef _printexc_
+#define _printexc_
+
+
+#include "misc.h"
+#include "mlvalues.h"
+
+CAMLextern char * format_caml_exception (value);
+void fatal_uncaught_exception (value) Noreturn;
+
+
+#endif /* _printexc_ */
diff --git a/byterun/reverse.h b/byterun/reverse.h
new file mode 100644
index 0000000000..85cd9fb329
--- /dev/null
+++ b/byterun/reverse.h
@@ -0,0 +1,64 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Swap byte-order in 16, 32, and 64-bit integers or floats */
+
+#ifndef _reverse_
+#define _reverse_
+
+#define Reverse_16(dst,src) {                                               \
+  char * _p, * _q;                                                          \
+  char _a;                                                                  \
+  _p = (char *) (src);                                                      \
+  _q = (char *) (dst);                                                      \
+  _a = _p[0];                                                               \
+  _q[0] = _p[1];                                                            \
+  _q[1] = _a;                                                               \
+}
+
+#define Reverse_32(dst,src) {                                               \
+  char * _p, * _q;                                                          \
+  char _a, _b;                                                              \
+  _p = (char *) (src);                                                      \
+  _q = (char *) (dst);                                                      \
+  _a = _p[0];                                                               \
+  _b = _p[1];                                                               \
+  _q[0] = _p[3];                                                            \
+  _q[1] = _p[2];                                                            \
+  _q[3] = _a;                                                               \
+  _q[2] = _b;                                                               \
+}
+
+#define Reverse_64(dst,src) {                                               \
+  char * _p, * _q;                                                          \
+  char _a, _b;                                                              \
+  _p = (char *) (src);                                                      \
+  _q = (char *) (dst);                                                      \
+  _a = _p[0];                                                               \
+  _b = _p[1];                                                               \
+  _q[0] = _p[7];                                                            \
+  _q[1] = _p[6];                                                            \
+  _q[7] = _a;                                                               \
+  _q[6] = _b;                                                               \
+  _a = _p[2];                                                               \
+  _b = _p[3];                                                               \
+  _q[2] = _p[5];                                                            \
+  _q[3] = _p[4];                                                            \
+  _q[5] = _a;                                                               \
+  _q[4] = _b;                                                               \
+}
+
+
+#endif /* _reverse_ */
diff --git a/byterun/roots.h b/byterun/roots.h
new file mode 100644
index 0000000000..1e6c169b0e
--- /dev/null
+++ b/byterun/roots.h
@@ -0,0 +1,38 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#ifndef _roots_
+#define _roots_
+
+#include "misc.h"
+#include "memory.h"
+
+typedef void (*scanning_action) (value, value *);
+
+void oldify_local_roots (void);
+void darken_all_roots (void);
+void do_roots (scanning_action);
+#ifndef NATIVE_CODE
+CAMLextern void do_local_roots (scanning_action, value *, value *,
+                                struct caml__roots_block *);
+#else
+CAMLextern void do_local_roots(scanning_action f, char * bottom_of_stack,
+                               unsigned long last_retaddr, value * gc_regs,
+                               struct caml__roots_block * local_roots);
+#endif
+
+CAMLextern void (*scan_roots_hook) (scanning_action);
+
+#endif /* _roots_ */
diff --git a/byterun/rotatecursor.c b/byterun/rotatecursor.c
new file mode 100644
index 0000000000..29506108db
--- /dev/null
+++ b/byterun/rotatecursor.c
@@ -0,0 +1,120 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Damien Doligez, projet Para, INRIA Rocquencourt          */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* rotatecursor library, written by <Damien.Doligez@inria.fr>
+   This file is in the public domain.
+
+   version 1.13
+   
+   See rotatecursor.h for documentation.
+*/
+
+#include <CursorCtl.h>
+#include <MacTypes.h>
+#include <stdlib.h>
+#include <Timer.h>
+
+#include "rotatecursor.h"
+
+typedef struct {
+  TMTask t;
+  int volatile *p1;
+  int volatile *p2;
+} Xtmtask;
+
+int volatile rotatecursor_flag = 1;
+static int rotatecursor_inited = 0;
+static int rotatecursor_period = 50;
+static Xtmtask rotatecursor_tmtask;
+static pascal void (*rotatecursor_action) (long) = &RotateCursor;
+
+
+#if GENERATINGCFM
+
+static void rotatecursor_timerproc (Xtmtask *p)
+{
+  if (p->p1 != NULL && *(p->p1) == 0) *(p->p1) = 1;
+  if (p->p2 != NULL && *(p->p2) == 0) *(p->p2) = 1;
+}
+
+#else /* GENERATINGCFM */
+
+extern Xtmtask *getparam() ONEWORDINLINE(0x2009);  /* MOVE.L A1, D0 */
+
+static void rotatecursor_timerproc (void)
+{
+  register Xtmtask *p = getparam ();
+
+  if (p->p1 != NULL && *(p->p1) == 0) *(p->p1) = 1;
+  if (p->p2 != NULL && *(p->p2) == 0) *(p->p2) = 1;
+}
+
+#endif /* else GENERATINGCFM */
+
+
+void rotatecursor_final (void)
+{
+  if (rotatecursor_inited){
+    RmvTime ((QElemPtr) &rotatecursor_tmtask);
+    rotatecursor_flag = 1;
+    rotatecursor_inited = 0;
+  }
+}
+
+static void rotatecursor_init (void)
+{
+  if (rotatecursor_inited) return;
+
+  rotatecursor_tmtask.t.tmAddr = NewTimerProc (rotatecursor_timerproc);
+  rotatecursor_tmtask.t.tmCount = 0;
+  rotatecursor_tmtask.t.tmWakeUp = 0;
+  rotatecursor_tmtask.t.tmReserved = 0;
+  rotatecursor_tmtask.p1 = NULL;
+  rotatecursor_tmtask.p2 = &rotatecursor_flag;
+
+  InsTime ((QElemPtr) &rotatecursor_tmtask);
+  atexit (rotatecursor_final);
+  rotatecursor_flag = 1;
+
+  rotatecursor_inited = 1;
+}
+
+void rotatecursor_options (int volatile *p1, int period, pascal void (*f) (long))
+{
+  if (!rotatecursor_inited) rotatecursor_init ();
+
+  rotatecursor_tmtask.p1 = p1;
+  if (p1 != NULL && *p1 == 0) *p1 = rotatecursor_flag;
+  rotatecursor_period = (period == 0) ? 50 : period;
+  rotatecursor_action = (f == NULL) ? &RotateCursor : f;
+}
+
+int rotatecursor_rearm (void)
+{
+  if (!rotatecursor_inited) rotatecursor_init ();
+  
+  rotatecursor_flag = 0;
+  PrimeTime ((QElemPtr) &rotatecursor_tmtask, rotatecursor_period);
+  return 0;
+}
+
+int rotatecursor_ticker (void)
+{
+  if (!rotatecursor_inited) rotatecursor_init ();
+
+  rotatecursor_rearm ();
+  (*rotatecursor_action) (32);
+  return 0;
+}
diff --git a/byterun/rotatecursor.h b/byterun/rotatecursor.h
new file mode 100644
index 0000000000..0fedabc67c
--- /dev/null
+++ b/byterun/rotatecursor.h
@@ -0,0 +1,124 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Damien Doligez, projet Para, INRIA Rocquencourt          */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* rotatecursor library, written by <Damien.Doligez@inria.fr>
+   This file is in the public domain.
+
+   version 1.13
+
+   The goal of this library is to help implement cooperative multitasking
+   for MPW tools: to make sure that your program calls RotateCursor often
+   enough (about 20 times per second) but not too often (to avoid a big
+   slowdown).
+   It can also be used for applications with a little more work.
+
+
+   Simple usage for MPW tools:
+   ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+   1. #include this file where appropriate
+   2. Insert the following line in every loop of your program:
+        ROTATECURSOR_MAGIC ();
+      The overhead of this macro is only a few CPU cycles, so it can be
+      used without problem even in tight loops.
+
+
+   Simple usage for applications:
+   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+   1. Write a function with prototype:
+        pascal void myaction (long x);
+      This functions should get and handle all events until the event
+      queue is empty (i.e. until it gets a null event).  It should also
+      animate the cursor.
+   2. #include this file where appropriate
+   3. Add this line to the init code of your program:
+        rotatecursor_options (NULL, 0, &myaction);
+   4. Insert the following line in every loop of your program:
+        ROTATECURSOR_MAGIC ();
+      The overhead of this macro is only a few CPU cycles, so it can be
+      used without problem even in tight loops.
+   5. If there is no function called RotateCursor in your libraries, you
+      will have to provide one that does nothing (it will not be called).
+
+   See below for advanced options.
+*/
+
+#ifndef _rotatecursor_h_
+#define _rotatecursor_h_
+
+extern int volatile rotatecursor_flag;
+/*
+  [rotatecursor_flag] will be automagically set to 1 when the time comes
+  to call [rotatecursor_ticker].
+*/
+
+
+void rotatecursor_options (int volatile *p1, int period,
+                           pascal void (*action) (long));
+/*
+  Use [rotatecursor_options] to change advanced parameters:
+
+  1. [p1] is a pointer to another variable that will be set to 1 when
+     the time is up, unless it is already nonzero.  Typical use is when
+     you already have a variable in your program that is set
+     asynchronously for something else, and you want to avoid testing
+     two different variables in your inner loop.  Pass [NULL] in this
+     argument if you don't need this feature.
+
+  2. [period] is the interval (in milliseconds) between calls to
+     RotateCursor.  Reasonable values are between 10 and 200.
+     If you pass 0 in this argument, the default value (50) will
+     be used.  This value is passed to PrimeTime, so a negative value
+     represents a delay in microseconds (not very useful here...)
+
+  3. [action] is the function that will be called at regular intervals
+     by [rotatecursor_ticker].  If you pass [NULL] in this argument,
+     the default function, [RotateCursor], will be called.
+*/
+
+int rotatecursor_rearm (void);
+/*
+  [rotatecursor_rearm] resets [rotatecursor_flag] to 0 and rearms the
+  Time Manager task that will set [rotatecursor_flag] to 1 after the
+  appropriate delay.
+  You can use [rotatecursor_rearm] if some part of your program needs
+  to perform a periodic action that is not the normal one set up
+  with [rotatecursor_options].
+  This function always returns 0.
+*/
+
+int rotatecursor_ticker (void);
+/*
+  [rotatecursor_ticker] calls [rotatecursor_rearm] (see below) and your
+  [action] function (or [RotateCursor]).
+  This function always returns 0.  It returns an int so you can use
+  it in an expression as well as a statement.
+ */
+
+#define ROTATECURSOR_MAGIC() (rotatecursor_flag ? rotatecursor_ticker () : 0)
+/*
+  [ROTATECURSOR_MAGIC] is a simple interface to [rotatecursor_flag]
+  and [rotatecursor_ticker].  Can be used as a statement (followed by
+  a semicolon) or in an expression (followed by a comma).
+*/
+
+void rotatecursor_final (void);
+/*
+  [rotatecursor_final] is set up (with [atexit]) to be called before your
+  program finishes.  If for any reason the [atexit] functions are not
+  called before your program exits, you should call this function by hand.
+  It is harmless to call [rotatecursor_final] twice.
+*/
+
+#endif /* _rotatecursor_h_ */
diff --git a/byterun/signals.c b/byterun/signals.c
new file mode 100644
index 0000000000..727b87aff7
--- /dev/null
+++ b/byterun/signals.c
@@ -0,0 +1,291 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#include <signal.h>
+#include "alloc.h"
+#include "callback.h"
+#include "config.h"
+#include "fail.h"
+#include "memory.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "roots.h"
+#include "signals.h"
+#include "sys.h"
+
+#if macintosh
+#include "rotatecursor.h"
+#endif /* macintosh */
+
+#ifdef _WIN32
+typedef void (*sighandler)(int sig);
+extern sighandler win32_signal(int sig, sighandler action);
+#define signal(sig,act) win32_signal(sig,act)
+#endif
+
+int volatile async_signal_mode = 0;
+int volatile pending_signal = 0;
+int volatile something_to_do = 0;
+int volatile force_major_slice = 0;
+value signal_handlers = 0;
+void (*enter_blocking_section_hook)(void) = NULL;
+void (*leave_blocking_section_hook)(void) = NULL;
+void (* volatile async_action_hook)(void) = NULL;
+
+void process_event(void)
+{
+  int signal_number;
+  void (*async_action)(void);
+  if (force_major_slice) minor_collection (); /* FIXME should be check_urgent_gc */
+  /* If a signal arrives between the following two instructions,
+     it will be lost.  To do: use atomic swap or atomic read-and-clear
+     for processors that support it? */
+  signal_number = pending_signal;
+  pending_signal = 0;
+  if (signal_number) execute_signal(signal_number, 0);
+  /* If an async action is scheduled between the following two instructions,
+     it will be lost. */
+  async_action = async_action_hook;
+  async_action_hook = NULL;
+  if (async_action != NULL) (*async_action)();
+#if macintosh
+  ROTATECURSOR_MAGIC ();
+#endif
+}
+
+static int rev_convert_signal_number(int signo);
+
+void execute_signal(int signal_number, int in_signal_handler)
+{
+  value res;
+#ifdef POSIX_SIGNALS
+  sigset_t sigs;
+  /* Block the signal before executing the handler, and record in sigs
+     the original signal mask */
+  sigemptyset(&sigs);
+  sigaddset(&sigs, signal_number);
+  sigprocmask(SIG_BLOCK, &sigs, &sigs);
+#endif
+  res = callback_exn(Field(signal_handlers, signal_number),
+                     Val_int(rev_convert_signal_number(signal_number)));
+#ifdef POSIX_SIGNALS
+  if (! in_signal_handler) {
+    /* Restore the original signal mask */
+    sigprocmask(SIG_SETMASK, &sigs, NULL);
+  } else if (Is_exception_result(res)) {
+    /* Restore the original signal mask and unblock the signal itself */
+    sigdelset(&sigs, signal_number);
+    sigprocmask(SIG_SETMASK, &sigs, NULL);
+  }
+#endif
+  if (Is_exception_result(res)) mlraise(Extract_exception(res));
+}
+
+void handle_signal(int signal_number)
+{
+#if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS)
+  signal(signal_number, handle_signal);
+#endif
+  if (async_signal_mode){
+    leave_blocking_section ();
+    execute_signal(signal_number, 1);
+    enter_blocking_section ();
+  }else{
+    pending_signal = signal_number;
+    something_to_do = 1;
+  }
+}
+
+void urge_major_slice (void)
+{
+  force_major_slice = 1;
+  something_to_do = 1;
+}
+
+CAMLexport void enter_blocking_section(void)
+{
+  int temp;
+
+  while (1){
+    Assert (!async_signal_mode);
+    /* If a signal arrives between the next two instructions,
+       it will be lost. */
+    temp = pending_signal;   pending_signal = 0;
+    if (temp) execute_signal(temp, 0);
+    async_signal_mode = 1;
+    if (!pending_signal) break;
+    async_signal_mode = 0;
+  }
+  if (enter_blocking_section_hook != NULL) enter_blocking_section_hook();
+}
+
+CAMLexport void leave_blocking_section(void)
+{
+#ifdef _WIN32
+  /* Under Win32, asynchronous signals such as ctrl-C are not processed
+     immediately (see ctrl_handler in win32.c), but simply set
+     pending_signal and let the system call run to completion.
+     Hence, test pending_signal here and act upon it, before we get
+     a chance to process the result of the system call. */
+  int signal_number = pending_signal;
+  pending_signal = 0;
+  if (signal_number) execute_signal(signal_number, 1);
+#endif
+  if (leave_blocking_section_hook != NULL) leave_blocking_section_hook();
+  Assert(async_signal_mode);
+  async_signal_mode = 0;
+}
+
+#ifndef SIGABRT
+#define SIGABRT -1
+#endif
+#ifndef SIGALRM
+#define SIGALRM -1
+#endif
+#ifndef SIGFPE
+#define SIGFPE -1
+#endif
+#ifndef SIGHUP
+#define SIGHUP -1
+#endif
+#ifndef SIGILL
+#define SIGILL -1
+#endif
+#ifndef SIGINT
+#define SIGINT -1
+#endif
+#ifndef SIGKILL
+#define SIGKILL -1
+#endif
+#ifndef SIGPIPE
+#define SIGPIPE -1
+#endif
+#ifndef SIGQUIT
+#define SIGQUIT -1
+#endif
+#ifndef SIGSEGV
+#define SIGSEGV -1
+#endif
+#ifndef SIGTERM
+#define SIGTERM -1
+#endif
+#ifndef SIGUSR1
+#define SIGUSR1 -1
+#endif
+#ifndef SIGUSR2
+#define SIGUSR2 -1
+#endif
+#ifndef SIGCHLD
+#define SIGCHLD -1
+#endif
+#ifndef SIGCONT
+#define SIGCONT -1
+#endif
+#ifndef SIGSTOP
+#define SIGSTOP -1
+#endif
+#ifndef SIGTSTP
+#define SIGTSTP -1
+#endif
+#ifndef SIGTTIN
+#define SIGTTIN -1
+#endif
+#ifndef SIGTTOU
+#define SIGTTOU -1
+#endif
+#ifndef SIGVTALRM
+#define SIGVTALRM -1
+#endif
+#ifndef SIGPROF
+#define SIGPROF -1
+#endif
+
+static int posix_signals[] = {
+  SIGABRT, SIGALRM, SIGFPE, SIGHUP, SIGILL, SIGINT, SIGKILL, SIGPIPE,
+  SIGQUIT, SIGSEGV, SIGTERM, SIGUSR1, SIGUSR2, SIGCHLD, SIGCONT,
+  SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU, SIGVTALRM, SIGPROF
+};
+
+CAMLexport int convert_signal_number(int signo)
+{
+  if (signo < 0 && signo >= -(sizeof(posix_signals) / sizeof(int)))
+    return posix_signals[-signo-1];
+  else
+    return signo;
+}
+
+static int rev_convert_signal_number(int signo)
+{
+  int i;
+  for (i = 0; i < sizeof(posix_signals) / sizeof(int); i++)
+    if (signo == posix_signals[i]) return -i - 1;
+  return signo;
+}
+
+#ifndef NSIG
+#define NSIG 64
+#endif
+
+CAMLprim value install_signal_handler(value signal_number, value action)
+{
+  CAMLparam2 (signal_number, action);
+  int sig;
+  void (*act)(int signo), (*oldact)(int signo);
+#ifdef POSIX_SIGNALS
+  struct sigaction sigact, oldsigact;
+#endif
+  CAMLlocal1 (res);
+
+  sig = convert_signal_number(Int_val(signal_number));
+  if (sig < 0 || sig >= NSIG) 
+    invalid_argument("Sys.signal: unavailable signal");
+  switch(action) {
+  case Val_int(0):              /* Signal_default */
+    act = SIG_DFL;
+    break;
+  case Val_int(1):              /* Signal_ignore */
+    act = SIG_IGN;
+    break;
+  default:                      /* Signal_handle */
+    act = handle_signal;
+    break;
+  }
+#ifdef POSIX_SIGNALS
+  sigact.sa_handler = act;
+  sigemptyset(&sigact.sa_mask);
+  sigact.sa_flags = 0;
+  if (sigaction(sig, &sigact, &oldsigact) == -1) sys_error(NO_ARG);
+  oldact = oldsigact.sa_handler;
+#else
+  oldact = signal(sig, act);
+  if (oldact == SIG_ERR) sys_error(NO_ARG);
+#endif
+  if (oldact == handle_signal) {
+    res = alloc_small (1, 0);          /* Signal_handle */
+    Field(res, 0) = Field(signal_handlers, sig);
+  }
+  else if (oldact == SIG_IGN)
+    res = Val_int(1);           /* Signal_ignore */
+  else
+    res = Val_int(0);           /* Signal_default */
+  if (Is_block(action)) {
+    if (signal_handlers == 0) {
+      signal_handlers = alloc(NSIG, 0);
+      register_global_root(&signal_handlers);
+    }
+    modify(&Field(signal_handlers, sig), Field(action, 0));
+  }
+  CAMLreturn (res);
+}
diff --git a/byterun/signals.h b/byterun/signals.h
new file mode 100644
index 0000000000..f052ba500d
--- /dev/null
+++ b/byterun/signals.h
@@ -0,0 +1,40 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#ifndef _signals_
+#define _signals_
+
+#include "misc.h"
+#include "mlvalues.h"
+
+extern value signal_handlers;
+CAMLextern int volatile pending_signal;
+CAMLextern int volatile something_to_do;
+extern int volatile force_major_slice;
+CAMLextern int volatile async_signal_mode;
+
+CAMLextern void enter_blocking_section (void);
+CAMLextern void leave_blocking_section (void);
+void urge_major_slice (void);
+CAMLextern int convert_signal_number (int);
+void execute_signal(int signal_number, int in_signal_handler);
+void process_event(void);
+
+CAMLextern void (*enter_blocking_section_hook)(void);
+CAMLextern void (*leave_blocking_section_hook)(void);
+CAMLextern void (* volatile async_action_hook)(void);
+
+#endif /* _signals_ */
+
diff --git a/byterun/stacks.c b/byterun/stacks.c
new file mode 100644
index 0000000000..3d0e2c4666
--- /dev/null
+++ b/byterun/stacks.c
@@ -0,0 +1,102 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* To initialize and resize the stacks */
+
+#include <string.h>
+#include "config.h"
+#include "fail.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "stacks.h"
+
+CAMLexport value * stack_low;
+CAMLexport value * stack_high;
+CAMLexport value * stack_threshold;
+CAMLexport value * extern_sp;
+CAMLexport value * trapsp;
+CAMLexport value * trap_barrier;
+value global_data;
+
+unsigned long max_stack_size;            /* also used in gc_ctrl.c */
+
+void init_stack (long unsigned int initial_max_size)
+{
+  stack_low = (value *) stat_alloc(Stack_size);
+  stack_high = stack_low + Stack_size / sizeof (value);
+  stack_threshold = stack_low + Stack_threshold / sizeof (value);
+  extern_sp = stack_high;
+  trapsp = stack_high;
+  trap_barrier = stack_high + 1;
+  max_stack_size = initial_max_size;
+  gc_message (0x08, "Initial stack limit: %luk bytes\n",
+              max_stack_size / 1024 * sizeof (value));
+}
+
+void realloc_stack(asize_t required_space)
+{
+  asize_t size;
+  value * new_low, * new_high, * new_sp;
+  value * p;
+
+  Assert(extern_sp >= stack_low);
+  size = stack_high - stack_low;
+  do {
+    if (size >= max_stack_size) raise_stack_overflow();
+    size *= 2;
+  } while (size < stack_high - extern_sp + required_space);
+  gc_message (0x08, "Growing stack to %luk bytes\n",
+              (unsigned long) size * sizeof(value) / 1024);
+  new_low = (value *) stat_alloc(size * sizeof(value));
+  new_high = new_low + size;
+
+#define shift(ptr) \
+    ((char *) new_high - ((char *) stack_high - (char *) (ptr)))
+
+  new_sp = (value *) shift(extern_sp);
+  memmove((char *) new_sp,
+          (char *) extern_sp,
+          (stack_high - extern_sp) * sizeof(value));
+  stat_free(stack_low);
+  trapsp = (value *) shift(trapsp);
+  trap_barrier = (value *) shift(trap_barrier);
+  for (p = trapsp; p < new_high; p = Trap_link(p))
+    Trap_link(p) = (value *) shift(Trap_link(p));
+  stack_low = new_low;
+  stack_high = new_high;
+  stack_threshold = stack_low + Stack_threshold / sizeof (value);
+  extern_sp = new_sp;
+
+#undef shift
+}
+
+CAMLprim value ensure_stack_capacity(value required_space)
+{
+  asize_t req = Long_val(required_space);
+  if (extern_sp - req < stack_low) realloc_stack(req);
+  return Val_unit;
+}
+
+void change_max_stack_size (long unsigned int new_max_size)
+{
+  asize_t size = stack_high - extern_sp + Stack_threshold / sizeof (value);
+
+  if (new_max_size < size) new_max_size = size;
+  if (new_max_size != max_stack_size){
+    gc_message (0x08, "Changing stack limit to %luk bytes\n",
+                new_max_size * sizeof (value) / 1024);
+  }
+  max_stack_size = new_max_size;
+}
diff --git a/byterun/stacks.h b/byterun/stacks.h
new file mode 100644
index 0000000000..96e45ad827
--- /dev/null
+++ b/byterun/stacks.h
@@ -0,0 +1,43 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* structure of the stacks */
+
+#ifndef _stacks_
+#define _stacks_
+
+
+#include "misc.h"
+#include "mlvalues.h"
+#include "memory.h"
+
+CAMLextern value * stack_low;
+CAMLextern value * stack_high;
+CAMLextern value * stack_threshold;
+CAMLextern value * extern_sp;
+CAMLextern value * trapsp;
+CAMLextern value * trap_barrier;
+
+#define Trap_pc(tp) (((code_t *)(tp))[0])
+#define Trap_link(tp) (((value **)(tp))[1])
+
+void reset_roots (void);
+void init_stack (unsigned long init_max_size);
+void realloc_stack (asize_t required_size);
+void change_max_stack_size (unsigned long new_max_size);
+
+
+#endif /* _stacks_ */
+
diff --git a/byterun/str.c b/byterun/str.c
new file mode 100644
index 0000000000..905b3a308a
--- /dev/null
+++ b/byterun/str.c
@@ -0,0 +1,133 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Operations on strings */
+
+#include <string.h>
+#include <ctype.h>
+#include "alloc.h"
+#include "fail.h"
+#include "mlvalues.h"
+#include "misc.h"
+#ifdef HAS_LOCALE
+#include <locale.h>
+#endif
+
+CAMLexport mlsize_t string_length(value s)
+{
+  mlsize_t temp;
+  temp = Bosize_val(s) - 1;
+  Assert (Byte (s, temp - Byte (s, temp)) == 0);
+  return temp - Byte (s, temp);
+}
+
+CAMLprim value ml_string_length(value s)
+{
+  mlsize_t temp;
+  temp = Bosize_val(s) - 1;
+  Assert (Byte (s, temp - Byte (s, temp)) == 0);
+  return Val_long(temp - Byte (s, temp));
+}
+
+CAMLprim value create_string(value len)
+{
+  mlsize_t size = Long_val(len);
+  if (size > Bsize_wsize (Max_wosize) - 1) invalid_argument("String.create");
+  return alloc_string(size);
+}
+
+CAMLprim value string_get(value str, value index)
+{
+  long idx = Long_val(index);
+  if (idx < 0 || idx >= string_length(str)) invalid_argument("String.get");
+  return Val_int(Byte_u(str, idx));
+}
+
+CAMLprim value string_set(value str, value index, value newval)
+{
+  long idx = Long_val(index);
+  if (idx < 0 || idx >= string_length(str)) invalid_argument("String.set");
+  Byte_u(str, idx) = Int_val(newval);
+  return Val_unit;
+}
+
+CAMLprim value string_equal(value s1, value s2)
+{
+  mlsize_t sz1 = Wosize_val(s1);
+  mlsize_t sz2 = Wosize_val(s2);
+  value * p1, * p2;
+  if (sz1 != sz2) return Val_false;
+  for(p1 = Op_val(s1), p2 = Op_val(s2); sz1 > 0; sz1--, p1++, p2++)
+    if (*p1 != *p2) return Val_false;
+  return Val_true;
+}
+
+CAMLprim value string_notequal(value s1, value s2)
+{
+  return Val_not(string_equal(s1, s2));
+}
+  
+CAMLprim value blit_string(value s1, value ofs1, value s2, value ofs2, value n)
+{
+  memmove(&Byte(s2, Long_val(ofs2)), &Byte(s1, Long_val(ofs1)), Int_val(n));
+  return Val_unit;
+}
+
+CAMLprim value fill_string(value s, value offset, value len, value init)
+{
+  register char * p;
+  register mlsize_t n;
+  register char c;
+
+  c = Long_val(init);
+  for(p = &Byte(s, Long_val(offset)), n = Long_val(len);
+      n > 0; n--, p++)
+    *p = c;
+  return Val_unit;
+}
+
+CAMLprim value is_printable(value chr)
+{
+  int c;
+
+#ifdef _WIN32
+  /* FIXME: is this necessary?  Wouldn't isprint() do what we want? */
+  static unsigned char printable_chars_iso[] = { /* 0x20-0x7E 0xA1-0xFF */
+    0, 0, 0, 0, 0xFF, 0xFF, 0xFF, 0xFF,
+    0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0x7F,
+    0, 0, 0, 0, 0xFE, 0xFF, 0xFF, 0xFF,
+    0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF
+  };
+  c = Int_val(chr);
+  return Val_bool(printable_chars_iso[c >> 3] & (1 << (c & 7)));
+#else
+#ifdef HAS_LOCALE
+  static int locale_is_set = 0;
+  if (! locale_is_set) {
+    setlocale(LC_CTYPE, "");
+    locale_is_set = 1;
+  }
+#endif
+  c = Int_val(chr);
+  return Val_bool(isprint(c));
+#endif
+}
+
+CAMLprim value bitvect_test(value bv, value n)
+{
+  int pos = Int_val(n);
+  return Val_int(Byte_u(bv, pos >> 3) & (1 << (pos & 7)));
+}
+
diff --git a/byterun/terminfo.c b/byterun/terminfo.c
new file mode 100644
index 0000000000..f136fc8992
--- /dev/null
+++ b/byterun/terminfo.c
@@ -0,0 +1,129 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Read and output terminal commands */
+
+#include "config.h"
+#include "alloc.h"
+#include "fail.h"
+#include "io.h"
+#include "mlvalues.h"
+
+#define Uninitialised (Val_int(0))
+#define Bad_term (Val_int(1))
+#define Good_term_tag 0
+
+#if defined (HAS_TERMCAP) && !defined (NATIVE_CODE)
+
+extern int tgetent (char * buffer, char * name);
+extern char * tgetstr (char * id, char ** area);
+extern int tgetnum (char * id);
+extern int tputs (char * str, int count, int (*outchar)(int c));
+
+static struct channel *chan;
+static char area [1024];
+static char *area_p = area;
+static int num_lines;
+static char *up = NULL;
+static char *down = NULL;
+static char *standout = NULL;
+static char *standend = NULL;
+
+CAMLprim value terminfo_setup (value vchan)
+{
+  value result;
+  static char buffer[1024];
+
+  chan = Channel (vchan);
+
+  if (tgetent(buffer, getenv("TERM")) != 1) return Bad_term;
+
+  num_lines = tgetnum ("li");
+  up = tgetstr ("up", &area_p);
+  down = tgetstr ("do", &area_p);
+  standout = tgetstr ("us", &area_p);
+  standend = tgetstr ("ue", &area_p);
+  if (standout == NULL || standend == NULL){
+    standout = tgetstr ("so", &area_p);
+    standend = tgetstr ("se", &area_p);
+  }
+  Assert (area_p <= area + 1024);
+  if (num_lines == -1 || up == NULL || down == NULL
+      || standout == NULL || standend == NULL){
+    return Bad_term;
+  }
+  result = alloc_small (1, Good_term_tag);
+  Field (result, 0) = Val_int (num_lines);
+  return result;
+}
+
+static int terminfo_putc (int c)
+{
+  putch (chan, c);
+  return c;
+}
+
+CAMLprim value terminfo_backup (value lines)
+{
+  int i;
+
+  for (i = 0; i < Int_val (lines); i++){
+    tputs (up, 1, terminfo_putc);
+  }
+  return Val_unit;
+}
+
+CAMLprim value terminfo_standout (value start)
+{
+  tputs (Bool_val (start) ? standout : standend, 1, terminfo_putc);
+  return Val_unit;
+}
+
+CAMLprim value terminfo_resume (value lines)
+{
+  int i;
+
+  for (i = 0; i < Int_val (lines); i++){
+    tputs (down, 1, terminfo_putc);
+  }
+  return Val_unit;
+}
+
+#else /* defined (HAS_TERMCAP) && !defined (NATIVE_CODE) */
+
+CAMLexport value terminfo_setup (value vchan)
+{
+  return Bad_term;
+}
+
+CAMLexport value terminfo_backup (value lines)
+{
+  invalid_argument("Terminfo.backup");
+  return Val_unit;
+}
+
+CAMLexport value terminfo_standout (value start)
+{
+  invalid_argument("Terminfo.standout");
+  return Val_unit;
+}
+
+CAMLexport value terminfo_resume (value lines)
+{
+  invalid_argument("Terminfo.resume");
+  return Val_unit;
+}
+
+#endif /* defined (HAS_TERMCAP) && !defined (NATIVE_CODE) */
diff --git a/byterun/ui.h b/byterun/ui.h
new file mode 100644
index 0000000000..66b3c50d54
--- /dev/null
+++ b/byterun/ui.h
@@ -0,0 +1,23 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Damien Doligez, projet Para, INRIA Rocquencourt          */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Function declarations for non-Unix user interfaces */
+
+#include "config.h"
+
+void ui_exit (int return_code);
+int ui_read (int file_desc, char *buf, unsigned int length);
+int ui_write (int file_desc, char *buf, unsigned int length);
+void ui_print_stderr (char *format, void *arg);
diff --git a/byterun/unix.c b/byterun/unix.c
new file mode 100644
index 0000000000..38b9b4aad3
--- /dev/null
+++ b/byterun/unix.c
@@ -0,0 +1,203 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*           Xavier Leroy, projet Cristal, INRIA Rocquencourt          */
+/*                                                                     */
+/*  Copyright 2001 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Unix-specific stuff */
+
+#include <stddef.h>
+#include <stdlib.h>
+#include <string.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include "config.h"
+#ifdef SUPPORT_DYNAMIC_LINKING
+#include <dlfcn.h>
+#endif
+#include "memory.h"
+#include "misc.h"
+#include "osdeps.h"
+
+#ifndef S_ISREG
+#define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG)
+#endif
+
+char * decompose_path(struct ext_table * tbl, char * path)
+{
+  char * p, * q;
+  int n;
+
+  if (path == NULL) return NULL;
+  p = stat_alloc(strlen(path) + 1);
+  strcpy(p, path);
+  q = p;
+  while (1) {
+    for (n = 0; q[n] != 0 && q[n] != ':'; n++) /*nothing*/;
+    ext_table_add(tbl, q);
+    q = q + n;
+    if (*q == 0) break;
+    *q = 0;
+    q += 1;
+  }
+  return p;
+}
+
+char * search_in_path(struct ext_table * path, char * name)
+{
+  char * p, * fullname;
+  int i;
+  struct stat st;
+
+  for (p = name; *p != 0; p++) {
+    if (*p == '/') goto not_found;
+  }
+  for (i = 0; i < path->size; i++) {
+    fullname = stat_alloc(strlen((char *)(path->contents[i])) +
+                          strlen(name) + 2);
+    strcpy(fullname, (char *)(path->contents[i]));
+    if (fullname[0] != 0) strcat(fullname, "/");
+    strcat(fullname, name);
+    if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname;
+    stat_free(fullname);
+  }
+ not_found:
+  fullname = stat_alloc(strlen(name) + 1);
+  strcpy(fullname, name);
+  return fullname;
+}
+  
+#ifdef __CYGWIN32__
+
+/* Cygwin needs special treatment because of the implicit ".exe" at the
+   end of executable file names */
+
+static int cygwin_file_exists(char * name)
+{
+  int fd;
+  /* Cannot use stat() here because it adds ".exe" implicitly */
+  fd = open(name, O_RDONLY);
+  if (fd == -1) return 0;
+  close(fd);
+  return 1;
+}
+
+static char * cygwin_search_exe_in_path(struct ext_table * path, char * name)
+{
+  char * p, * fullname;
+  int i;
+
+  for (p = name; *p != 0; p++) {
+    if (*p == '/' || *p == '\\') goto not_found;
+  }
+  for (i = 0; i < path->size; i++) {
+    fullname = stat_alloc(strlen((char *)(path->contents[i])) +
+                          strlen(name) + 6);
+    strcpy(fullname, (char *)(path->contents[i]));
+    strcat(fullname, "/");
+    strcat(fullname, name);
+    if (cygwin_file_exists(fullname)) return fullname;
+    strcat(fullname, ".exe");
+    if (cygwin_file_exists(fullname)) return fullname;
+    stat_free(fullname);
+  }
+ not_found:
+  fullname = stat_alloc(strlen(name) + 5);
+  strcpy(fullname, name);
+  if (cygwin_file_exists(fullname)) return fullname;
+  strcat(fullname, ".exe");
+  if (cygwin_file_exists(fullname)) return fullname;
+  strcpy(fullname, name);
+  return fullname;
+}
+  
+#endif
+
+char * search_exe_in_path(char * name)
+{
+  struct ext_table path;
+  char * tofree;
+  char * res;
+
+  ext_table_init(&path, 8);
+  tofree = decompose_path(&path, getenv("PATH"));
+#ifndef __CYGWIN32__
+  res = search_in_path(&path, name);
+#else
+  res = cygwin_search_exe_in_path(&path, name);
+#endif
+  stat_free(tofree);
+  ext_table_free(&path, 0);
+  return res;
+}
+
+char * search_dll_in_path(struct ext_table * path, char * name)
+{
+  char * dllname = stat_alloc(strlen(name) + 4);
+  char * res;
+  strcpy(dllname, name);
+  strcat(dllname, ".so");
+  res = search_in_path(path, dllname);
+  stat_free(dllname);
+  return res;
+}
+
+#ifdef SUPPORT_DYNAMIC_LINKING
+
+#ifndef RTLD_GLOBAL
+#define RTLD_GLOBAL 0
+#endif
+
+void * caml_dlopen(char * libname)
+{
+  return dlopen(libname, RTLD_NOW|RTLD_GLOBAL);
+}
+
+void caml_dlclose(void * handle)
+{
+  dlclose(handle);
+}
+
+void * caml_dlsym(void * handle, char * name)
+{
+  return dlsym(handle, name);
+}
+
+char * caml_dlerror(void)
+{
+  return dlerror();
+}
+
+#else
+
+void * caml_dlopen(char * libname)
+{
+  return NULL;
+}
+
+void caml_dlclose(void * handle)
+{
+}
+
+void * caml_dlsym(void * handle, char * name)
+{
+  return NULL;
+}
+
+char * caml_dlerror(void)
+{
+  return "dynamic loading not supported on this platform";
+}
+
+#endif
+
diff --git a/byterun/weak.h b/byterun/weak.h
new file mode 100644
index 0000000000..18c6736ce6
--- /dev/null
+++ b/byterun/weak.h
@@ -0,0 +1,20 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Damien Doligez, projet Para, INRIA Rocquencourt          */
+/*                                                                     */
+/*  Copyright 1997 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Operations on weak arrays */
+
+#include "mlvalues.h"
+
+extern value weak_list_head;
diff --git a/byterun/win32.c b/byterun/win32.c
new file mode 100644
index 0000000000..d118b19763
--- /dev/null
+++ b/byterun/win32.c
@@ -0,0 +1,375 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*           Xavier Leroy, projet Cristal, INRIA Rocquencourt          */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Win32-specific stuff */
+
+#include <windows.h>
+#include <stdlib.h>
+#include <stdio.h>
+#ifndef HAS_UI
+#include <io.h>
+#endif
+#include <fcntl.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <ctype.h>
+#include <string.h>
+#include <signal.h>
+#include "memory.h"
+#include "misc.h"
+#include "osdeps.h"
+#include "signals.h"
+
+#ifndef S_ISREG
+#define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG)
+#endif
+
+char * decompose_path(struct ext_table * tbl, char * path)
+{
+  char * p, * q;
+  int n;
+
+  if (path == NULL) return NULL;
+  p = stat_alloc(strlen(path) + 1);
+  strcpy(p, path);
+  q = p;
+  while (1) {
+    for (n = 0; q[n] != 0 && q[n] != ';'; n++) /*nothing*/;
+    ext_table_add(tbl, q);
+    q = q + n;
+    if (*q == 0) break;
+    *q = 0;
+    q += 1;
+  }
+  return p;
+}
+
+char * search_in_path(struct ext_table * path, char * name)
+{
+  char * p, * fullname;
+  int i;
+  struct stat st;
+
+  for (p = name; *p != 0; p++) {
+    if (*p == '/' || *p == '\\') goto not_found;
+  }
+  for (i = 0; i < path->size; i++) {
+    fullname = stat_alloc(strlen((char *)(path->contents[i])) +
+                          strlen(name) + 2);
+    strcpy(fullname, (char *)(path->contents[i]));
+    strcat(fullname, "\\");
+    strcat(fullname, name);
+    gc_message(0x100, "Searching %s\n", (unsigned long) fullname);
+    if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname;
+    stat_free(fullname);
+  }
+ not_found:
+  gc_message(0x100, "%s not found in search path\n", (unsigned long) name);
+  fullname = stat_alloc(strlen(name) + 1);
+  strcpy(fullname, name);
+  return fullname;
+}
+  
+CAMLexport char * search_exe_in_path(char * name)
+{
+#define MAX_PATH_LENGTH 512
+  char * fullname = stat_alloc(512);
+  char * filepart;
+
+  if (! SearchPath(NULL,              /* use system search path */
+                   name,
+                   ".exe",            /* add .exe extension if needed */
+                   MAX_PATH_LENGTH,   /* size of buffer */
+                   fullname,
+                   &filepart))
+    strcpy(fullname, name);
+  return fullname;
+}
+
+char * search_dll_in_path(struct ext_table * path, char * name)
+{
+  char * dllname = stat_alloc(strlen(name) + 5);
+  char * res;
+  strcpy(dllname, name);
+  strcat(dllname, ".dll");
+  res = search_in_path(path, dllname);
+  stat_free(dllname);
+  return res;
+}
+
+void * caml_dlopen(char * libname)
+{
+  return (void *) LoadLibrary(libname);
+}
+
+void caml_dlclose(void * handle)
+{
+  FreeLibrary((HMODULE) handle);
+}
+
+void * caml_dlsym(void * handle, char * name)
+{
+  return (void *) GetProcAddress((HMODULE) handle, name);
+}
+
+char * caml_dlerror(void)
+{
+  static char dlerror_buffer[256];
+  DWORD msglen =
+    FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
+                  NULL,         /* message source */
+                  GetLastError(), /* error number */
+                  0,            /* default language */
+                  dlerror_buffer, /* destination */
+                  sizeof(dlerror_buffer), /* size of destination */
+                  NULL);         /* no inserts */
+  if (msglen == 0)
+    return "unknown error";
+  else
+    return dlerror_buffer;
+}
+
+/* Proper emulation of signal(), including ctrl-C and ctrl-break */
+
+typedef void (*sighandler)(int sig);
+static int ctrl_handler_installed = 0;
+static volatile sighandler ctrl_handler_action = SIG_DFL;
+
+static BOOL WINAPI ctrl_handler(DWORD event)
+{
+  int saved_mode;
+  sighandler action;
+
+  /* Only ctrl-C and ctrl-Break are handled */
+  if (event != CTRL_C_EVENT && event != CTRL_BREAK_EVENT) return FALSE;
+  /* Default behavior is to exit, which we get by not handling the event */
+  if (ctrl_handler_action == SIG_DFL) return FALSE;
+  /* Ignore behavior is to do nothing, which we get by claiming that we
+     have handled the event */
+  if (ctrl_handler_action == SIG_IGN) return TRUE;
+  /* Reset handler to default action for consistency with signal() */
+  action = ctrl_handler_action;
+  ctrl_handler_action = SIG_DFL;
+  /* Call user-provided signal handler.  Win32 doesn't like it when
+     we do a longjmp() at this point (it looks like we're running in
+     a different thread than the main program!).  So, pretend we are not in
+     async signal mode, so that the handler simply records the signal. */
+  saved_mode = async_signal_mode;
+  async_signal_mode = 0;
+  action(SIGINT);
+  async_signal_mode = saved_mode;
+  /* We have handled the event */
+  return TRUE;
+}
+
+sighandler win32_signal(int sig, sighandler action)
+{
+  sighandler oldaction;
+
+  if (sig != SIGINT) return signal(sig, action);
+  if (! ctrl_handler_installed) {
+    SetConsoleCtrlHandler(ctrl_handler, TRUE);
+    ctrl_handler_installed = 1;
+  }
+  oldaction = ctrl_handler_action;
+  ctrl_handler_action = action;
+  return oldaction;
+}
+
+/* Expansion of @responsefile and *? file patterns in the command line */
+
+#ifndef HAS_UI
+
+static int argc;
+static char ** argv;
+static int argvsize;
+
+static void store_argument(char * arg);
+static void expand_argument(char * arg);
+static void expand_pattern(char * arg);
+static void expand_diversion(char * filename);
+
+static void out_of_memory(void)
+{
+  fprintf(stderr, "Out of memory while expanding command line\n");
+  exit(2);
+}
+
+static void store_argument(char * arg)
+{
+  if (argc + 1 >= argvsize) {
+    argvsize *= 2;
+    argv = (char **) realloc(argv, argvsize * sizeof(char *));
+    if (argv == NULL) out_of_memory();
+  }
+  argv[argc++] = arg;
+}
+
+static void expand_argument(char * arg)
+{
+  char * p;
+
+  if (arg[0] == '@') {
+    expand_diversion(arg + 1);
+    return;
+  }
+  for (p = arg; *p != 0; p++) {
+    if (*p == '*' || *p == '?') {
+      expand_pattern(arg);
+      return;
+    }
+  }
+  store_argument(arg);
+}
+
+static void expand_pattern(char * pat)
+{
+  int handle;
+  struct _finddata_t ffblk;
+  int preflen;
+
+  handle = _findfirst(pat, &ffblk);
+  if (handle == -1) {
+    store_argument(pat); /* a la Bourne shell */
+    return;
+  }
+  for (preflen = strlen(pat); preflen > 0; preflen--) {
+    char c = pat[preflen - 1];
+    if (c == '\\' || c == '/' || c == ':') break;
+  }
+  do {
+    char * name = malloc(preflen + strlen(ffblk.name) + 1);
+    if (name == NULL) out_of_memory();
+    memcpy(name, pat, preflen);
+    strcpy(name + preflen, ffblk.name);
+    store_argument(name);
+  } while (_findnext(handle, &ffblk) != -1);
+  _findclose(handle);
+}
+
+static void expand_diversion(char * filename)
+{
+  struct _stat stat;
+  int fd;
+  char * buf, * endbuf, * p, * s;
+
+  if (_stat(filename, &stat) == -1 ||
+      (fd = _open(filename, O_RDONLY | O_BINARY, 0)) == -1) {
+    fprintf(stderr, "Cannot open file %s\n", filename);
+    exit(2);
+  }
+  buf = (char *) malloc(stat.st_size + 1);
+  if (buf == NULL) out_of_memory();
+  _read(fd, buf, stat.st_size);
+  endbuf = buf + stat.st_size;
+  _close(fd);
+  for (p = buf; p < endbuf; /*nothing*/) {
+    /* Skip leading blanks */
+    while (p < endbuf && isspace(*p)) p++;
+    if (p >= endbuf) break;
+    s = p;
+    /* Skip to next blank or end of buffer */
+    while (p < endbuf && !isspace(*p)) p++;
+    /* Delimit argument and expand it */
+    *p++ = 0;
+    expand_argument(s);
+  }
+}
+
+CAMLexport void expand_command_line(int * argcp, char *** argvp)
+{
+  int i;
+  argc = 0;
+  argvsize = 16;
+  argv = (char **) malloc(argvsize * sizeof(char *));
+  if (argv == NULL) out_of_memory();
+  for (i = 0; i < *argcp; i++) expand_argument((*argvp)[i]);
+  argv[argc] = NULL;
+  *argcp = argc;
+  *argvp = argv;
+}
+
+#endif
+
+/* Wrapper around "system" for Win32.  Create a diversion file if
+   command line is too long. */
+
+int win32_system(char * cmdline)
+{
+#define MAX_CMD_LENGTH 256
+  char cmd[MAX_CMD_LENGTH + 16];
+  char template[9];
+  char * tempfile;
+  FILE * fd;
+  int len, i, j, k, retcode;
+
+  len = strlen(cmdline);
+  if (len < 1000) {
+    return system(cmdline);
+  } else {
+    /* Skip initial blanks, if any */
+    for (i = 0; cmdline[i] != 0 && isspace(cmdline[i]); i++) /*nothing*/;
+    /* Copy command name to buffer, stop at first blank */
+    for (j = 0; cmdline[i] != 0 && ! isspace(cmdline[i]); i++) {
+      if (j < MAX_CMD_LENGTH) cmd[j++] = cmdline[i];
+    }
+    /* Save remainder of command line to temp file */
+    strcpy(template, "cmXXXXXX");
+    tempfile = mktemp(template);
+    fd = fopen(tempfile, "w");
+    if (fd == NULL) return -1;
+    for (k = i; k < len; k++)
+      fputc((isspace(cmdline[k]) ? '\n' : cmdline[k]), fd);
+    fclose(fd);
+    /* Add " @tempfile" to the command line */
+    sprintf(cmd + j, " @%s", tempfile);
+    /* Run command */
+    retcode = system(cmd);
+    /* Remove temp file and exit */
+    unlink(tempfile);
+    return retcode;
+  }
+}
+
+#ifndef NATIVE_CODE
+
+/* Set up a new thread for control-C emulation */
+
+void caml_signal_thread(void * lpParam)
+{
+  char *endptr;
+  HANDLE h;
+  /* Get an hexa-code raw handle through the environment */
+  h = (HANDLE) strtol(getenv("CAMLSIGPIPE"), &endptr, 16);
+  while (1) {
+    DWORD numread;
+    BOOL ret;
+    char iobuf[2];
+    /* This shall always return a single character */
+    ret = ReadFile(h, iobuf, 1, &numread, NULL);
+    if (!ret || numread != 1) sys_exit(Val_int(0));
+    switch (iobuf[0]) {
+    case 'C':
+      pending_signal = SIGINT;
+      something_to_do = 1;
+      break;
+    case 'T':
+      exit(0);
+      break;
+    }
+  }
+}
+
+#endif
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
new file mode 100644
index 0000000000..207a3ef95b
--- /dev/null
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -0,0 +1,838 @@
+(*************************************************************************)
+(*                                                                       *)
+(*                Objective Caml LablTk library                          *)
+(*                                                                       *)
+(*            Jacques Garrigue, Kyoto University RIMS                    *)
+(*                                                                       *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et    *)
+(*   en Automatique and Kyoto University.  All rights reserved.          *)
+(*   This file is distributed under the terms of the GNU Library         *)
+(*   General Public License, with the special exception on linking       *)
+(*   described in file ../../../LICENSE.                                 *)
+(*                                                                       *)
+(*************************************************************************)
+
+(* $Id$ *)
+
+open StdLabels
+open Support
+open Tk
+open Jg_tk
+open Parsetree
+open Types
+open Typedtree
+open Location
+open Longident
+open Path
+open Env
+open Searchid
+
+(* auxiliary functions *)
+
+let (~!) = Jg_memo.fast ~f:Str.regexp
+
+let lines_to_chars n ~text:s =
+  let l = String.length s in
+  let rec ltc n ~pos =
+    if n = 1 || pos >= l then pos else
+    if s.[pos] = '\n' then ltc (n-1) ~pos:(pos+1) else ltc n ~pos:(pos+1)
+  in ltc n ~pos:0
+
+let in_loc loc ~pos =
+  loc.loc_ghost || pos >= loc.loc_start && pos < loc.loc_end
+
+let le_loc loc1 loc2 =
+  loc1.loc_start <= loc2.loc_start
+  && loc1.loc_end >= loc2.loc_end
+
+let add_found ~found sol ~env ~loc =
+  if loc.loc_ghost then () else
+  if List.exists !found ~f:(fun (_,_,loc') -> le_loc loc loc') then ()
+  else found := (sol, env, loc) ::
+    List.filter !found ~f:(fun (_,_,loc') -> not (le_loc loc' loc))
+
+let observe ~ref ?init f x =
+  let old = !ref in
+  begin match init with None -> () | Some x -> ref := x end;
+  try (f x : unit); let v = !ref in ref := old; v
+  with exn -> ref := old; raise exn
+
+let rec string_of_longident = function
+    Lident s -> s
+  | Ldot (id,s) -> string_of_longident id ^ "." ^ s
+  | Lapply (id1, id2) ->
+      string_of_longident id1 ^ "(" ^ string_of_longident id2 ^ ")"
+
+let string_of_path p = string_of_longident (Searchid.longident_of_path p)
+
+let parent_path = function
+    Pdot (path, _, _) -> Some path
+  | Pident _ | Papply _ -> None
+
+let ident_of_path ~default = function
+    Pident i -> i
+  | Pdot (_, s, _) -> Ident.create s
+  | Papply _ -> Ident.create default
+
+let rec head_id = function
+    Pident id -> id
+  | Pdot (path,_,_) -> head_id path
+  | Papply (path,_) -> head_id path (* wrong, but ... *)
+
+let rec list_of_path = function
+    Pident id -> [Ident.name id]
+  | Pdot (path, s, _) -> list_of_path path @ [s]
+  | Papply (path, _) -> list_of_path path (* wrong, but ... *)
+
+(* a simple wrapper *)
+
+class buffer ~size = object
+  val buffer = Buffer.create size
+  method out buf = Buffer.add_substring buffer buf
+  method get = Buffer.contents buffer
+end
+
+(* Search in a signature *)
+
+type skind = [`Type|`Class|`Module|`Modtype]
+
+let found_sig = ref ([] : ((skind * Longident.t) * Env.t * Location.t) list)
+let add_found_sig = add_found ~found:found_sig
+
+let rec search_pos_type t ~pos ~env =
+  if in_loc ~pos t.ptyp_loc then
+  begin match t.ptyp_desc with
+    Ptyp_any
+  | Ptyp_var _ -> ()
+  | Ptyp_variant(tl, _, _) ->
+      List.iter tl ~f:
+        begin function
+            Rtag (_,_,tl) -> List.iter tl ~f:(search_pos_type ~pos ~env)
+          | Rinherit st -> search_pos_type ~pos ~env st
+        end
+  | Ptyp_arrow (_, t1, t2) ->
+      search_pos_type t1 ~pos ~env;
+      search_pos_type t2 ~pos ~env
+  | Ptyp_tuple tl ->
+      List.iter tl ~f:(search_pos_type ~pos ~env)
+  | Ptyp_constr (lid, tl) ->
+      List.iter tl ~f:(search_pos_type ~pos ~env);
+      add_found_sig (`Type, lid) ~env ~loc:t.ptyp_loc
+  | Ptyp_object fl ->
+      List.iter fl ~f:
+        begin function
+        | {pfield_desc = Pfield (_, ty)} -> search_pos_type ty ~pos ~env
+        | _ -> ()
+        end
+  | Ptyp_class (lid, tl, _) ->
+      List.iter tl ~f:(search_pos_type ~pos ~env);
+      add_found_sig (`Type, lid) ~env ~loc:t.ptyp_loc
+  | Ptyp_alias (t, _) -> search_pos_type ~pos ~env t
+  end
+
+let rec search_pos_class_type cl ~pos ~env =
+  if in_loc cl.pcty_loc ~pos then
+    begin match cl.pcty_desc with
+      Pcty_constr (lid, _) ->
+        add_found_sig (`Class, lid) ~env ~loc:cl.pcty_loc
+    | Pcty_signature (_, cfl) ->
+        List.iter cfl ~f:
+          begin function
+              Pctf_inher cty -> search_pos_class_type cty ~pos ~env
+            | Pctf_val (_, _, Some ty, loc) ->
+                if in_loc loc ~pos then search_pos_type ty ~pos ~env
+            | Pctf_val _ -> ()
+            | Pctf_virt (_, _, ty, loc) ->
+                if in_loc loc ~pos then search_pos_type ty ~pos ~env
+            | Pctf_meth (_, _, ty, loc) ->
+                if in_loc loc ~pos then search_pos_type ty ~pos ~env
+            | Pctf_cstr (ty1, ty2, loc) ->
+                if in_loc loc ~pos then begin
+                  search_pos_type ty1 ~pos ~env;
+                  search_pos_type ty2 ~pos ~env
+                end
+          end
+    | Pcty_fun (_, ty, cty) ->
+        search_pos_type ty ~pos ~env;
+        search_pos_class_type cty ~pos ~env
+    end
+
+let search_pos_type_decl td ~pos ~env =
+  if in_loc ~pos td.ptype_loc then begin
+    begin match td.ptype_manifest with
+      Some t -> search_pos_type t ~pos ~env
+    | None -> ()
+    end;
+    begin match td.ptype_kind with
+      Ptype_abstract -> ()
+    | Ptype_variant dl ->
+        List.iter dl
+          ~f:(fun (_, tl) -> List.iter tl ~f:(search_pos_type ~pos ~env))
+    | Ptype_record dl ->
+        List.iter dl ~f:(fun (_, _, t) -> search_pos_type t ~pos ~env)
+    end
+  end
+  
+let rec search_pos_signature l ~pos ~env =
+  ignore (
+  List.fold_left l ~init:env ~f:
+  begin fun env pt ->
+    let env = match pt.psig_desc with
+      Psig_open id ->
+        let path, mt = lookup_module id env in
+        begin match mt with
+          Tmty_signature sign -> open_signature path sign env
+        | _ -> env
+        end
+    | sign_item ->
+        try add_signature (Typemod.transl_signature env [pt]) env
+        with Typemod.Error _ | Typeclass.Error _
+        | Typetexp.Error _  | Typedecl.Error _ -> env
+    in
+    if in_loc ~pos pt.psig_loc then
+      begin match pt.psig_desc with
+        Psig_value (_, desc) -> search_pos_type desc.pval_type ~pos ~env
+      | Psig_type l ->
+          List.iter l ~f:(fun (_,desc) -> search_pos_type_decl ~pos desc ~env)
+      | Psig_exception (_, l) ->
+          List.iter l ~f:(search_pos_type ~pos ~env);
+          add_found_sig (`Type, Lident "exn") ~env ~loc:pt.psig_loc
+      | Psig_module (_, t) -> 
+          search_pos_module t ~pos ~env
+      | Psig_modtype (_, Pmodtype_manifest t) ->
+          search_pos_module t ~pos ~env
+      | Psig_modtype _ -> ()
+      | Psig_class l ->
+          List.iter l
+            ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env)
+      | Psig_class_type l ->
+          List.iter l
+            ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env)
+      (* The last cases should not happen in generated interfaces *) 
+      | Psig_open lid -> add_found_sig (`Module, lid) ~env ~loc:pt.psig_loc
+      | Psig_include t -> search_pos_module t ~pos ~env
+      end;
+    env
+  end)
+
+and search_pos_module m ~pos ~env =
+  if in_loc m.pmty_loc ~pos then begin
+    begin match m.pmty_desc with
+      Pmty_ident lid -> add_found_sig (`Modtype, lid) ~env ~loc:m.pmty_loc
+    | Pmty_signature sg -> search_pos_signature sg ~pos ~env
+    | Pmty_functor (_ , m1, m2) ->
+        search_pos_module m1 ~pos ~env;
+        search_pos_module m2 ~pos ~env
+    | Pmty_with (m, l) ->
+        search_pos_module m ~pos ~env;
+        List.iter l ~f:
+          begin function
+              _, Pwith_type t -> search_pos_type_decl t ~pos ~env 
+            | _ -> ()
+          end
+    end
+  end
+
+let search_pos_signature l ~pos ~env =
+  observe ~ref:found_sig (search_pos_signature ~pos ~env) l
+
+(* the module display machinery *)
+
+type module_widgets =
+    { mw_frame: Widget.frame Widget.widget;
+      mw_title: Widget.label Widget.widget option;
+      mw_detach: Widget.button Widget.widget;
+      mw_edit: Widget.button Widget.widget;
+      mw_intf: Widget.button Widget.widget }
+
+let shown_modules = Hashtbl.create 17
+let default_frame = ref None
+let filter_modules () =
+  Hashtbl.iter
+    (fun key data ->
+      if not (Winfo.exists data.mw_frame) then
+        Hashtbl.remove shown_modules key)
+    shown_modules
+let add_shown_module path ~widgets =
+  Hashtbl'.add shown_modules ~key:path ~data:widgets
+let find_shown_module path =
+  try
+    filter_modules ();
+    Hashtbl.find shown_modules path
+  with Not_found ->
+    match !default_frame with
+      None -> raise Not_found
+    | Some mw -> mw
+
+let is_shown_module path =
+  !default_frame <> None ||
+  (filter_modules (); Hashtbl.mem shown_modules path)
+
+(* Viewing a signature *)
+
+(* Forward definitions of Viewer.view_defined and Editor.editor *)
+let view_defined_ref = ref (fun lid ~env -> ())
+let editor_ref = ref (fun ?file ?pos ?opendialog () -> ())
+
+let edit_source ~file ~path ~sign =
+  match sign with
+    [item] ->
+      let id, kind =
+        match item with
+          Tsig_value (id, _) -> id, Pvalue
+        | Tsig_type (id, _) -> id, Ptype
+        | Tsig_exception (id, _) -> id, Pconstructor
+        | Tsig_module (id, _) -> id, Pmodule
+        | Tsig_modtype (id, _) -> id, Pmodtype
+        | Tsig_class (id, _) -> id, Pclass
+        | Tsig_cltype (id, _) -> id, Pcltype
+      in
+      let prefix = List.tl (list_of_path path) and name = Ident.name id in
+      let pos =
+        try
+          let chan = open_in file in
+          if Filename.check_suffix file ".ml" then
+            let parsed = Parse.implementation (Lexing.from_channel chan) in
+            close_in chan;
+            Searchid.search_structure parsed ~name ~kind ~prefix
+          else
+            let parsed = Parse.interface (Lexing.from_channel chan) in
+            close_in chan;
+            Searchid.search_signature parsed ~name ~kind ~prefix
+        with _ -> 0
+      in !editor_ref ~file ~pos ()
+  | _ -> !editor_ref ~file ()
+
+(* List of windows to destroy by Close All *)
+let top_widgets = ref []
+
+let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign =
+  let env =
+    match path with None -> env
+    | Some path -> Env.open_signature path sign env in
+  let title =
+    match title, path with Some title, _ -> title
+    | None, Some path -> string_of_path path
+    | None, None -> "Signature"
+  in
+  let tl, tw, finish =
+    try match path, !default_frame with
+      None, Some ({mw_title=Some label} as mw) when not detach ->
+        Button.configure mw.mw_detach
+          ~command:(fun () -> view_signature sign ~title ~env);
+        pack [mw.mw_detach] ~side:`Left;
+        Pack.forget [mw.mw_edit; mw.mw_intf];
+        List.iter ~f:destroy (Winfo.children mw.mw_frame);
+        Label.configure label ~text:title;
+        pack [label] ~fill:`X ~side:`Bottom;
+        Jg_message.formatted ~title ~on:mw.mw_frame ~maxheight:15 ()
+    | None, _ -> raise Not_found
+    | Some path, _ ->
+        let mw =
+          try find_shown_module path
+          with Not_found ->
+            view_module path ~env;
+            find_shown_module path
+        in
+        begin match mw.mw_title with None -> ()
+        | Some label ->
+            Label.configure label ~text:title;
+            pack [label] ~fill:`X ~side:`Bottom
+        end;
+        Button.configure mw.mw_detach
+          ~command:(fun () -> view_signature sign ~title ~env ~detach:true);
+        pack [mw.mw_detach] ~side:`Left;
+        let repack = ref false in
+        List.iter2 [mw.mw_edit; mw.mw_intf] [".ml"; ".mli"] ~f:
+          begin fun button ext ->
+            try
+              let id = head_id path in
+              let file =
+                Misc.find_in_path !Config.load_path
+                  (String.uncapitalize (Ident.name id) ^ ext) in
+              Button.configure button
+                ~command:(fun () -> edit_source ~file ~path ~sign);
+              if !repack then Pack.forget [button] else
+              if not (Winfo.viewable button) then repack := true;
+              pack [button] ~side:`Left
+            with Not_found ->
+              Pack.forget [button]
+          end;
+        let top = Winfo.toplevel mw.mw_frame in
+        if not (Winfo.ismapped top) then Wm.deiconify top;
+        List.iter ~f:destroy (Winfo.children mw.mw_frame);
+        Jg_message.formatted ~title ~on:mw.mw_frame ~maxheight:15 ()
+    with Not_found ->
+      let tl, tw, finish = Jg_message.formatted ~title ~maxheight:15 () in
+      top_widgets := tl :: !top_widgets;
+      tl, tw, finish
+  in
+  Format.set_max_boxes 100;
+  Printtyp.signature Format.std_formatter sign;
+  finish ();
+  Lexical.init_tags tw;
+  Lexical.tag tw;
+  Text.configure tw ~state:`Disabled;
+  let text = Jg_text.get_all tw in
+  let pt =
+      try Parse.interface (Lexing.from_string text)
+      with Syntaxerr.Error e ->
+        let l =
+          match e with
+            Syntaxerr.Unclosed(l,_,_,_) -> l
+          | Syntaxerr.Other l -> l
+        in
+        Jg_text.tag_and_see  tw ~start:(tpos l.loc_start)
+          ~stop:(tpos l.loc_end) ~tag:"error"; []
+      | Lexer.Error (_, s, e) ->
+         Jg_text.tag_and_see tw ~start:(tpos s) ~stop:(tpos e) ~tag:"error"; []
+  in
+  Jg_bind.enter_focus tw;
+  bind tw ~events:[`Modified([`Control], `KeyPressDetail"s")]
+    ~action:(fun _ -> Jg_text.search_string tw);
+  bind tw ~events:[`Modified([`Double], `ButtonPressDetail 1)]
+    ~fields:[`MouseX;`MouseY] ~breakable:true
+    ~action:(fun ev ->
+      let `Linechar (l, c) =
+        Text.index tw ~index:(`Atxy(ev.ev_MouseX,ev.ev_MouseY), []) in
+      try
+        match search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env
+        with [] -> break ()
+        | ((kind, lid), env, loc) :: _ -> view_decl lid ~kind ~env
+      with Not_found | Env.Error _ -> ());
+  bind tw ~events:[`ButtonPressDetail 3] ~breakable:true
+    ~fields:[`MouseX;`MouseY]
+    ~action:(fun ev ->
+      let x = ev.ev_MouseX and y = ev.ev_MouseY in
+      let `Linechar (l, c) =
+        Text.index tw ~index:(`Atxy(x,y), []) in
+      try
+        match search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env
+        with [] -> break ()
+        | ((kind, lid), env, loc) :: _ ->
+            let menu = view_decl_menu lid ~kind ~env ~parent:tw in
+            let x = x + Winfo.rootx tw and y = y + Winfo.rooty tw - 10 in
+            Menu.popup menu ~x ~y
+      with Not_found -> ())
+
+and view_signature_item sign ~path ~env =
+  view_signature sign ~title:(string_of_path path)
+    ?path:(parent_path path) ~env
+
+and view_module path ~env =
+  match find_module path env with
+    Tmty_signature sign -> 
+      !view_defined_ref (Searchid.longident_of_path path) ~env
+  | modtype ->
+      let id = ident_of_path path ~default:"M" in
+      view_signature_item [Tsig_module (id, modtype)] ~path ~env
+
+and view_module_id id ~env =
+  let path, _ = lookup_module id env in
+  view_module path ~env
+
+and view_type_decl path ~env =
+  let td = find_type path env in
+  try match td.type_manifest with None -> raise Not_found
+    | Some ty -> match Ctype.repr ty with
+        {desc = Tobject _} ->
+          let clt = find_cltype path env in
+          view_signature_item ~path ~env
+            [Tsig_cltype(ident_of_path path ~default:"ct", clt)]
+      | _ -> raise Not_found
+  with Not_found ->
+    view_signature_item ~path ~env
+      [Tsig_type(ident_of_path path ~default:"t", td)]
+
+and view_type_id li ~env =
+  let path, decl = lookup_type li env in
+  view_type_decl path ~env
+
+and view_class_id li ~env =
+  let path, cl = lookup_class li env in
+  view_signature_item ~path ~env
+     [Tsig_class(ident_of_path path ~default:"c", cl)]
+
+and view_cltype_id li ~env =
+  let path, clt = lookup_cltype li env in
+  view_signature_item ~path ~env
+     [Tsig_cltype(ident_of_path path ~default:"ct", clt)]
+
+and view_modtype_id li ~env =
+  let path, td = lookup_modtype li env in
+  view_signature_item ~path ~env
+    [Tsig_modtype(ident_of_path path ~default:"S", td)]
+
+and view_expr_type ?title ?path ?env ?(name="noname") t =
+  let title =
+    match title, path with Some title, _ -> title
+    | None, Some path -> string_of_path path
+    | None, None -> "Expression type"
+  and path, id =
+    match path with None -> None, Ident.create name
+    | Some path -> parent_path path, ident_of_path path ~default:name
+  in
+  view_signature ~title ?path ?env
+    [Tsig_value (id, {val_type = t; val_kind = Val_reg})]
+
+and view_decl lid ~kind ~env =
+  match kind with
+    `Type -> view_type_id lid ~env
+  | `Class -> view_class_id lid ~env
+  | `Module -> view_module_id lid ~env
+  | `Modtype -> view_modtype_id lid ~env
+
+and view_decl_menu lid ~kind ~env ~parent =
+  let path, kname =
+    try match kind with
+      `Type -> fst (lookup_type lid env), "Type"
+    | `Class -> fst (lookup_class lid env), "Class"
+    | `Module -> fst (lookup_module lid env), "Module"
+    | `Modtype -> fst (lookup_modtype lid env), "Module type"
+    with Env.Error _ -> raise Not_found
+  in
+  let menu = Menu.create parent ~tearoff:false in
+  let label = kname ^ " " ^ string_of_path path in
+  begin match path with
+    Pident _ ->
+      Menu.add_command menu ~label ~state:`Disabled
+  | _ ->
+      Menu.add_command menu ~label
+        ~command:(fun () -> view_decl lid ~kind ~env);
+  end;
+  if kind = `Type || kind = `Modtype then begin
+    let buf = new buffer ~size:60 in
+    let (fo,ff) = Format.get_formatter_output_functions ()
+    and margin = Format.get_margin () in
+    Format.set_formatter_output_functions buf#out (fun () -> ());
+    Format.set_margin 60;
+    Format.open_hbox ();
+    if kind = `Type then
+      Printtyp.type_declaration
+        (ident_of_path path ~default:"t")
+        Format.std_formatter
+        (find_type path env)
+    else
+      Printtyp.modtype_declaration
+        (ident_of_path path ~default:"S")
+        Format.std_formatter
+        (find_modtype path env);
+    Format.close_box (); Format.print_flush ();
+    Format.set_formatter_output_functions fo ff;
+    Format.set_margin margin;
+    let l = Str.split ~!"\n" buf#get in
+    let font =
+      let font =
+        Option.get Widget.default_toplevel ~name:"font" ~clas:"Font" in
+      if font = "" then "7x14" else font
+    in
+    (* Menu.add_separator menu; *)
+    List.iter l
+      ~f:(fun label -> Menu.add_command menu ~label ~font ~state:`Disabled)
+  end;
+  menu
+
+(* search and view in a structure *)
+
+type fkind = [
+    `Exp of
+      [`Expr|`Pat|`Const|`Val of Path.t|`Var of Path.t|`New of Path.t]
+        * Types.type_expr
+  | `Class of Path.t * Types.class_type
+  | `Module of Path.t * Types.module_type
+]
+
+let view_type kind ~env =
+  match kind with
+    `Exp (k, ty) ->
+      begin match k with
+        `Expr -> view_expr_type ty ~title:"Expression type" ~env
+      | `Pat -> view_expr_type ty ~title:"Pattern type" ~env
+      | `Const -> view_expr_type ty ~title:"Constant type" ~env
+      | `Val path ->
+          begin try
+            let vd = find_value path env in
+            view_signature_item ~path ~env
+              [Tsig_value(ident_of_path path ~default:"v", vd)]
+          with Not_found ->
+            view_expr_type ty ~path ~env
+          end
+      | `Var path ->
+          let vd = find_value path env in
+          view_expr_type vd.val_type ~env ~path ~title:"Variable type"
+      | `New path ->
+          let cl = find_class path env in
+          view_signature_item ~path ~env
+            [Tsig_class(ident_of_path path ~default:"c", cl)]
+      end
+  | `Class (path, cty) ->
+      let cld = { cty_params = []; cty_type = cty;
+                  cty_path = path; cty_new = None } in
+      view_signature_item ~path ~env
+        [Tsig_class(ident_of_path path ~default:"c", cld)]
+  | `Module (path, mty) ->
+      match mty with
+        Tmty_signature sign -> view_signature sign ~path ~env
+      | modtype ->
+          view_signature_item ~path ~env
+            [Tsig_module(ident_of_path path ~default:"M", mty)]
+
+let view_type_menu kind ~env ~parent =
+  let title =
+    match kind with
+      `Exp (`Expr,_) -> "Expression :"
+    | `Exp (`Pat, _) -> "Pattern :"
+    | `Exp (`Const, _) -> "Constant :"
+    | `Exp (`Val path, _) -> "Value " ^ string_of_path path ^ " :"
+    | `Exp (`Var path, _) ->
+        "Variable " ^ Ident.name (ident_of_path path ~default:"noname") ^ " :"
+    | `Exp (`New path, _) -> "Class " ^ string_of_path path ^ " :"
+    | `Class (path, _) -> "Class " ^ string_of_path path ^ " :"
+    | `Module (path,_) -> "Module " ^ string_of_path path in
+  let menu = Menu.create parent ~tearoff:false in
+  begin match kind with
+    `Exp((`Expr | `Pat | `Const | `Val (Pident _)),_)  ->
+      Menu.add_command menu ~label:title ~state:`Disabled
+  | `Exp _ | `Class _ | `Module _ ->
+      Menu.add_command menu ~label:title
+        ~command:(fun () -> view_type kind ~env)
+  end;
+  begin match kind with `Module _ | `Class _ -> ()
+  | `Exp(_, ty) ->
+      let buf = new buffer ~size:60 in
+      let (fo,ff) = Format.get_formatter_output_functions ()
+      and margin = Format.get_margin () in
+      Format.set_formatter_output_functions buf#out ignore;
+      Format.set_margin 60;
+      Format.open_hbox ();
+      Printtyp.reset ();
+      Printtyp.mark_loops ty;
+      Printtyp.type_expr Format.std_formatter ty;
+      Format.close_box (); Format.print_flush ();
+      Format.set_formatter_output_functions fo ff;
+      Format.set_margin margin;
+      let l = Str.split ~!"\n" buf#get in
+      let font =
+        let font =
+          Option.get Widget.default_toplevel ~name:"font" ~clas:"Font" in
+        if font = "" then "7x14" else font
+      in
+      (* Menu.add_separator menu; *)
+      List.iter l ~f:
+        begin fun label -> match (Ctype.repr ty).desc with
+          Tconstr (path,_,_) ->
+            Menu.add_command menu ~label ~font
+              ~command:(fun () -> view_type_decl path ~env)
+        | Tvariant {row_name = Some (path, _)} ->
+            Menu.add_command menu ~label ~font
+              ~command:(fun () -> view_type_decl path ~env)
+        | _ ->
+            Menu.add_command menu ~label ~font ~state:`Disabled
+        end
+  end;
+  menu
+
+let found_str = ref ([] : (fkind * Env.t * Location.t) list)
+let add_found_str = add_found ~found:found_str
+
+let rec search_pos_structure ~pos str =
+  List.iter str ~f:
+  begin function
+    Tstr_eval exp -> search_pos_expr exp ~pos
+  | Tstr_value (rec_flag, l) ->
+      List.iter l ~f:
+      begin fun (pat, exp) ->
+        let env =
+          if rec_flag = Asttypes.Recursive then exp.exp_env else Env.empty in
+        search_pos_pat pat ~pos ~env;
+        search_pos_expr exp ~pos
+      end
+  | Tstr_primitive (_, vd) ->()
+  | Tstr_type _ -> ()
+  | Tstr_exception _ -> ()
+  | Tstr_exn_rebind(_, _) -> ()
+  | Tstr_module (_, m) -> search_pos_module_expr m ~pos
+  | Tstr_modtype _ -> ()
+  | Tstr_open _ -> ()
+  | Tstr_class l ->
+      List.iter l ~f:(fun (id, _, _, cl) -> search_pos_class_expr cl ~pos)
+  | Tstr_cltype _ -> ()
+  | Tstr_include (m, _) -> search_pos_module_expr m ~pos
+  end
+
+and search_pos_class_expr ~pos cl =
+  if in_loc cl.cl_loc ~pos then begin
+    begin match cl.cl_desc with
+      Tclass_ident path ->
+        add_found_str (`Class (path, cl.cl_type))
+          ~env:!start_env ~loc:cl.cl_loc
+    | Tclass_structure cls ->
+        List.iter cls.cl_field ~f:
+          begin function
+              Cf_inher (cl, _, _) ->
+                search_pos_class_expr cl ~pos
+            | Cf_val (_, _, exp) -> search_pos_expr exp ~pos
+            | Cf_meth (_, exp) -> search_pos_expr exp ~pos
+            | Cf_let (_, pel, iel) ->
+                List.iter pel ~f:
+                  begin fun (pat, exp) ->
+                    search_pos_pat pat ~pos ~env:exp.exp_env;
+                    search_pos_expr exp ~pos
+                  end;
+                List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos)
+            | Cf_init exp -> search_pos_expr exp ~pos
+          end
+    | Tclass_fun (pat, iel, cl, _) ->
+        search_pos_pat pat ~pos ~env:pat.pat_env;
+        List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos);
+        search_pos_class_expr cl ~pos
+    | Tclass_apply (cl, el) ->
+        search_pos_class_expr cl ~pos;
+        List.iter el ~f:(fun (x,_) -> Misc.may (search_pos_expr ~pos) x)
+    | Tclass_let (_, pel, iel, cl) ->
+        List.iter pel ~f:
+          begin fun (pat, exp) ->
+            search_pos_pat pat ~pos ~env:exp.exp_env;
+            search_pos_expr exp ~pos
+          end;
+        List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos);
+        search_pos_class_expr cl ~pos
+    | Tclass_constraint (cl, _, _, _) ->
+        search_pos_class_expr cl ~pos
+    end;
+    add_found_str (`Class (Pident (Ident.create "c"), cl.cl_type))
+      ~env:!start_env ~loc:cl.cl_loc
+  end
+
+and search_pos_expr ~pos exp =
+  if in_loc exp.exp_loc ~pos then begin
+  begin match exp.exp_desc with
+    Texp_ident (path, _) ->
+      add_found_str (`Exp(`Val path, exp.exp_type))
+        ~env:exp.exp_env ~loc:exp.exp_loc
+  | Texp_constant v ->
+      add_found_str (`Exp(`Const, exp.exp_type))
+        ~env:exp.exp_env ~loc:exp.exp_loc
+  | Texp_let (_, expl, exp) ->
+      List.iter expl ~f:
+      begin fun (pat, exp') ->
+        search_pos_pat pat ~pos ~env:exp.exp_env;
+        search_pos_expr exp' ~pos
+      end;
+      search_pos_expr exp ~pos
+  | Texp_function (l, _) ->
+      List.iter l ~f:
+      begin fun (pat, exp) ->
+        search_pos_pat pat ~pos ~env:exp.exp_env;
+        search_pos_expr exp ~pos
+      end
+  | Texp_apply (exp, l) ->
+      List.iter l ~f:(fun (x,_) -> Misc.may (search_pos_expr ~pos) x);
+      search_pos_expr exp ~pos
+  | Texp_match (exp, l, _) ->
+      search_pos_expr exp ~pos;
+      List.iter l ~f:
+      begin fun (pat, exp) ->
+        search_pos_pat pat ~pos ~env:exp.exp_env;
+        search_pos_expr exp ~pos
+      end
+  | Texp_try (exp, l) ->
+      search_pos_expr exp ~pos;
+      List.iter l ~f:
+      begin fun (pat, exp) ->
+        search_pos_pat pat ~pos ~env:exp.exp_env;
+        search_pos_expr exp ~pos
+      end
+  | Texp_tuple l -> List.iter l ~f:(search_pos_expr ~pos)
+  | Texp_construct (_, l) -> List.iter l ~f:(search_pos_expr ~pos)
+  | Texp_variant (_, None) -> ()
+  | Texp_variant (_, Some exp) -> search_pos_expr exp ~pos
+  | Texp_record (l, opt) ->
+      List.iter l ~f:(fun (_, exp) -> search_pos_expr exp ~pos);
+      (match opt with None -> () | Some exp -> search_pos_expr exp ~pos)
+  | Texp_field (exp, _) -> search_pos_expr exp ~pos
+  | Texp_setfield (a, _, b) ->
+      search_pos_expr a ~pos; search_pos_expr b ~pos
+  | Texp_array l -> List.iter l ~f:(search_pos_expr ~pos)
+  | Texp_ifthenelse (a, b, c) ->
+      search_pos_expr a ~pos; search_pos_expr b ~pos;
+      begin match c with None -> ()
+      | Some exp -> search_pos_expr exp ~pos
+      end
+  | Texp_sequence (a,b) ->
+      search_pos_expr a ~pos; search_pos_expr b ~pos
+  | Texp_while (a,b) ->
+      search_pos_expr a ~pos; search_pos_expr b ~pos
+  | Texp_for (_, a, b, _, c) ->
+      List.iter [a;b;c] ~f:(search_pos_expr ~pos)
+  | Texp_when (a, b) ->
+      search_pos_expr a ~pos; search_pos_expr b ~pos
+  | Texp_send (exp, _) -> search_pos_expr exp ~pos
+  | Texp_new (path, _) ->
+      add_found_str (`Exp(`New path, exp.exp_type))
+        ~env:exp.exp_env ~loc:exp.exp_loc
+  | Texp_instvar (_,path) ->
+      add_found_str (`Exp(`Var path, exp.exp_type))
+        ~env:exp.exp_env ~loc:exp.exp_loc
+  | Texp_setinstvar (_, path, exp) ->
+      search_pos_expr exp ~pos;
+      add_found_str (`Exp(`Var path, exp.exp_type))
+        ~env:exp.exp_env ~loc:exp.exp_loc
+  | Texp_override (_, l) ->
+      List.iter l ~f:(fun (_, exp) -> search_pos_expr exp ~pos)
+  | Texp_letmodule (id, modexp, exp) ->
+      search_pos_module_expr modexp ~pos;
+      search_pos_expr exp ~pos
+  | Texp_assertfalse -> ()
+  | Texp_assert exp ->
+      search_pos_expr exp ~pos
+  end;
+  add_found_str (`Exp(`Expr, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc
+  end
+
+and search_pos_pat ~pos ~env pat =
+  if in_loc pat.pat_loc ~pos then begin
+  begin match pat.pat_desc with
+    Tpat_any -> ()
+  | Tpat_var id ->
+      add_found_str (`Exp(`Val (Pident id), pat.pat_type))
+        ~env ~loc:pat.pat_loc
+  | Tpat_alias (pat, _) -> search_pos_pat pat ~pos ~env
+  | Tpat_constant _ ->
+      add_found_str (`Exp(`Const, pat.pat_type)) ~env ~loc:pat.pat_loc
+  | Tpat_tuple l ->
+      List.iter l ~f:(search_pos_pat ~pos ~env)
+  | Tpat_construct (_, l) ->
+      List.iter l ~f:(search_pos_pat ~pos ~env)
+  | Tpat_variant (_, None, _) -> ()
+  | Tpat_variant (_, Some pat, _) -> search_pos_pat pat ~pos ~env
+  | Tpat_record l ->
+      List.iter l ~f:(fun (_, pat) -> search_pos_pat pat ~pos ~env)
+  | Tpat_array l ->
+      List.iter l ~f:(search_pos_pat ~pos ~env)
+  | Tpat_or (a, b, None) ->
+      search_pos_pat a ~pos ~env; search_pos_pat b ~pos ~env
+  | Tpat_or (_, _, Some _) ->
+      ()
+  end;
+  add_found_str (`Exp(`Pat, pat.pat_type)) ~env ~loc:pat.pat_loc
+  end
+
+and search_pos_module_expr ~pos m =
+  if in_loc m.mod_loc ~pos then begin
+    begin match m.mod_desc with
+      Tmod_ident path ->
+        add_found_str (`Module (path, m.mod_type))
+          ~env:m.mod_env ~loc:m.mod_loc
+    | Tmod_structure str -> search_pos_structure str ~pos
+    | Tmod_functor (_, _, m) -> search_pos_module_expr m ~pos
+    | Tmod_apply (a, b, _) ->
+        search_pos_module_expr a ~pos; search_pos_module_expr b ~pos
+    | Tmod_constraint (m, _, _) -> search_pos_module_expr m ~pos
+    end;
+    add_found_str (`Module (Pident (Ident.create "M"), m.mod_type))
+      ~env:m.mod_env ~loc:m.mod_loc
+  end
+
+let search_pos_structure ~pos str =
+  observe ~ref:found_str (search_pos_structure ~pos) str
diff --git a/stdlib/arg.ml b/stdlib/arg.ml
new file mode 100644
index 0000000000..e038ad0ebe
--- /dev/null
+++ b/stdlib/arg.ml
@@ -0,0 +1,119 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*             Damien Doligez, projet Para, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+type spec =
+  | Unit of (unit -> unit)     (* Call the function with unit argument *)
+  | Set of bool ref            (* Set the reference to true *)
+  | Clear of bool ref          (* Set the reference to false *)
+  | String of (string -> unit) (* Call the function with a string argument *)
+  | Int of (int -> unit)       (* Call the function with an int argument *)
+  | Float of (float -> unit)   (* Call the function with a float argument *)
+  | Rest of (string -> unit)   (* Stop interpreting keywords and call the
+                                  function with each remaining argument *)
+
+exception Bad of string
+
+type error =
+  | Unknown of string
+  | Wrong of string * string * string  (* option, actual, expected *)
+  | Missing of string
+  | Message of string
+
+open Printf
+
+let rec assoc3 x l =
+  match l with
+  | [] -> raise Not_found
+  | (y1, y2, y3)::t when y1 = x -> y2
+  | _::t -> assoc3 x t
+;;
+
+let usage speclist errmsg =
+  eprintf "%s\n" errmsg;
+  List.iter (function (key, _, doc) -> eprintf "  %s %s\n" key doc) speclist;
+  try ignore (assoc3 "-help" speclist)
+  with Not_found -> eprintf "  -help  display this list of options\n";
+  try ignore (assoc3 "--help" speclist)
+  with Not_found -> eprintf "  --help display this list of options\n";
+;;
+
+let current = ref 0;;
+
+let parse speclist anonfun errmsg =
+  let initpos = !current in
+  let stop error =
+    let progname =
+      if initpos < Array.length Sys.argv then Sys.argv.(initpos) else "(?)" in
+    begin match error with
+      | Unknown "-help" -> ()
+      | Unknown "--help" -> ()
+      | Unknown s ->
+          eprintf "%s: unknown option `%s'.\n" progname s
+      | Missing s ->
+          eprintf "%s: option `%s' needs an argument.\n" progname s
+      | Wrong (opt, arg, expected) ->
+          eprintf "%s: wrong argument `%s'; option `%s' expects %s.\n"
+                  progname arg opt expected
+      | Message s ->
+          eprintf "%s: %s.\n" progname s
+    end;
+    usage speclist errmsg;
+    if error = Unknown "-help" || error = Unknown "--help"
+    then exit 0
+    else exit 2
+  in
+  let l = Array.length Sys.argv in
+  incr current;
+  while !current < l do
+    let s = Sys.argv.(!current) in
+    if String.length s >= 1 && String.get s 0 = '-' then begin
+      let action =
+        try assoc3 s speclist
+        with Not_found -> stop (Unknown s)
+      in
+      begin try
+        match action with
+        | Unit f -> f ();
+        | Set r -> r := true;
+        | Clear r -> r := false;
+        | String f when !current + 1 < l ->
+            let arg = Sys.argv.(!current+1) in
+            f arg;
+            incr current;
+        | Int f when !current + 1 < l ->
+            let arg = Sys.argv.(!current+1) in
+            begin try f (int_of_string arg)
+            with Failure "int_of_string" -> stop (Wrong (s, arg, "an integer"))
+            end;
+            incr current;
+        | Float f when !current + 1 < l ->
+            let arg = Sys.argv.(!current+1) in
+            f (float_of_string arg);
+            incr current;
+        | Rest f ->
+            while !current < l-1 do
+              f Sys.argv.(!current+1);
+              incr current;
+            done;
+        | _ -> stop (Missing s)
+      with Bad m -> stop (Message m);
+      end;
+      incr current;
+    end else begin
+      (try anonfun s with Bad m -> stop (Message m));
+      incr current;
+    end;
+  done;
+;;
diff --git a/stdlib/array.ml b/stdlib/array.ml
new file mode 100644
index 0000000000..d77cf624dc
--- /dev/null
+++ b/stdlib/array.ml
@@ -0,0 +1,276 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Array operations *)
+
+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 unsafe_get: 'a array -> int -> 'a = "%array_unsafe_get"
+external unsafe_set: 'a array -> int -> 'a -> unit = "%array_unsafe_set"
+external make: int -> 'a -> 'a array = "make_vect"
+external create: int -> 'a -> 'a array = "make_vect"
+
+let init l f =
+  if l = 0 then [||] else
+   let res = create l (f 0) in
+   for i = 1 to pred l do
+     unsafe_set res i (f i)
+   done;
+   res 
+
+let make_matrix sx sy init =
+  let res = create sx [||] in
+  for x = 0 to pred sx do
+    unsafe_set res x (create sy init)
+  done;
+  res
+
+let create_matrix = make_matrix
+
+let copy a =
+  let l = length a in
+  if l = 0 then [||] else begin
+    let res = create l (unsafe_get a 0) in
+    for i = 1 to pred l do
+      unsafe_set res i (unsafe_get a i)
+    done;
+    res
+  end
+
+let append a1 a2 =
+  let l1 = length a1 and l2 = length a2 in
+  if l1 = 0 && l2 = 0 then [||] else begin
+    let r = create (l1 + l2) (unsafe_get (if l1 > 0 then a1 else a2) 0) in
+    for i = 0 to l1 - 1 do unsafe_set r i (unsafe_get a1 i) done;  
+    for i = 0 to l2 - 1 do unsafe_set r (i + l1) (unsafe_get a2 i) done;  
+    r
+  end
+
+let concat_aux init al =
+  let rec size accu = function
+    | [] -> accu
+    | h::t -> size (accu + length h) t
+  in
+  let res = create (size 0 al) init in
+  let rec fill pos = function
+    | [] -> ()
+    | h::t -> 
+        for i = 0 to length h - 1 do
+          unsafe_set res (pos + i) (unsafe_get h i);
+        done;
+        fill (pos + length h) t;
+  in
+  fill 0 al;
+  res
+;;
+
+let concat al =
+  let rec find_init = function
+      [] -> [||]
+    | a :: rem ->
+        if length a > 0 then concat_aux (unsafe_get a 0) al else find_init rem
+  in find_init al
+
+let sub a ofs len =
+  if ofs < 0 || len < 0 || ofs + len > length a then invalid_arg "Array.sub"
+  else if len = 0 then [||]
+  else begin
+    let r = create len (unsafe_get a ofs) in
+    for i = 1 to len - 1 do unsafe_set r i (unsafe_get a (ofs + i)) done;
+    r
+  end
+
+let fill a ofs len v =
+  if ofs < 0 || len < 0 || ofs + len > length a
+  then invalid_arg "Array.fill"
+  else for i = ofs to ofs + len - 1 do unsafe_set a i v done
+
+let blit a1 ofs1 a2 ofs2 len =
+  if len < 0 || ofs1 < 0 || ofs1 + len > length a1
+             || ofs2 < 0 || ofs2 + len > length a2
+  then invalid_arg "Array.blit"
+  else if ofs1 < ofs2 then
+    (* Top-down copy *)
+    for i = len - 1 downto 0 do
+      unsafe_set a2 (ofs2 + i) (unsafe_get a1 (ofs1 + i))
+    done
+  else
+    (* Bottom-up copy *)
+    for i = 0 to len - 1 do
+      unsafe_set a2 (ofs2 + i) (unsafe_get a1 (ofs1 + i))
+    done
+
+let iter f a =
+  for i = 0 to length a - 1 do f(unsafe_get a i) done
+
+let map f a =
+  let l = length a in
+  if l = 0 then [||] else begin
+    let r = create l (f(unsafe_get a 0)) in
+    for i = 1 to l - 1 do
+      unsafe_set r i (f(unsafe_get a i))
+    done;
+    r
+  end
+
+let iteri f a =
+  for i = 0 to length a - 1 do f i (unsafe_get a i) done
+
+let mapi f a =
+  let l = length a in
+  if l = 0 then [||] else begin
+    let r = create l (f 0 (unsafe_get a 0)) in
+    for i = 1 to l - 1 do
+      unsafe_set r i (f i (unsafe_get a i))
+    done;
+    r
+  end
+
+let to_list a =
+  let rec tolist i res =
+    if i < 0 then res else tolist (i - 1) (unsafe_get a i :: res) in
+  tolist (length a - 1) []
+
+let rec list_length accu = function
+  | [] -> accu
+  | h::t -> list_length (succ accu) t
+;;
+
+let of_list = function
+    [] -> [||]
+  | hd::tl as l ->
+      let a = create (list_length 0 l) hd in
+      let rec fill i = function
+          [] -> a
+        | hd::tl -> unsafe_set a i hd; fill (i+1) tl in
+      fill 1 tl
+
+let fold_left f x a =
+  let r = ref x in
+  for i = 0 to length a - 1 do
+    r := f !r (unsafe_get a i)
+  done;
+  !r
+
+let fold_right f a x =
+  let r = ref x in
+  for i = length a - 1 downto 0 do
+    r := f (unsafe_get a i) !r
+  done;
+  !r
+
+exception Bottom of int;;
+let sort cmp a =
+  let maxson l i =
+    let i31 = i+i+i+1 in
+    let x = ref i31 in
+    if i31+2 < l then begin
+      if cmp (get a i31) (get a (i31+1)) < 0 then x := i31+1;
+      if cmp (get a !x) (get a (i31+2)) < 0 then x := i31+2;
+      !x
+    end else
+      if i31+1 < l && cmp (get a i31) (get a (i31+1)) < 0
+      then i31+1
+      else if i31 < l then i31 else raise (Bottom i)
+  in
+  let rec trickledown l i e =
+    let j = maxson l i in
+    if cmp (get a j) e > 0 then begin
+      set a i (get a j);
+      trickledown l j e;
+    end else begin
+      set a i e;
+    end;
+  in
+  let rec trickle l i e = try trickledown l i e with Bottom i -> set a i e in
+  let rec bubbledown l i =
+    let j = maxson l i in
+    set a i (get a j);
+    bubbledown l j;
+  in
+  let bubble l i = try bubbledown l i with Bottom i -> i in
+  let rec trickleup i e =
+    let father = (i - 1) / 3 in
+    assert (i <> father);
+    if cmp (get a father) e < 0 then begin
+      set a i (get a father);
+      if father > 0 then trickleup father e else set a 0 e;
+    end else begin
+      set a i e;
+    end;
+  in
+  let l = length a in
+  for i = (l + 1) / 3 - 1 downto 0 do trickle l i (get a i); done;
+  for i = l - 1 downto 2 do
+    let e = (get a i) in
+    set a i (get a 0);
+    trickleup (bubble i 0) e;
+  done;
+  if l > 1 then (let e = (get a 1) in set a 1 (get a 0); set a 0 e);
+;;
+
+let cutoff = 5;;
+let stable_sort cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
+    let rec loop i1 s1 i2 s2 d =
+      if cmp s1 s2 <= 0 then begin
+        set dst d s1;
+        let i1 = i1 + 1 in
+        if i1 < src1r then
+          loop i1 (get a i1) i2 s2 (d + 1)
+        else
+          blit src2 i2 dst (d + 1) (src2r - i2)
+      end else begin
+        set dst d s2;
+        let i2 = i2 + 1 in
+        if i2 < src2r then
+          loop i1 s1 i2 (get src2 i2) (d + 1)
+        else
+          blit a i1 dst (d + 1) (src1r - i1)
+      end
+    in loop src1ofs (get a src1ofs) src2ofs (get src2 src2ofs) dstofs;
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len - 1 do
+      let e = (get a (srcofs + i)) in
+      let j = ref (dstofs + i - 1) in
+      while (!j >= dstofs && cmp (get dst !j) e > 0) do
+        set dst (!j + 1) (get dst !j);
+        decr j;
+      done;
+      set dst (!j + 1) e;
+    done;
+  in
+  let rec sortto srcofs dst dstofs len =
+    if len <= cutoff then isortto srcofs dst dstofs len else begin
+      let l1 = len / 2 in
+      let l2 = len - l1 in
+      sortto (srcofs + l1) dst (dstofs + l1) l2;
+      sortto srcofs a (srcofs + l2) l1;
+      merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
+    end;
+  in
+  let l = length a in
+  if l <= cutoff then isortto 0 a 0 l else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = make l2 (get a 0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end;
+;;
diff --git a/stdlib/arrayLabels.ml b/stdlib/arrayLabels.ml
new file mode 100644
index 0000000000..fed0ad1c2c
--- /dev/null
+++ b/stdlib/arrayLabels.ml
@@ -0,0 +1,18 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*               Jacques Garrigue, Kyoto University RIMS               *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Module [ArrayLabels]: labelled Array module *)
+
+include Array
diff --git a/stdlib/arrayLabels.mli b/stdlib/arrayLabels.mli
new file mode 100644
index 0000000000..64b6644107
--- /dev/null
+++ b/stdlib/arrayLabels.mli
@@ -0,0 +1,186 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Array operations. *)
+
+external length : 'a array -> int = "%array_length"
+(** Return the length (number of elements) of the given array. *)
+
+external get : 'a array -> int -> 'a = "%array_safe_get"
+(** [Array.get a n] returns the element number [n] of array [a].
+   The first element has number 0.
+   The last element has number [Array.length a - 1].
+   Raise [Invalid_argument "Array.get"]  if [n] is outside the range
+   0 to [(Array.length a - 1)].
+   You can also write [a.(n)] instead of [Array.get a n]. *)
+
+external set : 'a array -> int -> 'a -> unit = "%array_safe_set"
+(** [Array.set a n x] modifies array [a] in place, replacing
+   element number [n] with [x].
+
+   Raise [Invalid_argument "Array.set"] if [n] is outside the range
+   0 to [Array.length a - 1].
+   You can also write [a.(n) <- x] instead of [Array.set a n x]. *)
+
+external make : int -> 'a -> 'a array = "make_vect"
+(** [Array.make n x] returns a fresh array of length [n],
+   initialized with [x].
+   All the elements of this new array are initially
+   physically equal to [x] (in the sense of the [==] predicate).
+   Consequently, if [x] is mutable, it is shared among all elements
+   of the array, and modifying [x] through one of the array entries
+   will modify all other entries at the same time.
+
+   Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length].
+   If the value of [x] is a floating-point number, then the maximum
+   size is only [Sys.max_array_length / 2].*)
+
+external create : int -> 'a -> 'a array = "make_vect"
+(** @deprecated [Array.create] is an alias for {!ArrayLabels.make}. *)
+
+val init : int -> f:(int -> 'a) -> 'a array
+(** [Array.init n f] returns a fresh array of length [n],
+   with element number [i] initialized to the result of [f i].
+   In other terms, [Array.init n f] tabulates the results of [f]
+   applied to the integers [0] to [n-1]. *)
+
+val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array
+(** [Array.make_matrix dimx dimy e] returns a two-dimensional array
+   (an array of arrays) with first dimension [dimx] and
+   second dimension [dimy]. All the elements of this new matrix
+   are initially physically equal to [e].
+   The element ([x,y]) of a matrix [m] is accessed
+   with the notation [m.(x).(y)].
+
+   Raise [Invalid_argument] if [dimx] or [dimy] is less than 1 or
+   greater than [Sys.max_array_length].
+   If the value of [e] is a floating-point number, then the maximum
+   size is only [Sys.max_array_length / 2]. *)
+
+val create_matrix : dimx:int -> dimy:int -> 'a -> 'a array array
+(** @deprecated [Array.create_matrix] is an alias for {!ArrayLabels.make_matrix}. *)
+
+val append : 'a array -> 'a array -> 'a array
+(** [Array.append v1 v2] returns a fresh array containing the
+   concatenation of the arrays [v1] and [v2]. *)
+
+val concat : 'a array list -> 'a array
+(** Same as [Array.append], but concatenates a list of arrays. *)
+
+val sub : 'a array -> pos:int -> len:int -> 'a array
+(** [Array.sub a start len] returns a fresh array of length [len],
+   containing the elements number [start] to [start + len - 1]
+   of array [a].
+
+   Raise [Invalid_argument "Array.sub"] if [start] and [len] do not
+   designate a valid subarray of [a]; that is, if
+   [start < 0], or [len < 0], or [start + len > Array.length a]. *)
+
+val copy : 'a array -> 'a array
+(** [Array.copy a] returns a copy of [a], that is, a fresh array
+   containing the same elements as [a]. *)
+
+val fill : 'a array -> pos:int -> len:int -> 'a -> unit
+(** [Array.fill a ofs len x] modifies the array [a] in place,
+   storing [x] in elements number [ofs] to [ofs + len - 1].
+
+   Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not
+   designate a valid subarray of [a]. *)
+
+val blit :
+  src:'a array -> src_pos:int -> dst:'a array -> dst_pos:int -> len:int ->
+    unit
+(** [Array.blit v1 o1 v2 o2 len] copies [len] elements
+   from array [v1], starting at element number [o1], to array [v2],
+   starting at element number [o2]. It works correctly even if
+   [v1] and [v2] are the same array, and the source and
+   destination chunks overlap.
+
+   Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not
+   designate a valid subarray of [v1], or if [o2] and [len] do not
+   designate a valid subarray of [v2]. *)
+
+val to_list : 'a array -> 'a list
+(** [Array.to_list a] returns the list of all the elements of [a]. *)
+
+val of_list : 'a list -> 'a array
+(** [Array.of_list l] returns a fresh array containing the elements
+   of [l]. *)
+
+val iter : f:('a -> unit) -> 'a array -> unit
+(** [Array.iter f a] applies function [f] in turn to all
+   the elements of [a].  It is equivalent to
+   [f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *)
+
+val map : f:('a -> 'b) -> 'a array -> 'b array
+(** [Array.map f a] applies function [f] to all the elements of [a],
+   and builds an array with the results returned by [f]:
+   [[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *)
+
+val iteri : f:(int -> 'a -> unit) -> 'a array -> unit
+(** Same as {!ArrayLabels.iter}, but the
+   function is applied to the index of the element as first argument,
+   and the element itself as second argument. *)
+
+val mapi : f:(int -> 'a -> 'b) -> 'a array -> 'b array
+(** Same as {!ArrayLabels.map}, but the
+   function is applied to the index of the element as first argument,
+   and the element itself as second argument. *)
+
+val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b array -> 'a
+(** [Array.fold_left f x a] computes
+   [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)],
+   where [n] is the length of the array [a]. *)
+
+val fold_right : f:('b -> 'a -> 'a) -> 'b array -> init:'a -> 'a
+(** [Array.fold_right f a x] computes
+   [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))],
+   where [n] is the length of the array [a]. *)
+
+
+
+(** {6 Sorting} *)
+
+
+val sort : cmp:('a -> 'a -> int) -> 'a array -> unit
+(** Sort an array in increasing order according to a comparison
+   function.  The comparison function must return 0 if its arguments
+   compare as equal, a positive integer if the first is greater,
+   and a negative integer if the first is smaller.  For example,
+   the {!Pervasives.compare} function is a suitable comparison function.
+   After calling [Array.sort], the array is sorted in place in
+   increasing order.
+   [Array.sort] is guaranteed to run in constant heap space
+   and logarithmic stack space.
+
+   
+   The current implementation uses Heap Sort.  It runs in constant
+   stack space.
+*)
+
+val stable_sort : cmp:('a -> 'a -> int) -> 'a array -> unit
+(** Same as {!ArrayLabels.sort}, but the sorting algorithm is stable and
+   not guaranteed to use a fixed amount of heap memory.
+   The current implementation is Merge Sort. It uses [n/2]
+   words of heap space, where [n] is the length of the array.
+   It is faster than the current implementation of {!ArrayLabels.sort}.
+*)
+
+(**/**)
+
+(** {6 Undocumented functions} *)
+
+external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
+external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
diff --git a/stdlib/buffer.ml b/stdlib/buffer.ml
new file mode 100644
index 0000000000..86812de9cb
--- /dev/null
+++ b/stdlib/buffer.ml
@@ -0,0 +1,77 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*   Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt  *)
+(*                                                                     *)
+(*  Copyright 1999 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* Extensible buffers *)
+
+type t =
+ {mutable buffer : string;
+  mutable position : int;
+  mutable length : int;
+  initial_buffer : string}
+
+let create n =
+ let n = if n < 1 then 1 else n in
+ let n = if n > Sys.max_string_length then Sys.max_string_length else n in
+ let s = String.create n in
+ {buffer = s; position = 0; length = n; initial_buffer = s}
+
+let contents b = String.sub b.buffer 0 b.position
+
+let length b = b.position
+
+let clear b = b.position <- 0
+
+let reset b =
+  b.position <- 0; b.buffer <- b.initial_buffer;
+  b.length <- String.length b.buffer
+
+let resize b more =
+  let len = b.length in
+  let new_len = ref len in
+  while b.position + more > !new_len do new_len := 2 * !new_len done;
+  let new_buffer = String.create !new_len in
+  String.blit b.buffer 0 new_buffer 0 b.position;
+  b.buffer <- new_buffer;
+  b.length <- !new_len
+
+let add_char b c =
+  let pos = b.position in
+  if pos >= b.length then resize b 1;
+  b.buffer.[pos] <- c;
+  b.position <- pos + 1
+
+let add_substring b s offset len =
+  if offset < 0 || len < 0 || offset + len > String.length s
+  then invalid_arg "Buffer.add_substring";
+  let new_position = b.position + len in
+  if new_position > b.length then resize b len;
+  String.blit s offset b.buffer b.position len;
+  b.position <- new_position
+
+let add_string b s =
+  let len = String.length s in
+  let new_position = b.position + len in
+  if new_position > b.length then resize b len;
+  String.blit s 0 b.buffer b.position len;
+  b.position <- new_position
+  
+let add_buffer b bs =
+  add_substring b bs.buffer 0 bs.position
+
+let add_channel b ic len =
+  if b.position + len > b.length then resize b len;
+  really_input ic b.buffer b.position len;
+  b.position <- b.position + len
+
+let output_buffer oc b =
+  output oc b.buffer 0 b.position
diff --git a/stdlib/buffer.mli b/stdlib/buffer.mli
new file mode 100644
index 0000000000..c4ae68469c
--- /dev/null
+++ b/stdlib/buffer.mli
@@ -0,0 +1,79 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*  Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt   *)
+(*                                                                     *)
+(*  Copyright 1999 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(** Extensible string buffers.
+
+   This module implements string buffers that automatically expand
+   as necessary.  It provides accumulative concatenation of strings
+   in quasi-linear time (instead of quadratic time when strings are
+   concatenated pairwise). 
+*)
+
+type t
+(** The abstract type of buffers. *)
+
+val create : int -> t
+(** [create n] returns a fresh buffer, initially empty.
+   The [n] parameter is the initial size of the internal string
+   that holds the buffer contents.  That string is automatically
+   reallocated when more than [n] characters are stored in the buffer,
+   but shrinks back to [n] characters when [reset] is called.
+   For best performance, [n] should be of the same order of magnitude
+   as the number of characters that are expected to be stored in
+   the buffer (for instance, 80 for a buffer that holds one output
+   line).  Nothing bad will happen if the buffer grows beyond that
+   limit, however.  In doubt, take [n = 16] for instance.
+   If [n] is not between 1 and {!Sys.max_string_length}, it will
+   be clipped to that interval. *)
+
+val contents : t -> string
+(** Return a copy of the current contents of the buffer.
+   The buffer itself is unchanged. *)
+
+val length : t -> int
+(** Return the number of characters currently contained in the buffer. *)
+
+val clear : t -> unit
+(** Empty the buffer. *)
+
+val reset : t -> unit
+(** Empty the buffer and deallocate the internal string holding the
+   buffer contents, replacing it with the initial internal string
+   of length [n] that was allocated by {!Buffer.create} [n].
+   For long-lived buffers that may have grown a lot, [reset] allows
+   faster reclaimation of the space used by the buffer. *)
+
+val add_char : t -> char -> unit
+(** [add_char b c] appends the character [c] at the end of the buffer [b]. *)
+
+val add_string : t -> string -> unit
+(** [add_string b s] appends the string [s] at the end of the buffer [b]. *)
+
+val add_substring : t -> string -> int -> int -> unit
+(** [add_substring b s ofs len] takes [len] characters from offset
+   [ofs] in string [s] and appends them at the end of the buffer [b]. *)
+
+val add_buffer : t -> t -> unit
+(** [add_buffer b1 b2] appends the current contents of buffer [b2]
+   at the end of buffer [b1].  [b2] is not modified. *)
+
+val add_channel : t -> in_channel -> int -> unit
+(** [add_channel b ic n] reads exactly [n] character from the
+   input channel [ic] and stores them at the end of buffer [b].
+   Raise [End_of_file] if the channel contains fewer than [n]
+   characters. *)
+
+val output_buffer : out_channel -> t -> unit
+(** [output_buffer oc b] writes the current contents of buffer [b]
+   on the output channel [oc]. *)
+
diff --git a/stdlib/callback.ml b/stdlib/callback.ml
new file mode 100644
index 0000000000..d070c2bb6a
--- /dev/null
+++ b/stdlib/callback.ml
@@ -0,0 +1,24 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Registering Caml values with the C runtime for later callbacks *)
+
+external register_named_value: string -> Obj.t -> unit = "register_named_value"
+
+let register name v =
+  register_named_value name (Obj.repr v)
+
+let register_exception name (exn : exn) =
+  register_named_value name (Obj.field (Obj.repr exn) 0)
diff --git a/stdlib/callback.mli b/stdlib/callback.mli
new file mode 100644
index 0000000000..70ba06c78d
--- /dev/null
+++ b/stdlib/callback.mli
@@ -0,0 +1,34 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Registering Caml values with the C runtime.
+
+   This module allows Caml values to be registered with the C runtime
+   under a symbolic name, so that C code can later call back registered
+   Caml functions, or raise registered Caml exceptions. 
+*)
+
+val register : string -> 'a -> unit
+(** [Callback.register n v] registers the value [v] under
+   the name [n]. C code can later retrieve a handle to [v]
+   by calling [caml_named_value(n)]. *)
+
+val register_exception : string -> exn -> unit
+(** [Callback.register_exception n exn] registers the
+   exception contained in the exception value [exn]
+   under the name [n]. C code can later retrieve a handle to
+   the exception by calling [caml_named_value(n)]. The exception
+   value thus obtained is suitable for passign as first argument
+   to [raise_constant] or [raise_with_arg]. *)
diff --git a/stdlib/char.ml b/stdlib/char.ml
new file mode 100644
index 0000000000..d8d7a286cd
--- /dev/null
+++ b/stdlib/char.ml
@@ -0,0 +1,62 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Character operations *)
+
+external code: char -> int = "%identity"
+external unsafe_chr: int -> char = "%identity"
+
+let chr n =
+  if n < 0 or n > 255 then invalid_arg "Char.chr" else unsafe_chr n
+
+external is_printable: char -> bool = "is_printable"
+
+external string_create: int -> string = "create_string"
+external string_unsafe_get : string -> int -> char = "%string_unsafe_get"
+external string_unsafe_set : string -> int -> char -> unit
+                           = "%string_unsafe_set"
+
+let escaped = function
+    '\'' -> "\\'"
+  | '\\' -> "\\\\"
+  | '\n' -> "\\n"
+  | '\t' -> "\\t"
+  | c ->  if is_printable c then begin
+            let s = string_create 1 in
+            string_unsafe_set s 0 c;
+            s
+          end else begin
+            let n = code c in
+            let s = string_create 4 in
+            string_unsafe_set s 0 '\\';
+            string_unsafe_set s 1 (unsafe_chr (48 + n / 100));
+            string_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10));
+            string_unsafe_set s 3 (unsafe_chr (48 + n mod 10));
+            s
+          end
+
+let lowercase c =
+  if (c >= 'A' && c <= 'Z')
+  || (c >= '\192' && c <= '\214')
+  || (c >= '\216' && c <= '\222')
+  then unsafe_chr(code c + 32)
+  else c
+
+let uppercase c =
+  if (c >= 'a' && c <= 'z')
+  || (c >= '\224' && c <= '\246')
+  || (c >= '\248' && c <= '\254')
+  then unsafe_chr(code c - 32)
+  else c
diff --git a/stdlib/char.mli b/stdlib/char.mli
new file mode 100644
index 0000000000..931dd7d2b4
--- /dev/null
+++ b/stdlib/char.mli
@@ -0,0 +1,39 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Character operations. *)
+
+external code : char -> int = "%identity"
+(** Return the ASCII code of the argument. *)
+        
+val chr : int -> char
+(** Return the character with the given ASCII code.
+   Raise [Invalid_argument "Char.chr"] if the argument is
+   outside the range 0--255. *)
+
+val escaped : char -> string
+(** Return a string representing the given character,
+   with special characters escaped following the lexical conventions
+   of Objective Caml. *)
+
+val lowercase : char -> char
+(** Convert the given character to its equivalent lowercase character. *)
+
+val uppercase : char -> char
+(** Convert the given character to its equivalent uppercase character. *)
+
+(**/**)
+
+external unsafe_chr : int -> char = "%identity"
diff --git a/stdlib/digest.ml b/stdlib/digest.ml
new file mode 100644
index 0000000000..15755c31af
--- /dev/null
+++ b/stdlib/digest.ml
@@ -0,0 +1,43 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Message digest (MD5) *)
+
+type t = string
+
+external unsafe_string: string -> int -> int -> t = "md5_string"
+external channel: in_channel -> int -> t = "md5_chan"
+
+let string str =
+  unsafe_string str 0 (String.length str)
+
+let substring str ofs len =
+  if ofs < 0 || len < 0 || ofs + len > String.length str
+  then invalid_arg "Digest.substring"
+  else unsafe_string str ofs len
+
+let file filename =
+  let ic = open_in_bin filename in
+  let d = channel ic (in_channel_length ic) in
+  close_in ic;
+  d
+
+let output chan digest =
+  output chan digest 0 16
+
+let input chan =
+  let digest = String.create 16 in
+  really_input chan digest 0 16;
+  digest
diff --git a/stdlib/digest.mli b/stdlib/digest.mli
new file mode 100644
index 0000000000..bbcf516045
--- /dev/null
+++ b/stdlib/digest.mli
@@ -0,0 +1,47 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** MD5 message digest.
+
+   This module provides functions to compute 128-bit ``digests'' of
+   arbitrary-length strings or files. The digests are of cryptographic
+   quality: it is very hard, given a digest, to forge a string having
+   that digest. The algorithm used is MD5. 
+*)
+
+type t = string
+(** The type of digests: 16-character strings. *)
+
+val string : string -> t
+(** Return the digest of the given string. *)
+
+val substring : string -> int -> int -> t
+(** [Digest.substring s ofs len] returns the digest of the substring
+   of [s] starting at character number [ofs] and containing [len]
+   characters. *)
+
+external channel : in_channel -> int -> t = "md5_chan"
+(** [Digest.channel ic len] reads [len] characters from channel [ic]
+   and returns their digest. *)
+
+val file : string -> t
+(** Return the digest of the file whose name is given. *)
+
+val output : out_channel -> t -> unit
+(** Write a digest on the given output channel. *)
+
+val input : in_channel -> t
+(** Read a digest from the given input channel. *)
+
diff --git a/stdlib/filename.ml b/stdlib/filename.ml
new file mode 100644
index 0000000000..05ba374de0
--- /dev/null
+++ b/stdlib/filename.ml
@@ -0,0 +1,185 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*          Xavier Leroy and Damien Doligez, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+module Unix = struct
+  let current_dir_name = "."
+  let parent_dir_name = ".."
+  let concat dirname filename =
+    let l = String.length dirname in
+    if l = 0 || dirname.[l-1] = '/'
+    then dirname ^ filename
+    else dirname ^ "/" ^ filename
+  let is_relative n = String.length n < 1 || n.[0] <> '/';;
+  let is_implicit n =
+    is_relative n
+    && (String.length n < 2 || String.sub n 0 2 <> "./")
+    && (String.length n < 3 || String.sub n 0 3 <> "../")
+  let check_suffix name suff =
+    String.length name >= String.length suff &&
+    String.sub name (String.length name - String.length suff)
+                    (String.length suff) = suff
+  let basename name =
+    try
+      let p = String.rindex name '/' + 1 in
+      String.sub name p (String.length name - p)
+    with Not_found ->
+      name
+  let dirname name =
+    try
+      match String.rindex name '/' with
+        0 -> "/"
+      | n -> String.sub name 0 n
+    with Not_found ->
+      "."
+  let temporary_directory =
+    try Sys.getenv "TMPDIR" with Not_found -> "/tmp"
+end
+
+module Win32 = struct
+  let current_dir_name = "."
+  let parent_dir_name = ".."
+  let concat dirname filename =
+    let l = String.length dirname in
+    if l = 0 || (let c = dirname.[l-1] in c = '/' || c = '\\' || c = ':')
+    then dirname ^ filename
+    else dirname ^ "\\" ^ filename
+  let is_relative n =
+    (String.length n < 1 || n.[0] <> '/')
+    && (String.length n < 1 || n.[0] <> '\\')
+    && (String.length n < 2 || n.[1] <> ':')
+  let is_implicit n =
+    is_relative n
+    && (String.length n < 2 || String.sub n 0 2 <> "./")
+    && (String.length n < 2 || String.sub n 0 2 <> ".\\")
+    && (String.length n < 3 || String.sub n 0 3 <> "../")
+    && (String.length n < 3 || String.sub n 0 3 <> "..\\")
+  let check_suffix name suff =
+   String.length name >= String.length suff &&
+   (let s = String.sub name (String.length name - String.length suff)
+                            (String.length suff) in
+    String.lowercase s = String.lowercase suff)
+  let rindexsep s =
+    let rec pos i =
+      if i < 0 then raise Not_found
+      else if (let c = s.[i] in c = '/' || c = '\\' || c = ':') then i
+      else pos (i - 1)
+    in pos (String.length s - 1)
+  let basename name =
+    try
+      let p = rindexsep name + 1 in
+      String.sub name p (String.length name - p)
+    with Not_found ->
+      name
+  let dirname name =
+    try
+      match rindexsep name with
+        0 -> "\\"
+      | n ->
+          let n =
+            if name.[n] = ':' || (n > 0 && name.[n-1] = ':')
+            then n+1 else n in
+          String.sub name 0 n
+    with Not_found ->
+      "."
+  let temporary_directory =
+    try Sys.getenv "TEMP" with Not_found -> "C:\\temp"
+end
+
+module MacOS = struct
+  let current_dir_name = "."
+  let parent_dir_name = ".."
+  let concat dirname filename =
+    let l = String.length dirname in
+    if l = 0 || dirname.[l-1] = ':'
+    then dirname ^ filename
+    else dirname ^ ":" ^ filename
+  let contains_colon n = String.contains n ':'
+  let is_relative n =
+    (String.length n >= 1 && n.[0] = ':')
+    || not (contains_colon n)
+  let is_implicit n = not (contains_colon n)
+  let check_suffix = Unix.check_suffix
+  let basename name =
+    try
+      let p = String.rindex name ':' + 1 in
+      String.sub name p (String.length name - p)
+    with Not_found -> name
+  let dirname name =
+    try match String.rindex name ':' with
+        | 0 -> ":"
+        | n -> String.sub name 0 n
+    with Not_found -> ":"
+  let temporary_directory =
+    try Sys.getenv "TempFolder" with Not_found -> ":"
+end
+
+let (current_dir_name, parent_dir_name, concat, is_relative, is_implicit,
+     check_suffix, basename, dirname, temporary_directory) =
+  match Sys.os_type with
+    "Unix" | "Cygwin" ->
+      (Unix.current_dir_name, Unix.parent_dir_name, Unix.concat,
+       Unix.is_relative, Unix.is_implicit, Unix.check_suffix,
+       Unix.basename, Unix.dirname, Unix.temporary_directory)
+  | "Win32" ->
+      (Win32.current_dir_name, Win32.parent_dir_name, Win32.concat,
+       Win32.is_relative, Win32.is_implicit, Win32.check_suffix,
+       Win32.basename, Win32.dirname, Win32.temporary_directory)
+  | "MacOS" ->
+      (MacOS.current_dir_name, MacOS.parent_dir_name, MacOS.concat,
+       MacOS.is_relative, MacOS.is_implicit, MacOS.check_suffix,
+       MacOS.basename, MacOS.dirname, MacOS.temporary_directory)
+  | _ -> assert false
+
+let chop_suffix name suff =
+  let n = String.length name - String.length suff in
+  if n < 0 then invalid_arg "Filename.chop_suffix" else String.sub name 0 n
+
+let chop_extension name =
+  try
+    String.sub name 0 (String.rindex name '.')
+  with Not_found ->
+    invalid_arg "Filename.chop_extension"
+
+external open_desc: string -> open_flag list -> int -> int = "sys_open"
+external close_desc: int -> unit = "sys_close"
+
+let temp_file prefix suffix =
+  let rec try_name counter =
+    if counter >= 1000 then
+      invalid_arg "Filename.temp_file: temp dir nonexistent or full"
+    else begin
+      let name =
+        concat temporary_directory (prefix ^ string_of_int counter ^ suffix) in
+      try
+        close_desc(open_desc name [Open_wronly; Open_creat; Open_excl] 0o666);
+        name
+      with Sys_error _ ->
+        try_name (counter + 1)
+    end
+  in try_name 0
+
+let quote s =
+  let quotequote =
+    match Sys.os_type with "MacOS" -> "'\182''" | _ -> "'\\''" in
+  let l = String.length s in
+  let b = Buffer.create (l + 20) in
+  Buffer.add_char b '\'';
+  for i = 0 to l - 1 do
+    if s.[i] = '\''
+    then Buffer.add_string b quotequote
+    else Buffer.add_char b  s.[i]
+  done;
+  Buffer.add_char b '\'';
+  Buffer.contents b
diff --git a/stdlib/filename.mli b/stdlib/filename.mli
new file mode 100644
index 0000000000..3bcce1d0f8
--- /dev/null
+++ b/stdlib/filename.mli
@@ -0,0 +1,88 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Operations on file names. *)
+
+val current_dir_name : string
+(** The conventional name for the current directory (e.g. [.] in Unix). *)
+
+val parent_dir_name : string
+(** The conventional name for the parent of the current directory
+   (e.g. [..] in Unix). *)
+
+val concat : string -> string -> string
+(** [concat dir file] returns a file name that designates file
+   [file] in directory [dir]. *)
+
+val is_relative : string -> bool
+(** Return [true] if the file name is relative to the current
+   directory, [false] if it is absolute (i.e. in Unix, starts
+   with [/]). *)
+
+val is_implicit : string -> bool
+(** Return [true] if the file name is relative and does not start
+   with an explicit reference to the current directory ([./] or
+   [../] in Unix), [false] if it starts with an explicit reference
+   to the root directory or the current directory. *)
+
+val check_suffix : string -> string -> bool
+(** [check_suffix name suff] returns [true] if the filename [name]
+   ends with the suffix [suff]. *)
+
+val chop_suffix : string -> string -> string
+(** [chop_suffix name suff] removes the suffix [suff] from
+   the filename [name]. The behavior is undefined if [name] does not
+   end with the suffix [suff]. *)
+
+val chop_extension : string -> string
+(** Return the given file name without its extension. The extension
+   is the shortest suffix starting with a period, [.xyz] for instance.
+
+   Raise [Invalid_argument] if the given name does not contain
+   a period. *)
+
+val basename : string -> string
+(** Split a file name into directory name / base file name.
+   {!Filename.concat} [(]{!Filename.dirname}[ name) (]{!Filename.basename}[ name)]
+   returns a file name which is equivalent to [name]. Moreover, after setting the
+   current directory to {!Filename.dirname}[ name] (with {!Sys.chdir}),
+   references to {!Filename.basename}[ name] (which is a relative file name)
+   designate the same file as [name] before the call to {!Sys.chdir}. *)
+
+val dirname : string -> string
+(** See {!Filename.dirname}. *)
+
+val temp_file : string -> string -> string
+(** [temp_file prefix suffix] returns the name of a
+   fresh temporary file in the temporary directory.
+   The base name of the temporary file is formed by concatenating
+   [prefix], then a suitably chosen integer number, then [suffix].
+   The temporary file is created empty, and is guaranteed to be
+   different from any other file that existed when [temp_file]
+   was called.
+   Under Unix, the temporary directory is [/tmp] by default; if set,
+   the value of the environment variable [TMPDIR] is used instead.
+   Under Windows, the name of the temporary directory is the
+   value of the environment variable [TEMP],
+   or [C:\temp] by default.
+   Under MacOS, the name of the temporary directory is given
+   by the environment variable [TempFolder]; if not set,
+   temporary files are created in the current directory. *)
+
+val quote : string -> string
+(** Return a quoted version of a file name, suitable for use as
+   one argument in a shell command line, escaping any shell
+   meta-characters. *)
+
diff --git a/stdlib/format.ml b/stdlib/format.ml
new file mode 100644
index 0000000000..21ad6b134c
--- /dev/null
+++ b/stdlib/format.ml
@@ -0,0 +1,883 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Pierre Weis, projet Cristal, INRIA Rocquencourt          *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Tokens are one of the following : *)
+
+type pp_token = 
+| Pp_text of string            (* normal text *)
+| Pp_break of int * int        (* complete break *)
+| Pp_tbreak of int * int       (* go to next tab *)
+| Pp_stab                      (* set a tabulation *)
+| Pp_begin of int * block_type (* beginning of a block *)
+| Pp_end                       (* end of a block *)
+| Pp_tbegin of tblock          (* Beginning of a tabulation block *)
+| Pp_tend                      (* end of a tabulation block *)
+| Pp_newline                   (* to force a newline inside a block *)
+| Pp_if_newline                (* to do something only if this very
+                                  line has been broken *)
+
+and block_type =
+| Pp_hbox   (* Horizontal block no line breaking *)
+| Pp_vbox   (* Vertical block each break leads to a new line *)
+| Pp_hvbox  (* Horizontal-vertical block: same as vbox, except if this block
+               is small enough to fit on a single line *)
+| Pp_hovbox (* Horizontal or Vertical block: breaks lead to new line
+               only when necessary to print the content of the block *)
+| Pp_box    (* Horizontal or Indent block: breaks lead to new line
+               only when necessary to print the content of the block, or
+               when it leads to a new indentation of the current line *)
+| Pp_fits   (* Internal usage: when a block fits on a single line *)
+
+and tblock = Pp_tbox of int list ref  (* Tabulation box *)
+;;
+
+(* The Queue: contains all formatting elements.
+   elements are tuples (size, token, length), where
+   size is set when the size of the block is known
+   len is the declared length of the token *)
+type pp_queue_elem =
+{mutable elem_size : int; token : pp_token; length : int};;
+
+(* Scan stack
+   each element is (left_total, queue element) where left_total
+   is the value of pp_left_total when the element has been enqueued *)
+type pp_scan_elem = Scan_elem of int * pp_queue_elem;;
+
+(* Formatting Stack:
+   used to break the lines while printing tokens.
+   The formatting stack contains the description of
+   the currently active blocks. *)
+type pp_format_elem = Format_elem of block_type * int;;
+
+(* General purpose queues, used in the formatter *)
+type 'a queue_elem = | Nil | Cons of 'a queue_cell
+and 'a queue_cell = {mutable head : 'a; mutable tail : 'a queue_elem};;
+
+type 'a queue =
+{mutable insert : 'a queue_elem;
+ mutable body : 'a queue_elem};;
+
+type formatter =
+{mutable pp_scan_stack : pp_scan_elem list;
+ mutable pp_format_stack : pp_format_elem list;
+ mutable pp_tbox_stack : tblock list;
+ (* Global variables: default initialization is
+    set_margin 78
+    set_min_space_left 0 *)
+ (* Value of right margin *)
+ mutable pp_margin : int;
+ (* Minimal space left before margin, when opening a block *)
+ mutable pp_min_space_left : int;
+ (* Maximum value of indentation:
+    no blocks can be opened further *)
+ mutable pp_max_indent : int;
+ (* Space remaining on the current line *)
+ mutable pp_space_left : int;
+ (* Current value of indentation *)
+ mutable pp_current_indent : int;
+ (* True when the line has been broken by the pretty-printer *)
+ mutable pp_is_new_line : bool;
+ (* Total width of tokens already printed *)
+ mutable pp_left_total : int;
+ (* Total width of tokens ever put in queue *)
+ mutable pp_right_total : int;
+ (* Current number of opened blocks *)
+ mutable pp_curr_depth : int;
+ (* Maximum number of blocks which can be simultaneously opened *)
+ mutable pp_max_boxes : int;
+ (* Ellipsis string *)
+ mutable pp_ellipsis : string;
+ (* Output function *)
+ mutable pp_output_function : string -> int -> int -> unit;
+ (* Flushing function *)
+ mutable pp_flush_function : unit -> unit;
+ (* Output of new lines *)
+ mutable pp_output_newline : formatter -> unit -> unit;
+ (* Output of indentation spaces *)
+ mutable pp_output_spaces : formatter -> int -> unit;
+ (* The pretty-printer queue *)
+ mutable pp_queue : pp_queue_elem queue
+};;
+
+(* Qeues *)
+let make_queue () = {insert = Nil; body = Nil};;
+
+let clear_queue q = q.insert <- Nil; q.body <- Nil;;
+
+let add_queue x q =
+ let c = Cons {head = x; tail = Nil} in
+ match q with
+ | {insert = Cons cell} -> q.insert <- c; cell.tail <- c
+ (* Invariant: when insert is Nil body should be Nil *)
+ | _ -> q.insert <- c; q.body <- c;;
+
+exception Empty_queue;;
+
+let peek_queue = function
+ | {body = Cons {head = x}} -> x
+ | _ -> raise Empty_queue;;
+
+let take_queue = function
+ | {body = Cons {head = x; tail = tl}} as q ->
+    q.body <- tl;
+    if tl = Nil then q.insert <- Nil; (* Maintain the invariant *)
+    x
+ | _ -> raise Empty_queue;;
+
+(* Enter a token in the pretty-printer queue *)
+let pp_enqueue state ({length = len} as token) =
+    state.pp_right_total <- state.pp_right_total + len;
+    add_queue token state.pp_queue;;
+
+let pp_clear_queue state =
+    state.pp_left_total <- 1; state.pp_right_total <- 1;
+    clear_queue state.pp_queue;;
+
+(* Large value for default tokens size *)
+(* Could be 1073741823 that is 2^30 - 1, that is the minimal upper bound
+   of integers *)
+let pp_infinity = 999999999;;
+
+(* Output functions for the formatter *)
+let pp_output_string state s = state.pp_output_function s 0 (String.length s)
+and pp_output_newline state = state.pp_output_newline state ();;
+
+let pp_display_blanks state n = state.pp_output_spaces state n;;
+
+(* To format a break, indenting a new line *)
+let break_new_line state offset width =
+    pp_output_newline state;
+    state.pp_is_new_line <- true;
+    let indent = state.pp_margin - width + offset in
+    (* Don't indent more than pp_max_indent *)
+    let real_indent = min state.pp_max_indent indent in
+    state.pp_current_indent <- real_indent;
+    state.pp_space_left <- state.pp_margin - state.pp_current_indent;
+    pp_display_blanks state state.pp_current_indent;;
+
+(* To force a line break inside a block: no offset is added *)
+let break_line state width = break_new_line state 0 width;;
+
+(* To format a break that fits on the current line *)
+let break_same_line state width =
+    state.pp_space_left <- state.pp_space_left - width;
+    pp_display_blanks state width;;
+
+(* To indent no more than pp_max_indent, if one tries to open a block
+   beyond pp_max_indent, then the block is rejected on the left
+   by simulating a break. *)
+let pp_force_break_line state =
+    match state.pp_format_stack with
+    | Format_elem (bl_ty, width) :: _ ->
+        if width > state.pp_space_left then
+         (match bl_ty with
+          | Pp_fits -> () | Pp_hbox -> () | _ -> break_line state width)
+    | _ -> pp_output_newline state;;
+
+(* To skip a token, if the previous line has been broken *)
+let pp_skip_token state =
+    (* When calling pp_skip_token the queue cannot be empty *)
+    match take_queue state.pp_queue with
+    {elem_size = size; length = len} ->
+       state.pp_left_total <- state.pp_left_total - len;
+       state.pp_space_left <- state.pp_space_left + size;;
+
+(* To format a token *)
+let format_pp_token state size = function
+
+  | Pp_text s ->
+      state.pp_space_left <- state.pp_space_left - size;
+      pp_output_string state s;
+      state.pp_is_new_line <- false
+
+  | Pp_begin (off, ty) ->
+      let insertion_point = state.pp_margin - state.pp_space_left in
+      if insertion_point > state.pp_max_indent then
+         (* can't open a block right there *)
+         begin pp_force_break_line state end;
+      let offset = state.pp_space_left - off in
+      let bl_type =
+       begin match ty with
+        | Pp_vbox -> Pp_vbox
+        | _ -> if size > state.pp_space_left then ty else Pp_fits
+       end in
+       state.pp_format_stack <-
+        Format_elem (bl_type, offset) :: state.pp_format_stack
+
+  | Pp_end ->
+      begin match state.pp_format_stack with
+        | x :: (y :: l as ls) -> state.pp_format_stack <- ls
+        | _ -> () (* No more block to close *)
+      end
+
+  | Pp_tbegin (Pp_tbox _ as tbox) ->
+      state.pp_tbox_stack <- tbox :: state.pp_tbox_stack
+
+  | Pp_tend ->
+      begin match state.pp_tbox_stack with
+        | x :: ls -> state.pp_tbox_stack <- ls
+        | _ -> () (* No more tabulation block to close *)
+      end
+
+  | Pp_stab ->
+     begin match state.pp_tbox_stack with
+     | Pp_tbox tabs :: _ -> 
+        let rec add_tab n = function
+          | [] -> [n]
+          | x :: l as ls -> if n < x then n :: ls else x :: add_tab n l in
+        tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs
+     | _ -> () (* No opened tabulation block *)
+     end
+
+  | Pp_tbreak (n, off) ->
+      let insertion_point = state.pp_margin - state.pp_space_left in
+      begin match state.pp_tbox_stack with
+      | Pp_tbox tabs :: _ -> 
+         let rec find n = function
+           | x :: l -> if x >= n then x else find n l
+           | [] -> raise Not_found in
+         let tab =
+             match !tabs with
+             | x :: l ->
+                begin try find insertion_point !tabs with Not_found -> x end
+             | _ -> insertion_point in
+         let offset = tab - insertion_point in
+         if offset >= 0 then break_same_line state (offset + n) else
+          break_new_line state (tab + off) state.pp_margin
+      | _ -> () (* No opened tabulation block *)
+      end
+
+  | Pp_newline ->
+     begin match state.pp_format_stack with
+     | Format_elem (_, width) :: _ -> break_line state width
+     | _ -> pp_output_newline state
+     end
+
+  | Pp_if_newline ->
+     if state.pp_current_indent != state.pp_margin - state.pp_space_left
+     then pp_skip_token state
+
+  | Pp_break (n, off) ->
+     begin match state.pp_format_stack with
+     | Format_elem (ty, width) :: _ ->
+        begin match ty with
+        | Pp_hovbox ->
+           if size > state.pp_space_left 
+           then break_new_line state off width
+           else break_same_line state n
+        | Pp_box ->
+           (* Have the line just been broken here ? *)
+           if state.pp_is_new_line then break_same_line state n else
+           if size > state.pp_space_left
+            then break_new_line state off width else
+           (* break the line here leads to new indentation ? *)
+           if state.pp_current_indent > state.pp_margin - width + off
+           then break_new_line state off width
+           else break_same_line state n
+        | Pp_hvbox -> break_new_line state off width
+        | Pp_fits -> break_same_line state n
+        | Pp_vbox -> break_new_line state off width
+        | Pp_hbox -> break_same_line state n
+        end
+     | _ -> () (* No opened block *)
+     end;;
+
+(* Print if token size is known or printing is delayed
+   Size is known when not negative
+   Printing is delayed when the text waiting in the queue requires
+   more room to format than exists on the current line *)
+let rec advance_left state =
+    try
+     match peek_queue state.pp_queue with
+      {elem_size = size; token = tok; length = len} ->
+       if not
+        (size < 0 &&
+         (state.pp_right_total - state.pp_left_total < state.pp_space_left))
+        then begin
+         ignore(take_queue state.pp_queue);
+         format_pp_token state (if size < 0 then pp_infinity else size) tok;
+         state.pp_left_total <- len + state.pp_left_total;
+         advance_left state
+        end
+    with Empty_queue -> ();;
+
+let enqueue_advance state tok = pp_enqueue state tok; advance_left state;;
+
+(* To enqueue a string : try to advance *)
+let enqueue_string_as state n s =
+    enqueue_advance state {elem_size = n; token = Pp_text s; length = n};;
+
+let enqueue_string state s = enqueue_string_as state (String.length s) s;;
+
+(* Routines for scan stack
+   determine sizes of blocks *)
+
+(* The scan_stack is never empty *)
+let scan_stack_bottom =
+    [Scan_elem (-1, {elem_size = (-1); token = Pp_text ""; length = 0})];;
+
+(* Set size of blocks on scan stack:
+   if ty = true then size of break is set else size of block is set
+   in each case pp_scan_stack is popped *)
+let clear_scan_stack state = state.pp_scan_stack <- scan_stack_bottom;;
+
+(* Pattern matching on scan stack is exhaustive,
+   since scan_stack is never empty.
+   Pattern matching on token in scan stack is also exhaustive,
+   since scan_push is used on breaks and opening of boxes *)
+let set_size state ty =
+    match state.pp_scan_stack with
+    | Scan_elem (left_tot,
+                 ({elem_size = size; token = tok} as queue_elem)) :: t ->
+       (* test if scan stack contains any data that is not obsolete *)
+       if left_tot < state.pp_left_total then clear_scan_stack state else
+        begin match tok with
+        | Pp_break (_, _) | Pp_tbreak (_, _) ->
+           if ty then
+            begin
+             queue_elem.elem_size <- state.pp_right_total + size;
+             state.pp_scan_stack <- t
+            end
+        | Pp_begin (_, _) ->
+           if not ty then
+            begin
+             queue_elem.elem_size <- state.pp_right_total + size;
+             state.pp_scan_stack <- t
+            end
+        | _ -> () (* scan_push is only used for breaks and boxes *)
+        end
+    | _ -> () (* scan_stack is never empty *);;
+
+(* Push a token on scan stack. If b is true set_size is called *)
+let scan_push state b tok =
+    pp_enqueue state tok;
+    if b then set_size state true;
+    state.pp_scan_stack <-
+     Scan_elem (state.pp_right_total, tok) :: state.pp_scan_stack;;
+
+(* To open a new block :
+   the user may set the depth bound pp_max_boxes
+   any text nested deeper is printed as the ellipsis string *)
+let pp_open_box_gen state indent br_ty =
+    state.pp_curr_depth <- state.pp_curr_depth + 1;
+    if state.pp_curr_depth < state.pp_max_boxes then
+      (scan_push state false
+        {elem_size = (- state.pp_right_total);
+         token = Pp_begin (indent, br_ty); length = 0}) else
+    if state.pp_curr_depth = state.pp_max_boxes
+    then enqueue_string state state.pp_ellipsis;;
+
+(* The box which is always opened *)
+let pp_open_sys_box state =
+    state.pp_curr_depth <- state.pp_curr_depth + 1;
+    scan_push state false
+     {elem_size = (- state.pp_right_total);
+      token = Pp_begin (0, Pp_hovbox); length = 0};;
+
+(* Close a block, setting sizes of its subblocks *)
+let pp_close_box state () =
+    if state.pp_curr_depth > 1 then
+     begin
+      if state.pp_curr_depth < state.pp_max_boxes then
+       begin
+        pp_enqueue state {elem_size = 0; token = Pp_end; length = 0};
+        set_size state true; set_size state false
+       end;
+      state.pp_curr_depth <- state.pp_curr_depth - 1;
+     end;;
+
+(* Initialize pretty-printer. *)
+let pp_rinit state =
+    pp_clear_queue state;
+    clear_scan_stack state;
+    state.pp_current_indent <- 0;
+    state.pp_curr_depth <- 0;
+    state.pp_space_left <- state.pp_margin;
+    state.pp_format_stack <- [];
+    state.pp_tbox_stack <- [];
+    pp_open_sys_box state;;
+
+(* Flushing pretty-printer queue. *)
+let pp_flush_queue state b =
+    while state.pp_curr_depth > 1 do
+     pp_close_box state ()
+    done;
+    state.pp_right_total <- pp_infinity; advance_left state;
+    if b then pp_output_newline state;
+    pp_rinit state;;
+
+(**************************************************************
+
+  Procedures to format objects, and use boxes
+
+ **************************************************************)
+
+(* To format a string *)
+let pp_print_as state n s =
+  if state.pp_curr_depth < state.pp_max_boxes
+  then enqueue_string_as state n s;;
+
+let pp_print_string state s = pp_print_as state (String.length s) s;;
+
+(* To format an integer *)
+let pp_print_int state i = pp_print_string state (string_of_int i);;
+
+(* To format a float *)
+let pp_print_float state f = pp_print_string state (string_of_float f);;
+
+(* To format a boolean *)
+let pp_print_bool state b = pp_print_string state (string_of_bool b);;
+
+(* To format a char *)
+let pp_print_char state c =
+  let s = String.create 1 in s.[0] <- c; pp_print_as state 1 s;;
+
+(* Opening boxes *)
+let pp_open_hbox state () = pp_open_box_gen state 0 Pp_hbox
+and pp_open_vbox state indent = pp_open_box_gen state indent Pp_vbox
+
+and pp_open_hvbox state indent = pp_open_box_gen state indent Pp_hvbox
+and pp_open_hovbox state indent = pp_open_box_gen state indent Pp_hovbox
+and pp_open_box state indent = pp_open_box_gen state indent Pp_box;;
+
+(* Print a new line after printing all queued text
+   (same for print_flush but without a newline).    *)
+let pp_print_newline state () =
+    pp_flush_queue state true; state.pp_flush_function ()
+and pp_print_flush state () =
+    pp_flush_queue state false; state.pp_flush_function ();;
+
+(* To get a newline when one does not want to close the current block *)
+let pp_force_newline state () =
+  if state.pp_curr_depth < state.pp_max_boxes then
+    enqueue_advance state {elem_size = 0; token = Pp_newline; length = 0};;
+
+(* To format something if the line has just been broken *)
+let pp_print_if_newline state () =
+  if state.pp_curr_depth < state.pp_max_boxes then
+    enqueue_advance state {elem_size = 0; token = Pp_if_newline; length = 0};;
+
+(* Breaks: indicate where a block may be broken.
+   If line is broken then offset is added to the indentation of the current
+   block else (the value of) width blanks are printed.
+   To do (?) : add a maximum width and offset value *)
+let pp_print_break state width offset =
+  if state.pp_curr_depth < state.pp_max_boxes then 
+    scan_push state true
+     {elem_size = (- state.pp_right_total); token = Pp_break (width, offset);
+      length = width};;
+
+let pp_print_space state () = pp_print_break state 1 0
+and pp_print_cut state () = pp_print_break state 0 0;;
+
+(* Tabulation boxes *)
+let pp_open_tbox state () =
+  state.pp_curr_depth <- state.pp_curr_depth + 1;
+  if state.pp_curr_depth < state.pp_max_boxes then
+    enqueue_advance state
+      {elem_size = 0;
+       token = Pp_tbegin (Pp_tbox (ref [])); length = 0};;
+
+(* Close a tabulation block *)
+let pp_close_tbox state () =
+  if state.pp_curr_depth > 1 then begin
+   if state.pp_curr_depth < state.pp_max_boxes then
+    enqueue_advance state {elem_size = 0; token = Pp_tend; length = 0};
+   state.pp_curr_depth <- state.pp_curr_depth - 1 end;;
+
+(* Print a tabulation break *)
+let pp_print_tbreak state width offset =
+  if state.pp_curr_depth < state.pp_max_boxes then
+    scan_push state true
+     {elem_size = (- state.pp_right_total); token = Pp_tbreak (width, offset); 
+      length = width};;
+
+let pp_print_tab state () = pp_print_tbreak state 0 0;;
+
+let pp_set_tab state () =
+  if state.pp_curr_depth < state.pp_max_boxes
+  then enqueue_advance state {elem_size = 0; token = Pp_stab; length=0};;
+
+(**************************************************************
+
+  Procedures to control the pretty-printer
+
+ **************************************************************)
+
+(* Fit max_boxes *)
+let pp_set_max_boxes state n = if n > 1 then state.pp_max_boxes <- n;;
+
+(* To know the current maximum number of boxes allowed *)
+let pp_get_max_boxes state () = state.pp_max_boxes;;
+
+let pp_over_max_boxes state () = state.pp_curr_depth = state.pp_max_boxes;;
+
+(* Ellipsis *)
+let pp_set_ellipsis_text state s = state.pp_ellipsis <- s
+and pp_get_ellipsis_text state () = state.pp_ellipsis;;
+
+(* To set the margin of pretty-formater *)
+let pp_set_min_space_left state n =
+  if n >= 1 && n < pp_infinity then
+   begin
+    state.pp_min_space_left <- n;
+    state.pp_max_indent <- state.pp_margin - state.pp_min_space_left;
+    pp_rinit state end;;
+
+(* Initially we have :
+  pp_max_indent = pp_margin - pp_min_space_left, and
+  pp_space_left = pp_margin *)
+let pp_set_max_indent state n =
+  pp_set_min_space_left state (state.pp_margin - n);;
+let pp_get_max_indent state () = state.pp_max_indent;;
+
+let pp_set_margin state n =
+  if n >= 1 && n < pp_infinity then
+   begin
+    state.pp_margin <- n;
+    let new_max_indent =
+        (* Try to maintain max_indent to its actual value *)
+        if state.pp_max_indent <= state.pp_margin
+        then state.pp_max_indent else
+        (* If possible maintain pp_min_space_left to its actual value,
+           if this leads to a too small max_indent, take half of the
+           new margin, if it is greater than 1 *)
+         max (max (state.pp_margin - state.pp_min_space_left)
+                  (state.pp_margin / 2)) 1 in
+    (* Rebuild invariants *)
+    pp_set_max_indent state new_max_indent end;;
+
+let pp_get_margin state () = state.pp_margin;;
+
+let pp_set_formatter_output_functions state f g =
+  state.pp_output_function <- f; state.pp_flush_function <- g;;
+let pp_get_formatter_output_functions state () = 
+  (state.pp_output_function, state.pp_flush_function);;
+
+let pp_set_all_formatter_output_functions state
+    ~out:f ~flush:g ~newline:h ~spaces:i =
+  pp_set_formatter_output_functions state f g;
+  state.pp_output_newline <- (function _ -> function () -> h ());
+  state.pp_output_spaces <- (function _ -> function n -> i n);;
+let pp_get_all_formatter_output_functions state () = 
+  (state.pp_output_function, state.pp_flush_function,
+   state.pp_output_newline state, state.pp_output_spaces state);;
+
+let pp_set_formatter_out_channel state os =
+  state.pp_output_function <- output os;
+  state.pp_flush_function <- (fun () -> flush os);;
+
+let pp_make_formatter f g h i = 
+ (* The initial state of the formatter contains a dummy box *)
+ let pp_q = make_queue () in
+ let sys_tok =
+     {elem_size = (- 1); token = Pp_begin (0, Pp_hovbox); length = 0} in
+ add_queue sys_tok pp_q;
+ let sys_scan_stack =
+     (Scan_elem (1, sys_tok)) :: scan_stack_bottom in
+ {pp_scan_stack = sys_scan_stack;
+  pp_format_stack = [];
+  pp_tbox_stack = [];
+  pp_margin = 78;
+  pp_min_space_left = 10;
+  pp_max_indent = 78 - 10;
+  pp_space_left = 78;
+  pp_current_indent = 0;
+  pp_is_new_line = true;
+  pp_left_total = 1;
+  pp_right_total = 1;
+  pp_curr_depth = 1;
+  pp_max_boxes = max_int;
+  pp_ellipsis = ".";
+  pp_output_function = f;
+  pp_flush_function = g;
+  pp_output_newline = h;
+  pp_output_spaces = i;
+  pp_queue = pp_q
+ };;
+
+(* Default function to output spaces *)
+let blank_line = String.make 80 ' ';;
+let rec display_blanks state n =
+    if n > 0 then
+    if n <= 80 then state.pp_output_function blank_line 0 n else
+     begin
+      state.pp_output_function blank_line 0 80;
+      display_blanks state (n - 80)
+     end;;
+
+(* Default function to output new lines *)
+let display_newline state () = state.pp_output_function "\n" 0  1;;
+
+let make_formatter f g = pp_make_formatter f g display_newline display_blanks;;
+
+let formatter_of_out_channel oc =
+ make_formatter (output oc) (fun () -> flush oc);;
+
+let unit_out () = ();;
+
+let formatter_of_buffer b =
+ make_formatter (Buffer.add_substring b) unit_out;;
+
+let stdbuf = Buffer.create 512;;
+
+let str_formatter = formatter_of_buffer stdbuf;;
+let std_formatter = formatter_of_out_channel stdout;;
+let err_formatter = formatter_of_out_channel stderr;;
+
+let flush_str_formatter () =
+ pp_flush_queue str_formatter false;
+ let s = Buffer.contents stdbuf in
+ Buffer.reset stdbuf;
+ s;;
+
+let open_hbox = pp_open_hbox std_formatter
+and open_vbox = pp_open_vbox std_formatter
+and open_hvbox = pp_open_hvbox std_formatter
+and open_hovbox = pp_open_hovbox std_formatter
+and open_box = pp_open_box std_formatter
+and close_box = pp_close_box std_formatter
+and print_as = pp_print_as std_formatter
+and print_string = pp_print_string std_formatter
+and print_int = pp_print_int std_formatter
+and print_float = pp_print_float std_formatter
+and print_char = pp_print_char std_formatter
+and print_bool = pp_print_bool std_formatter
+and print_break = pp_print_break std_formatter
+and print_cut = pp_print_cut std_formatter
+and print_space = pp_print_space std_formatter
+and force_newline = pp_force_newline std_formatter
+and print_flush = pp_print_flush std_formatter
+and print_newline = pp_print_newline std_formatter
+and print_if_newline = pp_print_if_newline std_formatter
+
+and open_tbox = pp_open_tbox std_formatter
+and close_tbox = pp_close_tbox std_formatter
+and print_tbreak = pp_print_tbreak std_formatter
+
+and set_tab = pp_set_tab std_formatter
+and print_tab = pp_print_tab std_formatter
+
+and set_margin = pp_set_margin std_formatter
+and get_margin = pp_get_margin std_formatter
+
+and set_max_indent = pp_set_max_indent std_formatter
+and get_max_indent = pp_get_max_indent std_formatter
+
+and set_max_boxes = pp_set_max_boxes std_formatter
+and get_max_boxes = pp_get_max_boxes std_formatter
+and over_max_boxes = pp_over_max_boxes std_formatter
+
+and set_ellipsis_text = pp_set_ellipsis_text std_formatter
+and get_ellipsis_text = pp_get_ellipsis_text std_formatter
+
+and set_formatter_out_channel =
+    pp_set_formatter_out_channel std_formatter
+
+and set_formatter_output_functions =
+    pp_set_formatter_output_functions std_formatter
+and get_formatter_output_functions =
+    pp_get_formatter_output_functions std_formatter
+
+and set_all_formatter_output_functions =
+    pp_set_all_formatter_output_functions std_formatter
+and get_all_formatter_output_functions =
+    pp_get_all_formatter_output_functions std_formatter;;
+
+
+(* Printf implementation. *)
+
+external format_int : string -> int -> string = "format_int";;
+external format_float : string -> float -> string = "format_float";;
+
+let format_invalid_arg s c = invalid_arg (s ^ String.make 1 c);;
+
+(* [fprintf_out] is the printf-like function generator: given the
+   - [str] flag that tells if we are printing into a string,
+   - the [out] function that has to be called at the end of formatting,
+   it generates a [fprintf] function that takes as arguments a [ppf]
+   formatter and a printing format to print the rest of arguments
+   according to the format.
+   Regular [fprintf]-like functions of this module are obtained via partial
+   applications of [fprintf_out]. *)
+let fprintf_out str out ppf format =
+  let format = (Obj.magic format : string) in
+  let limit = String.length format in
+
+  let print_as = ref None in
+
+  let pp_print_as_char c =
+      match !print_as with
+      | None -> pp_print_char ppf c
+      | Some size ->
+         pp_print_as ppf size (String.make 1 c);
+         print_as := None
+  and pp_print_as_string s =
+      match !print_as with
+      | None -> pp_print_string ppf s
+      | Some size ->
+         pp_print_as ppf size s;
+         print_as := None in
+
+  let rec doprn i =
+    if i >= limit then
+      Obj.magic (out ())
+    else
+      match format.[i] with
+      | '%' ->
+          Printf.scan_format format i cont_s cont_a cont_t
+      | '@' ->
+          let j = succ i in
+          if j >= limit then invalid_arg ("fprintf: unknown format " ^ format)
+          else
+          begin match format.[j] with
+          | '@' ->
+              pp_print_char ppf '@';
+              doprn (succ j)
+          | '[' ->
+              let j = do_pp_open ppf (i + 2) in
+              doprn j
+          | ']' ->
+              pp_close_box ppf ();
+              doprn (succ j)
+          | ' ' ->
+              pp_print_space ppf ();
+              doprn (succ j)
+          | ',' ->
+              pp_print_cut ppf ();
+              doprn (succ j)
+          | '?' ->
+              pp_print_flush ppf ();
+              doprn (succ j)
+          | '.' ->
+              pp_print_newline ppf ();
+              doprn (succ j)
+          | '\n' ->
+              pp_force_newline ppf ();
+              doprn (succ j)
+          | ';' ->
+              let j = do_pp_break ppf (i + 2) in
+              doprn j
+          | '<' ->
+              let size, j =
+                get_int "fprintf: bad print format " format (i + 2) in
+              if format.[pred j] != '>'
+               then invalid_arg ("fprintf: bad print format " ^ format)
+               else print_as := Some size;
+              doprn j
+          | c -> format_invalid_arg "fprintf: unknown format " c
+          end
+      | c -> pp_print_as_char c; doprn (succ i)
+
+  and cont_s s i =
+    pp_print_as_string s; doprn i
+  and cont_a printer arg i =
+    if str then
+      pp_print_as_string ((Obj.magic printer) () arg)
+    else
+      printer ppf arg;
+    doprn i
+  and cont_t printer i =
+    if str then
+      pp_print_as_string ((Obj.magic printer) ())
+    else
+      printer ppf;
+    doprn i
+
+  and get_int s1 s2 i =
+   if i >= limit then invalid_arg (s1 ^ s2) else
+   match format.[i] with
+   | ' ' -> get_int s1 s2 (succ i)
+   | c ->
+      let rec get j =
+       if j >= limit then invalid_arg (s1 ^ s2) else
+       match format.[j] with
+       | '0' .. '9' | '-' -> get (succ j)
+       | '>' | ' ' ->
+         if j = i then 0, succ j else
+          begin try int_of_string (String.sub format i (j - i)), succ j
+          with Failure _ -> invalid_arg (s1 ^ s2) end
+       | c -> format_invalid_arg (s1 ^ s2) c in
+       get i
+
+  and get_box_kind j =
+   if j >= limit then Pp_box, j else
+   match format.[j] with
+   | 'h' ->
+      let j = succ j in
+      if j >= limit then Pp_hbox, j else
+      begin match format.[j] with
+      | 'o' ->
+         let j = succ j in
+         if j >= limit
+          then invalid_arg ("fprintf: bad box format " ^ format) else
+         begin match format.[j] with
+         | 'v' -> Pp_hovbox, succ j
+         | c -> format_invalid_arg "fprintf: bad box name " c end
+      | 'v' -> Pp_hvbox, succ j
+      | c -> Pp_hbox, j
+      end
+   | 'b' -> Pp_box, succ j
+   | 'v' -> Pp_vbox, succ j
+   | _ -> Pp_box, j
+
+  and do_pp_break ppf i =
+   if i >= limit then begin pp_print_space ppf (); i end else
+   match format.[i] with
+   | '<' ->
+     let nspaces, j =
+       get_int "fprintf: bad break format " format (succ i) in
+     let offset, j =
+       get_int "fprintf: bad break format " format j in
+     if format.[pred j] != '>'
+     then invalid_arg "fprintf: bad break format" format
+     else pp_print_break ppf nspaces offset;
+     j
+   | c -> pp_print_space ppf (); i
+
+  and do_pp_open ppf i =
+   if i >= limit then begin pp_open_box_gen ppf 0 Pp_box; i end else
+   match format.[i] with
+   | '<' ->
+     let kind, j = get_box_kind (succ i) in
+     let size, j = get_int "fprintf: bad box format " format j in
+     pp_open_box_gen ppf size kind;
+     j
+   | c -> pp_open_box_gen ppf 0 Pp_box; i
+
+  in doprn 0;;
+
+let get_buffer_out b =
+ let s = Buffer.contents b in
+ Buffer.reset b;
+ s;;
+
+let string_out b ppf () =
+ pp_flush_queue ppf false;
+ get_buffer_out b;;
+
+let fprintf ppf = fprintf_out false unit_out ppf;;
+let printf f = fprintf_out false unit_out std_formatter f;;
+let eprintf f = fprintf_out false unit_out err_formatter f;;
+let sprintf f =
+ let b = Buffer.create 512 in
+ let ppf = formatter_of_buffer b in
+ fprintf_out true (string_out b ppf) ppf f;;
+
+let bprintf b =
+ let ppf = formatter_of_buffer b in
+ fprintf_out false (fun () -> pp_flush_queue ppf false) ppf;;
+
+at_exit print_flush;;
diff --git a/stdlib/genlex.ml b/stdlib/genlex.ml
new file mode 100644
index 0000000000..a4e494c077
--- /dev/null
+++ b/stdlib/genlex.ml
@@ -0,0 +1,202 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*              Xavier Leroy, projet Cristal, INRIA Rocquencourt       *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+type token =
+    Kwd of string
+  | Ident of string
+  | Int of int
+  | Float of float
+  | String of string
+  | Char of char
+
+
+(* The string buffering machinery *)
+
+let initial_buffer = String.create 32
+
+let buffer = ref initial_buffer
+let bufpos = ref 0
+
+let reset_buffer () = buffer := initial_buffer; bufpos := 0
+
+let store c =
+  if !bufpos >= String.length !buffer then
+    begin
+      let newbuffer = String.create (2 * !bufpos) in
+      String.blit !buffer 0 newbuffer 0 !bufpos; buffer := newbuffer
+    end;
+  String.set !buffer !bufpos c;
+  incr bufpos
+
+let get_string () =
+  let s = String.sub !buffer 0 !bufpos in buffer := initial_buffer; s
+
+(* The lexer *)
+
+let make_lexer keywords =
+  let kwd_table = Hashtbl.create 17 in
+  List.iter (fun s -> Hashtbl.add kwd_table s (Kwd s)) keywords;
+  let ident_or_keyword id =
+    try Hashtbl.find kwd_table id with
+      Not_found -> Ident id
+  and keyword_or_error c =
+    let s = String.make 1 c in
+    try Hashtbl.find kwd_table s with
+      Not_found -> raise (Stream.Error ("Illegal character " ^ s))
+  in
+  let rec next_token (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some (' ' | '\010' | '\013' | '\009' | '\026' | '\012') ->
+        Stream.junk strm__; next_token strm__
+    | Some ('A'..'Z' | 'a'..'z' | '\192'..'\255' as c) ->
+        Stream.junk strm__;
+        let s = strm__ in reset_buffer (); store c; ident s
+    | Some
+        ('!' | '%' | '&' | '$' | '#' | '+' | '/' | ':' | '<' | '=' | '>' |
+         '?' | '@' | '\\' | '~' | '^' | '|' | '*' as c) ->
+        Stream.junk strm__;
+        let s = strm__ in reset_buffer (); store c; ident2 s
+    | Some ('0'..'9' as c) ->
+        Stream.junk strm__;
+        let s = strm__ in reset_buffer (); store c; number s
+    | Some '\'' ->
+        Stream.junk strm__;
+        let c =
+          try char strm__ with
+            Stream.Failure -> raise (Stream.Error "")
+        in
+        begin match Stream.peek strm__ with
+          Some '\'' -> Stream.junk strm__; Some (Char c)
+        | _ -> raise (Stream.Error "")
+        end
+    | Some '"' ->
+        Stream.junk strm__;
+        let s = strm__ in reset_buffer (); Some (String (string s))
+    | Some '-' -> Stream.junk strm__; neg_number strm__
+    | Some '(' -> Stream.junk strm__; maybe_comment strm__
+    | Some c -> Stream.junk strm__; Some (keyword_or_error c)
+    | _ -> None
+  and ident (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some
+        ('A'..'Z' | 'a'..'z' | '\192'..'\255' | '0'..'9' | '_' | '\'' as c) ->
+        Stream.junk strm__; let s = strm__ in store c; ident s
+    | _ -> Some (ident_or_keyword (get_string ()))
+  and ident2 (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some
+        ('!' | '%' | '&' | '$' | '#' | '+' | '-' | '/' | ':' | '<' | '=' |
+         '>' | '?' | '@' | '\\' | '~' | '^' | '|' | '*' as c) ->
+        Stream.junk strm__; let s = strm__ in store c; ident2 s
+    | _ -> Some (ident_or_keyword (get_string ()))
+  and neg_number (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some ('0'..'9' as c) ->
+        Stream.junk strm__;
+        let s = strm__ in reset_buffer (); store '-'; store c; number s
+    | _ -> let s = strm__ in reset_buffer (); store '-'; ident2 s
+  and number (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some ('0'..'9' as c) ->
+        Stream.junk strm__; let s = strm__ in store c; number s
+    | Some '.' ->
+        Stream.junk strm__; let s = strm__ in store '.'; decimal_part s
+    | Some ('e' | 'E') ->
+        Stream.junk strm__; let s = strm__ in store 'E'; exponent_part s
+    | _ -> Some (Int (int_of_string (get_string ())))
+  and decimal_part (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some ('0'..'9' as c) ->
+        Stream.junk strm__; let s = strm__ in store c; decimal_part s
+    | Some ('e' | 'E') ->
+        Stream.junk strm__; let s = strm__ in store 'E'; exponent_part s
+    | _ -> Some (Float (float_of_string (get_string ())))
+  and exponent_part (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some ('+' | '-' as c) ->
+        Stream.junk strm__; let s = strm__ in store c; end_exponent_part s
+    | _ -> end_exponent_part strm__
+  and end_exponent_part (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some ('0'..'9' as c) ->
+        Stream.junk strm__; let s = strm__ in store c; end_exponent_part s
+    | _ -> Some (Float (float_of_string (get_string ())))
+  and string (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some '"' -> Stream.junk strm__; get_string ()
+    | Some '\\' ->
+        Stream.junk strm__;
+        let c =
+          try escape strm__ with
+            Stream.Failure -> raise (Stream.Error "")
+        in
+        let s = strm__ in store c; string s
+    | Some c -> Stream.junk strm__; let s = strm__ in store c; string s
+    | _ -> raise Stream.Failure
+  and char (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some '\\' ->
+        Stream.junk strm__;
+        begin try escape strm__ with
+          Stream.Failure -> raise (Stream.Error "")
+        end
+    | Some c -> Stream.junk strm__; c
+    | _ -> raise Stream.Failure
+  and escape (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some 'n' -> Stream.junk strm__; '\n'
+    | Some 'r' -> Stream.junk strm__; '\r'
+    | Some 't' -> Stream.junk strm__; '\t'
+    | Some ('0'..'9' as c1) ->
+        Stream.junk strm__;
+        begin match Stream.peek strm__ with
+          Some ('0'..'9' as c2) ->
+            Stream.junk strm__;
+            begin match Stream.peek strm__ with
+              Some ('0'..'9' as c3) ->
+                Stream.junk strm__;
+                Char.chr
+                  ((Char.code c1 - 48) * 100 + (Char.code c2 - 48) * 10 +
+                     (Char.code c3 - 48))
+            | _ -> raise (Stream.Error "")
+            end
+        | _ -> raise (Stream.Error "")
+        end
+    | Some c -> Stream.junk strm__; c
+    | _ -> raise Stream.Failure
+  and maybe_comment (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some '*' ->
+        Stream.junk strm__; let s = strm__ in comment s; next_token s
+    | _ -> Some (keyword_or_error '(')
+  and comment (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some '(' -> Stream.junk strm__; maybe_nested_comment strm__
+    | Some '*' -> Stream.junk strm__; maybe_end_comment strm__
+    | Some c -> Stream.junk strm__; comment strm__
+    | _ -> raise Stream.Failure
+  and maybe_nested_comment (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some '*' -> Stream.junk strm__; let s = strm__ in comment s; comment s
+    | Some c -> Stream.junk strm__; comment strm__
+    | _ -> raise Stream.Failure
+  and maybe_end_comment (strm__ : _ Stream.t) =
+    match Stream.peek strm__ with
+      Some ')' -> Stream.junk strm__; ()
+    | Some '*' -> Stream.junk strm__; maybe_end_comment strm__
+    | Some c -> Stream.junk strm__; comment strm__
+    | _ -> raise Stream.Failure
+  in
+  fun input -> Stream.from (fun count -> next_token input)
diff --git a/stdlib/genlex.mli b/stdlib/genlex.mli
new file mode 100644
index 0000000000..7ac0b647b6
--- /dev/null
+++ b/stdlib/genlex.mli
@@ -0,0 +1,68 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*              Xavier Leroy, projet Cristal, INRIA Rocquencourt       *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** A generic lexical analyzer.
+
+
+   This module implements a simple ``standard'' lexical analyzer, presented
+   as a function from character streams to token streams. It implements
+   roughly the lexical conventions of Caml, but is parameterized by the
+   set of keywords of your language. 
+
+
+   Example: a lexer suitable for a desk calculator is obtained by
+   {[     let lexer = make_lexer ["+";"-";"*";"/";"let";"="; "("; ")"]  ]}
+
+   The associated parser would be a function from [token stream]
+   to, for instance, [int], and would have rules such as:
+
+   {[
+           let parse_expr = parser
+                  [< 'Int n >] -> n
+                | [< 'Kwd "("; n = parse_expr; 'Kwd ")" >] -> n
+                | [< n1 = parse_expr; n2 = parse_remainder n1 >] -> n2
+           and parse_remainder n1 = parser
+                  [< 'Kwd "+"; n2 = parse_expr >] -> n1+n2
+                | ...
+   ]}
+*)
+
+(** The type of tokens. The lexical classes are: [Int] and [Float]
+   for integer and floating-point numbers; [String] for
+   string literals, enclosed in double quotes; [Char] for
+   character literals, enclosed in single quotes; [Ident] for
+   identifiers (either sequences of letters, digits, underscores
+   and quotes, or sequences of ``operator characters'' such as
+   [+], [*], etc); and [Kwd] for keywords (either identifiers or
+   single ``special characters'' such as [(], [}], etc). *)
+type token =
+    Kwd of string
+  | Ident of string
+  | Int of int
+  | Float of float
+  | String of string
+  | Char of char
+           
+val make_lexer : string list -> char Stream.t -> token Stream.t
+(** Construct the lexer function. The first argument is the list of
+   keywords. An identifier [s] is returned as [Kwd s] if [s]
+   belongs to this list, and as [Ident s] otherwise.
+   A special character [s] is returned as [Kwd s] if [s]
+   belongs to this list, and cause a lexical error (exception
+   [Parse_error]) otherwise. Blanks and newlines are skipped.
+   Comments delimited by [(*] and [*)] are skipped as well,
+   and can be nested. *)
+
+        
diff --git a/stdlib/header.c b/stdlib/header.c
new file mode 100644
index 0000000000..0d536be18d
--- /dev/null
+++ b/stdlib/header.c
@@ -0,0 +1,191 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1998 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* The launcher for bytecode executables (if #! is not working) */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include "../config/s.h"
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#include <fcntl.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include "../byterun/mlvalues.h"
+#include "../byterun/exec.h"
+
+char * default_runtime_path = RUNTIME_NAME;
+
+#ifndef MAXPATHLEN
+#define MAXPATHLEN 1024
+#endif
+
+#ifndef S_ISREG
+#define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG)
+#endif
+
+#ifndef SEEK_END
+#define SEEK_END 2
+#endif
+
+#ifndef __CYGWIN32__
+
+/* Normal Unix search path function */
+
+static char * searchpath(char * name)
+{
+  static char fullname[MAXPATHLEN + 1];
+  char * path;
+  char * p;
+  char * q;
+  struct stat st;
+
+  for (p = name; *p != 0; p++) {
+    if (*p == '/') return name;
+  }
+  path = getenv("PATH");
+  if (path == NULL) return name;
+  while(1) {
+    for (p = fullname; *path != 0 && *path != ':'; p++, path++)
+      if (p < fullname + MAXPATHLEN) *p = *path;
+    if (p != fullname && p < fullname + MAXPATHLEN)
+      *p++ = '/';
+    for (q = name; *q != 0; p++, q++)
+      if (p < fullname + MAXPATHLEN) *p = *q;
+    *p = 0;
+    if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) break;
+    if (*path == 0) return name;
+    path++;
+  }
+  return fullname;
+}
+
+#else
+
+/* Special version for Cygwin32: takes care of the ".exe" implicit suffix */
+
+static int file_ok(char * name)
+{
+  int fd;
+  /* Cannot use stat() here because it adds ".exe" implicitly */
+  fd = open(name, O_RDONLY);
+  if (fd == -1) return 0;
+  close(fd);
+  return 1;
+}
+
+static char * searchpath(char * name)
+{
+  char * path, * fullname, * p;
+
+  path = getenv("PATH");
+  fullname = malloc(strlen(name) + (path == NULL ? 0 : strlen(path)) + 6);
+  /* 6 = "/" plus ".exe" plus final "\0" */
+  if (fullname == NULL) return name;
+  /* Check for absolute path name */
+  for (p = name; *p != 0; p++) {
+    if (*p == '/' || *p == '\\') {
+      if (file_ok(name)) return name;
+      strcpy(fullname, name);
+      strcat(fullname, ".exe");
+      if (file_ok(fullname)) return fullname;
+      return name;
+    }
+  }
+  /* Search in path */
+  if (path == NULL) return name;
+  while(1) {
+    for (p = fullname; *path != 0 && *path != ':'; p++, path++) *p = *path;
+    if (p != fullname) *p++ = '/';
+    strcpy(p, name);
+    if (file_ok(fullname)) return fullname;
+    strcat(fullname, ".exe");
+    if (file_ok(fullname)) return fullname;
+    if (*path == 0) break;
+    path++;
+  }
+  return name;
+}
+
+#endif  
+
+static unsigned long read_size(char * ptr)
+{
+  unsigned char * p = (unsigned char *) ptr;
+  return ((unsigned long) p[0] << 24) + ((unsigned long) p[1] << 16) +
+         ((unsigned long) p[2] << 8) + p[3];
+}
+
+static char * read_runtime_path(int fd)
+{
+  char buffer[TRAILER_SIZE];
+  static char runtime_path[MAXPATHLEN];
+  int num_sections, i;
+  uint32 path_size;
+  long ofs;
+
+  lseek(fd, (long) -TRAILER_SIZE, SEEK_END);
+  if (read(fd, buffer, TRAILER_SIZE) < TRAILER_SIZE) return NULL;
+  num_sections = read_size(buffer);
+  ofs = TRAILER_SIZE + num_sections * 8;
+  lseek(fd, -ofs, SEEK_END);
+  path_size = 0;
+  for (i = 0; i < num_sections; i++) {
+    if (read(fd, buffer, 8) < 8) return NULL;
+    if (buffer[0] == 'R' && buffer[1] == 'N' &&
+        buffer[2] == 'T' && buffer[3] == 'M') {
+      path_size = read_size(buffer + 4);
+      ofs += path_size;
+    } else if (path_size > 0)
+      ofs += read_size(buffer + 4);
+  }
+  if (path_size == 0) return default_runtime_path;
+  if (path_size >= MAXPATHLEN) return NULL;
+  lseek(fd, -ofs, SEEK_END);
+  if (read(fd, runtime_path, path_size) != path_size) return NULL;
+  runtime_path[path_size - 1] = 0;
+  return runtime_path;
+}
+
+static void errwrite(char * msg)
+{
+  write(2, msg, strlen(msg));
+}
+
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
+
+int main(int argc, char ** argv)
+{
+  char * truename, * runtime_path;
+  int fd;
+
+  truename = searchpath(argv[0]);
+  fd = open(truename, O_RDONLY | O_BINARY);
+  if (fd == -1 || (runtime_path = read_runtime_path(fd)) == NULL) {
+    errwrite(truename);
+    errwrite(" not found or is not a bytecode executable file\n");
+    return 2;
+  }
+  argv[0] = truename;
+  execv(runtime_path, argv);
+  errwrite("Cannot exec ");
+  errwrite(runtime_path);
+  errwrite("\n");
+  return 2;
+}
diff --git a/stdlib/headernt.c b/stdlib/headernt.c
new file mode 100644
index 0000000000..4dee822821
--- /dev/null
+++ b/stdlib/headernt.c
@@ -0,0 +1,166 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1998 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#define STRICT
+#define WIN32_LEAN_AND_MEAN
+
+#include <windows.h>
+#include "../byterun/mlvalues.h"
+#include "../byterun/exec.h"
+
+#pragma comment(linker , "/entry:headerentry")
+#pragma comment(linker , "/subsystem:console")
+#pragma comment(lib , "kernel32")
+
+char * default_runtime_name = "ocamlrun";
+
+static
+#if _MSC_VER >= 1200
+__forceinline
+#else
+__inline
+#endif
+unsigned long read_size(const char * const ptr)
+{
+  const unsigned char * const p = (const unsigned char * const) ptr;
+  return ((unsigned long) p[0] << 24) | ((unsigned long) p[1] << 16) |
+         ((unsigned long) p[2] << 8) | p[3];
+}
+
+static __inline char * read_runtime_path(HANDLE h)
+{
+  char buffer[TRAILER_SIZE];
+  static char runtime_path[MAX_PATH];
+  DWORD nread;
+  int num_sections, path_size, i;
+  long ofs;
+
+  if (SetFilePointer(h, -TRAILER_SIZE, NULL, FILE_END) == -1) return NULL;
+  if (! ReadFile(h, buffer, TRAILER_SIZE, &nread, NULL)) return NULL;
+  if (nread != TRAILER_SIZE) return NULL;
+  num_sections = read_size(buffer);
+  ofs = TRAILER_SIZE + num_sections * 8;
+  if (SetFilePointer(h, - ofs, NULL, FILE_END) == -1) return NULL;
+  path_size = 0;
+  for (i = 0; i < num_sections; i++) {
+    if (! ReadFile(h, buffer, 8, &nread, NULL) || nread != 8) return NULL;
+    if (buffer[0] == 'R' && buffer[1] == 'N' &&
+        buffer[2] == 'T' && buffer[3] == 'M') {
+      path_size = read_size(buffer + 4);
+      ofs += path_size;
+    } else if (path_size > 0)
+      ofs += read_size(buffer + 4);
+  }
+  if (path_size == 0) return default_runtime_name;
+  if (path_size >= MAX_PATH) return NULL;
+  if (SetFilePointer(h, -ofs, NULL, FILE_END) == -1) return NULL;
+  if (! ReadFile(h, runtime_path, path_size, &nread, NULL)) return NULL;
+  if (nread != path_size) return NULL;
+  runtime_path[path_size - 1] = 0;
+  return runtime_path;
+}
+
+static BOOL WINAPI ctrl_handler(DWORD event)
+{
+  if (event == CTRL_C_EVENT || event == CTRL_BREAK_EVENT)
+    return TRUE;		/* pretend we've handled them */
+  else
+    return FALSE;
+}
+
+#define msg_and_length(msg) msg , (sizeof(msg) - 1)
+
+static __inline void __declspec(noreturn) run_runtime(char * runtime,
+         char * const cmdline)
+{
+  char path[MAX_PATH];
+  STARTUPINFO stinfo;
+  PROCESS_INFORMATION procinfo;
+  DWORD retcode;
+  if (SearchPath(NULL, runtime, ".exe", MAX_PATH, path, &runtime) == 0) {
+    HANDLE errh;
+    DWORD numwritten;
+    errh = GetStdHandle(STD_ERROR_HANDLE);
+    WriteFile(errh, msg_and_length("Cannot exec "), &numwritten, NULL);
+    WriteFile(errh, runtime, strlen(runtime), &numwritten, NULL);
+    WriteFile(errh, msg_and_length("\r\n"), &numwritten, NULL);
+    ExitProcess(2);
+#if _MSC_VER >= 1200
+    __assume(0); /* Not reached */
+#endif
+  }
+  /* Need to ignore ctrl-C and ctrl-break, otherwise we'll die and take
+     the underlying OCaml program with us! */
+  SetConsoleCtrlHandler(ctrl_handler, TRUE);
+
+  stinfo.cb = sizeof(stinfo);
+  stinfo.lpReserved = NULL;
+  stinfo.lpDesktop = NULL;
+  stinfo.lpTitle = NULL;
+  stinfo.dwFlags = 0;
+  stinfo.cbReserved2 = 0;
+  stinfo.lpReserved2 = NULL;
+  if (!CreateProcess(path, cmdline, NULL, NULL, TRUE, 0, NULL, NULL,
+                     &stinfo, &procinfo)) {
+    HANDLE errh;
+    DWORD numwritten;
+    errh = GetStdHandle(STD_ERROR_HANDLE);
+    WriteFile(errh, msg_and_length("Cannot exec "), &numwritten, NULL);
+    WriteFile(errh, runtime, strlen(runtime), &numwritten, NULL);
+    WriteFile(errh, msg_and_length("\r\n"), &numwritten, NULL);
+    ExitProcess(2);
+#if _MSC_VER >= 1200
+    __assume(0); /* Not reached */
+#endif
+  }
+  CloseHandle(procinfo.hThread);
+  WaitForSingleObject(procinfo.hProcess , INFINITE);
+  GetExitCodeProcess(procinfo.hProcess , &retcode);
+  CloseHandle(procinfo.hProcess);
+  ExitProcess(retcode);
+#if _MSC_VER >= 1200
+    __assume(0); /* Not reached */
+#endif
+}
+
+void __declspec(noreturn) __cdecl headerentry()
+{
+  char truename[MAX_PATH];
+  char * cmdline = GetCommandLine();
+  char * runtime_path;
+  HANDLE h;
+
+  GetModuleFileName(NULL, truename, sizeof(truename));
+  h = CreateFile(truename, GENERIC_READ, FILE_SHARE_READ | FILE_SHARE_WRITE,
+                 NULL, OPEN_EXISTING, 0, NULL);
+  if (h == INVALID_HANDLE_VALUE ||
+      (runtime_path = read_runtime_path(h)) == NULL) {
+    HANDLE errh;
+    DWORD numwritten;
+    errh = GetStdHandle(STD_ERROR_HANDLE);
+    WriteFile(errh, truename, strlen(truename), &numwritten, NULL);
+    WriteFile(errh, msg_and_length(" not found or is not a bytecode executable file\r\n"),
+              &numwritten, NULL);
+    ExitProcess(2);
+#if _MSC_VER >= 1200
+    __assume(0); /* Not reached */
+#endif
+  }
+  CloseHandle(h);
+  run_runtime(runtime_path , cmdline);
+#if _MSC_VER >= 1200
+    __assume(0); /* Not reached */
+#endif
+}
diff --git a/stdlib/int32.ml b/stdlib/int32.ml
new file mode 100644
index 0000000000..363a1b3081
--- /dev/null
+++ b/stdlib/int32.ml
@@ -0,0 +1,48 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Module [Int32]: 32-bit integers *)
+
+external neg : int32 -> int32 = "%int32_neg"
+external add : int32 -> int32 -> int32 = "%int32_add"
+external sub : int32 -> int32 -> int32 = "%int32_sub"
+external mul : int32 -> int32 -> int32 = "%int32_mul"
+external div : int32 -> int32 -> int32 = "%int32_div"
+external rem : int32 -> int32 -> int32 = "%int32_mod"
+external logand : int32 -> int32 -> int32 = "%int32_and"
+external logor : int32 -> int32 -> int32 = "%int32_or"
+external logxor : int32 -> int32 -> int32 = "%int32_xor"
+external shift_left : int32 -> int -> int32 = "%int32_lsl"
+external shift_right : int32 -> int -> int32 = "%int32_asr"
+external shift_right_logical : int32 -> int -> int32 = "%int32_lsr"
+external of_int : int -> int32 = "%int32_of_int"
+external to_int : int32 -> int = "%int32_to_int"
+external of_float : float -> int32 = "int32_of_float"
+external to_float : int32 -> float = "int32_to_float"
+
+let zero = of_int 0
+let one = of_int 1
+let minus_one = of_int (-1)
+let succ n = add n one
+let pred n = sub n one
+let abs n = if n >= zero then n else neg n
+let min_int = shift_left one 31
+let max_int = sub min_int one
+let lognot n = logxor n minus_one
+
+external format : string -> int32 -> string = "int32_format"
+let to_string n = format "%d" n
+
+external of_string : string -> int32 = "int32_of_string"
diff --git a/stdlib/int32.mli b/stdlib/int32.mli
new file mode 100644
index 0000000000..4a01dd7d76
--- /dev/null
+++ b/stdlib/int32.mli
@@ -0,0 +1,144 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** 32-bit integers.
+
+   This module provides operations on the type [int32]
+   of signed 32-bit integers.  Unlike the built-in [int] type,
+   the type [int32] is guaranteed to be exactly 32-bit wide on all
+   platforms.  All arithmetic operations over [int32] are taken
+   modulo 2{^32}.
+
+   Performance notice: values of type [int32] occupy more memory
+   space than values of type [int], and arithmetic operations on
+   [int32] are generally slower than those on [int].  Use [int32]
+   only when the application requires exact 32-bit arithmetic. *)
+
+val zero : int32
+(** The 32-bit integer 0. *)
+
+val one : int32
+(** The 32-bit integer 1. *)
+
+val minus_one : int32
+(** The 32-bit integer -1. *)
+
+external neg : int32 -> int32 = "%int32_neg"
+(** Unary negation. *)
+
+external add : int32 -> int32 -> int32 = "%int32_add"
+(** Addition. *)
+
+external sub : int32 -> int32 -> int32 = "%int32_sub"
+(** Subtraction. *)
+
+external mul : int32 -> int32 -> int32 = "%int32_mul"
+(** Multiplication. *)
+
+external div : int32 -> int32 -> int32 = "%int32_div"
+(** Integer division.  Raise [Division_by_zero] if the second 
+   argument is zero. *)
+
+external rem : int32 -> int32 -> int32 = "%int32_mod"
+(** Integer remainder.  If [x >= 0] and [y > 0], the result
+   of [Int32.rem x y] satisfies the following properties:
+   [0 <= Int32.rem x y < y] and
+   [x = Int32.add (Int32.mul (Int32.div x y) y) (Int32.rem x y)].
+   If [y = 0], [Int32.rem x y] raises [Division_by_zero].
+   If [x < 0] or [y < 0], the result of [Int32.rem x y] is
+   not specified and depends on the platform. *)
+
+val succ : int32 -> int32
+(** Successor.  [Int32.succ x] is [Int32.add x Int32.one]. *)
+
+val pred : int32 -> int32
+(** Predecessor.  [Int32.pred x] is [Int32.sub x Int32.one]. *)
+
+val abs : int32 -> int32
+(** Return the absolute value of its argument. *)
+
+val max_int : int32
+(** The greatest representable 32-bit integer, 2{^31} - 1. *)
+
+val min_int : int32
+(** The smallest representable 32-bit integer, -2{^31}. *)
+
+
+external logand : int32 -> int32 -> int32 = "%int32_and"
+(** Bitwise logical and. *)
+
+external logor : int32 -> int32 -> int32 = "%int32_or"
+(** Bitwise logical or. *)
+
+external logxor : int32 -> int32 -> int32 = "%int32_xor"
+(** Bitwise logical exclusive or. *)
+
+val lognot : int32 -> int32
+(** Bitwise logical negation *)
+
+external shift_left : int32 -> int -> int32 = "%int32_lsl"
+(** [Int32.shift_left x y] shifts [x] to the left by [y] bits.
+   The result is unspecified if [y < 0] or [y >= 32]. *)
+
+external shift_right : int32 -> int -> int32 = "%int32_asr"
+(** [Int32.shift_right x y] shifts [x] to the right by [y] bits.
+   This is an arithmetic shift: the sign bit of [x] is replicated
+   and inserted in the vacated bits.
+   The result is unspecified if [y < 0] or [y >= 32]. *)
+
+external shift_right_logical : int32 -> int -> int32 = "%int32_lsr"
+(** [Int32.shift_right_logical x y] shifts [x] to the right by [y] bits.
+   This is a logical shift: zeroes are inserted in the vacated bits
+   regardless of the sign of [x].
+   The result is unspecified if [y < 0] or [y >= 32]. *)
+
+external of_int : int -> int32 = "%int32_of_int"
+(** Convert the given integer (type [int]) to a 32-bit integer (type [int32]). *)
+
+external to_int : int32 -> int = "%int32_to_int"
+(** Convert the given 32-bit integer (type [int32]) to an
+   integer (type [int]).  On 32-bit platforms, the 32-bit integer
+   is taken modulo 2{^31}, i.e. the high-order bit is lost
+   during the conversion.  On 64-bit platforms, the conversion
+   is exact. *)
+
+external of_float : float -> int32 = "int32_of_float"
+(** Convert the given floating-point number to a 32-bit integer,
+   discarding the fractional part (truncate towards 0).
+   The result of the conversion is undefined if, after truncation,
+   the number is outside the range \[{!Int32.min_int}, {!Int32.max_int}\]. *)
+
+external to_float : int32 -> float = "int32_to_float"
+(** Convert the given 32-bit integer to a floating-point number. *)
+
+external of_string : string -> int32 = "int32_of_string"
+(** Convert the given string to a 32-bit integer.
+   The string is read in decimal (by default) or in hexadecimal,
+   octal or binary if the string begins with [0x], [0o] or [0b]
+   respectively.
+   Raise [Failure "int_of_string"] if the given string is not
+   a valid representation of an integer. *)
+
+val to_string : int32 -> string
+(** Return the string representation of its argument, in signed decimal. *)
+
+external format : string -> int32 -> string = "int32_format"
+(** [Int32.format fmt n] return the string representation of the
+   32-bit integer [n] in the format specified by [fmt].
+   [fmt] is a [Printf]-style format containing exactly
+   one [%d], [%i], [%u], [%x], [%X] or [%o] conversion specification.
+   This function is deprecated; use {!Printf.sprintf} with a [%lx] format
+   instead. *)
+
diff --git a/stdlib/int64.ml b/stdlib/int64.ml
new file mode 100644
index 0000000000..09f72d8304
--- /dev/null
+++ b/stdlib/int64.ml
@@ -0,0 +1,57 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Module [Int64]: 64-bit integers *)
+
+external neg : int64 -> int64 = "%int64_neg"
+external add : int64 -> int64 -> int64 = "%int64_add"
+external sub : int64 -> int64 -> int64 = "%int64_sub"
+external mul : int64 -> int64 -> int64 = "%int64_mul"
+external div : int64 -> int64 -> int64 = "%int64_div"
+external rem : int64 -> int64 -> int64 = "%int64_mod"
+external logand : int64 -> int64 -> int64 = "%int64_and"
+external logor : int64 -> int64 -> int64 = "%int64_or"
+external logxor : int64 -> int64 -> int64 = "%int64_xor"
+external shift_left : int64 -> int -> int64 = "%int64_lsl"
+external shift_right : int64 -> int -> int64 = "%int64_asr"
+external shift_right_logical : int64 -> int -> int64 = "%int64_lsr"
+external of_int : int -> int64 = "%int64_of_int"
+external to_int : int64 -> int = "%int64_to_int"
+external of_float : float -> int64 = "int64_of_float"
+external to_float : int64 -> float = "int64_to_float"
+external of_int32 : int32 -> int64 = "%int64_of_int32"
+external to_int32 : int64 -> int32 = "%int64_to_int32"
+external of_nativeint : nativeint -> int64 = "%int64_of_nativeint"
+external to_nativeint : int64 -> nativeint = "%int64_to_nativeint"
+
+let zero = try of_int 0 with Invalid_argument _ -> Obj.magic Int32.zero
+let one = try of_int 1 with Invalid_argument _ -> Obj.magic Int32.one
+let minus_one = try of_int (-1) with Invalid_argument _ -> Obj.magic Int32.minus_one
+let succ n = add n one
+let pred n = sub n one
+let abs n = if n >= zero then n else neg n
+let min_int =
+  try shift_left one 63 with Invalid_argument _ -> Obj.magic Int32.min_int
+let max_int =
+  try sub min_int one with Invalid_argument _ -> Obj.magic Int32.max_int
+let lognot n = logxor n minus_one
+
+external format : string -> int64 -> string = "int64_format"
+let to_string n = format "%d" n
+
+external of_string : string -> int64 = "int64_of_string"
+
+external bits_of_float : float -> int64 = "int64_bits_of_float"
+external float_of_bits : int64 -> float = "int64_float_of_bits"
diff --git a/stdlib/int64.mli b/stdlib/int64.mli
new file mode 100644
index 0000000000..0478d375bc
--- /dev/null
+++ b/stdlib/int64.mli
@@ -0,0 +1,183 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** 64-bit integers.
+
+   This module provides operations on the type [int64] of
+   signed 64-bit integers.  Unlike the built-in [int] type,
+   the type [int64] is guaranteed to be exactly 64-bit wide on all
+   platforms.  All arithmetic operations over [int64] are taken
+   modulo 2{^64} 
+
+   The type [int64] is supported on all 64-bit platforms, as well as
+   on all 32-bit platforms for which the C compiler supports 64-bit
+   arithmetic.  On 32-bit platforms without support for 64-bit arithmetic,
+   all functions in this module raise an [Invalid_argument] exception.
+
+   Performance notice: values of type [int64] occupy more memory
+   space than values of type [int], and arithmetic operations on
+   [int64] are generally slower than those on [int].  Use [int64]
+   only when the application requires exact 64-bit arithmetic. 
+*)
+
+val zero : int64
+(** The 64-bit integer 0. *)
+
+val one : int64
+(** The 64-bit integer 1. *)
+
+val minus_one : int64
+(** The 64-bit integer -1. *)
+
+external neg : int64 -> int64 = "%int64_neg"
+(** Unary negation. *)
+
+external add : int64 -> int64 -> int64 = "%int64_add"
+(** Addition. *)
+
+external sub : int64 -> int64 -> int64 = "%int64_sub"
+(** Subtraction. *)
+
+external mul : int64 -> int64 -> int64 = "%int64_mul"
+(** Multiplication. *)
+
+external div : int64 -> int64 -> int64 = "%int64_div"
+(** Integer division.  Raise [Division_by_zero] if the second 
+   argument is zero. *)
+
+external rem : int64 -> int64 -> int64 = "%int64_mod"
+(** Integer remainder.  If [x >= 0] and [y > 0], the result
+   of [Int64.rem x y] satisfies the following properties:
+   [0 <= Int64.rem x y < y] and
+   [x = Int64.add (Int64.mul (Int64.div x y) y) (Int64.rem x y)].
+   If [y = 0], [Int64.rem x y] raises [Division_by_zero].
+   If [x < 0] or [y < 0], the result of [Int64.rem x y] is
+   not specified and depends on the platform. *)
+
+val succ : int64 -> int64
+(** Successor.  [Int64.succ x] is [Int64.add x Int64.one]. *)
+
+val pred : int64 -> int64
+(** Predecessor.  [Int64.pred x] is [Int64.sub x Int64.one]. *)
+
+val abs : int64 -> int64
+(** Return the absolute value of its argument. *)
+
+val max_int : int64
+(** The greatest representable 64-bit integer, 2{^63} - 1. *)
+
+val min_int : int64
+(** The smallest representable 64-bit integer, -2{^63}. *)
+
+external logand : int64 -> int64 -> int64 = "%int64_and"
+(** Bitwise logical and. *)
+
+external logor : int64 -> int64 -> int64 = "%int64_or"
+(** Bitwise logical or. *)
+
+external logxor : int64 -> int64 -> int64 = "%int64_xor"
+(** Bitwise logical exclusive or. *)
+
+val lognot : int64 -> int64
+(** Bitwise logical negation *)
+
+external shift_left : int64 -> int -> int64 = "%int64_lsl"
+(** [Int64.shift_left x y] shifts [x] to the left by [y] bits.
+   The result is unspecified if [y < 0] or [y >= 64]. *)
+
+external shift_right : int64 -> int -> int64 = "%int64_asr"
+(** [Int64.shift_right x y] shifts [x] to the right by [y] bits.
+   This is an arithmetic shift: the sign bit of [x] is replicated
+   and inserted in the vacated bits.
+   The result is unspecified if [y < 0] or [y >= 64]. *)
+
+external shift_right_logical : int64 -> int -> int64 = "%int64_lsr"
+(** [Int64.shift_right_logical x y] shifts [x] to the right by [y] bits.
+   This is a logical shift: zeroes are inserted in the vacated bits
+   regardless of the sign of [x].
+   The result is unspecified if [y < 0] or [y >= 64]. *)
+
+external of_int : int -> int64 = "%int64_of_int"
+(** Convert the given integer (type [int]) to a 64-bit integer (type [int64]). *)
+
+external to_int : int64 -> int = "%int64_to_int"
+(** Convert the given 64-bit integer (type [int64]) to an
+   integer (type [int]).  On 64-bit platforms, the 64-bit integer
+   is taken modulo 2{^63}, i.e. the high-order bit is lost
+   during the conversion.  On 32-bit platforms, the 64-bit integer
+   is taken modulo 2{^31}, i.e. the top 33 bits are lost
+   during the conversion. *)
+
+external of_float : float -> int64 = "int64_of_float"
+(** Convert the given floating-point number to a 64-bit integer,
+   discarding the fractional part (truncate towards 0).
+   The result of the conversion is undefined if, after truncation,
+   the number is outside the range \[{!Int64.min_int}, {!Int64.max_int}\]. *)
+
+external to_float : int64 -> float = "int64_to_float"
+(** Convert the given 64-bit integer to a floating-point number. *)
+
+
+external of_int32 : int32 -> int64 = "%int64_of_int32"
+(** Convert the given 32-bit integer (type [int32])
+   to a 64-bit integer (type [int64]). *)
+
+external to_int32 : int64 -> int32 = "%int64_to_int32"
+(** Convert the given 64-bit integer (type [int64]) to a
+   32-bit integer (type [int32]). The 64-bit integer
+   is taken modulo 2{^32}, i.e. the top 32 bits are lost
+   during the conversion.  *)
+
+external of_nativeint : nativeint -> int64 = "%int64_of_nativeint"
+(** Convert the given native integer (type [nativeint])
+   to a 64-bit integer (type [int64]). *)
+
+external to_nativeint : int64 -> nativeint = "%int64_to_nativeint"
+(** Convert the given 64-bit integer (type [int64]) to a
+   native integer.  On 32-bit platforms, the 64-bit integer
+   is taken modulo 2{^32}.  On 64-bit platforms,
+   the conversion is exact. *)
+
+external of_string : string -> int64 = "int64_of_string"
+(** Convert the given string to a 64-bit integer.
+   The string is read in decimal (by default) or in hexadecimal,
+   octal or binary if the string begins with [0x], [0o] or [0b]
+   respectively.
+   Raise [Failure "int_of_string"] if the given string is not
+   a valid representation of an integer. *)
+
+val to_string : int64 -> string
+(** Return the string representation of its argument, in decimal. *)
+
+external format : string -> int64 -> string = "int64_format"
+(** [Int64.format fmt n] return the string representation of the
+   64-bit integer [n] in the format specified by [fmt].
+   [fmt] is a {!Printf}-style format containing exactly
+   one [%d], [%i], [%u], [%x], [%X] or [%o] conversion specification.
+   This function is deprecated; use {!Printf.sprintf} with a [%Lx] format
+   instead. *)
+
+external bits_of_float : float -> int64 = "int64_bits_of_float"
+(** Return the internal representation of the given float according
+   to the IEEE 754 floating-point ``double format'' bit layout.
+   Bit 63 of the result represents the sign of the float;
+   bits 62 to 52 represent the (biased) exponent; bits 51 to 0
+   represent the mantissa. *)
+
+external float_of_bits : int64 -> float = "int64_float_of_bits"
+(** Return the floating-point number whose internal representation,
+   according to the IEEE 754 floating-point ``double format'' bit layout,
+   is the given [int64]. *)
+
diff --git a/stdlib/lexing.ml b/stdlib/lexing.ml
new file mode 100644
index 0000000000..53ea7ba4cf
--- /dev/null
+++ b/stdlib/lexing.ml
@@ -0,0 +1,106 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* The run-time library for lexers generated by camllex *)
+
+type lexbuf =
+  { refill_buff : lexbuf -> unit;
+    mutable lex_buffer : string;
+    mutable lex_buffer_len : int;
+    mutable lex_abs_pos : int;
+    mutable lex_start_pos : int;
+    mutable lex_curr_pos : int;
+    mutable lex_last_pos : int;
+    mutable lex_last_action : int;
+    mutable lex_eof_reached : bool }
+
+type lex_tables =
+  { lex_base: string;
+    lex_backtrk: string;
+    lex_default: string;
+    lex_trans: string;
+    lex_check: string }
+
+external engine: lex_tables -> int -> lexbuf -> int = "lex_engine"
+
+let lex_refill read_fun aux_buffer lexbuf =
+  let read =
+    read_fun aux_buffer (String.length aux_buffer) in
+  let n =
+    if read > 0
+    then read
+    else (lexbuf.lex_eof_reached <- true; 0) in
+  if lexbuf.lex_start_pos < n then begin
+    let oldlen = lexbuf.lex_buffer_len in
+    let newlen = oldlen * 2 in
+    let newbuf = String.create newlen in
+    String.unsafe_blit lexbuf.lex_buffer 0 newbuf oldlen oldlen;
+    lexbuf.lex_buffer <- newbuf;
+    lexbuf.lex_buffer_len <- newlen;
+    lexbuf.lex_abs_pos <- lexbuf.lex_abs_pos - oldlen;
+    lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos + oldlen;
+    lexbuf.lex_start_pos <- lexbuf.lex_start_pos + oldlen;
+    lexbuf.lex_last_pos <- lexbuf.lex_last_pos + oldlen
+  end;
+  String.unsafe_blit lexbuf.lex_buffer n
+                     lexbuf.lex_buffer 0 
+                     (lexbuf.lex_buffer_len - n);
+  String.unsafe_blit aux_buffer 0
+                     lexbuf.lex_buffer (lexbuf.lex_buffer_len - n)
+                     n;
+  lexbuf.lex_abs_pos <- lexbuf.lex_abs_pos + n;
+  lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos - n;
+  lexbuf.lex_start_pos <- lexbuf.lex_start_pos - n;
+  lexbuf.lex_last_pos <- lexbuf.lex_last_pos - n
+
+let from_function f =
+  { refill_buff = lex_refill f (String.create 512);
+    lex_buffer = String.create 1024;
+    lex_buffer_len = 1024;
+    lex_abs_pos = - 1024;
+    lex_start_pos = 1024;
+    lex_curr_pos = 1024;
+    lex_last_pos = 1024;
+    lex_last_action = 0;
+    lex_eof_reached = false }
+
+let from_channel ic =
+  from_function (fun buf n -> input ic buf 0 n)
+
+let from_string s =
+  { refill_buff = (fun lexbuf -> lexbuf.lex_eof_reached <- true);
+    lex_buffer = s ^ "";
+    lex_buffer_len = String.length s;
+    lex_abs_pos = 0;
+    lex_start_pos = 0;
+    lex_curr_pos = 0;
+    lex_last_pos = 0;
+    lex_last_action = 0;
+    lex_eof_reached = true }
+
+let lexeme lexbuf =
+  let len = lexbuf.lex_curr_pos - lexbuf.lex_start_pos in
+  let s = String.create len in
+  String.unsafe_blit lexbuf.lex_buffer lexbuf.lex_start_pos s 0 len;
+  s
+
+let lexeme_char lexbuf i =
+  String.get lexbuf.lex_buffer (lexbuf.lex_start_pos + i)
+
+let lexeme_start lexbuf =
+  lexbuf.lex_abs_pos + lexbuf.lex_start_pos
+and lexeme_end lexbuf =
+  lexbuf.lex_abs_pos + lexbuf.lex_curr_pos
+
diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli
new file mode 100644
index 0000000000..e8fc975310
--- /dev/null
+++ b/stdlib/lexing.mli
@@ -0,0 +1,100 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** The run-time library for lexers generated by [ocamllex]. *)
+
+(** {6 Lexer buffers} *)
+
+
+type lexbuf =
+  { refill_buff : lexbuf -> unit;
+    mutable lex_buffer : string;
+    mutable lex_buffer_len : int;
+    mutable lex_abs_pos : int;
+    mutable lex_start_pos : int;
+    mutable lex_curr_pos : int;
+    mutable lex_last_pos : int;
+    mutable lex_last_action : int;
+    mutable lex_eof_reached : bool }
+(** The type of lexer buffers. A lexer buffer is the argument passed
+   to the scanning functions defined by the generated scanners.
+   The lexer buffer holds the current state of the scanner, plus
+   a function to refill the buffer from the input. *)
+
+val from_channel : in_channel -> lexbuf
+(** Create a lexer buffer on the given input channel.
+   [Lexing.from_channel inchan] returns a lexer buffer which reads
+   from the input channel [inchan], at the current reading position. *)
+
+val from_string : string -> lexbuf
+(** Create a lexer buffer which reads from
+   the given string. Reading starts from the first character in
+   the string. An end-of-input condition is generated when the
+   end of the string is reached. *)
+
+val from_function : (string -> int -> int) -> lexbuf
+(** Create a lexer buffer with the given function as its reading method.
+   When the scanner needs more characters, it will call the given
+   function, giving it a character string [s] and a character
+   count [n]. The function should put [n] characters or less in [s],
+   starting at character number 0, and return the number of characters
+   provided. A return value of 0 means end of input. *)
+
+
+(** {6 Functions for lexer semantic actions} *)
+
+
+(** The following functions can be called from the semantic actions
+   of lexer definitions (the ML code enclosed in braces that
+   computes the value returned by lexing functions). They give
+   access to the character string matched by the regular expression
+   associated with the semantic action. These functions must be
+   applied to the argument [lexbuf], which, in the code generated by
+   [ocamllex], is bound to the lexer buffer passed to the parsing
+   function. *)
+
+val lexeme : lexbuf -> string
+(** [Lexing.lexeme lexbuf] returns the string matched by
+           the regular expression. *)
+
+val lexeme_char : lexbuf -> int -> char
+(** [Lexing.lexeme_char lexbuf i] returns character number [i] in
+   the matched string. *)
+
+val lexeme_start : lexbuf -> int
+(** [Lexing.lexeme_start lexbuf] returns the position in the
+   input stream of the first character of the matched string.
+   The first character of the stream has position 0. *)
+
+val lexeme_end : lexbuf -> int
+(** [Lexing.lexeme_end lexbuf] returns the position in the input stream
+   of the character following the last character of the matched
+   string. The first character of the stream has position 0. *)
+
+(**/**)
+
+(** {6  } *)
+
+(** The following definitions are used by the generated scanners only.
+   They are not intended to be used by user programs. *)
+
+type lex_tables =
+  { lex_base : string;
+    lex_backtrk : string;
+    lex_default : string;
+    lex_trans : string;
+    lex_check : string }
+
+external engine : lex_tables -> int -> lexbuf -> int = "lex_engine"
diff --git a/stdlib/list.ml b/stdlib/list.ml
new file mode 100644
index 0000000000..a6aeceef57
--- /dev/null
+++ b/stdlib/list.ml
@@ -0,0 +1,221 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* List operations *)
+
+let rec length_aux len = function
+    [] -> len
+  | a::l -> length_aux (len + 1) l
+
+let length l = length_aux 0 l
+
+let hd = function
+    [] -> failwith "hd"
+  | a::l -> a
+
+let tl = function
+    [] -> failwith "tl"
+  | a::l -> l
+
+let rec nth l n =
+  match l with
+    [] -> failwith "nth"
+  | a::l ->
+      if n = 0 then a else
+      if n > 0 then nth l (n-1) else
+      invalid_arg "List.nth"
+
+let append = (@)
+
+let rec rev_append l1 l2 =
+  match l1 with
+    [] -> l2
+  | a :: l -> rev_append l (a :: l2)
+
+let rev l = rev_append l []
+
+let rec flatten = function
+    [] -> []
+  | l::r -> l @ flatten r
+
+let concat = flatten
+
+let rec map f = function
+    [] -> []
+  | a::l -> let r = f a in r :: map f l
+
+let rev_map f l =
+  let rec rmap_f accu = function
+    | [] -> accu
+    | a::l -> rmap_f (f a :: accu) l
+  in
+  rmap_f [] l
+;;
+
+let rec iter f = function
+    [] -> ()
+  | a::l -> f a; iter f l
+
+let rec fold_left f accu l =
+  match l with
+    [] -> accu
+  | a::l -> fold_left f (f accu a) l
+
+let rec fold_right f l accu =
+  match l with
+    [] -> accu
+  | a::l -> f a (fold_right f l accu)
+
+let rec map2 f l1 l2 =
+  match (l1, l2) with
+    ([], []) -> []
+  | (a1::l1, a2::l2) -> let r = f a1 a2 in r :: map2 f l1 l2
+  | (_, _) -> invalid_arg "List.map2"
+
+let rev_map2 f l1 l2 =
+  let rec rmap2_f accu l1 l2 =
+    match (l1, l2) with
+    | ([], []) -> accu
+    | (a1::l1, a2::l2) -> rmap2_f (f a1 a2 :: accu) l1 l2
+    | (_, _) -> invalid_arg "List.rev_map2"
+  in
+  rmap2_f [] l1 l2
+;;
+
+let rec iter2 f l1 l2 =
+  match (l1, l2) with
+    ([], []) -> ()
+  | (a1::l1, a2::l2) -> f a1 a2; iter2 f l1 l2
+  | (_, _) -> invalid_arg "List.iter2"
+
+let rec fold_left2 f accu l1 l2 =
+  match (l1, l2) with
+    ([], []) -> accu
+  | (a1::l1, a2::l2) -> fold_left2 f (f accu a1 a2) l1 l2
+  | (_, _) -> invalid_arg "List.fold_left2"
+
+let rec fold_right2 f l1 l2 accu =
+  match (l1, l2) with
+    ([], []) -> accu
+  | (a1::l1, a2::l2) -> f a1 a2 (fold_right2 f l1 l2 accu)
+  | (_, _) -> invalid_arg "List.fold_right2"
+
+let rec for_all p = function
+    [] -> true
+  | a::l -> p a && for_all p l
+
+let rec exists p = function
+    [] -> false
+  | a::l -> p a || exists p l
+
+let rec for_all2 p l1 l2 =
+  match (l1, l2) with
+    ([], []) -> true
+  | (a1::l1, a2::l2) -> p a1 a2 && for_all2 p l1 l2
+  | (_, _) -> invalid_arg "List.for_all2"
+
+let rec exists2 p l1 l2 =
+  match (l1, l2) with
+    ([], []) -> false
+  | (a1::l1, a2::l2) -> p a1 a2 || exists2 p l1 l2
+  | (_, _) -> invalid_arg "List.exists2"
+
+let rec mem x = function
+    [] -> false
+  | a::l -> a = x || mem x l
+
+let rec memq x = function
+    [] -> false
+  | a::l -> a == x || memq x l
+
+let rec assoc x = function
+    [] -> raise Not_found
+  | (a,b)::l -> if a = x then b else assoc x l
+
+let rec assq x = function
+    [] -> raise Not_found
+  | (a,b)::l -> if a == x then b else assq x l
+
+let rec mem_assoc x = function
+  | [] -> false
+  | (a, b) :: l -> a = x || mem_assoc x l
+
+let rec mem_assq x = function
+  | [] -> false
+  | (a, b) :: l -> a == x || mem_assq x l
+
+let rec remove_assoc x = function
+  | [] -> []
+  | (a, b as pair) :: l -> if a = x then l else pair :: remove_assoc x l
+
+let rec remove_assq x = function
+  | [] -> []
+  | (a, b as pair) :: l -> if a == x then l else pair :: remove_assq x l
+
+let rec find p = function
+  | [] -> raise Not_found
+  | x :: l -> if p x then x else find p l
+
+let find_all p =
+  let rec find accu = function
+  | [] -> rev accu
+  | x :: l -> if p x then find (x :: accu) l else find accu l in
+  find []
+
+let filter = find_all
+
+let partition p l =
+  let rec part yes no = function
+  | [] -> (rev yes, rev no)
+  | x :: l -> if p x then part (x :: yes) no l else part yes (x :: no) l in
+  part [] [] l
+
+let rec split = function
+    [] -> ([], [])
+  | (x,y)::l ->
+      let (rx, ry) = split l in (x::rx, y::ry)
+
+let rec combine l1 l2 =
+  match (l1, l2) with
+    ([], []) -> []
+  | (a1::l1, a2::l2) -> (a1, a2) :: combine l1 l2
+  | (_, _) -> invalid_arg "List.combine"
+
+(** sorting *)
+
+external obj_truncate : 'a array -> int -> unit = "obj_truncate"
+
+let array_to_list_in_place a =
+  let l = Array.length a in
+  let rec loop accu n p =
+    if p <= 0 then accu else begin
+      if p = n then begin
+        obj_truncate a p;
+        loop (a.(p-1) :: accu) (n-1000) (p-1)
+      end else begin
+        loop (a.(p-1) :: accu) n (p-1)
+      end
+    end
+  in
+  loop [] (l-1000) l
+;;
+
+let stable_sort cmp l =
+  let a = Array.of_list l in
+  Array.stable_sort cmp a;
+  array_to_list_in_place a
+;;
+
+let sort = stable_sort;;
diff --git a/stdlib/listLabels.ml b/stdlib/listLabels.ml
new file mode 100644
index 0000000000..be7bddea36
--- /dev/null
+++ b/stdlib/listLabels.ml
@@ -0,0 +1,18 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*               Jacques Garrigue, Kyoto University RIMS               *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Module [ListLabels]: labelled List module *)
+
+include List
diff --git a/stdlib/listLabels.mli b/stdlib/listLabels.mli
new file mode 100644
index 0000000000..1f26c0c56d
--- /dev/null
+++ b/stdlib/listLabels.mli
@@ -0,0 +1,270 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+
+(** List operations.
+
+   Some functions are flagged as not tail-recursive.  A tail-recursive
+   function uses constant stack space, while a non-tail-recursive function
+   uses stack space proportional to the length of its list argument, which
+   can be a problem with very long lists.  When the function takes several
+   list arguments, an approximate formula giving stack usage (in some
+   unspecified constant unit) is shown in parentheses.
+
+   The above considerations can usually be ignored if your lists are not
+   longer than about 10000 elements.
+*)
+
+val length : 'a list -> int
+(** Return the length (number of elements) of the given list. *)
+
+val hd : 'a list -> 'a
+(** Return the first element of the given list. Raise
+   [Failure "hd"] if the list is empty. *)
+
+val tl : 'a list -> 'a list
+(** Return the given list without its first element. Raise
+   [Failure "tl"] if the list is empty. *)
+
+val nth : 'a list -> int -> 'a
+(** Return the n-th element of the given list.
+   The first element (head of the list) is at position 0.
+   Raise [Failure "nth"] if the list is too short. *)
+
+val rev : 'a list -> 'a list
+(** List reversal. *)
+
+val append : 'a list -> 'a list -> 'a list
+(** Catenate two lists.  Same function as the infix operator [@].
+   Not tail-recursive (length of the first argument).  The [@]
+   operator is not tail-recursive either. *)
+
+val rev_append : 'a list -> 'a list -> 'a list
+(** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2].
+   This is equivalent to {!ListLabels.rev}[ l1 @ l2], but [rev_append] is
+   tail-recursive and more efficient. *)
+
+val concat : 'a list list -> 'a list
+(** Concatenate a list of lists.  Not tail-recursive
+   (length of the argument + length of the longest sub-list). *)
+
+val flatten : 'a list list -> 'a list
+(** Flatten a list of lists.  Not tail-recursive
+   (length of the argument + length of the longest sub-list). *)
+
+
+(** {6 Iterators} *)
+
+
+val iter : f:('a -> unit) -> 'a list -> unit
+(** [List.iter f [a1; ...; an]] applies function [f] in turn to
+   [a1; ...; an]. It is equivalent to
+   [begin f a1; f a2; ...; f an; () end]. *)
+
+val map : f:('a -> 'b) -> 'a list -> 'b list
+(** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an],
+   and builds the list [[f a1; ...; f an]]
+   with the results returned by [f].  Not tail-recursive. *)
+
+val rev_map : f:('a -> 'b) -> 'a list -> 'b list
+(** [List.rev_map f l] gives the same result as
+   {!ListLabels.rev}[ (]{!ListLabels.map}[ f l)], but is tail-recursive and
+   more efficient. *)
+
+val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b list -> 'a
+(** [List.fold_left f a [b1; ...; bn]] is
+   [f (... (f (f a b1) b2) ...) bn]. *)
+
+val fold_right : f:('a -> 'b -> 'b) -> 'a list -> init:'b -> 'b
+(** [List.fold_right f [a1; ...; an] b] is
+   [f a1 (f a2 (... (f an b) ...))].  Not tail-recursive. *)
+
+
+(** {6 Iterators on two lists} *)
+
+
+val iter2 : f:('a -> 'b -> unit) -> 'a list -> 'b list -> unit
+(** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn
+   [f a1 b1; ...; f an bn].
+   Raise [Invalid_argument] if the two lists have
+   different lengths. *)
+
+val map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+(** [List.map2 f [a1; ...; an] [b1; ...; bn]] is
+   [[f a1 b1; ...; f an bn]].
+   Raise [Invalid_argument] if the two lists have
+   different lengths.  Not tail-recursive. *)
+
+val rev_map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+(** [List.rev_map2 f l] gives the same result as
+   {!ListLabels.rev}[ (]{!ListLabels.map2}[ f l)], but is tail-recursive and
+   more efficient. *)
+
+val fold_left2 :
+  f:('a -> 'b -> 'c -> 'a) -> init:'a -> 'b list -> 'c list -> 'a
+(** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is
+   [f (... (f (f a b1 c1) b2 c2) ...) bn cn].
+   Raise [Invalid_argument] if the two lists have
+   different lengths. *)
+
+val fold_right2 :
+  f:('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> init:'c -> 'c
+(** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is
+   [f a1 b1 (f a2 b2 (... (f an bn c) ...))].
+   Raise [Invalid_argument] if the two lists have
+   different lengths.  Not tail-recursive. *)
+
+
+
+
+(** {6 List scanning} *)
+
+
+val for_all : f:('a -> bool) -> 'a list -> bool
+(** [for_all p [a1; ...; an]] checks if all elements of the list
+   satisfy the predicate [p]. That is, it returns
+   [(p a1) && (p a2) && ... && (p an)]. *)
+
+val exists : f:('a -> bool) -> 'a list -> bool
+(** [exists p [a1; ...; an]] checks if at least one element of
+   the list satisfies the predicate [p]. That is, it returns
+   [(p a1) || (p a2) || ... || (p an)]. *)
+
+val for_all2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+(** Same as {!ListLabels.for_all}, but for a two-argument predicate.
+   Raise [Invalid_argument] if the two lists have
+   different lengths. *)
+
+val exists2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+(** Same as {!ListLabels.exists}, but for a two-argument predicate.
+   Raise [Invalid_argument] if the two lists have
+   different lengths. *)
+
+val mem : 'a -> set:'a list -> bool
+(** [mem a l] is true if and only if [a] is equal
+   to an element of [l]. *)
+
+val memq : 'a -> set:'a list -> bool
+(** Same as {!ListLabels.mem}, but uses physical equality instead of structural
+   equality to compare list elements. *)
+
+
+
+
+(** {6 List searching} *)
+
+
+val find : f:('a -> bool) -> 'a list -> 'a
+(** [find p l] returns the first element of the list [l]
+   that satisfies the predicate [p].
+   Raise [Not_found] if there is no value that satisfies [p] in the
+   list [l]. *)
+
+val filter : f:('a -> bool) -> 'a list -> 'a list
+(** [filter p l] returns all the elements of the list [l]
+   that satisfy the predicate [p].  The order of the elements
+   in the input list is preserved.  *)
+
+val find_all : f:('a -> bool) -> 'a list -> 'a list
+(** [find_all] is another name for {!ListLabels.filter}. *)
+
+val partition : f:('a -> bool) -> 'a list -> 'a list * 'a list
+(** [partition p l] returns a pair of lists [(l1, l2)], where
+   [l1] is the list of all the elements of [l] that
+   satisfy the predicate [p], and [l2] is the list of all the
+   elements of [l] that do not satisfy [p].
+   The order of the elements in the input list is preserved. *)
+
+
+
+
+(** {6 Association lists} *)
+
+
+val assoc : 'a -> ('a * 'b) list -> 'b
+(** [assoc a l] returns the value associated with key [a] in the list of
+   pairs [l]. That is,
+   [assoc a [ ...; (a,b); ...] = b]
+   if [(a,b)] is the leftmost binding of [a] in list [l].
+   Raise [Not_found] if there is no value associated with [a] in the
+   list [l]. *)
+
+val assq : 'a -> ('a * 'b) list -> 'b
+(** Same as {!ListLabels.assoc}, but uses physical equality instead of structural
+   equality to compare keys. *)
+
+val mem_assoc : 'a -> map:('a * 'b) list -> bool
+(** Same as {!ListLabels.assoc}, but simply return true if a binding exists,
+   and false if no bindings exist for the given key. *)
+
+val mem_assq : 'a -> map:('a * 'b) list -> bool
+(** Same as {!ListLabels.mem_assoc}, but uses physical equality instead of
+   structural equality to compare keys. *)
+
+val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list
+(** [remove_assoc a l] returns the list of
+   pairs [l] without the first pair with key [a], if any.
+   Not tail-recursive. *)
+
+val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
+(** Same as {!ListLabels.remove_assq}, but uses physical equality instead
+   of structural equality to compare keys.  Not tail-recursive. *)
+
+
+
+
+(** {6 Lists of pairs} *)
+
+
+val split : ('a * 'b) list -> 'a list * 'b list
+(** Transform a list of pairs into a pair of lists:
+   [split [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])].
+   Not tail-recursive.
+*)
+
+val combine : 'a list -> 'b list -> ('a * 'b) list
+(** Transform a pair of lists into a list of pairs:
+   [combine [a1; ...; an] [b1; ...; bn]] is
+   [[(a1,b1); ...; (an,bn)]].
+   Raise [Invalid_argument] if the two lists
+   have different lengths.  Not tail-recursive. *)
+
+
+
+(** {6 Sorting} *)
+
+
+val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
+(** Sort a list in increasing order according to a comparison
+   function.  The comparison function must return 0 if it arguments
+   compare as equal, a positive integer if the first is greater,
+   and a negative integer if the first is smaller.  For example,
+   the [compare] function is a suitable comparison function.
+   The resulting list is sorted in increasing order.
+   [List.sort] is guaranteed to run in constant heap space
+   (in addition to the size of the result list) and logarithmic
+   stack space.
+   
+   The current implementation uses Merge Sort and is the same as
+   {!ListLabels.stable_sort}.
+*)
+
+val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
+(** Same as {!ListLabels.sort}, but the sorting algorithm is stable.
+   
+   The current implementation is Merge Sort. It runs in constant
+   heap space and logarithmic stack space.
+*)
+
diff --git a/stdlib/map.ml b/stdlib/map.ml
new file mode 100644
index 0000000000..18b910a001
--- /dev/null
+++ b/stdlib/map.ml
@@ -0,0 +1,150 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+module type OrderedType =
+  sig
+    type t
+    val compare: t -> t -> int
+  end
+
+module type S =
+  sig
+    type key
+    type +'a t
+    val empty: 'a t
+    val add: key -> 'a -> 'a t -> 'a t
+    val find: key -> 'a t -> 'a
+    val remove: key -> 'a t -> 'a t
+    val mem:  key -> 'a t -> bool
+    val iter: (key -> 'a -> unit) -> 'a t -> unit
+    val map: ('a -> 'b) -> 'a t -> 'b t
+    val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t
+    val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  end
+
+module Make(Ord: OrderedType) = struct
+
+    type key = Ord.t
+
+    type 'a t =
+        Empty
+      | Node of 'a t * key * 'a * 'a t * int
+
+    let empty = Empty
+
+    let height = function
+        Empty -> 0
+      | Node(_,_,_,_,h) -> h
+
+    let create l x d r =
+      let hl = height l and hr = height r in
+      Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    let bal l x d r =
+      let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
+      let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
+      if hl > hr + 2 then begin
+        match l with
+          Empty -> invalid_arg "Map.bal"
+        | Node(ll, lv, ld, lr, _) ->
+            if height ll >= height lr then
+              create ll lv ld (create lr x d r)
+            else begin
+              match lr with
+                Empty -> invalid_arg "Map.bal"
+              | Node(lrl, lrv, lrd, lrr, _)->
+                  create (create ll lv ld lrl) lrv lrd (create lrr x d r)
+            end
+      end else if hr > hl + 2 then begin
+        match r with
+          Empty -> invalid_arg "Map.bal"
+        | Node(rl, rv, rd, rr, _) ->
+            if height rr >= height rl then
+              create (create l x d rl) rv rd rr
+            else begin
+              match rl with
+                Empty -> invalid_arg "Map.bal"
+              | Node(rll, rlv, rld, rlr, _) ->
+                  create (create l x d rll) rlv rld (create rlr rv rd rr)
+            end
+      end else
+        Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    let rec add x data = function
+        Empty ->
+          Node(Empty, x, data, Empty, 1)
+      | Node(l, v, d, r, h) as t ->
+          let c = Ord.compare x v in
+          if c = 0 then
+            Node(l, x, data, r, h)
+          else if c < 0 then
+            bal (add x data l) v d r
+          else
+            bal l v d (add x data r)
+
+    let rec find x = function
+        Empty ->
+          raise Not_found
+      | Node(l, v, d, r, _) ->
+          let c = Ord.compare x v in
+          if c = 0 then d
+          else find x (if c < 0 then l else r)
+
+    let rec mem x = function
+        Empty ->
+          false
+      | Node(l, v, d, r, _) ->
+          let c = Ord.compare x v in
+          c = 0 || mem x (if c < 0 then l else r)
+
+    let rec merge t1 t2 =
+      match (t1, t2) with
+        (Empty, t) -> t
+      | (t, Empty) -> t
+      | (Node(l1, v1, d1, r1, h1), Node(l2, v2, d2, r2, h2)) ->
+          bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2)
+
+    let rec remove x = function
+        Empty ->
+          Empty
+      | Node(l, v, d, r, h) as t ->
+          let c = Ord.compare x v in
+          if c = 0 then
+            merge l r
+          else if c < 0 then
+            bal (remove x l) v d r
+          else
+            bal l v d (remove x r)
+
+    let rec iter f = function
+        Empty -> ()
+      | Node(l, v, d, r, _) ->
+          iter f l; f v d; iter f r
+
+    let rec map f = function
+        Empty               -> Empty
+      | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h)
+
+    let rec mapi f = function
+        Empty               -> Empty
+      | Node(l, v, d, r, h) -> Node(mapi f l, v, f v d, mapi f r, h)
+
+    let rec fold f m accu =
+      match m with
+        Empty -> accu
+      | Node(l, v, d, r, _) ->
+          fold f l (f v d (fold f r accu))
+
+end
diff --git a/stdlib/map.mli b/stdlib/map.mli
new file mode 100644
index 0000000000..320db3f546
--- /dev/null
+++ b/stdlib/map.mli
@@ -0,0 +1,99 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Association tables over ordered types.
+
+   This module implements applicative association tables, also known as
+   finite maps or dictionaries, given a total ordering function
+   over the keys.
+   All operations over maps are purely applicative (no side-effects).
+   The implementation uses balanced binary trees, and therefore searching
+   and insertion take time logarithmic in the size of the map. 
+*)
+
+module type OrderedType = 
+  sig
+    type t
+      (** The type of the map keys. *)
+    val compare : t -> t -> int
+      (** A total ordering function over the keys.
+          This is a two-argument function [f] such that
+          [f e1 e2] is zero if the keys [e1] and [e2] are equal,
+          [f e1 e2] is strictly negative if [e1] is smaller than [e2],
+          and [f e1 e2] is strictly positive if [e1] is greater than [e2].
+          Example: a suitable ordering function is
+          the generic structural comparison function {!Pervasives.compare}. *)
+  end
+(** Input signature of the functor {!Map.Make}. *)
+
+module type S =
+  sig
+    type key
+    (** The type of the map keys. *)
+
+    type (+'a) t
+    (** The type of maps from type [key] to type ['a]. *)
+
+    val empty: 'a t
+    (** The empty map. *)
+
+    val add: key -> 'a -> 'a t -> 'a 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: key -> 'a t -> 'a
+    (** [find x m] returns the current binding of [x] in [m],
+       or raises [Not_found] if no such binding exists. *)
+
+    val remove: key -> 'a t -> 'a 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: key -> 'a t -> bool
+    (** [mem x m] returns [true] if [m] contains a binding for [x],
+       and [false] otherwise. *)
+
+    val iter: (key -> 'a -> unit) -> 'a 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: ('a -> 'b) -> 'a t -> 'b 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: (key -> 'a -> 'b) -> 'a t -> 'b t
+    (** Same as {!Map.S.map}, but the function receives as arguments both the
+       key and the associated value for each binding of the map. *)
+
+    val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    (** [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. *)
+  end
+(** Output signature of the functor {!Map.Make}. *)
+
+module Make (Ord : OrderedType) : S with type key = Ord.t
+(** Functor building an implementation of the map structure
+   given a totally ordered type. *)
+
diff --git a/stdlib/marshal.ml b/stdlib/marshal.ml
new file mode 100644
index 0000000000..e248c468d2
--- /dev/null
+++ b/stdlib/marshal.ml
@@ -0,0 +1,52 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+type extern_flags =
+    No_sharing
+  | Closures
+
+external to_channel: out_channel -> 'a -> extern_flags list -> unit
+    = "output_value"
+external to_string: 'a -> extern_flags list -> string
+    = "output_value_to_string"
+external to_buffer_unsafe:
+      string -> int -> int -> 'a -> extern_flags list -> int
+    = "output_value_to_buffer"
+
+let to_buffer buff ofs len v flags =
+  if ofs < 0 || len < 0 || ofs + len > String.length buff
+  then invalid_arg "Marshal.to_buffer: substring out of bounds"
+  else to_buffer_unsafe buff ofs len v flags
+
+external from_channel: in_channel -> 'a = "input_value"
+external from_string_unsafe: string -> int -> 'a = "input_value_from_string"
+external data_size_unsafe: string -> int -> int = "marshal_data_size"
+
+let header_size = 20
+let data_size buff ofs =
+  if ofs < 0 || ofs + header_size > String.length buff
+  then invalid_arg "Marshal.data_size"
+  else data_size_unsafe buff ofs
+let total_size buff ofs = header_size + data_size buff ofs
+
+let from_string buff ofs =
+  if ofs < 0 || ofs + header_size > String.length buff
+  then invalid_arg "Marshal.from_size"
+  else begin
+    let len = data_size_unsafe buff ofs in
+    if ofs + header_size + len > String.length buff
+    then invalid_arg "Marshal.from_string"
+    else from_string_unsafe buff ofs
+  end  
diff --git a/stdlib/marshal.mli b/stdlib/marshal.mli
new file mode 100644
index 0000000000..d410b79b33
--- /dev/null
+++ b/stdlib/marshal.mli
@@ -0,0 +1,138 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Marshaling of data structures.
+
+   This module provides functions to encode arbitrary data structures
+   as sequences of bytes, which can then be written on a file or
+   sent over a pipe or network connection.  The bytes can then
+   be read back later, possibly in another process, and decoded back
+   into a data structure. The format for the byte sequences
+   is compatible across all machines for a given version of Objective Caml.
+
+   Warning: marshaling is currently not type-safe. The type
+   of marshaled data is not transmitted along the value of the data,
+   making it impossible to check that the data read back possesses the
+   type expected by the context. In particular, the result type of
+   the [Marshal.from_*] functions is given as ['a], but this is
+   misleading: the returned Caml value does not possess type ['a]
+   for all ['a]; it has one, unique type which cannot be determined
+   at compile-type.  The programmer should explicitly give the expected
+   type of the returned value, using the following syntax:
+   - [(Marshal.from_channel chan : type)].
+   Anything can happen at run-time if the object in the file does not
+   belong to the given type.
+
+   The representation of marshaled values is not human-readable,
+   and uses bytes that are not printable characters. Therefore,
+   input and output channels used in conjunction with [Marshal.to_channel]
+   and [Marshal.from_channel] must be opened in binary mode, using e.g.
+   [open_out_bin] or [open_in_bin]; channels opened in text mode will
+   cause unmarshaling errors on platforms where text channels behave
+   differently than binary channels, e.g. Windows. 
+*)
+
+type extern_flags =
+    No_sharing                          (** Don't preserve sharing *)
+  | Closures                            (** Send function closures *)
+(** The flags to the [Marshal.to_*] functions below. *)
+
+val to_channel : out_channel -> 'a -> extern_flags list -> unit
+(** [Marshal.to_channel chan v flags] writes the representation
+   of [v] on channel [chan]. The [flags] argument is a
+   possibly empty list of flags that governs the marshaling
+   behavior with respect to sharing and functional values.
+   
+   If [flags] does not contain [Marshal.No_sharing], circularities 
+   and sharing inside the value [v] are detected and preserved
+   in the sequence of bytes produced. In particular, this
+   guarantees that marshaling always terminates. Sharing
+   between values marshaled by successive calls to
+   [Marshal.to_channel] is not detected, though.
+   If [flags] contains [Marshal.No_sharing], sharing is ignored.
+   This results in faster marshaling if [v] contains no shared
+   substructures, but may cause slower marshaling and larger
+   byte representations if [v] actually contains sharing,
+   or even non-termination if [v] contains cycles.
+   
+   If [flags] does not contain [Marshal.Closures],
+   marshaling fails when it encounters a functional value
+   inside [v]: only ``pure'' data structures, containing neither
+   functions nor objects, can safely be transmitted between
+   different programs. If [flags] contains [Marshal.Closures],
+   functional values will be marshaled as a position in the code
+   of the program. In this case, the output of marshaling can
+   only be read back in processes that run exactly the same program,
+   with exactly the same compiled code. (This is checked
+   at un-marshaling time, using an MD5 digest of the code
+   transmitted along with the code position.) *)
+
+external to_string :
+  'a -> extern_flags list -> string = "output_value_to_string"
+(** [Marshal.to_string v flags] returns a string containing
+   the representation of [v] as a sequence of bytes.
+   The [flags] argument has the same meaning as for
+   {!Marshal.to_channel}. *)
+
+val to_buffer : string -> int -> int -> 'a -> extern_flags list -> int
+(** [Marshal.to_buffer buff ofs len v flags] marshals the value [v],
+   storing its byte representation in the string [buff],
+   starting at character number [ofs], and writing at most
+   [len] characters.  It returns the number of characters
+   actually written to the string. If the byte representation
+   of [v] does not fit in [len] characters, the exception [Failure]
+   is raised. *)
+
+val from_channel : in_channel -> 'a
+(** [Marshal.from_channel chan] reads from channel [chan] the
+   byte representation of a structured value, as produced by
+   one of the [Marshal.to_*] functions, and reconstructs and
+   returns the corresponding value.*)
+
+val from_string : string -> int -> 'a
+(** [Marshal.from_string buff ofs] unmarshals a structured value
+   like {!Marshal.from_channel} does, except that the byte
+   representation is not read from a channel, but taken from
+   the string [buff], starting at position [ofs]. *)
+
+val header_size : int
+(** The bytes representing a marshaled value are composed of
+   a fixed-size header and a variable-sized data part,
+   whose size can be determined from the header.
+   {!Marshal.header_size} is the size, in characters, of the header.
+   {!Marshal.data_size}[ buff ofs] is the size, in characters,
+   of the data part, assuming a valid header is stored in
+   [buff] starting at position [ofs].
+   Finally, {!Marshal.total_size}[ buff ofs] is the total size,
+   in characters, of the marshaled value.
+   Both {!Marshal.data_size} and {!Marshal.total_size} raise [Failure]
+   if [buff], [ofs] does not contain a valid header.
+   
+   To read the byte representation of a marshaled value into
+   a string buffer, the program needs to read first
+   {!Marshal.header_size} characters into the buffer,
+   then determine the length of the remainder of the
+   representation using {!Marshal.data_size},
+   make sure the buffer is large enough to hold the remaining
+   data, then read it, and finally call {!Marshal.from_string}
+   to unmarshal the value. *)
+
+val data_size : string -> int -> int
+(** See {!Marshal.header_size}.*)
+
+val total_size : string -> int -> int
+(** See {!Marshal.header_size}.*)
+
+
diff --git a/stdlib/moreLabels.ml b/stdlib/moreLabels.ml
new file mode 100644
index 0000000000..f6cfddabc6
--- /dev/null
+++ b/stdlib/moreLabels.ml
@@ -0,0 +1,22 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*               Jacques Garrigue, Kyoto University RIMS               *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Module [MoreLabels]: meta-module for compatibility labelled libraries *)
+
+module Hashtbl = Hashtbl
+
+module Map = Map
+
+module Set = Set
diff --git a/stdlib/moreLabels.mli b/stdlib/moreLabels.mli
new file mode 100644
index 0000000000..977893aecf
--- /dev/null
+++ b/stdlib/moreLabels.mli
@@ -0,0 +1,118 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*               Jacques Garrigue, Kyoto University RIMS               *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Extra labeled libraries.
+
+   This meta-module provides labelized version of the {!Hashtbl},
+   {!Map} and {!Set} modules.
+
+   They only differ by their labels. They are provided to help
+   porting from previous versions of Objective Caml.
+   The contents of this module are subject to change.
+*)
+
+module Hashtbl : sig
+  type ('a, 'b) t = ('a, 'b) Hashtbl.t
+  val create : int -> ('a, 'b) t
+  val clear : ('a, 'b) t -> unit
+  val add : ('a, 'b) t -> key:'a -> data:'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 -> key:'a -> data:'b -> unit
+  val iter : f:(key:'a -> data:'b -> unit) -> ('a, 'b) t -> unit
+  val fold :
+      f:(key:'a -> data:'b -> 'c -> 'c) ->
+        ('a, 'b) t -> init:'c -> 'c
+  module type HashedType = Hashtbl.HashedType
+  module type S =
+    sig
+      type key
+      and 'a t
+      val create : int -> 'a t
+      val clear : 'a t -> unit
+      val copy : 'a t -> 'a t
+      val add : 'a t -> key:key -> data:'a -> unit
+      val remove : 'a t -> key -> unit
+      val find : 'a t -> key -> 'a
+      val find_all : 'a t -> key -> 'a list
+      val replace : 'a t -> key:key -> data:'a -> unit
+      val mem : 'a t -> key -> bool
+      val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit
+      val fold :
+          f:(key:key -> data:'a -> 'b -> 'b) ->
+          'a t -> init:'b -> 'b
+    end
+  module Make : functor (H : HashedType) -> S with type key = H.t
+  val hash : 'a -> int
+  external hash_param : int -> int -> 'a -> int
+      = "hash_univ_param" "noalloc"
+end
+
+module Map : sig
+  module type OrderedType = Map.OrderedType
+  module type S =
+    sig
+      type key
+      and (+'a) t
+      val empty : 'a t
+      val add : key:key -> data:'a -> 'a t -> 'a t
+      val find : key -> 'a t -> 'a
+      val remove : key -> 'a t -> 'a t
+      val mem : key -> 'a t -> bool
+      val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit
+      val map : f:('a -> 'b) -> 'a t -> 'b t
+      val mapi : f:(key -> 'a -> 'b) -> 'a t -> 'b t
+      val fold :
+          f:(key:key -> data:'a -> 'b -> 'b) ->
+          'a t -> init:'b -> 'b
+    end
+  module Make : functor (Ord : OrderedType) -> S with type key = Ord.t
+end
+
+module Set : sig
+  module type OrderedType = Set.OrderedType
+  module type S =
+    sig
+      type elt
+      and t
+      val empty : t
+      val is_empty : t -> bool
+      val mem : elt -> t -> bool
+      val add : elt -> t -> t
+      val singleton : elt -> t
+      val remove : elt -> t -> t
+      val union : t -> t -> t
+      val inter : t -> t -> t
+      val diff : t -> t -> t
+      val compare : t -> t -> int
+      val equal : t -> t -> bool
+      val subset : t -> t -> bool
+      val iter : f:(elt -> unit) -> t -> unit
+      val fold : f:(elt -> 'a -> 'a) -> t -> init:'a -> 'a
+      val for_all : f:(elt -> bool) -> t -> bool
+      val exists : f:(elt -> bool) -> t -> bool
+      val filter : f:(elt -> bool) -> t -> t
+      val partition : f:(elt -> bool) -> t -> t * t
+      val cardinal : t -> int
+      val elements : t -> elt list
+      val min_elt : t -> elt
+      val max_elt : t -> elt
+      val choose : t -> elt
+    end
+  module Make : functor (Ord : OrderedType) -> S with type elt = Ord.t
+end
diff --git a/stdlib/nativeint.ml b/stdlib/nativeint.ml
new file mode 100644
index 0000000000..9057ad9617
--- /dev/null
+++ b/stdlib/nativeint.ml
@@ -0,0 +1,51 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Module [Nativeint]: processor-native integers *)
+
+external neg: nativeint -> nativeint = "%nativeint_neg"
+external add: nativeint -> nativeint -> nativeint = "%nativeint_add"
+external sub: nativeint -> nativeint -> nativeint = "%nativeint_sub"
+external mul: nativeint -> nativeint -> nativeint = "%nativeint_mul"
+external div: nativeint -> nativeint -> nativeint = "%nativeint_div"
+external rem: nativeint -> nativeint -> nativeint = "%nativeint_mod"
+external logand: nativeint -> nativeint -> nativeint = "%nativeint_and"
+external logor: nativeint -> nativeint -> nativeint = "%nativeint_or"
+external logxor: nativeint -> nativeint -> nativeint = "%nativeint_xor"
+external shift_left: nativeint -> int -> nativeint = "%nativeint_lsl"
+external shift_right: nativeint -> int -> nativeint = "%nativeint_asr"
+external shift_right_logical: nativeint -> int -> nativeint = "%nativeint_lsr"
+external of_int: int -> nativeint = "%nativeint_of_int"
+external to_int: nativeint -> int = "%nativeint_to_int"
+external of_float : float -> nativeint = "nativeint_of_float"
+external to_float : nativeint -> float = "nativeint_to_float"
+external of_int32: int32 -> nativeint = "%nativeint_of_int32"
+external to_int32: nativeint -> int32 = "%nativeint_to_int32"
+
+let zero = of_int 0
+let one = of_int 1
+let minus_one = of_int (-1)
+let succ n = add n one
+let pred n = sub n one
+let abs n = if n >= zero then n else neg n
+let size = Sys.word_size
+let min_int = shift_left one (size - 1)
+let max_int = sub min_int one
+let lognot n = logxor n minus_one
+
+external format : string -> nativeint -> string = "nativeint_format"
+let to_string n = format "%d" n
+
+external of_string: string -> nativeint = "nativeint_of_string"
diff --git a/stdlib/nativeint.mli b/stdlib/nativeint.mli
new file mode 100644
index 0000000000..b839352623
--- /dev/null
+++ b/stdlib/nativeint.mli
@@ -0,0 +1,174 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Processor-native integers.
+
+   This module provides operations on the type [nativeint] of
+   signed 32-bit integers (on 32-bit platforms) or
+   signed 64-bit integers (on 64-bit platforms).
+   This integer type has exactly the same width as that of a [long]
+   integer type in the C compiler.  All arithmetic operations over
+   [nativeint] are taken modulo 2{^32} or 2{^64} depending
+   on the word size of the architecture.
+
+   Performance notice: values of type [nativeint] occupy more memory
+   space than values of type [int], and arithmetic operations on
+   [nativeint] are generally slower than those on [int].  Use [nativeint]
+   only when the application requires the extra bit of precision
+   over the [int] type. 
+*)
+
+val zero : nativeint
+(** The native integer 0.*)
+
+val one : nativeint
+(** The native integer 1.*)
+
+val minus_one : nativeint
+(** The native integer -1.*)
+
+external neg : nativeint -> nativeint = "%nativeint_neg"
+(** Unary negation. *)
+
+external add : nativeint -> nativeint -> nativeint = "%nativeint_add"
+(** Addition. *)
+
+external sub : nativeint -> nativeint -> nativeint = "%nativeint_sub"
+(** Subtraction. *)
+
+external mul : nativeint -> nativeint -> nativeint = "%nativeint_mul"
+(** Multiplication. *)
+
+external div : nativeint -> nativeint -> nativeint = "%nativeint_div"
+(** Integer division.  Raise [Division_by_zero] if the second 
+   argument is zero. *)
+
+external rem : nativeint -> nativeint -> nativeint = "%nativeint_mod"
+(** Integer remainder.  If [x >= 0] and [y > 0], the result
+   of [Nativeint.rem x y] satisfies the following properties:
+   [0 <= Nativeint.rem x y < y] and
+   [x = Nativeint.add (Nativeint.mul (Nativeint.div x y) y) (Nativeint.rem x y)].
+   If [y = 0], [Nativeint.rem x y] raises [Division_by_zero].
+   If [x < 0] or [y < 0], the result of [Nativeint.rem x y] is
+   not specified and depends on the platform. *)
+
+val succ : nativeint -> nativeint
+(** Successor.
+   [Nativeint.succ x] is [Nativeint.add x Nativeint.one]. *)
+
+val pred : nativeint -> nativeint
+(** Predecessor.
+   [Nativeint.pred x] is [Nativeint.sub x Nativeint.one]. *)
+
+val abs : nativeint -> nativeint
+(** Return the absolute value of its argument. *)
+
+val size : int
+(** The size in bits of a native integer.  This is equal to [32]
+   on a 32-bit platform and to [64] on a 64-bit platform. *)
+
+val max_int : nativeint
+(** The greatest representable native integer,
+   either 2{^31} - 1 on a 32-bit platform,
+   or 2{^63} - 1 on a 64-bit platform. *)
+
+val min_int : nativeint
+(** The greatest representable native integer,
+   either -2{^31} on a 32-bit platform,
+   or -2{^63} on a 64-bit platform. *)
+
+external logand : nativeint -> nativeint -> nativeint = "%nativeint_and"
+(** Bitwise logical and. *)
+
+external logor : nativeint -> nativeint -> nativeint = "%nativeint_or"
+(** Bitwise logical or. *)
+
+external logxor : nativeint -> nativeint -> nativeint = "%nativeint_xor"
+(** Bitwise logical exclusive or. *)
+
+val lognot : nativeint -> nativeint
+(** Bitwise logical negation *)
+
+external shift_left : nativeint -> int -> nativeint = "%nativeint_lsl"
+(** [Nativeint.shift_left x y] shifts [x] to the left by [y] bits.
+   The result is unspecified if [y < 0] or [y >= bitsize],
+   where [bitsize] is [32] on a 32-bit platform and
+   [64] on a 64-bit platform. *)
+
+external shift_right : nativeint -> int -> nativeint = "%nativeint_asr"
+(** [Nativeint.shift_right x y] shifts [x] to the right by [y] bits.
+   This is an arithmetic shift: the sign bit of [x] is replicated
+   and inserted in the vacated bits.
+   The result is unspecified if [y < 0] or [y >= bitsize]. *)
+
+external shift_right_logical :
+  nativeint -> int -> nativeint = "%nativeint_lsr"
+(** [Nativeint.shift_right_logical x y] shifts [x] to the right
+   by [y] bits.
+   This is a logical shift: zeroes are inserted in the vacated bits
+   regardless of the sign of [x].
+   The result is unspecified if [y < 0] or [y >= bitsize]. *)
+
+
+external of_int : int -> nativeint = "%nativeint_of_int"
+(** Convert the given integer (type [int]) to a native integer
+   (type [nativeint]). *)
+
+external to_int : nativeint -> int = "%nativeint_to_int"
+(** Convert the given native integer (type [nativeint]) to an
+   integer (type [int]).  The high-order bit is lost during
+   the conversion. *)
+
+external of_float : float -> nativeint = "nativeint_of_float"
+(** Convert the given floating-point number to a native integer,
+   discarding the fractional part (truncate towards 0).
+   The result of the conversion is undefined if, after truncation,
+   the number is outside the range
+   \[{!Nativeint.min_int}, {!Nativeint.max_int}\]. *)
+       
+external to_float : nativeint -> float = "nativeint_to_float"
+(** Convert the given native integer to a floating-point number. *)
+
+external of_int32 : int32 -> nativeint = "%nativeint_of_int32"
+(** Convert the given 32-bit integer (type [int32])
+   to a native integer. *)
+
+external to_int32 : nativeint -> int32 = "%nativeint_to_int32"
+(** Convert the given native integer to a
+   32-bit integer (type [int32]).  On 64-bit platforms,
+   the 64-bit native integer is taken modulo 2{^32},
+   i.e. the top 32 bits are lost.  On 32-bit platforms,
+   the conversion is exact. *)
+
+external of_string : string -> nativeint = "nativeint_of_string"
+(** Convert the given string to a native integer.
+   The string is read in decimal (by default) or in hexadecimal,
+   octal or binary if the string begins with [0x], [0o] or [0b]
+   respectively.
+   Raise [Failure "int_of_string"] if the given string is not
+   a valid representation of an integer. *)
+
+val to_string : nativeint -> string
+(** Return the string representation of its argument, in decimal. *)
+
+external format : string -> nativeint -> string = "nativeint_format"
+(** [Nativeint.format fmt n] return the string representation of the
+   native integer [n] in the format specified by [fmt].
+   [fmt] is a [Printf]-style format containing exactly
+   one [%d], [%i], [%u], [%x], [%X] or [%o] conversion specification.
+   This function is deprecated; use {!Printf.sprintf} with a [%nx] format
+   instead. *)
+
+
diff --git a/stdlib/oo.mli b/stdlib/oo.mli
new file mode 100644
index 0000000000..d3f2c3ed45
--- /dev/null
+++ b/stdlib/oo.mli
@@ -0,0 +1,78 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Object-oriented extension *)
+
+val copy : (< .. > as 'a) -> 'a
+(** [Oo.copy o] returns a copy of object [o], that is a fresh
+   object with the same methods and instance variables as [o]  *)
+        
+
+(**/**)
+
+(** {6 For system use only, not for the casual user} *)
+
+(** {6 Methods} *)
+
+type label
+val new_method : string -> label
+
+(** {6 Classes} *)
+
+type table
+type meth
+type t
+type obj
+val new_variable : table -> string -> int
+val get_variable : table -> string -> int
+val get_method_label : table -> string -> label
+val get_method : table -> label -> meth
+val set_method : table -> label -> meth -> unit
+val narrow : table -> string list -> string list -> string list -> unit
+val widen : table -> unit
+val add_initializer : table -> (obj -> unit) -> unit
+val create_table : string list -> table
+val init_class : table -> unit
+
+(** {6 Objects} *)
+
+val create_object : table -> obj
+val run_initializers : obj -> table -> unit
+val send : obj -> label -> t
+
+(** {6 Parameters} *)
+
+type params =
+  { mutable compact_table : bool;
+    mutable copy_parent : bool;
+    mutable clean_when_copying : bool;
+    mutable retry_count : int;
+    mutable bucket_small_size : int }
+
+val params : params
+
+(** {6 Statistics} *)
+
+type stats =
+  { classes : int; 
+    labels : int; 
+    methods : int; 
+    inst_vars : int; 
+    buckets : int;
+    distrib : int array; 
+    small_bucket_count : int; 
+    small_bucket_max : int }
+val stats : unit -> stats
+val show_buckets : unit -> unit
diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml
new file mode 100644
index 0000000000..0803315f67
--- /dev/null
+++ b/stdlib/parsing.ml
@@ -0,0 +1,193 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* The parsing engine *)
+
+open Lexing
+
+(* Internal interface to the parsing engine *)
+
+type parser_env =
+  { mutable s_stack : int array;        (* States *)
+    mutable v_stack : Obj.t array;      (* Semantic attributes *)
+    mutable symb_start_stack : int array; (* Start positions *)
+    mutable symb_end_stack : int array;   (* End positions *)
+    mutable stacksize : int;            (* Size of the stacks *)
+    mutable stackbase : int;            (* Base sp for current parse *)
+    mutable curr_char : int;            (* Last token read *)
+    mutable lval : Obj.t;               (* Its semantic attribute *)
+    mutable symb_start : int;           (* Start pos. of the current symbol*)
+    mutable symb_end : int;             (* End pos. of the current symbol *)
+    mutable asp : int;                  (* The stack pointer for attributes *)
+    mutable rule_len : int;             (* Number of rhs items in the rule *)
+    mutable rule_number : int;          (* Rule number to reduce by *)
+    mutable sp : int;                   (* Saved sp for parse_engine *)
+    mutable state : int;                (* Saved state for parse_engine *)
+    mutable errflag : int }             (* Saved error flag for parse_engine *)
+
+type parse_tables =
+  { actions : (parser_env -> Obj.t) array;
+    transl_const : int array;
+    transl_block : int array;
+    lhs : string;
+    len : string;
+    defred : string;
+    dgoto : string;
+    sindex : string;
+    rindex : string;
+    gindex : string;
+    tablesize : int;
+    table : string;
+    check : string;
+    error_function : string -> unit;
+    names_const : string;
+    names_block : string }
+
+exception YYexit of Obj.t
+exception Parse_error
+
+type parser_input =
+    Start
+  | Token_read
+  | Stacks_grown_1
+  | Stacks_grown_2
+  | Semantic_action_computed
+  | Error_detected
+
+type parser_output =
+    Read_token
+  | Raise_parse_error
+  | Grow_stacks_1
+  | Grow_stacks_2
+  | Compute_semantic_action
+  | Call_error_function
+
+external parse_engine :
+    parse_tables -> parser_env -> parser_input -> Obj.t -> parser_output
+    = "parse_engine"
+
+let env =
+  { s_stack = Array.create 100 0;
+    v_stack = Array.create 100 (Obj.repr ());
+    symb_start_stack = Array.create 100 0;
+    symb_end_stack = Array.create 100 0;
+    stacksize = 100;
+    stackbase = 0;
+    curr_char = 0;
+    lval = Obj.repr ();
+    symb_start = 0;
+    symb_end = 0;
+    asp = 0;
+    rule_len = 0;
+    rule_number = 0;
+    sp = 0;
+    state = 0;
+    errflag = 0 }
+
+let grow_stacks() =
+  let oldsize = env.stacksize in
+  let newsize = oldsize * 2 in
+  let new_s = Array.create newsize 0
+  and new_v = Array.create newsize (Obj.repr ())
+  and new_start = Array.create newsize 0
+  and new_end = Array.create newsize 0 in
+    Array.blit env.s_stack 0 new_s 0 oldsize;
+    env.s_stack <- new_s;
+    Array.blit env.v_stack 0 new_v 0 oldsize;
+    env.v_stack <- new_v;
+    Array.blit env.symb_start_stack 0 new_start 0 oldsize;
+    env.symb_start_stack <- new_start;
+    Array.blit env.symb_end_stack 0 new_end 0 oldsize;
+    env.symb_end_stack <- new_end;
+    env.stacksize <- newsize
+
+let clear_parser() =
+  Array.fill env.v_stack 0 env.stacksize (Obj.repr ());
+  env.lval <- Obj.repr ()
+
+let current_lookahead_fun = ref (fun (x : Obj.t) -> false)
+
+let yyparse tables start lexer lexbuf =
+  let rec loop cmd arg =
+    match parse_engine tables env cmd arg with
+      Read_token ->
+        let t = Obj.repr(lexer lexbuf) in
+        env.symb_start <- lexbuf.lex_abs_pos + lexbuf.lex_start_pos;
+        env.symb_end   <- lexbuf.lex_abs_pos + lexbuf.lex_curr_pos;
+        loop Token_read t
+    | Raise_parse_error ->
+        raise Parse_error
+    | Compute_semantic_action ->
+        let (action, value) =
+          try
+            (Semantic_action_computed, tables.actions.(env.rule_number) env)
+          with Parse_error ->
+            (Error_detected, Obj.repr ()) in
+        loop action value
+    | Grow_stacks_1 ->
+        grow_stacks(); loop Stacks_grown_1 (Obj.repr ())
+    | Grow_stacks_2 ->
+        grow_stacks(); loop Stacks_grown_2 (Obj.repr ())
+    | Call_error_function ->
+        tables.error_function "syntax error";
+        loop Error_detected (Obj.repr ()) in
+  let init_asp = env.asp
+  and init_sp = env.sp
+  and init_stackbase = env.stackbase
+  and init_state = env.state
+  and init_curr_char = env.curr_char
+  and init_errflag = env.errflag in
+  env.stackbase <- env.sp + 1;
+  env.curr_char <- start;
+  try
+    loop Start (Obj.repr ())
+  with exn ->
+    let curr_char = env.curr_char in
+    env.asp <- init_asp;
+    env.sp <- init_sp;
+    env.stackbase <- init_stackbase;
+    env.state <- init_state;
+    env.curr_char <- init_curr_char;
+    env.errflag <- init_errflag;
+    match exn with
+      YYexit v ->
+        Obj.magic v
+    | _ ->
+        current_lookahead_fun :=
+          (fun tok ->
+            if Obj.is_block tok
+            then tables.transl_block.(Obj.tag tok) = curr_char
+            else tables.transl_const.(Obj.magic tok) = curr_char);
+        raise exn
+
+let peek_val env n =
+  Obj.magic env.v_stack.(env.asp - n)
+
+let symbol_start () =
+  if env.rule_len > 0
+  then env.symb_start_stack.(env.asp - env.rule_len + 1)
+  else env.symb_end_stack.(env.asp)
+let symbol_end () =
+  env.symb_end_stack.(env.asp)
+
+let rhs_start n =
+  env.symb_start_stack.(env.asp - (env.rule_len - n))
+let rhs_end n =
+  env.symb_end_stack.(env.asp - (env.rule_len - n))
+
+let is_current_lookahead tok =
+  (!current_lookahead_fun)(Obj.repr tok)
+
+let parse_error (msg : string) = ()
diff --git a/stdlib/parsing.mli b/stdlib/parsing.mli
new file mode 100644
index 0000000000..54a247bd9e
--- /dev/null
+++ b/stdlib/parsing.mli
@@ -0,0 +1,84 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** The run-time library for parsers generated by [ocamlyacc]. *)
+
+val symbol_start : unit -> int
+(** [symbol_start] and {!Parsing.symbol_end} are to be called in the action part
+   of a grammar rule only. They return the position of the string that
+   matches the left-hand side of the rule: [symbol_start()] returns
+   the position of the first character; [symbol_end()] returns the
+   position of the last character, plus one. The first character
+   in a file is at position 0. *)
+
+val symbol_end : unit -> int
+(** See {!Parsing.symbol_start}. *)
+
+val rhs_start : int -> int
+(** Same as {!Parsing.symbol_start} and {!Parsing.symbol_end}, but return the
+   position of the string matching the [n]th item on the
+   right-hand side of the rule, where [n] is the integer parameter
+   to [lhs_start] and [lhs_end]. [n] is 1 for the leftmost item. *)
+
+val rhs_end : int -> int
+(** See {!Parsing.rhs_start}. *)
+
+val clear_parser : unit -> unit
+(** Empty the parser stack. Call it just after a parsing function
+   has returned, to remove all pointers from the parser stack
+   to structures that were built by semantic actions during parsing.
+   This is optional, but lowers the memory requirements of the
+   programs. *)
+
+exception Parse_error
+(** Raised when a parser encounters a syntax error.
+   Can also be raised from the action part of a grammar rule,
+   to initiate error recovery. *)
+
+
+(**/**)
+
+(** {6  } *)
+
+(** The following definitions are used by the generated parsers only.
+   They are not intended to be used by user programs. *)
+
+type parser_env
+
+type parse_tables =
+  { actions : (parser_env -> Obj.t) array;
+    transl_const : int array;
+    transl_block : int array;
+    lhs : string;
+    len : string;
+    defred : string;
+    dgoto : string;
+    sindex : string;
+    rindex : string;
+    gindex : string;
+    tablesize : int;
+    table : string;
+    check : string;
+    error_function : string -> unit;
+    names_const : string;
+    names_block : string }
+
+exception YYexit of Obj.t
+
+val yyparse :
+  parse_tables -> int -> (Lexing.lexbuf -> 'a) -> Lexing.lexbuf -> 'b
+val peek_val : parser_env -> int -> 'a
+val is_current_lookahead : 'a -> bool
+val parse_error : string -> unit
diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
new file mode 100644
index 0000000000..1b5905fe64
--- /dev/null
+++ b/stdlib/printexc.ml
@@ -0,0 +1,75 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open Printf;;
+
+let locfmt =
+  match Sys.os_type with
+  | "MacOS" -> ("File \"%s\"; line %d; characters %d to %d ### %s"
+                : ('a, 'b, 'c) format)
+  | _ -> ("File \"%s\", line %d, characters %d-%d: %s" : ('a, 'b, 'c) format)
+;;
+
+let field x i =
+  let f = Obj.field x i in
+  if not (Obj.is_block f) then
+    sprintf "%d" (Obj.magic f : int)           (* can also be a char *)
+  else if Obj.tag f = Obj.string_tag then
+    sprintf "\"%s\"" (String.escaped (Obj.magic f : string))
+  else if Obj.tag f = Obj.double_tag then
+    string_of_float (Obj.magic f : float)
+  else
+    "_"
+;;
+let rec other_fields x i =
+  if i >= Obj.size x then ""
+  else sprintf ", %s%s" (field x i) (other_fields x (i+1))
+;;
+let fields x =
+  match Obj.size x with
+  | 0 -> ""
+  | 1 -> ""
+  | 2 -> sprintf "(%s)" (field x 1)
+  | n -> sprintf "(%s%s)" (field x 1) (other_fields x 2)
+;;
+
+let to_string = function
+  | Out_of_memory -> "Out of memory";
+  | Stack_overflow -> "Stack overflow";
+  | Match_failure(file, first_char, last_char) ->
+      sprintf locfmt file 0 first_char last_char "Pattern matching failed";
+  | Assert_failure(file, first_char, last_char) ->
+      sprintf locfmt file 0 first_char last_char "Assertion failed";
+  | x ->
+      let x = Obj.repr x in
+      let constructor = (Obj.magic(Obj.field (Obj.field x 0) 0) : string) in
+      constructor ^ (fields x)
+;;
+
+let print fct arg =
+  try
+    fct arg
+  with x ->
+    eprintf "Uncaught exception: %s\n" (to_string x);
+    flush stderr;
+    raise x
+
+let catch fct arg =
+  try
+    fct arg
+  with x ->
+    flush stdout;
+    eprintf "Uncaught exception: %s\n" (to_string x);
+    exit 2
diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli
new file mode 100644
index 0000000000..cb012f2e7e
--- /dev/null
+++ b/stdlib/printexc.mli
@@ -0,0 +1,39 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Facilities for printing exceptions. *)
+
+val to_string : exn -> string
+(** [Printexc.to_string e] returns a string representation of
+   the exception [e]. *)
+
+val print : ('a -> 'b) -> 'a -> 'b
+(** [Printexc.print fn x] applies [fn] to [x] and returns the result.
+   If the evaluation of [fn x] raises any exception, the
+   name of the exception is printed on standard error output,
+   and the exception is raised again.
+   The typical use is to catch and report exceptions that
+   escape a function application. *)
+
+val catch : ('a -> 'b) -> 'a -> 'b
+(** [Printexc.catch fn x] is similar to {!Printexc.print}, but
+   aborts the program with exit code 2 after printing the
+   uncaught exception.  This function is deprecated: the runtime
+   system is now able to print uncaught exceptions as precisely
+   as [Printexc.catch] does.  Moreover, calling [Printexc.catch]
+   makes it harder to track the location of the exception
+   using the debugger or the stack backtrace facility.
+   So, do not use [Printexc.catch] in new code.  *)
+
diff --git a/stdlib/printf.ml b/stdlib/printf.ml
new file mode 100644
index 0000000000..e4d6f6a55a
--- /dev/null
+++ b/stdlib/printf.ml
@@ -0,0 +1,214 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+external format_int: string -> int -> string = "format_int"
+external format_int32: string -> int32 -> string = "int32_format"
+external format_nativeint: string -> nativeint -> string = "nativeint_format"
+external format_int64: string -> int64 -> string = "int64_format"
+external format_float: string -> float -> string = "format_float"
+
+let bad_format fmt pos =
+  invalid_arg
+    ("printf: bad format " ^ String.sub fmt pos (String.length fmt - pos))
+
+(* Format a string given a %s format, e.g. %40s or %-20s.
+   To do: ignore other flags (#, +, etc)? *)
+
+let format_string format s =
+  let rec parse_format neg i =
+    if i >= String.length format then (0, neg) else
+    match String.unsafe_get format i with
+    | '1'..'9' ->
+        (int_of_string (String.sub format i (String.length format - i - 1)),
+         neg)
+    | '-' ->
+        parse_format true (succ i)
+    | _ ->
+        parse_format neg (succ i) in
+  let (p, neg) =
+    try parse_format false 1 with Failure _ -> bad_format format 0 in
+  if String.length s < p then begin
+    let res = String.make p ' ' in
+    if neg 
+    then String.blit s 0 res 0 (String.length s)
+    else String.blit s 0 res (p - String.length s) (String.length s);
+    res
+  end else
+    s
+
+(* Extract a %format from [fmt] between [start] and [stop] inclusive.
+   '*' in the format are replaced by integers taken from the [widths] list.
+   The function is somewhat optimized for the "no *" case. *)
+
+let extract_format fmt start stop widths =
+  match widths with
+  | [] -> String.sub fmt start (stop - start + 1)
+  | _  ->
+      let b = Buffer.create (stop - start + 10) in
+      let rec fill_format i w =
+        if i > stop then Buffer.contents b else
+          match (String.unsafe_get fmt i, w) with
+            ('*', h::t) ->
+              Buffer.add_string b (string_of_int h); fill_format (succ i) t
+          | ('*', []) ->
+              bad_format fmt start (* should not happen *)
+          | (c, _) ->
+              Buffer.add_char b c; fill_format (succ i) w
+      in fill_format start (List.rev widths)
+
+(* Decode a %format and act on it.
+   [fmt] is the printf format style, and [pos] points to a [%] character.  
+   After consuming the appropriate number of arguments and formatting
+   them, one of the three continuations is called:
+   [cont_s] for outputting a string (args: string, next pos)
+   [cont_a] for performing a %a action (args: fn, arg, next pos)
+   [cont_t] for performing a %t action (args: fn, next pos)
+   "next pos" is the position in [fmt] of the first character following
+   the %format in [fmt]. *)
+
+(* Note: here, rather than test explicitly against [String.length fmt]
+   to detect the end of the format, we use [String.unsafe_get] and
+   rely on the fact that we'll get a "nul" character if we access
+   one past the end of the string.  These "nul" characters are then
+   caught by the [_ -> bad_format] clauses below.
+   Don't do this at home, kids. *) 
+
+let scan_format fmt pos cont_s cont_a cont_t =
+  let rec scan_flags widths i =
+    match String.unsafe_get fmt i with
+    | '*' ->
+        Obj.magic(fun w -> scan_flags (w :: widths) (succ i))
+    | '0'..'9' | '.' | '#' | '-' | ' ' | '+' -> scan_flags widths (succ i)
+    | _ -> scan_conv widths i
+  and scan_conv widths i =
+    match String.unsafe_get fmt i with
+    | '%' ->
+        cont_s "%" (succ i)
+    | 's' ->
+        Obj.magic (fun (s: string) ->
+          if i = succ pos (* optimize for common case %s *)
+          then cont_s s (succ i)
+          else cont_s (format_string (extract_format fmt pos i widths) s)
+                      (succ i))
+    | 'c' ->
+        Obj.magic (fun (c: char) ->
+          cont_s (String.make 1 c) (succ i))
+    | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
+        Obj.magic(fun (n: int) ->
+          cont_s (format_int (extract_format fmt pos i widths) n) (succ i))
+    | 'f' | 'e' | 'E' | 'g' | 'G' ->
+        Obj.magic(fun (f: float) ->
+          cont_s (format_float (extract_format fmt pos i widths) f) (succ i))
+    | 'b' ->
+        Obj.magic(fun (b: bool) ->
+          cont_s (string_of_bool b) (succ i))
+    | 'a' ->
+        Obj.magic (fun printer arg ->
+          cont_a printer arg (succ i))
+    | 't' ->
+        Obj.magic (fun printer ->
+          cont_t printer (succ i))
+    | 'l' ->
+        begin match String.unsafe_get fmt (succ i) with
+        | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
+            Obj.magic(fun (n: int32) ->
+              cont_s (format_int32 (extract_format fmt pos (succ i) widths) n)
+                     (i + 2))
+        | _ ->
+            bad_format fmt pos
+        end
+    | 'n' ->
+        begin match String.unsafe_get fmt (succ i) with
+        | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
+            Obj.magic(fun (n: nativeint) ->
+              cont_s (format_nativeint
+                         (extract_format fmt pos (succ i) widths)
+                         n)
+                     (i + 2))
+        | _ ->
+            bad_format fmt pos
+        end
+    | 'L' ->
+        begin match String.unsafe_get fmt (succ i) with
+        | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
+            Obj.magic(fun (n: int64) ->
+              cont_s (format_int64 (extract_format fmt pos (succ i) widths) n)
+                     (i + 2))
+        | _ ->
+            bad_format fmt pos
+        end
+    | _ ->
+        bad_format fmt pos
+  in scan_flags [] (pos + 1)
+
+(* Application to [fprintf], etc.  See also [Format.*printf]. *)
+
+let fprintf chan fmt =
+  let fmt = (Obj.magic fmt : string) in
+  let len = String.length fmt in
+  let rec doprn i =
+    if i >= len then Obj.magic () else
+    match String.unsafe_get fmt i with
+    | '%' -> scan_format fmt i cont_s cont_a cont_t
+    |  c  -> output_char chan c; doprn (succ i)
+  and cont_s s i =
+    output_string chan s; doprn i
+  and cont_a printer arg i =
+    printer chan arg; doprn i
+  and cont_t printer i =
+    printer chan; doprn i
+  in doprn 0
+
+let printf fmt = fprintf stdout fmt
+let eprintf fmt = fprintf stderr fmt
+
+let sprintf fmt =
+  let fmt = (Obj.magic fmt : string) in
+  let len = String.length fmt in
+  let dest = Buffer.create (len + 16) in
+  let rec doprn i =
+    if i >= len then begin
+      let res = Buffer.contents dest in
+      Buffer.clear dest;  (* just in case sprintf is partially applied *)
+      Obj.magic res
+    end else
+    match String.unsafe_get fmt i with
+    | '%' -> scan_format fmt i cont_s cont_a cont_t
+    |  c  -> Buffer.add_char dest c; doprn (succ i)
+  and cont_s s i =
+    Buffer.add_string dest s; doprn i
+  and cont_a printer arg i =
+    Buffer.add_string dest (printer () arg); doprn i
+  and cont_t printer i =
+    Buffer.add_string dest (printer ()); doprn i
+  in doprn 0
+
+let bprintf dest fmt =
+  let fmt = (Obj.magic fmt : string) in
+  let len = String.length fmt in
+  let rec doprn i =
+    if i >= len then Obj.magic () else
+    match String.unsafe_get fmt i with
+    | '%' -> scan_format fmt i cont_s cont_a cont_t
+    |  c  -> Buffer.add_char dest c; doprn (succ i)
+  and cont_s s i =
+    Buffer.add_string dest s; doprn i
+  and cont_a printer arg i =
+    printer dest arg; doprn i
+  and cont_t printer i =
+    printer dest; doprn i
+  in doprn 0
+
+
diff --git a/stdlib/printf.mli b/stdlib/printf.mli
new file mode 100644
index 0000000000..ad02ffde1f
--- /dev/null
+++ b/stdlib/printf.mli
@@ -0,0 +1,111 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Formatted output functions. *)
+
+val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a
+(** [fprintf outchan format arg1 ... argN] formats the arguments
+   [arg1] to [argN] according to the format string [format],
+   and outputs the resulting string on the channel [outchan].
+   
+   The format is a character string which contains two types of
+   objects:  plain  characters, which are simply copied to the
+   output channel, and conversion specifications, each of which
+   causes  conversion and printing of one argument.
+   
+   Conversion specifications consist in the [%] character, followed
+   by optional flags and field widths, followed by one or two conversion
+   character. The conversion characters and their meanings are:
+   - [d] or [i]: convert an integer argument to signed decimal
+   - [u]: convert an integer argument to unsigned decimal
+   - [x]: convert an integer argument to unsigned hexadecimal,
+     using lowercase letters.
+   - [X]: convert an integer argument to unsigned hexadecimal,
+     using uppercase letters.
+   - [o]: convert an integer argument to unsigned octal.
+   - [s]: insert a string argument
+   - [c]: insert a character argument
+   - [f]: convert a floating-point argument to decimal notation,
+     in the style [dddd.ddd]
+   - [e] or [E]: convert a floating-point argument to decimal notation,
+     in the style [d.ddd e+-dd] (mantissa and exponent)
+   - [g] or [G]: convert a floating-point argument to decimal notation,
+     in style [f] or [e], [E] (whichever is more compact)
+   - [b]: convert a boolean argument to the string [true] or [false]
+   - [ld], [li], [lu], [lx], [lX], [lo]: convert an [int32] argument to
+     the format specified by the second letter (decimal, hexadecimal, etc).
+   - [nd], [ni], [nu], [nx], [nX], [no]: convert a [nativeint] argument to
+     the format specified by the second letter.
+   - [Ld], [Li], [Lu], [Lx], [LX], [Lo]: convert an [int64] argument to
+     the format specified by the second letter.
+   - [a]: user-defined printer. Takes two arguments and apply the first
+     one to [outchan] (the current output channel) and to the second
+     argument. The first argument must therefore have type
+     [out_channel -> 'b -> unit] and the second ['b].
+     The output produced by the function is therefore inserted
+     in the output of [fprintf] at the current point.
+   - [t]: same as [%a], but takes only one argument (with type
+     [out_channel -> unit]) and apply it to [outchan].
+   - [%]: take no argument and output one [%] character.
+
+   The optional flags include:
+   - [-]: left-justify the output (default is right justification).
+   - [+]: for numerical conversions, prefix number with a [+] sign if positive.
+   - space: for numerical conversions, prefix number with a space if positive.
+   - [#]: request an alternate formatting style for numbers.
+
+   The field widths are composed of an optional integer literal
+   indicating the minimal width of the result, possibly followed by
+   a dot [.] and another integer literal indicating how many digits
+   follow the decimal point in the [%f], [%e], and [%E] conversions.
+   For instance, [%6d] prints an integer, prefixing it with spaces to
+   fill at least 6 characters; and [%.4f] prints a float with 4
+   fractional digits.  Each or both of the integer literals can also be
+   specified as a [*], in which case an extra integer argument is taken
+   to specify the corresponding width or precision.
+   
+   Warning: if too few arguments are provided,
+   for instance because the [printf] function is partially
+   applied, the format is immediately printed up to
+   the conversion of the first missing argument; printing
+   will then resume when the missing arguments are provided.
+   For example, [List.iter (printf "x=%d y=%d " 1) [2;3]]
+   prints [x=1 y=2 3] instead of the expected
+   [x=1 y=2 x=1 y=3].  To get the expected behavior, do
+   [List.iter (fun y -> printf "x=%d y=%d " 1 y) [2;3]]. *)
+
+val printf : ('a, out_channel, unit) format -> 'a
+(** Same as {!Printf.fprintf}, but output on [stdout]. *)
+
+val eprintf : ('a, out_channel, unit) format -> 'a
+(** Same as {!Printf.fprintf}, but output on [stderr]. *)
+
+val sprintf : ('a, unit, string) format -> 'a
+(** Same as {!Printf.fprintf}, but instead of printing on an output channel,
+   return a string containing the result of formatting
+   the arguments. *)
+
+val bprintf : Buffer.t -> ('a, Buffer.t, unit) format -> 'a
+(** Same as {!Printf.fprintf}, but instead of printing on an output channel,
+   append the formatted arguments to the given extensible buffer
+   (see module {!Buffer}). *)
+
+(**/**)
+
+(* For system use only.  Don't call directly. *)
+
+val scan_format :
+  string -> int -> (string -> int -> 'a) -> ('b -> 'c -> int -> 'a) ->
+    ('e -> int -> 'a) -> 'a
diff --git a/stdlib/queue.ml b/stdlib/queue.ml
new file mode 100644
index 0000000000..58fc637ae9
--- /dev/null
+++ b/stdlib/queue.ml
@@ -0,0 +1,73 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+exception Empty
+
+type 'a queue_cell =
+    Nil
+  | Cons of 'a * 'a queue_cell ref
+
+type 'a t =
+  { mutable head: 'a queue_cell;
+    mutable tail: 'a queue_cell }
+
+let create () =
+  { head = Nil; tail = Nil }
+
+let clear q =
+  q.head <- Nil; q.tail <- Nil
+
+let add x q =
+  match q.tail with
+    Nil ->                              (* if tail = Nil then head = Nil *)
+      let c = Cons(x, ref Nil) in
+      q.head <- c; q.tail <- c
+  | Cons(_, newtailref) ->
+      let c = Cons(x, ref Nil) in
+      newtailref := c;
+      q.tail <- c
+
+let peek q =
+  match q.head with
+    Nil ->
+      raise Empty
+  | Cons(x, _) ->
+      x
+
+let take q =
+  match q.head with
+    Nil ->
+      raise Empty
+  | Cons(x, rest) ->
+      q.head <- !rest;
+      begin match !rest with
+        Nil -> q.tail <- Nil
+      |  _  -> ()
+      end;
+      x
+
+let rec length_aux = function
+    Nil -> 0
+  | Cons(_, rest) -> succ (length_aux !rest)
+
+let length q = length_aux q.head
+
+let rec iter_aux f = function
+    Nil ->
+      ()
+  | Cons(x, rest) ->
+      f x; iter_aux f !rest
+
+let iter f q = iter_aux f q.head
diff --git a/stdlib/queue.mli b/stdlib/queue.mli
new file mode 100644
index 0000000000..89af53d1be
--- /dev/null
+++ b/stdlib/queue.mli
@@ -0,0 +1,53 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** First-in first-out queues.
+
+   This module implements queues (FIFOs), with in-place modification.
+*)
+
+type 'a t
+(** The type of queues containing elements of type ['a]. *)
+
+
+exception Empty
+(** Raised when {!Queue.take} or {!Queue.peek} is applied to an empty queue. *)
+
+
+val create : unit -> 'a t
+(** Return a new queue, initially empty. *)
+
+val add : 'a -> 'a t -> unit
+(** [add x q] adds the element [x] at the end of the queue [q]. *)
+
+val take : 'a t -> 'a
+(** [take q] removes and returns the first element in queue [q],
+   or raises [Empty] if the queue is empty. *)
+
+val peek : 'a t -> 'a
+(** [peek q] returns the first element in queue [q], without removing
+   it from the queue, or raises [Empty] if the queue is empty. *)
+
+val clear : 'a t -> unit
+(** Discard all elements from a queue. *)
+
+val length : 'a t -> int
+(** Return the number of elements in a queue. *)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** [iter f q] applies [f] in turn to all elements of [q],
+   from the least recently entered to the most recently entered.
+   The queue itself is unchanged. *)
+
diff --git a/stdlib/set.ml b/stdlib/set.ml
new file mode 100644
index 0000000000..c93be23933
--- /dev/null
+++ b/stdlib/set.ml
@@ -0,0 +1,308 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Sets over ordered types *)
+
+module type OrderedType =
+  sig
+    type t
+    val compare: t -> t -> int
+  end
+
+module type S =
+  sig
+    type elt
+    type t
+    val empty: t
+    val is_empty: t -> bool
+    val mem: elt -> t -> bool
+    val add: elt -> t -> t
+    val singleton: elt -> t
+    val remove: elt -> t -> t
+    val union: t -> t -> t
+    val inter: t -> t -> t
+    val diff: t -> t -> t
+    val compare: t -> t -> int
+    val equal: t -> t -> bool
+    val subset: t -> t -> bool
+    val iter: (elt -> unit) -> t -> unit
+    val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    val for_all: (elt -> bool) -> t -> bool
+    val exists: (elt -> bool) -> t -> bool
+    val filter: (elt -> bool) -> t -> t
+    val partition: (elt -> bool) -> t -> t * t
+    val cardinal: t -> int
+    val elements: t -> elt list
+    val min_elt: t -> elt
+    val max_elt: t -> elt
+    val choose: t -> elt
+  end
+
+module Make(Ord: OrderedType) =
+  struct
+    type elt = Ord.t
+    type t = Empty | Node of t * elt * t * int
+
+    (* Sets are represented by balanced binary trees (the heights of the
+       children differ by at most 2 *)
+
+    let height = function
+        Empty -> 0
+      | Node(_, _, _, h) -> h
+
+    (* Creates a new node with left son l, value x and right son r.
+       l and r must be balanced and | height l - height r | <= 2.
+       Inline expansion of height for better speed. *)
+
+    let create l x r =
+      let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
+      let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+      Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    (* Same as create, but performs one step of rebalancing if necessary.
+       Assumes l and r balanced.
+       Inline expansion of create for better speed in the most frequent case
+       where no rebalancing is required. *)
+
+    let bal l x r =
+      let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
+      let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+      if hl > hr + 2 then begin
+        match l with
+          Empty -> invalid_arg "Set.bal"
+        | Node(ll, lv, lr, _) ->
+            if height ll >= height lr then
+              create ll lv (create lr x r)
+            else begin
+              match lr with
+                Empty -> invalid_arg "Set.bal"
+              | Node(lrl, lrv, lrr, _)->
+                  create (create ll lv lrl) lrv (create lrr x r)
+            end
+      end else if hr > hl + 2 then begin
+        match r with
+          Empty -> invalid_arg "Set.bal"
+        | Node(rl, rv, rr, _) ->
+            if height rr >= height rl then
+              create (create l x rl) rv rr
+            else begin
+              match rl with
+                Empty -> invalid_arg "Set.bal"
+              | Node(rll, rlv, rlr, _) ->
+                  create (create l x rll) rlv (create rlr rv rr)
+            end
+      end else
+        Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    (* Same as bal, but repeat rebalancing until the final result
+       is balanced. *)
+
+    let rec join l x r =
+      match bal l x r with
+        Empty -> invalid_arg "Set.join"
+      | Node(l', x', r', _) as t' ->
+          let d = height l' - height r' in
+          if d < -2 || d > 2 then join l' x' r' else t'
+
+    (* Merge two trees l and r into one.
+       All elements of l must precede the elements of r.
+       Assumes | height l - height r | <= 2. *)
+
+    let rec merge t1 t2 =
+      match (t1, t2) with
+        (Empty, t) -> t
+      | (t, Empty) -> t
+      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+          bal l1 v1 (bal (merge r1 l2) v2 r2)
+
+    (* Same as merge, but does not assume anything about l and r. *)
+
+    let rec concat t1 t2 =
+      match (t1, t2) with
+        (Empty, t) -> t
+      | (t, Empty) -> t
+      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+          join l1 v1 (join (concat r1 l2) v2 r2)
+
+    (* Splitting *)
+
+    let rec split x = function
+        Empty ->
+          (Empty, None, Empty)
+      | Node(l, v, r, _) ->
+          let c = Ord.compare x v in
+          if c = 0 then (l, Some v, r)
+          else if c < 0 then
+            let (ll, vl, rl) = split x l in (ll, vl, join rl v r)
+          else
+            let (lr, vr, rr) = split x r in (join l v lr, vr, rr)
+
+    (* Implementation of the set operations *)
+
+    let empty = Empty
+
+    let is_empty = function Empty -> true | _ -> false
+
+    let rec mem x = function
+        Empty -> false
+      | Node(l, v, r, _) ->
+          let c = Ord.compare x v in
+          c = 0 || mem x (if c < 0 then l else r)
+
+    let rec add x = function
+        Empty -> Node(Empty, x, Empty, 1)
+      | Node(l, v, r, _) as t ->
+          let c = Ord.compare x v in
+          if c = 0 then t else
+          if c < 0 then bal (add x l) v r else bal l v (add x r)
+
+    let singleton x = Node(Empty, x, Empty, 1)
+
+    let rec remove x = function
+        Empty -> Empty
+      | Node(l, v, r, _) ->
+          let c = Ord.compare x v in
+          if c = 0 then merge l r else
+          if c < 0 then bal (remove x l) v r else bal l v (remove x r)
+
+    let rec union s1 s2 =
+      match (s1, s2) with
+        (Empty, t2) -> t2
+      | (t1, Empty) -> t1
+      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+          if h1 >= h2 then
+            if h2 = 1 then add v2 s1 else begin
+              let (l2, _, r2) = split v1 s2 in
+              join (union l1 l2) v1 (union r1 r2)
+            end
+          else
+            if h1 = 1 then add v1 s2 else begin
+              let (l1, _, r1) = split v2 s1 in
+              join (union l1 l2) v2 (union r1 r2)
+            end
+
+    let rec inter s1 s2 =
+      match (s1, s2) with
+        (Empty, t2) -> Empty
+      | (t1, Empty) -> Empty
+      | (Node(l1, v1, r1, _), t2) ->
+          match split v1 t2 with
+            (l2, None, r2) ->
+              concat (inter l1 l2) (inter r1 r2)
+          | (l2, Some _, r2) ->
+              join (inter l1 l2) v1 (inter r1 r2)
+
+    let rec diff s1 s2 =
+      match (s1, s2) with
+        (Empty, t2) -> Empty
+      | (t1, Empty) -> t1
+      | (Node(l1, v1, r1, _), t2) ->
+          match split v1 t2 with
+            (l2, None, r2) ->
+              join (diff l1 l2) v1 (diff r1 r2)
+          | (l2, Some _, r2) ->
+              concat (diff l1 l2) (diff r1 r2)
+
+    let rec compare_aux l1 l2 =
+        match (l1, l2) with
+        ([], []) -> 0
+      | ([], _)  -> -1
+      | (_, []) -> 1
+      | (Empty :: t1, Empty :: t2) ->
+          compare_aux t1 t2
+      | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) ->
+          let c = Ord.compare v1 v2 in
+          if c <> 0 then c else compare_aux (r1::t1) (r2::t2)
+      | (Node(l1, v1, r1, _) :: t1, t2) ->
+          compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2
+      | (t1, Node(l2, v2, r2, _) :: t2) ->
+          compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2)
+
+    let compare s1 s2 =
+      compare_aux [s1] [s2]
+
+    let equal s1 s2 =
+      compare s1 s2 = 0
+
+    let rec subset s1 s2 =
+      match (s1, s2) with
+        Empty, _ ->
+          true
+      | _, Empty ->
+          false
+      | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
+          let c = Ord.compare v1 v2 in
+          if c = 0 then
+            subset l1 l2 && subset r1 r2
+          else if c < 0 then
+            subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2
+          else
+            subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2
+
+    let rec iter f = function
+        Empty -> ()
+      | Node(l, v, r, _) -> iter f l; f v; iter f r
+
+    let rec fold f s accu =
+      match s with
+        Empty -> accu
+      | Node(l, v, r, _) -> fold f l (f v (fold f r accu))
+
+    let rec for_all p = function
+        Empty -> true
+      | Node(l, v, r, _) -> p v && for_all p l && for_all p r
+
+    let rec exists p = function
+        Empty -> false
+      | Node(l, v, r, _) -> p v || exists p l || exists p r
+
+    let filter p s =
+      let rec filt accu = function
+        | Empty -> accu
+        | Node(l, v, r, _) ->
+            filt (filt (if p v then add v accu else accu) l) r in
+      filt Empty s
+
+    let partition p s =
+      let rec part (t, f as accu) = function
+        | Empty -> accu
+        | Node(l, v, r, _) ->
+            part (part (if p v then (add v t, f) else (t, add v f)) l) r in
+      part (Empty, Empty) s
+
+    let rec cardinal = function
+        Empty -> 0
+      | Node(l, v, r, _) -> cardinal l + 1 + cardinal r
+
+    let rec elements_aux accu = function
+        Empty -> accu
+      | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l
+
+    let elements s =
+      elements_aux [] s
+
+    let rec min_elt = function
+        Empty -> raise Not_found
+      | Node(Empty, v, r, _) -> v
+      | Node(l, v, r, _) -> min_elt l
+
+    let rec max_elt = function
+        Empty -> raise Not_found
+      | Node(l, v, Empty, _) -> v
+      | Node(l, v, r, _) -> max_elt r
+
+    let choose = min_elt
+
+  end
diff --git a/stdlib/set.mli b/stdlib/set.mli
new file mode 100644
index 0000000000..57c22adece
--- /dev/null
+++ b/stdlib/set.mli
@@ -0,0 +1,146 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Sets over ordered types.
+
+   This module implements the set data structure, given a total ordering
+   function over the set elements. All operations over sets
+   are purely applicative (no side-effects).
+   The implementation uses balanced binary trees, and is therefore
+   reasonably efficient: insertion and membership take time
+   logarithmic in the size of the set, for instance. 
+*)
+
+module type OrderedType = 
+  sig
+    type t
+      (** The type of the set elements. *)
+    val compare : t -> t -> int
+      (** A total ordering function over the set elements.
+          This is a two-argument function [f] such that
+          [f e1 e2] is zero if the elements [e1] and [e2] are equal,
+          [f e1 e2] is strictly negative if [e1] is smaller than [e2],
+          and [f e1 e2] is strictly positive if [e1] is greater than [e2].
+          Example: a suitable ordering function is
+          the generic structural comparison function {!Pervasives.compare}. *)
+  end
+(** Input signature of the functor {!Set.Make}. *)
+
+module type S =
+  sig
+    type elt
+    (** The type of the set elements. *)
+
+    type t
+    (** The type of sets. *)
+
+    val empty: t
+    (** The empty set. *)
+
+    val is_empty: t -> bool
+    (** Test whether a set is empty or not. *)
+
+    val mem: elt -> t -> bool
+    (** [mem x s] tests whether [x] belongs to the set [s]. *)
+
+    val add: elt -> t -> t
+    (** [add x s] returns a set containing all elements of [s],
+       plus [x]. If [x] was already in [s], [s] is returned unchanged. *)
+
+    val singleton: elt -> t
+    (** [singleton x] returns the one-element set containing only [x]. *)
+
+    val remove: elt -> t -> t
+    (** [remove x s] returns a set containing all elements of [s],
+       except [x]. If [x] was not in [s], [s] is returned unchanged. *)
+
+    val union: t -> t -> t
+    (** Set union. *)
+
+    val inter: t -> t -> t
+    (** Set interseection. *)
+
+    (** Set difference. *)
+    val diff: t -> t -> t
+
+    val compare: t -> t -> int
+    (** Total ordering between sets. Can be used as the ordering function
+       for doing sets of sets. *)
+
+    val equal: t -> t -> bool
+    (** [equal s1 s2] tests whether the sets [s1] and [s2] are
+       equal, that is, contain equal elements. *)
+
+    val subset: t -> t -> bool
+    (** [subset s1 s2] tests whether the set [s1] is a subset of
+       the set [s2]. *)
+
+    val iter: (elt -> unit) -> t -> unit
+    (** [iter f s] applies [f] in turn to all elements of [s].
+       The order in which the elements of [s] are presented to [f]
+       is unspecified. *)
+
+    val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
+       where [x1 ... xN] are the elements of [s].
+       The order in which elements of [s] are presented to [f] is
+       unspecified. *)
+
+    val for_all: (elt -> bool) -> t -> bool
+    (** [for_all p s] checks if all elements of the set
+       satisfy the predicate [p]. *)
+
+    val exists: (elt -> bool) -> t -> bool
+    (** [exists p s] checks if at least one element of
+       the set satisfies the predicate [p]. *)
+        
+    val filter: (elt -> bool) -> t -> t
+    (** [filter p s] returns the set of all elements in [s]
+       that satisfy predicate [p]. *)
+
+    val partition: (elt -> bool) -> t -> t * t
+    (** [partition p s] returns a pair of sets [(s1, s2)], where
+       [s1] is the set of all the elements of [s] that satisfy the
+       predicate [p], and [s2] is the set of all the elements of
+       [s] that do not satisfy [p]. *)
+
+    val cardinal: t -> int
+    (** Return the number of elements of a set. *)
+
+    val elements: t -> elt list
+    (** Return the list of all elements of the given set.
+       The returned list is sorted in increasing order with respect
+       to the ordering [Ord.compare], where [Ord] is the argument
+       given to {!Set.Make}. *)
+
+    val min_elt: t -> elt
+    (** Return the smallest element of the given set
+       (with respect to the [Ord.compare] ordering), or raise
+       [Not_found] if the set is empty. *)
+
+    val max_elt: t -> elt
+    (** Same as {!Set.S.min_elt}, but returns the largest element of the
+       given set. *)
+
+    val choose: t -> elt
+    (** Return one element of the given set, or raise [Not_found] if
+       the set is empty. Which element is chosen is unspecified,
+       but equal elements will be chosen for equal sets. *)
+  end
+(** Output signature of the functor {!Set.Make}. *)
+
+module Make (Ord : OrderedType) : S with type elt = Ord.t
+(** Functor building an implementation of the set structure
+   given a totally ordered type. *)
diff --git a/stdlib/sort.ml b/stdlib/sort.ml
new file mode 100644
index 0000000000..6f74dbd0ed
--- /dev/null
+++ b/stdlib/sort.ml
@@ -0,0 +1,97 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Merging and sorting *)
+
+open Array
+
+let rec merge order l1 l2 =
+  match l1 with
+    [] -> l2
+  | h1 :: t1 ->
+      match l2 with
+        [] -> l1
+      | h2 :: t2 ->
+          if order h1 h2
+          then h1 :: merge order t1 l2
+          else h2 :: merge order l1 t2
+
+let list order l =
+  let rec initlist = function
+      [] -> []
+    | [e] -> [[e]]
+    | e1::e2::rest ->
+        (if order e1 e2 then [e1;e2] else [e2;e1]) :: initlist rest in
+  let rec merge2 = function
+      l1::l2::rest -> merge order l1 l2 :: merge2 rest
+    | x -> x in
+  let rec mergeall = function
+      [] -> []
+    | [l] -> l
+    | llist -> mergeall (merge2 llist) in
+  mergeall(initlist l)
+
+let swap arr i j =
+  let tmp = unsafe_get arr i in
+  unsafe_set arr i (unsafe_get arr j);
+  unsafe_set arr j tmp
+
+let array cmp arr =
+  let rec qsort lo hi =
+    if hi - lo >= 6 then begin
+      let mid = (lo + hi) lsr 1 in
+      (* Select median value from among LO, MID, and HI. Rearrange
+         LO and HI so the three values are sorted. This lowers the
+         probability of picking a pathological pivot.  It also
+         avoids extra comparisons on i and j in the two tight "while"
+         loops below. *)
+      if cmp (unsafe_get arr mid) (unsafe_get arr lo) then swap arr mid lo;
+      if cmp (unsafe_get arr hi) (unsafe_get arr mid) then begin
+        swap arr mid hi;
+        if cmp (unsafe_get arr mid) (unsafe_get arr lo) then swap arr mid lo
+      end;
+      let pivot = unsafe_get arr mid in
+      let i = ref (lo + 1) and j = ref (hi - 1) in
+      if not (cmp pivot (unsafe_get arr hi))
+         || not (cmp (unsafe_get arr lo) pivot)
+      then raise (Invalid_argument "Sort.array");
+      while !i < !j do
+        while not (cmp pivot (unsafe_get arr !i)) do incr i done;
+        while not (cmp (unsafe_get arr !j) pivot) do decr j done;
+        if !i < !j then swap arr !i !j;
+        incr i; decr j
+      done;
+      (* Recursion on smaller half, tail-call on larger half *)
+      if !j - lo <= hi - !i then begin
+        qsort lo !j; qsort !i hi
+      end else begin
+        qsort !i hi; qsort lo !j
+      end
+    end in
+  qsort 0 (Array.length arr - 1);
+  (* Finish sorting by insertion sort *)
+  for i = 1 to Array.length arr - 1 do
+    let val_i = (unsafe_get arr i) in
+    if not (cmp (unsafe_get arr (i - 1)) val_i) then begin
+      unsafe_set arr i (unsafe_get arr (i - 1));
+      let j = ref (i - 1) in
+      while !j >= 1 && not (cmp (unsafe_get arr (!j - 1)) val_i) do
+        unsafe_set arr !j (unsafe_get arr (!j - 1));
+        decr j
+      done;
+      unsafe_set arr !j val_i
+    end
+  done
+
diff --git a/stdlib/sort.mli b/stdlib/sort.mli
new file mode 100644
index 0000000000..2879edfe37
--- /dev/null
+++ b/stdlib/sort.mli
@@ -0,0 +1,42 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Sorting and merging lists.
+
+   @deprecated This module is obsolete and exists only for backward
+   compatibility.
+   The sorting functions in {!Array} and {!List} should be used instead.
+   The new functions are faster and use less memory.
+*)
+
+val list : ('a -> 'a -> bool) -> 'a list -> 'a list
+(** Sort a list in increasing order according to an ordering predicate.
+   The predicate should return [true] if its first argument is
+   less than or equal to its second argument. *)
+
+val array : ('a -> 'a -> bool) -> 'a array -> unit
+(** Sort an array in increasing order according to an
+   ordering predicate.
+   The predicate should return [true] if its first argument is
+   less than or equal to its second argument.
+   The array is sorted in place. *)
+
+val merge : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list
+(** Merge two lists according to the given predicate.
+   Assuming the two argument lists are sorted according to the
+   predicate, [merge] returns a sorted list containing the elements
+   from the two lists. The behavior is undefined if the two
+   argument lists were not sorted. *)
+
diff --git a/stdlib/stack.ml b/stdlib/stack.ml
new file mode 100644
index 0000000000..f49ed547fa
--- /dev/null
+++ b/stdlib/stack.ml
@@ -0,0 +1,40 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+type 'a t = { mutable c : 'a list }
+
+exception Empty
+
+let create () = { c = [] }
+
+let clear s = s.c <- []
+
+let copy s = { c = s.c }
+
+let push x s = s.c <- x :: s.c
+
+let pop s =
+  match s.c with
+    hd::tl -> s.c <- tl; hd
+  | []     -> raise Empty
+
+let top s =
+  match s.c with
+    hd::_ -> hd
+  | []     -> raise Empty
+
+let length s = List.length s.c
+
+let iter f s = List.iter f s.c
diff --git a/stdlib/stack.mli b/stdlib/stack.mli
new file mode 100644
index 0000000000..536dd55536
--- /dev/null
+++ b/stdlib/stack.mli
@@ -0,0 +1,55 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Last-in first-out stacks.
+
+   This module implements stacks (LIFOs), with in-place modification. 
+*)
+
+type 'a t
+(** The type of stacks containing elements of type ['a]. *)
+
+exception Empty
+(** Raised when {!Stack.pop} or {!Stack.top} is applied to an empty stack. *)
+
+
+val create : unit -> 'a t
+(** Return a new stack, initially empty. *)
+
+val push : 'a -> 'a t -> unit
+(** [push x s] adds the element [x] at the top of stack [s]. *)
+
+val pop : 'a t -> 'a
+(** [pop s] removes and returns the topmost element in stack [s],
+   or raises [Empty] if the stack is empty. *)
+
+val top : 'a t -> 'a
+(** [top s] returns the topmost element in stack [s],
+   or raises [Empty] if the stack is empty. *)
+
+val clear : 'a t -> unit
+(** Discard all elements from a stack. *)
+
+val copy : 'a t -> 'a t
+(** Return a copy of the given stack. *)
+
+val length : 'a t -> int
+(** Return the number of elements in a stack. *)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** [iter f s] applies [f] in turn to all elements of [s],
+   from the element at the top of the stack to the element at the
+   bottom of the stack. The stack itself is unchanged. *)
+
diff --git a/stdlib/stdLabels.ml b/stdlib/stdLabels.ml
new file mode 100644
index 0000000000..bd6a5841de
--- /dev/null
+++ b/stdlib/stdLabels.ml
@@ -0,0 +1,22 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*               Jacques Garrigue, Kyoto University RIMS               *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Module [StdLabels]: meta-module for labelled libraries *)
+
+module Array = ArrayLabels
+
+module List = ListLabels
+
+module String = StringLabels
diff --git a/stdlib/stdLabels.mli b/stdlib/stdLabels.mli
new file mode 100644
index 0000000000..08ec70f5a8
--- /dev/null
+++ b/stdlib/stdLabels.mli
@@ -0,0 +1,136 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*               Jacques Garrigue, Kyoto University RIMS               *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Standard labeled libraries.
+
+   This meta-module provides labelized version of the {!Array},
+   {!List} and {!String} modules.
+
+   They only differ by their labels. Detailed interfaces can be found
+   in [arrayLabels.mli], [listLabels.mli] and [stringLabels.mli].
+*)
+
+module Array :
+  sig
+    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 = "make_vect"
+    external create : int -> 'a -> 'a array = "make_vect"
+    val init : int -> f:(int -> 'a) -> 'a array
+    val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array
+    val create_matrix : dimx:int -> dimy:int -> 'a -> 'a array array
+    val append : 'a array -> 'a array -> 'a array
+    val concat : 'a array list -> 'a array
+    val sub : 'a array -> pos:int -> len:int -> 'a array
+    val copy : 'a array -> 'a array
+    val fill : 'a array -> pos:int -> len:int -> 'a -> unit
+    val blit :
+      src:'a array -> src_pos:int -> dst:'a array -> dst_pos:int -> len:int ->
+        unit
+    val to_list : 'a array -> 'a list
+    val of_list : 'a list -> 'a array
+    val iter : f:('a -> unit) -> 'a array -> unit
+    val map : f:('a -> 'b) -> 'a array -> 'b array
+    val iteri : f:(int -> 'a -> unit) -> 'a array -> unit
+    val mapi : f:(int -> 'a -> 'b) -> 'a array -> 'b array
+    val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b array -> 'a
+    val fold_right : f:('a -> 'b -> 'b) -> 'a array -> init:'b -> 'b
+    val sort : cmp:('a -> 'a -> int) -> 'a array -> unit
+    val stable_sort : cmp:('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
+
+module List :
+  sig
+    val length : 'a list -> int
+    val hd : 'a list -> 'a
+    val tl : 'a list -> 'a list
+    val nth : 'a list -> int -> 'a
+    val rev : 'a list -> 'a list
+    val append : 'a list -> 'a list -> 'a list
+    val rev_append : 'a list -> 'a list -> 'a list
+    val concat : 'a list list -> 'a list
+    val flatten : 'a list list -> 'a list
+    val iter : f:('a -> unit) -> 'a list -> unit
+    val map : f:('a -> 'b) -> 'a list -> 'b list
+    val rev_map : f:('a -> 'b) -> 'a list -> 'b list
+    val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b list -> 'a
+    val fold_right : f:('a -> 'b -> 'b) -> 'a list -> init:'b -> 'b
+    val iter2 : f:('a -> 'b -> unit) -> 'a list -> 'b list -> unit
+    val map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+    val rev_map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+    val fold_left2 :
+      f:('a -> 'b -> 'c -> 'a) -> init:'a -> 'b list -> 'c list -> 'a
+    val fold_right2 :
+      f:('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> init:'c -> 'c
+    val for_all : f:('a -> bool) -> 'a list -> bool
+    val exists : f:('a -> bool) -> 'a list -> bool
+    val for_all2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+    val exists2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+    val mem : 'a -> set:'a list -> bool
+    val memq : 'a -> set:'a list -> bool
+    val find : f:('a -> bool) -> 'a list -> 'a
+    val filter : f:('a -> bool) -> 'a list -> 'a list
+    val find_all : f:('a -> bool) -> 'a list -> 'a list
+    val partition : f:('a -> bool) -> 'a list -> 'a list * 'a list
+    val assoc : 'a -> ('a * 'b) list -> 'b
+    val assq : 'a -> ('a * 'b) list -> 'b
+    val mem_assoc : 'a -> map:('a * 'b) list -> bool
+    val mem_assq : 'a -> map:('a * 'b) list -> bool
+    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
+    val combine : 'a list -> 'b list -> ('a * 'b) list
+    val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
+    val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
+  end
+
+module String :
+  sig
+    external length : string -> int = "%string_length"
+    external get : string -> int -> char = "%string_safe_get"
+    external set : string -> int -> char -> unit = "%string_safe_set"
+    external create : int -> string = "create_string"
+    val make : int -> char -> string
+    val copy : string -> string
+    val sub : string -> pos:int -> len:int -> string
+    val fill : string -> pos:int -> len:int -> char -> unit
+    val blit :
+      src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int ->
+        unit
+    val concat : sep:string -> string list -> string
+    val iter : f:(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
+    external unsafe_get : string -> int -> char = "%string_unsafe_get"
+    external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set"
+    external unsafe_blit :
+      src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int ->
+        unit = "blit_string" "noalloc"
+    external unsafe_fill :
+      string -> pos:int -> len:int -> char -> unit = "fill_string" "noalloc"
+  end
diff --git a/stdlib/std_exit.ml b/stdlib/std_exit.ml
new file mode 100644
index 0000000000..6f5ff301aa
--- /dev/null
+++ b/stdlib/std_exit.ml
@@ -0,0 +1,18 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Ensure that [at_exit] functions are called at the end of every program *)
+
+let _ = do_at_exit()
diff --git a/stdlib/stream.ml b/stdlib/stream.ml
new file mode 100644
index 0000000000..c9975c4a01
--- /dev/null
+++ b/stdlib/stream.ml
@@ -0,0 +1,190 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                             Ocaml                                   *)
+(*                                                                     *)
+(*        Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt     *)
+(*                                                                     *)
+(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* The fields of type t are not mutable to preserve polymorphism of
+   the empty stream. This is type safe because the empty stream is never
+   patched. *)
+
+type 'a t = { count : int; data : 'a data }
+and 'a data =
+    Sempty
+  | Scons of 'a * 'a data
+  | Sapp of 'a data * 'a data
+  | Slazy of (unit -> 'a data)
+  | Sgen of 'a gen
+  | Sbuffio of buffio
+and 'a gen = { mutable curr : 'a option option; func : int -> 'a option }
+and buffio =
+  { ic : in_channel; buff : string; mutable len : int; mutable ind : int }
+;;
+exception Failure;;
+exception Error of string;;
+
+external count : 'a t -> int = "%field0";;
+external set_count : 'a t -> int -> unit = "%setfield0";;
+let set_data (s : 'a t) (d : 'a data) =
+  Obj.set_field (Obj.repr s) 1 (Obj.repr d)
+;;
+
+let fill_buff b =
+  b.len <- input b.ic b.buff 0 (String.length b.buff); b.ind <- 0
+;;
+
+let rec get_data =
+  function
+    Sempty -> None
+  | Scons (a, d) -> Some (a, d)
+  | Sapp (d1, d2) ->
+      begin match get_data d1 with
+        Some (a, d1) -> Some (a, Sapp (d1, d2))
+      | None -> get_data d2
+      end
+  | Slazy f ->
+      begin match f () with
+        Sgen _ | Sbuffio _ -> failwith "illegal stream concatenation"
+      | x -> get_data x
+      end
+  | Sgen _ | Sbuffio _ ->
+      failwith "illegal stream concatenation"
+;;
+
+let rec peek s =
+  match s.data with
+    Sempty -> None
+  | Scons (a, _) -> Some a
+  | Sapp (_, _) ->
+      begin match get_data s.data with
+        Some (a, d) -> set_data s (Scons (a, d)); Some a
+      | None -> None
+      end
+  | Slazy f ->
+      begin match f () with
+        Sgen _ | Sbuffio _ -> failwith "illegal stream concatenation"
+      | d -> set_data s d; peek s
+      end
+  | Sgen {curr = Some a} -> a
+  | Sgen g -> let x = g.func s.count in g.curr <- Some x; x
+  | Sbuffio b ->
+      if b.ind >= b.len then fill_buff b;
+      if b.len == 0 then begin set_data s Sempty; None end
+      else Some (Obj.magic (String.unsafe_get b.buff b.ind))
+;;
+
+let rec junk s =
+  match s.data with
+    Scons (_, d) -> set_count s (succ s.count); set_data s d
+  | Sgen ({curr = Some _} as g) -> set_count s (succ s.count); g.curr <- None
+  | Sbuffio b -> set_count s (succ s.count); b.ind <- succ b.ind
+  | _ ->
+      match peek s with
+        None -> ()
+      | Some _ -> junk s
+;;
+
+let rec nget n s =
+  if n <= 0 then [], s.data, 0
+  else
+    match peek s with
+      Some a ->
+        junk s;
+        let (al, d, k) = nget (pred n) s in a :: al, Scons (a, d), succ k
+    | None -> [], s.data, 0
+;;
+
+let npeek n s =
+  let (al, d, len) = nget n s in set_count s (s.count - len); set_data s d; al
+;;
+
+let next s =
+  match peek s with
+    Some a -> junk s; a
+  | None -> raise Failure
+;;
+
+let empty s =
+  match peek s with
+    Some _ -> raise Failure
+  | None -> ()
+;;
+
+let iter f strm =
+  let rec do_rec () =
+    match peek strm with
+      Some a -> junk strm; ignore(f a); do_rec ()
+    | None -> ()
+  in
+  do_rec ()
+;;
+
+(* Stream building functions *)
+
+let from f = {count = 0; data = Sgen {curr = None; func = f}};;
+
+let of_list l =
+  {count = 0; data = List.fold_right (fun x l -> Scons (x, l)) l Sempty}
+;;
+
+let of_string s =
+  from (fun c -> if c < String.length s then Some s.[c] else None)
+;;
+
+let of_channel ic =
+  {count = 0;
+   data = Sbuffio {ic = ic; buff = String.create 4096; len = 0; ind = 0}}
+;;
+
+(* Stream expressions builders *)
+
+let iapp i s = {count = 0; data = Sapp (i.data, s.data)};;
+let icons i s = {count = 0; data = Scons (i, s.data)};;
+let ising i = {count = 0; data = Scons (i, Sempty)};;
+
+let lapp f s =
+  {count = 0; data = Slazy (fun _ -> Sapp ((f ()).data, s.data))}
+;;
+let lcons f s = {count = 0; data = Slazy (fun _ -> Scons (f (), s.data))};;
+let lsing f = {count = 0; data = Slazy (fun _ -> Scons (f (), Sempty))};;
+
+let sempty = {count = 0; data = Sempty};;
+let slazy f = {count = 0; data = Slazy (fun _ -> (f ()).data)};;
+
+(* For debugging use *)
+
+let rec dump f s =
+  print_string "{count = ";
+  print_int s.count;
+  print_string "; data = ";
+  dump_data f s.data;
+  print_string "}";
+  print_newline ()
+and dump_data f =
+  function
+    Sempty -> print_string "Sempty"
+  | Scons (a, d) ->
+      print_string "Scons (";
+      f a;
+      print_string ", ";
+      dump_data f d;
+      print_string ")"
+  | Sapp (d1, d2) ->
+      print_string "Sapp (";
+      dump_data f d1;
+      print_string ", ";
+      dump_data f d2;
+      print_string ")"
+  | Slazy f -> print_string "Slazy"
+  | Sgen _ -> print_string "Sgen"
+  | Sbuffio b -> print_string "Sbuffio"
+;;
diff --git a/stdlib/stream.mli b/stdlib/stream.mli
new file mode 100644
index 0000000000..13396df441
--- /dev/null
+++ b/stdlib/stream.mli
@@ -0,0 +1,106 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                             Ocaml                                   *)
+(*                                                                     *)
+(*        Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt     *)
+(*                                                                     *)
+(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Streams and parsers. *)
+
+type 'a t
+(** The type of streams holding values of type ['a]. *)
+
+exception Failure
+(** Raised by parsers when none of the first components of the stream
+   patterns is accepted. *)
+
+exception Error of string
+(** Raised by parsers when the first component of a stream pattern is
+   accepted, but one of the following components is rejected. *)
+
+
+(** {6 Stream builders}
+
+   Warning: these functions create streams with fast access; it is illegal
+   to mix them with streams built with [[< >]]; would raise [Failure]
+   when accessing such mixed streams. 
+*)
+
+val from : (int -> 'a option) -> 'a t
+(** [Stream.from f] returns a stream built from the function [f].
+   To create a new stream element, the function [f] is called with
+   the current stream count. The user function [f] must return either
+   [Some <value>] for a value or [None] to specify the end of the
+   stream. *)
+
+val of_list : 'a list -> 'a t
+(** Return the stream holding the elements of the list in the same
+   order. *)
+
+val of_string : string -> char t
+(** Return the stream of the characters of the string parameter. *)
+
+val of_channel : in_channel -> char t
+(** Return the stream of the characters read from the input channel. *)
+
+
+(** {6 Stream iterator} *)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** [Stream.iter f s] scans the whole stream s, applying function [f]
+   in turn to each stream element encountered. *)
+
+
+(** {6 Predefined parsers} *)
+
+val next : 'a t -> 'a
+(** Return the first element of the stream and remove it from the
+   stream. Raise Stream.Failure if the stream is empty. *)
+
+val empty : 'a t -> unit
+(** Return [()] if the stream is empty, else raise [Stream.Failure]. *)
+
+
+(** {6 Useful functions} *)
+
+val peek : 'a t -> 'a option
+(** Return [Some] of "the first element" of the stream, or [None] if
+   the stream is empty. *)
+
+val junk : 'a t -> unit
+(** Remove the first element of the stream, possibly unfreezing
+   it before. *)
+
+val count : 'a t -> int
+(** Return the current count of the stream elements, i.e. the number
+   of the stream elements discarded. *)
+
+val npeek : int -> 'a t -> 'a list
+(** [npeek n] returns the list of the [n] first elements of
+   the stream, or all its remaining elements if less than [n]
+   elements are available. *)
+
+(**/**)
+
+(** {6 For system use only, not for the casual user} *)
+
+val iapp : 'a t -> 'a t -> 'a t
+val icons : 'a -> 'a t -> 'a t
+val ising : 'a -> 'a t
+
+val lapp : (unit -> 'a t) -> 'a t -> 'a t
+val lcons : (unit -> 'a) -> 'a t -> 'a t
+val lsing : (unit -> 'a) -> 'a t
+
+val sempty : 'a t
+val slazy : (unit -> 'a t) -> 'a t
+
+val dump : ('a -> unit) -> 'a t -> unit
diff --git a/stdlib/string.ml b/stdlib/string.ml
new file mode 100644
index 0000000000..1913464a85
--- /dev/null
+++ b/stdlib/string.ml
@@ -0,0 +1,173 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* String operations *)
+
+external length : string -> int = "%string_length"
+external get : string -> int -> char = "%string_safe_get"
+external set : string -> int -> char -> unit = "%string_safe_set"
+external create : int -> string = "create_string"
+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
+                     = "blit_string" "noalloc"
+external unsafe_fill : string -> int -> int -> char -> unit
+                     = "fill_string" "noalloc"
+
+let make n c =
+  let s = create n in
+  unsafe_fill s 0 n c;
+  s
+
+let copy s =
+  let len = length s in
+  let r = create len in
+  unsafe_blit s 0 r 0 len;
+  r
+
+let sub s ofs len =
+  if ofs < 0 || len < 0 || ofs + len > length s
+  then invalid_arg "String.sub"
+  else begin
+    let r = create len in
+    unsafe_blit s ofs r 0 len;
+    r
+  end
+
+let fill s ofs len c =
+  if ofs < 0 || len < 0 || ofs + len > length s
+  then invalid_arg "String.fill"
+  else unsafe_fill s ofs len c
+
+let blit s1 ofs1 s2 ofs2 len =
+  if len < 0 || ofs1 < 0 || ofs1 + len > length s1
+             || ofs2 < 0 || ofs2 + len > length s2
+  then invalid_arg "String.blit"
+  else unsafe_blit s1 ofs1 s2 ofs2 len
+
+let iter f a =
+  for i = 0 to length a - 1 do f(unsafe_get a i) done
+
+let concat sep l =
+  match l with
+    [] -> ""
+  | hd :: tl ->
+      let num = ref 0 and len = ref 0 in
+      List.iter (fun s -> incr num; len := !len + length s) l;
+      let r = create (!len + length sep * (!num - 1)) in
+      unsafe_blit hd 0 r 0 (length hd);
+      let pos = ref(length hd) in
+      List.iter
+        (fun s ->
+          unsafe_blit sep 0 r !pos (length sep);
+          pos := !pos + length sep;
+          unsafe_blit s 0 r !pos (length s);
+          pos := !pos + length s)
+        tl;
+      r
+
+external is_printable: char -> bool = "is_printable"
+external char_code: char -> int = "%identity"
+external char_chr: int -> char = "%identity"
+
+let escaped s =
+  let n = ref 0 in
+    for i = 0 to length s - 1 do
+      n := !n +
+        (match unsafe_get s i with
+           '"' | '\\' | '\n' | '\t' -> 2
+          | c -> if is_printable c then 1 else 4)
+    done;
+    if !n = length s then s else begin
+      let s' = create !n in
+        n := 0;
+        for i = 0 to length s - 1 do
+          begin
+            match unsafe_get s i with
+              ('"' | '\\') as c ->
+                unsafe_set s' !n '\\'; incr n; unsafe_set s' !n c
+            | '\n' ->
+                unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'n'
+            | '\t' ->
+                unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 't'
+            | c ->
+                if is_printable c then
+                  unsafe_set s' !n c
+                else begin
+                  let a = char_code c in
+                  unsafe_set s' !n '\\';
+                  incr n;
+                  unsafe_set s' !n (char_chr (48 + a / 100));
+                  incr n;
+                  unsafe_set s' !n (char_chr (48 + (a / 10) mod 10));
+                  incr n;
+                  unsafe_set s' !n (char_chr (48 + a mod 10))
+                end
+          end;
+          incr n
+        done;
+        s'
+      end
+
+let map f s =
+  let l = length s in
+  if l = 0 then s else begin
+    let r = create l in
+    for i = 0 to l - 1 do unsafe_set r i (f(unsafe_get s i)) done;
+    r
+  end
+
+let uppercase s = map Char.uppercase s
+let lowercase s = map Char.lowercase s
+
+let apply1 f s =
+  if length s = 0 then s else begin
+    let r = copy s in
+    unsafe_set r 0 (f(unsafe_get s 0));
+    r
+  end
+
+let capitalize s = apply1 Char.uppercase s
+let uncapitalize s = apply1 Char.lowercase s
+
+let rec index_rec s lim i c =
+  if i >= lim then raise Not_found else
+  if unsafe_get s i = c then i else index_rec s lim (i+1) c;;
+
+let index s c = index_rec s (length s) 0 c;;
+
+let index_from s i c =
+  if i < 0 || i > length s then invalid_arg "String.index_from" else
+  index_rec s (length s) i c;;
+
+let rec rindex_rec s i c =
+  if i < 0 then raise Not_found else
+  if unsafe_get s i = c then i else rindex_rec s (i-1) c;;
+
+let rindex s c = rindex_rec s (length s - 1) c;;
+
+let rindex_from s i c =
+  if i < -1 || i >= length s then invalid_arg "String.rindex_from" else
+  rindex_rec s i c;;
+
+let contains_from s i c =
+  if i < 0 || i > length s then invalid_arg "String.contains_from" else
+  try ignore(index_rec s (length s) i c); true with Not_found -> false;;
+
+let rcontains_from s i c =
+  if i < 0 || i >= length s then invalid_arg "String.rcontains_from" else
+  try ignore(rindex_rec s i c); true with Not_found -> false;;
+
+let contains s c = contains_from s 0 c;;
diff --git a/stdlib/string.mli b/stdlib/string.mli
new file mode 100644
index 0000000000..ebd4a1a174
--- /dev/null
+++ b/stdlib/string.mli
@@ -0,0 +1,152 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** String operations. *)
+
+external length : string -> int = "%string_length"
+(** Return the length (number of characters) of the given string. *)
+
+external get : string -> int -> char = "%string_safe_get"
+(** [String.get s n] returns character number [n] in string [s].
+   The first character is character number 0.
+   The last character is character number [String.length s - 1].
+   Raise [Invalid_argument] if [n] is outside the range
+   0 to [(String.length s - 1)].
+   You can also write [s.[n]] instead of [String.get s n]. *)
+
+external set : string -> int -> char -> unit = "%string_safe_set"
+(** [String.set s n c] modifies string [s] in place,
+   replacing the character number [n] by [c].
+   Raise [Invalid_argument] if [n] is outside the range
+   0 to [(String.length s - 1)].
+   You can also write [s.[n] <- c] instead of [String.set s n c]. *)
+
+external create : int -> string = "create_string"
+(** [String.create n] returns a fresh string of length [n].
+   The string initially contains arbitrary characters.
+   Raise [Invalid_argument] if [n < 0] or [n > Sys.max_string_length].
+*)
+
+val make : int -> char -> string
+(** [String.make n c] returns a fresh string of length [n],
+   filled with the character [c].
+   Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.*)
+
+val copy : string -> string
+(** Return a copy of the given string. *)
+
+val sub : string -> int -> int -> string
+(** [String.sub s start len] returns a fresh string of length [len],
+   containing the characters number [start] to [start + len - 1]
+   of string [s].
+   Raise [Invalid_argument] if [start] and [len] do not
+   designate a valid substring of [s]; that is, if [start < 0],
+   or [len < 0], or [start + len > ]{!String.length}[ s]. *)
+
+val fill : string -> int -> int -> char -> unit
+(** [String.fill s start len c] modifies string [s] in place,
+   replacing the characters number [start] to [start + len - 1]
+   by [c].
+   Raise [Invalid_argument] if [start] and [len] do not
+   designate a valid substring of [s]. *)
+
+val blit : string -> int -> string -> int -> int -> unit
+(** [String.blit src srcoff dst dstoff len] copies [len] characters
+   from string [src], starting at character number [srcoff], to
+   string [dst], starting at character number [dstoff]. It works
+   correctly even if [src] and [dst] are the same string,
+   and the source and destination chunks overlap.
+   Raise [Invalid_argument] if [srcoff] and [len] do not
+   designate a valid substring of [src], or if [dstoff] and [len]
+   do not designate a valid substring of [dst]. *)
+
+val concat : string -> string list -> string
+(** [String.concat sep sl] concatenates the list of strings [sl],
+   inserting the separator string [sep] between each. *)
+
+val iter : (char -> unit) -> string -> unit
+(** [String.iter f s] applies function [f] in turn to all
+   the characters of [s].  It is equivalent to
+   [f s.(0); f s.(1); ...; f s.(String.length s - 1); ()]. *)
+
+val escaped : string -> string
+(** Return a copy of the argument, with special characters
+   represented by escape sequences, following the lexical
+   conventions of Objective Caml.  If there is no special
+   character in the argument, return the original string itself,
+   not a copy. *)
+
+val index : string -> char -> int
+(** [String.index s c] returns the position of the leftmost
+   occurrence of character [c] in string [s].
+   Raise [Not_found] if [c] does not occur in [s]. *)
+
+val rindex : string -> char -> int
+(** [String.rindex s c] returns the position of the rightmost
+   occurrence of character [c] in string [s].
+   Raise [Not_found] if [c] does not occur in [s]. *)
+
+val index_from : string -> int -> char -> int
+(** Same as {!String.index}, but start
+   searching at the character position given as second argument.
+   [String.index s c] is equivalent to [String.index_from s 0 c].*)
+
+val rindex_from : string -> int -> char -> int
+(** Same as {!String.rindex}, but start
+   searching at the character position given as second argument.
+   [String.rindex s c] is equivalent to
+   [String.rindex_from s (String.length s - 1) c]. *)
+
+val contains : string -> char -> bool
+(** [String.contains s c] tests if character [c]
+   appears in the string [s]. *)
+
+val contains_from : string -> int -> char -> bool
+(** [String.contains_from s start c] tests if character [c]
+   appears in the substring of [s] starting from [start] to the end
+   of [s].
+   Raise [Invalid_argument] if [start] is not a valid index of [s]. *)
+
+val rcontains_from : string -> int -> char -> bool
+(** [String.rcontains_from s stop c] tests if character [c]
+   appears in the substring of [s] starting from the beginning
+   of [s] to index [stop].
+   Raise [Invalid_argument] if [stop] is not a valid index of [s]. *)
+
+val uppercase : string -> string
+(** Return a copy of the argument, with all lowercase letters
+   translated to uppercase, including accented letters of the ISO
+   Latin-1 (8859-1) character set. *)
+
+val lowercase : string -> string
+(** Return a copy of the argument, with all uppercase letters
+   translated to lowercase, including accented letters of the ISO
+   Latin-1 (8859-1) character set. *)
+
+val capitalize : string -> string
+(** Return a copy of the argument, with the first letter set to uppercase. *)
+
+val uncapitalize : string -> string
+(** Return a copy of the argument, with the first letter set to lowercase. *)
+
+
+(**/**)
+
+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 = "blit_string" "noalloc"
+external unsafe_fill :
+  string -> int -> int -> char -> unit = "fill_string" "noalloc"
diff --git a/stdlib/stringLabels.ml b/stdlib/stringLabels.ml
new file mode 100644
index 0000000000..63f75a2088
--- /dev/null
+++ b/stdlib/stringLabels.ml
@@ -0,0 +1,18 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*               Jacques Garrigue, Kyoto University RIMS               *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Module [SringLabels]: labelled String module *)
+
+include String
diff --git a/stdlib/stringLabels.mli b/stdlib/stringLabels.mli
new file mode 100644
index 0000000000..884690e462
--- /dev/null
+++ b/stdlib/stringLabels.mli
@@ -0,0 +1,154 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** String operations. *)
+
+external length : string -> int = "%string_length"
+(** Return the length (number of characters) of the given string. *)
+
+external get : string -> int -> char = "%string_safe_get"
+(** [String.get s n] returns character number [n] in string [s].
+   The first character is character number 0.
+   The last character is character number [String.length s - 1].
+   Raise [Invalid_argument] if [n] is outside the range
+   0 to [(String.length s - 1)].
+   You can also write [s.[n]] instead of [String.get s n]. *)
+
+external set : string -> int -> char -> unit = "%string_safe_set"
+(** [String.set s n c] modifies string [s] in place,
+   replacing the character number [n] by [c].
+   Raise [Invalid_argument] if [n] is outside the range
+   0 to [(String.length s - 1)].
+   You can also write [s.[n] <- c] instead of [String.set s n c]. *)
+
+external create : int -> string = "create_string"
+(** [String.create n] returns a fresh string of length [n].
+   The string initially contains arbitrary characters.
+   Raise [Invalid_argument] if [n < 0] or [n > Sys.max_string_length].
+*)
+
+val make : int -> char -> string
+(** [String.make n c] returns a fresh string of length [n],
+   filled with the character [c].
+   Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.*)
+
+val copy : string -> string
+(** Return a copy of the given string. *)
+
+val sub : string -> pos:int -> len:int -> string
+(** [String.sub s start len] returns a fresh string of length [len],
+   containing the characters number [start] to [start + len - 1]
+   of string [s].
+   Raise [Invalid_argument] if [start] and [len] do not
+   designate a valid substring of [s]; that is, if [start < 0],
+   or [len < 0], or [start + len > ]{!StringLabels.length}[ s]. *)
+
+val fill : string -> pos:int -> len:int -> char -> unit
+(** [String.fill s start len c] modifies string [s] in place,
+   replacing the characters number [start] to [start + len - 1]
+   by [c].
+   Raise [Invalid_argument] if [start] and [len] do not
+   designate a valid substring of [s]. *)
+
+val blit :
+  src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int -> unit
+(** [String.blit src srcoff dst dstoff len] copies [len] characters
+   from string [src], starting at character number [srcoff], to
+   string [dst], starting at character number [dstoff]. It works
+   correctly even if [src] and [dst] are the same string,
+   and the source and destination chunks overlap.
+   Raise [Invalid_argument] if [srcoff] and [len] do not
+   designate a valid substring of [src], or if [dstoff] and [len]
+   do not designate a valid substring of [dst]. *)
+
+val concat : sep:string -> string list -> string
+(** [String.concat sep sl] concatenates the list of strings [sl],
+   inserting the separator string [sep] between each. *)
+
+val iter : f:(char -> unit) -> string -> unit
+(** [String.iter f s] applies function [f] in turn to all
+   the characters of [s].  It is equivalent to
+   [f s.(0); f s.(1); ...; f s.(String.length s - 1); ()]. *)
+
+val escaped : string -> string
+(** Return a copy of the argument, with special characters
+   represented by escape sequences, following the lexical
+   conventions of Objective Caml.  If there is no special
+   character in the argument, return the original string itself,
+   not a copy. *)
+
+val index : string -> char -> int
+(** [String.index s c] returns the position of the leftmost
+   occurrence of character [c] in string [s].
+   Raise [Not_found] if [c] does not occur in [s]. *)
+
+val rindex : string -> char -> int
+(** [String.rindex s c] returns the position of the rightmost
+   occurrence of character [c] in string [s].
+   Raise [Not_found] if [c] does not occur in [s]. *)
+
+val index_from : string -> int -> char -> int
+(** Same as {!StringLabels.index}, but start
+   searching at the character position given as second argument.
+   [String.index s c] is equivalent to [String.index_from s 0 c].*)
+
+val rindex_from : string -> int -> char -> int
+(** Same as {!StringLabels.rindex}, but start
+   searching at the character position given as second argument.
+   [String.rindex s c] is equivalent to
+   [String.rindex_from s (String.length s - 1) c]. *)
+
+val contains : string -> char -> bool
+(** [String.contains s c] tests if character [c]
+   appears in the string [s]. *)
+
+val contains_from : string -> int -> char -> bool
+(** [String.contains_from s start c] tests if character [c]
+   appears in the substring of [s] starting from [start] to the end
+   of [s].
+   Raise [Invalid_argument] if [start] is not a valid index of [s]. *)
+
+val rcontains_from : string -> int -> char -> bool
+(** [String.rcontains_from s stop c] tests if character [c]
+   appears in the substring of [s] starting from the beginning
+   of [s] to index [stop].
+   Raise [Invalid_argument] if [stop] is not a valid index of [s]. *)
+
+val uppercase : string -> string
+(** Return a copy of the argument, with all lowercase letters
+   translated to uppercase, including accented letters of the ISO
+   Latin-1 (8859-1) character set. *)
+
+val lowercase : string -> string
+(** Return a copy of the argument, with all uppercase letters
+   translated to lowercase, including accented letters of the ISO
+   Latin-1 (8859-1) character set. *)
+
+val capitalize : string -> string
+(** Return a copy of the argument, with the first letter set to uppercase. *)
+
+val uncapitalize : string -> string
+(** Return a copy of the argument, with the first letter set to lowercase. *)
+
+
+(**/**)
+
+external unsafe_get : string -> int -> char = "%string_unsafe_get"
+external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set"
+external unsafe_blit :
+  src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int ->
+    unit = "blit_string" "noalloc"
+external unsafe_fill :
+  string -> pos:int -> len:int -> char -> unit = "fill_string" "noalloc"
diff --git a/tools/Makefile b/tools/Makefile
new file mode 100644
index 0000000000..cb261330d8
--- /dev/null
+++ b/tools/Makefile
@@ -0,0 +1,239 @@
+#########################################################################
+#                                                                       #
+#                            Objective Caml                             #
+#                                                                       #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 1999 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+# $Id$
+
+include ../config/Makefile
+
+CAMLRUN=../boot/ocamlrun
+CAMLC=$(CAMLRUN) ../boot/ocamlc -I ../boot
+CAMLLEX=$(CAMLRUN) ../boot/ocamllex
+INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \
+         -I ../driver
+COMPFLAGS=$(INCLUDES)
+LINKFLAGS=$(INCLUDES)
+
+all: ocamldep ocamlprof ocamlcp ocamlmktop ocamlmklib scrapelabels addlabels
+
+# The dependency generator
+
+CAMLDEP_OBJ=ocamldep.cmo
+CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
+  linenum.cmo warnings.cmo location.cmo longident.cmo \
+  syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
+
+ocamldep: $(CAMLDEP_OBJ)
+	$(CAMLC) $(LINKFLAGS) -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ)
+
+clean::
+	rm -f ocamldep
+
+install::
+	cp ocamldep $(BINDIR)/ocamldep$(EXE)
+
+# The profiler
+
+CSLPROF=ocamlprof.cmo
+CSLPROF_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
+  linenum.cmo warnings.cmo location.cmo longident.cmo \
+  syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
+
+ocamlprof: $(CSLPROF) profiling.cmo
+	$(CAMLC) $(LINKFLAGS) -o ocamlprof $(CSLPROF_IMPORTS) $(CSLPROF)
+
+ocamlcp: ocamlcp.cmo
+	$(CAMLC) $(LINKFLAGS) -o ocamlcp main_args.cmo ocamlcp.cmo
+
+install::
+	cp ocamlprof $(BINDIR)/ocamlprof$(EXE)
+	cp ocamlcp $(BINDIR)/ocamlcp$(EXE)
+	cp profiling.cmi profiling.cmo $(LIBDIR)
+
+clean::
+	rm -f ocamlprof ocamlcp
+
+# To make custom toplevels
+
+ocamlmktop: ocamlmktop.tpl ../config/Makefile
+	sed -e 's|%%BINDIR%%|$(BINDIR)|' ocamlmktop.tpl > ocamlmktop
+	chmod +x ocamlmktop
+
+install::
+	cp ocamlmktop $(BINDIR)/ocamlmktop
+
+clean::
+	rm -f ocamlmktop
+
+# To help building mixed-mode libraries (Caml + C)
+
+ocamlmklib: ocamlmklib.cmo
+	$(CAMLC) $(LINKFLAGS) -o ocamlmklib ocamlmklib.cmo
+
+install::
+	cp ocamlmklib $(BINDIR)/ocamlmklib
+
+clean::
+	rm -f ocamlmklib
+
+ocamlmklib.ml: ocamlmklib.mlp ../config/Makefile
+	sed -e "s|%%BINDIR%%|$(BINDIR)|" \
+            -e "s|%%SUPPORTS_SHARED_LIBRARIES%%|$(SUPPORTS_SHARED_LIBRARIES)|" \
+            -e "s|%%MKSHAREDLIB%%|$(MKSHAREDLIB)|" \
+            -e "s|%%BYTECCRPATH%%|$(BYTECCRPATH)|" \
+            -e "s|%%NATIVECCRPATH%%|$(NATIVECCRPATH)|" \
+            -e "s|%%MKSHAREDLIBRPATH%%|$(MKSHAREDLIBRPATH)|" \
+            -e "s|%%RANLIB%%|$(RANLIB)|" \
+          ocamlmklib.mlp > ocamlmklib.ml
+
+beforedepend:: ocamlmklib.ml
+
+clean::
+	rm -f ocamlmklib.ml
+
+# Converter olabl/ocaml 2.99 to ocaml 3
+
+OCAML299TO3= lexer299.cmo ocaml299to3.cmo
+LIBRARY3= misc.cmo warnings.cmo linenum.cmo location.cmo
+
+ocaml299to3: $(OCAML299TO3)
+	$(CAMLC) $(LINKFLAGS) -o ocaml299to3 $(LIBRARY3) $(OCAML299TO3)
+
+lexer299.ml: lexer299.mll
+	$(CAMLLEX) lexer299.mll
+
+#install::
+#	cp ocaml299to3 $(BINDIR)/ocaml299to3$(EXE)
+
+clean::
+	rm -f ocaml299to3 lexer299.ml
+
+# Label remover for interface files (upgrade 3.02 to 3.03)
+
+SCRAPELABELS= lexer301.cmo scrapelabels.cmo
+
+scrapelabels: $(SCRAPELABELS)
+	$(CAMLC) $(LINKFLAGS) -o scrapelabels $(LIBRARY3) $(SCRAPELABELS)
+
+lexer301.ml: lexer301.mll
+	$(CAMLLEX) lexer301.mll
+
+install::
+	cp scrapelabels $(LIBDIR)
+
+clean::
+	rm -f scrapelabels lexer301.ml
+
+# Insert labels following an interface file (upgrade 3.02 to 3.03)
+
+ADDLABELS_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
+  linenum.cmo warnings.cmo location.cmo longident.cmo \
+  syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
+
+addlabels: addlabels.ml
+	$(CAMLC) $(LINKFLAGS) -w sl -o addlabels \
+		$(ADDLABELS_IMPORTS) addlabels.ml
+
+install::
+	cp addlabels $(LIBDIR)
+
+clean::
+	rm -f addlabels
+
+# The preprocessor for asm generators
+
+CVT_EMIT=cvt_emit.cmo
+
+cvt_emit: $(CVT_EMIT)
+	$(CAMLC) $(LINKFLAGS) -o cvt_emit $(CVT_EMIT)
+
+clean::
+	rm -f cvt_emit
+
+cvt_emit.ml: cvt_emit.mll
+	$(CAMLLEX) cvt_emit.mll
+
+clean::
+	rm -f cvt_emit.ml
+
+beforedepend:: cvt_emit.ml
+
+# The bytecode disassembler
+
+DUMPOBJ=opnames.cmo dumpobj.cmo
+
+dumpobj: $(DUMPOBJ)
+	$(CAMLC) $(LINKFLAGS) -o dumpobj \
+	         misc.cmo tbl.cmo config.cmo ident.cmo \
+	         opcodes.cmo bytesections.cmo $(DUMPOBJ)
+
+clean::
+	rm -f dumpobj
+
+opnames.ml: ../byterun/instruct.h
+	unset LC_ALL LC_CTYPE LC_COLLATE LANG; \
+	sed -e '/\/\*/d' \
+            -e '/^#/d' \
+            -e 's/enum \(.*\) {/let names_of_\1 = [|/' \
+            -e 's/};$$/ |]/' \
+            -e 's/\([A-Z][A-Z_0-9a-z]*\)/"\1"/g' \
+            -e 's/,/;/g' \
+        ../byterun/instruct.h > opnames.ml
+
+clean::
+	rm -f opnames.ml
+
+beforedepend:: opnames.ml
+
+# Dump .cmx files
+
+dumpapprox: dumpapprox.cmo
+	$(CAMLC) $(LINKFLAGS) -o dumpapprox config.cmo dumpapprox.cmo
+
+clean::
+	rm -f dumpapprox
+
+# Print imported interfaces for .cmo files
+
+objinfo: objinfo.cmo
+	$(CAMLC) $(LINKFLAGS) -o objinfo config.cmo objinfo.cmo
+
+clean::
+	rm -f objinfo
+
+# Scan object files for required primitives
+
+PRIMREQ=primreq.cmo
+
+primreq: $(PRIMREQ)
+	$(CAMLC) $(LINKFLAGS) -o primreq config.cmo $(PRIMREQ)
+
+clean::
+	rm -f primreq
+
+# Common stuff
+
+.SUFFIXES:
+.SUFFIXES: .ml .cmo .mli .cmi
+
+.ml.cmo:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.mli.cmi:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+clean::
+	rm -f *.cmo *.cmi
+
+depend: beforedepend
+	$(CAMLRUN) ./ocamldep $(INCLUDES) *.mli *.ml > .depend
+
+include .depend
diff --git a/tools/Makefile.Mac b/tools/Makefile.Mac
new file mode 100644
index 0000000000..5bba175db9
--- /dev/null
+++ b/tools/Makefile.Mac
@@ -0,0 +1,137 @@
+#########################################################################
+#                                                                       #
+#                            Objective Caml                             #
+#                                                                       #
+#            Damien Doligez, projet Para, INRIA Rocquencourt            #
+#                                                                       #
+#   Copyright 1999 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+# $Id$
+
+CAMLRUN = ::boot:ocamlrun
+CAMLC = "{CAMLRUN}" ::boot:ocamlc -I ::boot:
+CAMLLEX = "{CAMLRUN}" ::boot:ocamllex
+INCLUDES = -I ::utils: -I ::parsing: -I ::typing: -I ::bytecomp: -I ::asmcomp:
+COMPFLAGS = {INCLUDES}
+LINKFLAGS = {INCLUDES}
+
+all Ä ocamldep ocamldumpobj objinfo primreq keywords
+
+# The dependency generator
+
+CAMLDEP_IMPORTS = misc.cmo config.cmo clflags.cmo terminfo.cmo ¶
+   linenum.cmo warnings.cmo location.cmo longident.cmo ¶
+   syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
+
+CAMLDEP = ocamldep.cmo
+
+ocamldep Ä {CAMLDEP}
+    {CAMLC} {LINKFLAGS} -o ocamldep {CAMLDEP_IMPORTS} {CAMLDEP}
+
+clean ÄÄ
+    delete -i ocamldep
+
+install ÄÄ
+    duplicate -y ocamldep "{BINDIR}ocamldep"
+
+# The profiler  (not available on MacOS for the moment)
+#
+#CSLPROF = ocamlprof.cmo
+#CSLPROF_IMPORTS = misc.cmo config.cmo clflags.cmo terminfo.cmo ¶
+#  linenum.cmo warnings.cmo location.cmo longident.cmo pstream.cmo ¶
+#  syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
+#
+#ocamlprof Ä {CSLPROF} profiling.cmo
+#   {CAMLC} {LINKFLAGS} -o ocamlprof {CSLPROF_IMPORTS} {CSLPROF}
+#
+#install ÄÄ
+#   duplicate -y ocamlprof "{BINDIR}ocamlprof"
+#   duplicate -y ocamlcp "{BINDIR}ocamlcp"
+#   duplicate -y profiling.cmi profiling.cmo "{LIBDIR}"
+#
+#clean ÄÄ
+#   delete -i ocamlprof
+
+# To make custom toplevels
+
+install ÄÄ
+    duplicate -y ocamlmktop.tpl "{BINDIR}ocamlmktop"
+
+# The bytecode disassembler
+
+DUMPOBJ = opnames.cmo dumpobj.cmo
+
+ocamldumpobj Ä {DUMPOBJ}
+    {CAMLC} {LINKFLAGS} -o ocamldumpobj ¶
+            misc.cmo tbl.cmo config.cmo ident.cmo opcodes.cmo ¶
+            bytesections.cmo {DUMPOBJ}
+
+clean ÄÄ
+    delete -i ocamldumpobj
+
+install ÄÄ
+    duplicate -y ocamldumpobj "{BINDIR}ocamldumpobj"
+
+opnames.ml Ä ::byterun:instruct.h
+    streamedit -e '/¶/¶*/ delete' ¶
+           -e '/enum (Å)¨0 {/ replace // "let names_of_" ¨0 "= [|"' ¶
+           -e '/};°/ replace // "|]"' ¶
+           -e '/�([A-Z][A-Z_0-9a-z]*)¨0/ replace // "¶"" ¨0 "¶"" -c °' ¶
+           -e '/,/ replace // ";" -c °' ¶
+           ::byterun:instruct.h > opnames.ml
+
+clean ÄÄ
+    delete -i opnames.ml
+
+beforedepend ÄÄ opnames.ml
+
+# Dump .cmx files
+
+#dumpapprox Ä dumpapprox.cmo
+#    {CAMLC} {LINKFLAGS} -o dumpapprox config.cmo dumpapprox.cmo
+#
+#clean ÄÄ
+#    delete -i dumpapprox
+
+# Print imported interfaces for .cmo files
+
+objinfo Ä objinfo.cmo
+    {CAMLC} {LINKFLAGS} -o objinfo config.cmo objinfo.cmo
+
+clean ÄÄ
+    delete -i objinfo
+
+# Common stuff
+
+.cmo Ä .ml
+    {CAMLC} -c {COMPFLAGS} {depdir}{default}.ml
+
+.cmi Ä .mli
+    {CAMLC} -c {COMPFLAGS} {depdir}{default}.mli
+
+clean ÄÄ
+    delete -i Å.cm[io] || set status 0
+
+depend Ä beforedepend
+    {CAMLRUN} :ocamldep {INCLUDES} Å.mli Å.ml > Makefile.Mac.depend
+
+# Scan object files for required primitives
+
+primreq Ä primreq.cmo
+    {CAMLC} {LINKFLAGS} -o primreq config.cmo primreq.cmo
+ 
+clean ÄÄ
+    delete -i primreq
+
+
+# Resources for keyword-coloring for MPW Shell
+
+keywords Ä keywords.r
+    rez -t rsrc -c RSED -o keywords keywords.r
+
+clean ÄÄ
+    delete -i keywords
diff --git a/tools/dumpapprox.ml b/tools/dumpapprox.ml
new file mode 100644
index 0000000000..44d82d406b
--- /dev/null
+++ b/tools/dumpapprox.ml
@@ -0,0 +1,97 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Dump a .cmx file *)
+
+open Config
+open Format
+open Clambda
+open Compilenv
+
+let print_digest ppf d =
+  for i = 0 to String.length d - 1 do
+    print_string(Printf.sprintf "%02x" (Char.code d.[i]))
+  done
+
+let rec print_approx ppf = function
+    Value_closure(fundesc, approx) ->
+      printf "@[<2>function %s@ arity %i" fundesc.fun_label fundesc.fun_arity;
+      if fundesc.fun_closed then begin
+        printf "@ (closed)"
+      end;
+      if fundesc.fun_inline <> None then begin
+        printf "@ (inline)"
+      end;
+      printf "@ -> @ %a@]" print_approx approx
+  | Value_tuple approx ->
+      let tuple ppf approx =
+        for i = 0 to Array.length approx - 1 do
+          if i > 0 then printf ";@ ";
+          printf "%i: %a" i print_approx approx.(i)
+        done in
+      printf "@[<hov 1>%a@]" tuple approx
+  | Value_unknown ->
+      print_string "_"
+  | Value_integer n ->
+      print_int n
+  | Value_constptr n ->
+      print_int n; print_string "p"
+
+let print_name_crc (name, crc) =
+  printf "@ %s (%a)" name print_digest crc
+
+let print_infos (ui, crc) =
+  printf "Name: %s@." ui.ui_name;
+  printf "CRC of implementation: %a@." print_digest crc;
+  let pr_imports ppf imps = List.iter print_name_crc imps in
+  printf "@[<v 2>Interfaces imported:%a@]@." pr_imports ui.ui_imports_cmi;
+  printf "@[<v 2>Implementations imported:%a@]@." pr_imports ui.ui_imports_cmx;
+  printf "@[<v 2>Approximation:@ %a@]@." print_approx ui.ui_approx;
+  let pr_funs ppf fns =
+    List.iter (fun arity -> printf "@ %i" arity) fns in
+  printf "@[<2>Currying functions:%a@]@." pr_funs ui.ui_curry_fun;
+  printf "@[<2>Apply functions:%a@]@." pr_funs ui.ui_apply_fun
+
+let print_unit_info filename =
+  let ic = open_in_bin filename in
+  try
+    let buffer = String.create (String.length cmx_magic_number) in
+    really_input ic buffer 0 (String.length cmx_magic_number);
+    if buffer = cmx_magic_number then begin
+      let ui = (input_value ic : unit_infos) in
+      let crc = Digest.input ic in
+      close_in ic;
+      print_infos (ui, crc)
+    end else if buffer = cmxa_magic_number then begin
+      let li = (input_value ic : library_infos) in
+      close_in ic;
+      List.iter print_infos li.lib_units
+    end else begin
+      close_in ic;
+      prerr_endline "Wrong magic number";
+      exit 2
+    end
+  with End_of_file | Failure _ ->
+    close_in ic;
+    prerr_endline "Error reading file";
+    exit 2
+
+let main () =
+  print_unit_info Sys.argv.(1);
+  exit 0
+
+let _ = main ()
+
+
+    
diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml
new file mode 100644
index 0000000000..77ccacfeb2
--- /dev/null
+++ b/tools/dumpobj.ml
@@ -0,0 +1,534 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Disassembler for executable and .cmo object files *)
+
+open Obj
+open Printf
+open Config
+open Asttypes
+open Lambda
+open Emitcode
+open Opcodes
+open Instruct
+open Opnames
+
+(* Read signed and unsigned integers *)
+
+let inputu ic =
+  let b1 = input_byte ic in
+  let b2 = input_byte ic in
+  let b3 = input_byte ic in
+  let b4 = input_byte ic in
+  (b4 lsl 24) + (b3 lsl 16) + (b2 lsl 8) + b1
+
+let inputs ic =
+  let b1 = input_byte ic in
+  let b2 = input_byte ic in
+  let b3 = input_byte ic in
+  let b4 = input_byte ic in
+  let b4' = if b4 >= 128 then b4-256 else b4 in
+  (b4' lsl 24) + (b3 lsl 16) + (b2 lsl 8) + b1
+
+(* Global variables *)
+
+type global_table_entry =
+    Empty
+  | Global of Ident.t
+  | Constant of Obj.t
+
+let start = ref 0                              (* Position of beg. of code *)
+let reloc = ref ([] : (reloc_info * int) list) (* Relocation table *)
+let globals = ref ([||] : global_table_entry array) (* Global map *)
+let primitives = ref ([||] : string array)     (* Table of primitives *)
+let objfile = ref false                        (* true if dumping a .cmo *)
+
+(* Events (indexed by PC) *)
+
+let event_table = (Hashtbl.create 253 : (int, debug_event) Hashtbl.t)
+
+let relocate_event orig ev =
+  ev.ev_pos <- orig + ev.ev_pos;
+  match ev.ev_repr with
+    Event_parent repr -> repr := ev.ev_pos
+  | _                 -> ()
+
+let record_events orig evl =
+  List.iter 
+    (fun ev ->
+      relocate_event orig ev;
+      Hashtbl.add event_table ev.ev_pos ev)
+    evl
+
+(* Print a structured constant *)
+
+let print_float f =
+  if String.contains f '.'
+  then printf "%s" f
+  else printf "%s." f
+;;
+
+let rec print_struct_const = function
+    Const_base(Const_int i) ->
+      printf "%d" i
+  | Const_base(Const_float f) ->
+      print_float f
+  | Const_base(Const_string s) ->
+      printf "\"%s\"" (String.escaped s)
+  | Const_base(Const_char c) ->
+      printf "'%s'" (Char.escaped c)
+  | Const_pointer n ->
+      printf "%da" n
+  | Const_block(tag, args) ->
+      printf "<%d>" tag;
+      begin match args with
+        [] -> ()
+      | [a1] ->
+          printf "("; print_struct_const a1; printf ")"
+      | a1::al ->
+          printf "("; print_struct_const a1;
+          List.iter (fun a -> printf ", "; print_struct_const a) al;
+          printf ")"
+      end
+  | Const_float_array a ->
+      printf "[|";
+      List.iter (fun f -> print_float f; printf "; ") a;
+      printf "|]"
+
+(* Print an obj *)
+
+let rec print_obj x =
+  if Obj.is_block x then begin
+    match Obj.tag x with
+      252 ->                            (* string *)
+        printf "\"%s\"" (String.escaped (Obj.magic x : string))
+    | 253 ->                            (* float *)
+        printf "%.12g" (Obj.magic x : float)
+    | 254 ->                            (* float array *)
+        let a = (Obj.magic x : float array) in
+        printf "[|";
+        for i = 0 to Array.length a - 1 do
+          if i > 0 then printf ", ";
+          printf "%.12g" a.(i)
+        done;
+        printf "|]"
+    | _ ->
+        printf "<%d>" (Obj.tag x);
+        begin match Obj.size x with
+          0 -> ()
+        | 1 ->
+            printf "("; print_obj (Obj.field x 0); printf ")"
+        | n ->
+            printf "("; print_obj (Obj.field x 0);
+            for i = 1 to n - 1 do
+              printf ", "; print_obj (Obj.field x i)
+            done;
+            printf ")"
+        end
+  end else
+    printf "%d" (Obj.magic x : int)
+
+(* Current position in input file *)
+
+let currpos ic =
+  pos_in ic - !start
+
+(* Access in the relocation table *)
+
+let rec rassoc key = function
+    [] -> raise Not_found
+  | (a,b) :: l -> if b = key then a else rassoc key l
+
+let find_reloc ic =
+  rassoc (pos_in ic - !start) !reloc
+
+(* Symbolic printing of global names, etc *)
+
+let print_getglobal_name ic =
+  if !objfile then begin
+    begin try
+      match find_reloc ic with
+          Reloc_getglobal id -> print_string (Ident.name id)
+        | Reloc_literal sc -> print_struct_const sc
+        | _ -> print_string "<wrong reloc>"
+    with Not_found ->
+      print_string "<no reloc>"
+    end;
+    ignore (inputu ic);
+  end
+  else begin
+    let n = inputu ic in
+    if n >= Array.length !globals || n < 0
+    then print_string "<global table overflow>"
+    else match !globals.(n) with
+           Global id -> print_string(Ident.name id)
+         | Constant obj -> print_obj obj
+         | _ -> print_string "???"
+  end
+
+let print_setglobal_name ic =
+  if !objfile then begin
+    begin try
+      match find_reloc ic with
+        Reloc_setglobal id -> print_string (Ident.name id)
+      | _ -> print_string "<wrong reloc>"
+    with Not_found ->
+      print_string "<no reloc>"
+    end;
+    ignore (inputu ic);
+  end
+  else begin
+    let n = inputu ic in
+    if n >= Array.length !globals || n < 0
+    then print_string "<global table overflow>"
+    else match !globals.(n) with
+           Global id -> print_string(Ident.name id)
+         | _ -> print_string "???"
+  end
+
+let print_primitive ic =
+  if !objfile then begin
+    begin try
+      match find_reloc ic with
+        Reloc_primitive s -> print_string s
+      | _ -> print_string "<wrong reloc>"
+    with Not_found ->
+      print_string "<no reloc>"
+    end;
+    ignore (inputu ic);
+  end
+  else begin
+    let n = inputu ic in
+    if n >= Array.length !primitives || n < 0
+    then print_int n
+    else print_string !primitives.(n)
+  end
+
+(* Disassemble one instruction *)
+
+let currpc ic =
+  currpos ic / 4
+
+type shape =
+  | Nothing
+  | Uint
+  | Sint
+  | Uint_Uint
+  | Disp
+  | Uint_Disp
+  | Sint_Disp
+  | Getglobal
+  | Getglobal_Uint
+  | Setglobal
+  | Primitive
+  | Uint_Primitive
+  | Switch
+  | Closurerec
+;;
+
+let op_shapes = [
+  opACC0, Nothing;
+  opACC1, Nothing;
+  opACC2, Nothing;
+  opACC3, Nothing;
+  opACC4, Nothing;
+  opACC5, Nothing;
+  opACC6, Nothing;
+  opACC7, Nothing;
+  opACC, Uint;
+  opPUSH, Nothing;
+  opPUSHACC0, Nothing;
+  opPUSHACC1, Nothing;
+  opPUSHACC2, Nothing;
+  opPUSHACC3, Nothing;
+  opPUSHACC4, Nothing;
+  opPUSHACC5, Nothing;
+  opPUSHACC6, Nothing;
+  opPUSHACC7, Nothing;
+  opPUSHACC, Uint;
+  opPOP, Uint;
+  opASSIGN, Uint;
+  opENVACC1, Nothing;
+  opENVACC2, Nothing;
+  opENVACC3, Nothing;
+  opENVACC4, Nothing;
+  opENVACC, Uint;
+  opPUSHENVACC1, Nothing;
+  opPUSHENVACC2, Nothing;
+  opPUSHENVACC3, Nothing;
+  opPUSHENVACC4, Nothing;
+  opPUSHENVACC, Uint;
+  opPUSH_RETADDR, Disp;
+  opAPPLY, Uint;
+  opAPPLY1, Nothing;
+  opAPPLY2, Nothing;
+  opAPPLY3, Nothing;
+  opAPPTERM, Uint_Uint;
+  opAPPTERM1, Uint;
+  opAPPTERM2, Uint;
+  opAPPTERM3, Uint;
+  opRETURN, Uint;
+  opRESTART, Nothing;
+  opGRAB, Uint;
+  opCLOSURE, Uint_Disp;
+  opCLOSUREREC, Closurerec;
+  opOFFSETCLOSUREM2, Nothing;
+  opOFFSETCLOSURE0, Nothing;
+  opOFFSETCLOSURE2, Nothing;
+  opOFFSETCLOSURE, Sint;  (* was Uint *)
+  opPUSHOFFSETCLOSUREM2, Nothing;
+  opPUSHOFFSETCLOSURE0, Nothing;
+  opPUSHOFFSETCLOSURE2, Nothing;
+  opPUSHOFFSETCLOSURE, Sint; (* was Nothing *)
+  opGETGLOBAL, Getglobal;
+  opPUSHGETGLOBAL, Getglobal;
+  opGETGLOBALFIELD, Getglobal_Uint;
+  opPUSHGETGLOBALFIELD, Getglobal_Uint;
+  opSETGLOBAL, Setglobal;
+  opATOM0, Nothing;
+  opATOM, Uint;
+  opPUSHATOM0, Nothing;
+  opPUSHATOM, Uint;
+  opMAKEBLOCK, Uint_Uint;
+  opMAKEBLOCK1, Uint;
+  opMAKEBLOCK2, Uint;
+  opMAKEBLOCK3, Uint;
+  opMAKEFLOATBLOCK, Uint;
+  opGETFIELD0, Nothing;
+  opGETFIELD1, Nothing;
+  opGETFIELD2, Nothing;
+  opGETFIELD3, Nothing;
+  opGETFIELD, Uint;
+  opGETFLOATFIELD, Uint;
+  opSETFIELD0, Nothing;
+  opSETFIELD1, Nothing;
+  opSETFIELD2, Nothing;
+  opSETFIELD3, Nothing;
+  opSETFIELD, Uint;
+  opSETFLOATFIELD, Uint;
+  opVECTLENGTH, Nothing;
+  opGETVECTITEM, Nothing;
+  opSETVECTITEM, Nothing;
+  opGETSTRINGCHAR, Nothing;
+  opSETSTRINGCHAR, Nothing;
+  opBRANCH, Disp;
+  opBRANCHIF, Disp;
+  opBRANCHIFNOT, Disp;
+  opSWITCH, Switch;
+  opBOOLNOT, Nothing;
+  opPUSHTRAP, Disp;
+  opPOPTRAP, Nothing;
+  opRAISE, Nothing;
+  opCHECK_SIGNALS, Nothing;
+  opC_CALL1, Primitive;
+  opC_CALL2, Primitive;
+  opC_CALL3, Primitive;
+  opC_CALL4, Primitive;
+  opC_CALL5, Primitive;
+  opC_CALLN, Uint_Primitive;
+  opCONST0, Nothing;
+  opCONST1, Nothing;
+  opCONST2, Nothing;
+  opCONST3, Nothing;
+  opCONSTINT, Sint;
+  opPUSHCONST0, Nothing;
+  opPUSHCONST1, Nothing;
+  opPUSHCONST2, Nothing;
+  opPUSHCONST3, Nothing;
+  opPUSHCONSTINT, Sint;
+  opNEGINT, Nothing;
+  opADDINT, Nothing;
+  opSUBINT, Nothing;
+  opMULINT, Nothing;
+  opDIVINT, Nothing;
+  opMODINT, Nothing;
+  opANDINT, Nothing;
+  opORINT, Nothing;
+  opXORINT, Nothing;
+  opLSLINT, Nothing;
+  opLSRINT, Nothing;
+  opASRINT, Nothing;
+  opEQ, Nothing;
+  opNEQ, Nothing;
+  opLTINT, Nothing;
+  opLEINT, Nothing;
+  opGTINT, Nothing;
+  opGEINT, Nothing;
+  opOFFSETINT, Sint;
+  opOFFSETREF, Sint;
+  opISINT, Nothing;
+  opGETMETHOD, Nothing;
+  opBEQ, Sint_Disp;
+  opBNEQ, Sint_Disp;
+  opBLTINT, Sint_Disp;
+  opBLEINT, Sint_Disp;
+  opBGTINT, Sint_Disp;
+  opBGEINT, Sint_Disp;
+  opULTINT, Nothing;
+  opUGEINT, Nothing;
+  opBULTINT, Uint_Disp;
+  opBUGEINT, Uint_Disp;
+  opSTOP, Nothing;
+  opEVENT, Nothing;
+  opBREAK, Nothing;
+];;
+
+let print_event ev =
+  printf "%s, char %d:\n" ev.ev_module ev.ev_char
+
+let print_instr ic =
+  let pos = currpos ic in
+  List.iter print_event (Hashtbl.find_all event_table pos);
+  printf "%8d  " (pos / 4);
+  let op = inputu ic in
+  if op >= Array.length names_of_instructions || op < 0
+  then (print_string "*** unknown opcode : "; print_int op)
+  else print_string names_of_instructions.(op);
+  print_string " ";
+  begin try match List.assoc op op_shapes with
+  | Uint -> print_int (inputu ic)
+  | Sint -> print_int (inputs ic)
+  | Uint_Uint
+     -> print_int (inputu ic); print_string ", "; print_int (inputu ic)
+  | Disp -> let p = currpc ic in print_int (p + inputs ic)
+  | Uint_Disp
+     -> print_int (inputu ic); print_string ", ";
+        let p = currpc ic in print_int (p + inputs ic)
+  | Sint_Disp
+     -> print_int (inputs ic); print_string ", ";
+        let p = currpc ic in print_int (p + inputs ic)
+  | Getglobal -> print_getglobal_name ic
+  | Getglobal_Uint
+     -> print_getglobal_name ic; print_string ", "; print_int (inputu ic)
+  | Setglobal -> print_setglobal_name ic
+  | Primitive -> print_primitive ic
+  | Uint_Primitive
+     -> print_int(inputu ic); print_string ", "; print_primitive ic
+  | Switch
+     -> let n = inputu ic in
+        let orig = currpc ic in
+        for i = 0 to (n land 0xFFFF) - 1 do
+          print_string "\n        int "; print_int i; print_string " -> ";
+          print_int(orig + inputs ic);
+        done;
+        for i = 0 to (n lsr 16) - 1 do
+          print_string "\n        tag "; print_int i; print_string " -> ";
+          print_int(orig + inputs ic);
+        done;
+  | Closurerec
+     -> let nfuncs = inputu ic in
+        let nvars = inputu ic in
+        let orig = currpc ic in
+        print_int nvars;
+        for i = 0 to nfuncs - 1 do
+          print_string ", ";
+          print_int (orig + inputu ic);
+        done;
+  | Nothing -> ()
+  with Not_found -> print_string "(unknown arguments)"
+  end;
+  print_string "\n";
+;;
+
+(* Disassemble a block of code *)
+
+let print_code ic len =
+  start := pos_in ic;
+  let stop = !start + len in
+  while pos_in ic < stop do print_instr ic done
+
+(* Dump relocation info *)
+
+let print_reloc (info, pos) =
+  printf "    %d    (%d)    " pos (pos/4);
+  match info with
+    Reloc_literal sc -> print_struct_const sc; printf "\n"
+  | Reloc_getglobal id -> printf "require    %s\n" (Ident.name id)
+  | Reloc_setglobal id -> printf "provide    %s\n" (Ident.name id)
+  | Reloc_primitive s -> printf "prim    %s\n" s
+
+(* Print a .cmo file *)
+
+let dump_obj filename ic =
+  let buffer = String.create (String.length cmo_magic_number) in
+  really_input ic buffer 0 (String.length cmo_magic_number);
+  if buffer <> cmo_magic_number then begin
+    prerr_endline "Not an object file"; exit 2
+  end;
+  let cu_pos = input_binary_int ic in
+  seek_in ic cu_pos;
+  let cu = (input_value ic : compilation_unit) in
+  reloc := cu.cu_reloc;
+  if cu.cu_debug > 0 then begin
+    seek_in ic cu.cu_debug;
+    let evl = (input_value ic : debug_event list) in
+    record_events 0 evl
+  end;
+  seek_in ic cu.cu_pos;
+  print_code ic cu.cu_codesize
+
+(* Read the primitive table from an executable *)
+
+let read_primitive_table ic len =
+  let p = String.create len in
+  really_input ic p 0 len;
+  let rec split beg cur =
+    if cur >= len then []
+    else if p.[cur] = '\000' then
+      String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1)
+    else
+      split beg (cur + 1) in
+  Array.of_list(split 0 0)
+
+(* Print an executable file *)
+
+let dump_exe ic =
+  Bytesections.read_toc ic;
+  let prim_size = Bytesections.seek_section ic "PRIM" in
+  primitives := read_primitive_table ic prim_size;
+  ignore(Bytesections.seek_section ic "DATA");
+  let init_data = (input_value ic : Obj.t array) in
+  globals := Array.create (Array.length init_data) Empty;
+  for i = 0 to Array.length init_data - 1 do
+    !globals.(i) <- Constant (init_data.(i))
+  done;
+  ignore(Bytesections.seek_section ic "SYMB");
+  let (_, sym_table) = (input_value ic : int * (Ident.t, int) Tbl.t) in
+  Tbl.iter (fun id pos -> !globals.(pos) <- Global id) sym_table;
+  begin try
+    ignore (Bytesections.seek_section ic "DBUG");
+    let num_eventlists = input_binary_int ic in
+    for i = 1 to num_eventlists do
+      let orig = input_binary_int ic in
+      let evl = (input_value ic : debug_event list) in
+      record_events orig evl
+    done
+  with Not_found -> ()
+  end;
+  let code_size = Bytesections.seek_section ic "CODE" in
+  print_code ic code_size
+
+let main() =
+  for i = 1 to Array.length Sys.argv - 1 do
+    let ic = open_in_bin Sys.argv.(i) in
+    begin try
+      objfile := false; dump_exe ic
+    with Bytesections.Bad_magic_number ->
+      objfile := true; seek_in ic 0; dump_obj (Sys.argv.(i)) ic
+    end;
+    close_in ic
+  done;
+  exit 0
+
+let _ = Printexc.catch main (); exit 0
diff --git a/tools/keywords.r b/tools/keywords.r
new file mode 100644
index 0000000000..2a9054c8e0
--- /dev/null
+++ b/tools/keywords.r
@@ -0,0 +1,121 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*             Damien Doligez, projet Para, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+type 'Odds' {
+  longint;                  /* resource ID of corresponding 'Sods' */
+  longint = $$CountOf (suffixes);
+  wide array suffixes { pstring; };
+};
+
+type 'Sods' {
+  longint = 0xA5666D66;
+  pstring;                  /* default token breaks */
+  longint = $$CountOf (keywords);
+  wide array keywords {
+    pstring;                /* the keyword itself */
+    longint                 /* the keyword type */
+      case=0,
+      caseWord=1,
+      noCase=2,
+      noCaseWord=3,
+      line=4,
+      mystery=0xB,
+      opening=0x10000,
+      closing=0x20000,
+      openingFill=0x50000,
+      closingFill=0x60000,
+      quote=0x80000;
+    literal longint;        /* scoping parameter */
+    longint                 /* color */
+      red=0,
+      blue=1,
+      bluegreen=2,
+      bluepurple=3,
+      grey=4,
+      darkgreen=7,
+      black=255;
+  };
+};
+
+resource 'Odds' (26087, "O'Caml") {
+  26087,
+  { ".ml", ".mli", ".mll", ".mly", ".mlp" }
+};
+
+resource 'Sods' (26087, "O'Caml Keywords") {
+  "\t\r\n ~!$%^&*()/-+=<>,[]{};",
+  { 
+    "(*", openingFill, '(**)', red,
+    "*)", closingFill, '(**)', red,
+    "\"", quote, 0, grey,
+#define KEY caseWord, 0, blue
+    "and", KEY,
+    "as", KEY,
+    "assert", KEY,
+    "begin", KEY,
+    "class", KEY,
+    "constraint", KEY,
+    "do", KEY,
+    "done", KEY,
+    "downto", KEY,
+    "else", KEY,
+    "end", KEY,
+    "exception", KEY,
+    "external", KEY,
+    "false", KEY,
+    "for", KEY,
+    "fun", KEY,
+    "function", KEY,
+    "functor", KEY,
+    "if", KEY,
+    "in", KEY,
+    "include", KEY,
+    "inherit", KEY,
+    "initializer", KEY,
+    "lazy", KEY,
+    "let", KEY,
+    "match", KEY,
+    "method", KEY,
+    "module", KEY,
+    "mutable", KEY,
+    "new", KEY,
+    "object", KEY,
+    "of", KEY,
+    "open", KEY,
+    "or", KEY,
+    "parser", KEY,
+    "private", KEY,
+    "rec", KEY,
+    "sig", KEY,
+    "struct", KEY,
+    "then", KEY,
+    "to", KEY,
+    "true", KEY,
+    "try", KEY,
+    "type", KEY,
+    "val", KEY,
+    "virtual", KEY,
+    "when", KEY,
+    "while", KEY,
+    "with", KEY,
+    "mod", KEY,
+    "land", KEY,
+    "lor", KEY,
+    "lxor", KEY,
+    "lsl", KEY,
+    "lsr", KEY,
+    "asr", KEY,
+  }
+};
diff --git a/tools/magic b/tools/magic
new file mode 100644
index 0000000000..7468066e01
--- /dev/null
+++ b/tools/magic
@@ -0,0 +1,11 @@
+# Here are some definitions that can be added to the /usr/share/magic
+# database so that the file(1) command recognizes OCaml compiled files.
+# Contributed by Sven Luther.
+0       string  Caml1999        Objective Caml
+>8      string  X               bytecode executable
+>8      string  I               interface data (.cmi)
+>8      string  O               bytecode object data (.cmo)
+>8      string  A               bytecode library data (.cma)
+>8      string  Y               native object data (.cmx)
+>8      string  Z               native library data (.cmxa)
+>9      string  >\0             (Version %3.3s).
diff --git a/tools/ocamlmklib.mlp b/tools/ocamlmklib.mlp
new file mode 100644
index 0000000000..fc526e572d
--- /dev/null
+++ b/tools/ocamlmklib.mlp
@@ -0,0 +1,233 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open Printf
+
+let bindir = "%%BINDIR%%"
+and supports_shared_libraries = %%SUPPORTS_SHARED_LIBRARIES%%
+and mksharedlib = "%%MKSHAREDLIB%%"
+and bytecc_rpath = "%%BYTECCRPATH%%"
+and nativecc_rpath = "%%NATIVECCRPATH%%"
+and mksharedlib_rpath = "%%MKSHAREDLIBRPATH%%"
+and ranlib = "%%RANLIB%%"
+
+let bytecode_objs = ref []  (* .cmo,.cma,.ml,.mli files to pass to ocamlc *)
+and native_objs = ref []    (* .cmx,.cmxa,.ml,.mli files to pass to ocamlopt *)
+and c_objs = ref []         (* .o, .a files to pass to mksharedlib and ar *)
+and caml_libs = ref []      (* -cclib to pass to ocamlc, ocamlopt *)
+and caml_opts = ref []      (* -ccopt to pass to ocamlc, ocamlopt *)
+and dynlink = ref supports_shared_libraries
+and failsafe = ref false    (* whether to fall back on static build only *)
+and c_libs = ref []         (* libs to pass to mksharedlib and ocamlc -cclib *)
+and c_opts = ref []      (* options to pass to mksharedlib and ocamlc -ccopt *)
+and ocamlc = ref (Filename.concat bindir "ocamlc")
+and ocamlopt = ref (Filename.concat bindir "ocamlopt")
+and output = ref "a"        (* Output name for Caml part of library *)
+and output_c = ref ""       (* Output name for C part of library *)
+and rpath = ref []          (* rpath options *)
+and verbose = ref false
+
+let starts_with s pref =
+  String.length s >= String.length pref &&
+  String.sub s 0 (String.length pref) = pref
+let ends_with = Filename.check_suffix
+let chop_prefix s pref =
+  String.sub s (String.length pref) (String.length s - String.length pref)
+let chop_suffix = Filename.chop_suffix
+
+exception Bad_argument of string
+
+let parse_arguments argv =
+  let i = ref 1 in
+  let next_arg () =
+    if !i + 1 >= Array.length argv
+    then raise (Bad_argument("Option " ^ argv.(!i) ^ " expects one argument"));
+    incr i; argv.(!i) in
+  while !i < Array.length argv do
+    let s = argv.(!i) in
+    if ends_with s ".cmo" || ends_with s ".cma" then
+      bytecode_objs := s :: !bytecode_objs
+    else if ends_with s ".cmx" || ends_with s ".cmxa" then
+      native_objs := s :: !native_objs
+    else if ends_with s ".ml" || ends_with s ".mli" then
+     (bytecode_objs := s :: !bytecode_objs;
+      native_objs := s :: !native_objs)
+    else if ends_with s ".o" || ends_with s ".a" then
+      c_objs := s :: !c_objs
+    else if s = "-cclib" then
+      caml_libs := next_arg () :: "-cclib" :: !caml_libs
+    else if s = "-ccopt" then
+      caml_opts := next_arg () :: "-ccopt" :: !caml_opts
+    else if s = "-custom" then
+      dynlink := false
+    else if s = "-I" then
+      caml_opts := next_arg () :: "-I" :: !caml_opts
+    else if s = "-failsafe" then
+      failsafe := true
+    else if s = "-linkall" then
+      caml_opts := s :: !caml_opts
+    else if starts_with s "-l" then
+      c_libs := s :: !c_libs
+    else if starts_with s "-L" then
+     (c_opts := s :: !c_opts;
+      let l = chop_prefix s "-L" in
+      if not (Filename.is_relative l) then rpath := l :: !rpath)
+    else if s = "-ocamlc" then
+      ocamlc := next_arg ()
+    else if s = "-ocamlopt" then
+      ocamlopt := next_arg ()
+    else if s = "-o" then
+      output := next_arg()
+    else if s = "-oc" then
+      output_c := next_arg()
+    else if s = "-dllpath" || s = "-R" || s = "-rpath" then
+      rpath := next_arg() :: !rpath
+    else if starts_with s "-R" then
+      rpath := chop_prefix s "-R" :: !rpath
+    else if s = "-Wl,-rpath" then
+     (let a = next_arg() in
+      if starts_with a "-Wl,"
+      then rpath := chop_prefix a "-Wl," :: !rpath
+      else raise (Bad_argument("Option -Wl,-rpath expects a -Wl, argument")))
+    else if starts_with s "-Wl,-rpath," then
+      rpath := chop_prefix s "-Wl,-rpath," :: !rpath
+    else if starts_with s "-Wl,-R" then
+      rpath := chop_prefix s "-Wl,-R" :: !rpath
+    else if s = "-v" || s = "-verbose" then
+      verbose := true
+    else if starts_with s "-" then
+      prerr_endline ("Unknown option " ^ s)
+    else
+      raise (Bad_argument("Don't know what to do with " ^ s));
+    incr i
+  done;
+  List.iter
+    (fun r -> r := List.rev !r)
+    [ bytecode_objs; native_objs; c_objs; caml_libs; caml_opts; 
+      c_libs; c_objs; rpath ];
+  if !output_c = "" then output_c := !output
+
+let usage = "\
+Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a files>
+Options are:
+  -cclib <lib>   C library passed to ocamlc -a or ocamlopt -a only
+  -ccopt <opt>   C option passed to ocamlc -a or ocamlopt -a only
+  -custom        disable dynamic loading
+  -dllpath <dir> Add <dir> to the run-time search path for DLLs
+  -I <dir>       Add <dir> to the path searched for Caml object files
+  -failsafe      fall back to static linking if DLL construction failed
+  -linkall       Build Caml archive with link-all behavior
+  -l<lib>        Specify a dependent C library
+  -L<dir>        Add <dir> to the path searched for C libraries
+  -ocamlc <cmd>  Use <cmd> in place of \"ocamlc\"
+  -ocamlopt <cmd> Use <cmd> in place of \"ocamlopt\"
+  -o <name>      Generated Caml library is named <name>.cma or <name>.cmxa
+  -oc <name>     Generated C library is named lib<name>.so or lib<name>.a
+  -rpath <dir>   Same as -dllpath <dir>
+  -R<dir>        Same as -rpath
+  -verbose       Print commands before executing them
+  -Wl,-rpath,<dir>     Same as -dllpath <dir>
+  -Wl,-rpath -Wl,<dir> Same as -dllpath <dir>
+  -Wl,-R<dir>          Same as -dllpath <dir>
+"
+
+let command cmd =
+  if !verbose then (print_string "+ "; print_string cmd; print_newline());
+  Sys.command cmd
+
+let scommand cmd =
+  if command cmd <> 0 then exit 2
+
+let safe_remove s =
+  try Sys.remove s with Sys_error _ -> ()
+
+let make_set l =
+  let rec merge l = function
+    []     -> List.rev l
+  | p :: r -> if List.mem p l then merge l r else merge (p::l) r
+  in
+  merge [] l
+
+let make_rpath flag =
+  if !rpath = [] || flag = ""
+  then ""
+  else flag ^ String.concat ":" (make_set !rpath)
+
+let make_rpath_ccopt flag =
+  if !rpath = [] || flag = "" 
+  then ""
+  else "-ccopt " ^ flag ^ String.concat ":" (make_set !rpath)
+
+let prefix_list pref l =
+  List.map (fun s -> pref ^ s) l
+
+let build_libs () =
+  if !c_objs <> [] then begin
+    if !dynlink then begin
+      let retcode = command
+        (sprintf "%s dll%s.so %s %s %s %s"
+                    mksharedlib
+                    !output_c
+                    (String.concat " " !c_objs)
+                    (String.concat " " !c_opts)
+                    (make_rpath mksharedlib_rpath)
+                    (String.concat " " !c_libs)) in
+      if retcode <> 0 then if !failsafe then dynlink := false else exit 2
+    end;
+    safe_remove ("lib" ^ !output_c ^ ".a");
+    scommand
+      (sprintf "ar rc lib%s.a %s"
+                  !output_c
+                  (String.concat " " !c_objs));
+    scommand
+      (sprintf "%s lib%s.a"
+                  ranlib
+                  !output_c)
+  end;
+  if !bytecode_objs <> [] then
+    scommand
+      (sprintf "%s -a %s -o %s.cma %s %s -dllib -l%s -cclib -l%s %s %s %s"
+                  !ocamlc
+                  (if !dynlink then "" else "-custom")
+                  !output
+                  (String.concat " " !caml_opts)
+                  (String.concat " " !bytecode_objs)
+                  !output_c
+                  !output_c
+                  (String.concat " " (prefix_list "-ccopt " !c_opts))
+                  (make_rpath_ccopt bytecc_rpath)
+                  (String.concat " " (prefix_list "-cclib " !c_libs)));
+  if !native_objs <> [] then
+    scommand
+      (sprintf "%s -a -o %s.cmxa %s %s -cclib -l%s %s %s %s"
+                  !ocamlopt
+                  !output
+                  (String.concat " " !caml_opts)
+                  (String.concat " " !native_objs)
+                  !output_c
+                  (String.concat " " (prefix_list "-ccopt " !c_opts))
+                  (make_rpath_ccopt nativecc_rpath)
+                  (String.concat " " (prefix_list "-cclib " !c_libs)))
+
+let _ =
+  try
+    parse_arguments Sys.argv;
+    build_libs()
+  with
+  | Bad_argument s ->
+      prerr_endline s; prerr_string usage; exit 4
+  | Sys_error s ->
+      prerr_string "System error: "; prerr_endline s; exit 4
+  | x ->
+      raise x
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
new file mode 100644
index 0000000000..aa85dfdcfb
--- /dev/null
+++ b/tools/ocamlprof.ml
@@ -0,0 +1,476 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*      Damien Doligez and Francois Rouaix, INRIA Rocquencourt         *)
+(*          Ported to Caml Special Light by John Malecki               *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open Printf
+
+open Clflags
+open Config
+open Location
+open Misc
+open Parsetree
+
+(* User programs must not use identifiers that start with this prefix. *)
+let idprefix = "__ocaml_prof";;
+
+
+(* Errors specific to the profiler *)
+exception Profiler of string
+
+(* Modes *)
+let instr_fun    = ref false
+and instr_match  = ref false
+and instr_if     = ref false
+and instr_loops  = ref false
+and instr_try    = ref false
+
+let cur_point = ref 0
+and inchan = ref stdin
+and outchan = ref stdout
+
+(* In case we forgot something *)
+(*exception Inversion of int * int*)
+
+(* To copy source fragments *)
+let copy_buffer = String.create 256
+
+let copy_chars_unix nchars =
+  let n = ref nchars in
+  while !n > 0 do
+    let m = input !inchan copy_buffer 0 (min !n 256) in
+    if m = 0 then raise End_of_file;
+    output !outchan copy_buffer 0 m;
+    n := !n - m
+  done
+
+let copy_chars_win32 nchars =
+  for i = 1 to nchars do
+    let c = input_char !inchan in
+    if c <> '\r' then output_char !outchan c
+  done
+
+let copy_chars =
+  match Sys.os_type with
+    "Win32" | "Cygwin" -> copy_chars_win32
+  | _       -> copy_chars_unix
+
+let copy next =
+  if next < !cur_point then begin
+    (*raise (Inversion(!cur_point, next));*)
+    (*fprintf stderr "warning: inversion at %d, %d\n" !cur_point next;*)
+    assert false
+  end else begin
+    seek_in !inchan !cur_point;
+    copy_chars (next - !cur_point);
+    cur_point := next;
+  end
+
+let prof_counter = ref 0;;
+
+let instr_mode = ref false
+
+type insert = Open | Close;;
+let to_insert = ref ([] : (insert * int) list);;
+
+let insert_action st en =
+  to_insert := (Open, st) :: (Close, en) :: !to_insert
+;;
+
+(* Producing instrumented code *)
+let add_incr_counter modul (kind,pos) =
+   copy pos;
+   match kind with
+   | Close -> fprintf !outchan ")";
+   | Open ->
+         fprintf !outchan
+                 "(%s_cnt_%s_.(%d) <- Pervasives.succ %s_cnt_%s_.(%d); "
+                 idprefix modul !prof_counter idprefix modul !prof_counter;
+         incr prof_counter;
+;;
+
+let counters = ref (Array.create 0 0)
+
+(* User defined marker *)
+let special_id = ref ""
+
+(* Producing results of profile run *)
+let add_val_counter (kind,pos) =
+  if kind = Open then begin
+    copy pos;
+    fprintf !outchan "(* %s%d *) " !special_id !counters.(!prof_counter); 
+    incr prof_counter;
+  end
+;;
+
+(* ************* rewrite ************* *)
+
+let insert_profile rw_exp ex =
+  let st = ex.pexp_loc.loc_start
+  and en = ex.pexp_loc.loc_end
+  and gh = ex.pexp_loc.loc_ghost
+  in
+  if gh || st = en then
+    rw_exp true ex
+  else begin
+    insert_action st en;
+    rw_exp false ex;
+  end
+;;
+
+
+let pos_len = ref 0
+
+let init_rewrite modes mod_name =
+  cur_point := 0;
+  if !instr_mode then begin
+    fprintf !outchan "let %s_cnt_%s_ = Array.create 0000000" idprefix mod_name;
+    pos_len := pos_out !outchan;
+    fprintf !outchan 
+            " 0;; Profiling.counters := \
+              (\"%s\", (\"%s\", %s_cnt_%s_)) :: !Profiling.counters;; "
+            mod_name modes idprefix mod_name
+  end
+
+let final_rewrite add_function =
+  to_insert := Sort.list (fun x y -> snd x < snd y) !to_insert;
+  prof_counter := 0;
+  List.iter add_function !to_insert;
+  copy (in_channel_length !inchan);
+  if !instr_mode then begin
+    let len = string_of_int !prof_counter in
+    if String.length len > 7 then raise (Profiler "too many counters");
+    seek_out !outchan (!pos_len - String.length len);
+    output_string !outchan len
+  end;
+  (* Cannot close because outchan is stdout and Format doesn't like
+     a closed stdout.
+    close_out !outchan;
+  *)
+;;
+
+let rec rewrite_patexp_list iflag l =
+  rewrite_exp_list iflag (List.map snd l)
+
+and rewrite_patlexp_list iflag l =
+  rewrite_exp_list iflag (List.map snd l)
+
+and rewrite_labelexp_list iflag l =
+  rewrite_exp_list iflag (List.map snd l)
+
+and rewrite_exp_list iflag l =
+  List.iter (rewrite_exp iflag) l
+
+and rewrite_exp iflag sexp =
+  if iflag then insert_profile rw_exp sexp
+           else rw_exp false sexp
+
+and rw_exp iflag sexp =
+  match sexp.pexp_desc with
+    Pexp_ident lid -> ()
+  | Pexp_constant cst -> ()
+
+  | Pexp_let(_, spat_sexp_list, sbody) ->
+    rewrite_patexp_list iflag spat_sexp_list;
+    rewrite_exp iflag sbody
+
+  | Pexp_function (_, _, caselist) ->
+    if !instr_fun && not sexp.pexp_loc.loc_ghost then
+      rewrite_function iflag caselist
+    else
+      rewrite_patlexp_list iflag caselist
+
+  | Pexp_match(sarg, caselist) ->
+    rewrite_exp iflag sarg;
+    if !instr_match && not sexp.pexp_loc.loc_ghost then
+      rewrite_funmatching caselist
+    else
+      rewrite_patlexp_list iflag caselist
+
+  | Pexp_try(sbody, caselist) ->
+    rewrite_exp iflag sbody;
+    if !instr_try && not sexp.pexp_loc.loc_ghost then
+      rewrite_trymatching caselist
+    else
+      rewrite_patexp_list iflag caselist
+
+  | Pexp_apply(sfunct, sargs) ->
+    rewrite_exp iflag sfunct;
+    rewrite_exp_list iflag (List.map snd sargs)
+
+  | Pexp_tuple sexpl ->
+    rewrite_exp_list iflag sexpl
+
+  | Pexp_construct(_, None, _) -> ()
+  | Pexp_construct(_, Some sarg, _) ->
+    rewrite_exp iflag sarg
+
+  | Pexp_variant(_, None) -> ()
+  | Pexp_variant(_, Some sarg) ->
+    rewrite_exp iflag sarg
+
+  | Pexp_record(lid_sexp_list, None) ->
+    rewrite_labelexp_list iflag lid_sexp_list
+  | Pexp_record(lid_sexp_list, Some sexp) ->
+    rewrite_exp iflag sexp;
+    rewrite_labelexp_list iflag lid_sexp_list
+
+  | Pexp_field(sarg, _) ->
+    rewrite_exp iflag sarg
+
+  | Pexp_setfield(srecord, _, snewval) ->
+    rewrite_exp iflag srecord;
+    rewrite_exp iflag snewval
+
+  | Pexp_array(sargl) ->
+    rewrite_exp_list iflag sargl
+
+  | Pexp_ifthenelse(scond, sifso, None) ->
+      rewrite_exp iflag scond;
+      rewrite_ifbody iflag sexp.pexp_loc.loc_ghost sifso
+  | Pexp_ifthenelse(scond, sifso, Some sifnot) ->
+      rewrite_exp iflag scond;
+      rewrite_ifbody iflag sexp.pexp_loc.loc_ghost sifso;
+      rewrite_ifbody iflag sexp.pexp_loc.loc_ghost sifnot
+      
+  | Pexp_sequence(sexp1, sexp2) ->
+    rewrite_exp iflag sexp1;
+    rewrite_exp iflag sexp2
+
+  | Pexp_while(scond, sbody) ->
+    rewrite_exp iflag scond;
+    if !instr_loops && not sexp.pexp_loc.loc_ghost
+    then insert_profile rw_exp sbody
+    else rewrite_exp iflag sbody
+
+  | Pexp_for(_, slow, shigh, _, sbody) ->
+    rewrite_exp iflag slow;
+    rewrite_exp iflag shigh;
+    if !instr_loops && not sexp.pexp_loc.loc_ghost
+    then insert_profile rw_exp sbody
+    else rewrite_exp iflag sbody
+
+  | Pexp_constraint(sarg, _, _) ->
+    rewrite_exp iflag sarg
+
+  | Pexp_when(scond, sbody) ->
+    rewrite_exp iflag scond;
+    rewrite_exp iflag sbody
+
+  | Pexp_send (sobj, _) ->
+    rewrite_exp iflag sobj
+
+  | Pexp_new _ -> ()
+
+  | Pexp_setinstvar (_, sarg) ->
+    rewrite_exp iflag sarg
+
+  | Pexp_override l ->
+      List.iter (fun (_, sexp) -> rewrite_exp iflag sexp) l
+
+  | Pexp_letmodule (_, smod, sexp) ->
+      rewrite_mod iflag smod;
+      rewrite_exp iflag sexp
+
+  | Pexp_assert (cond) -> rewrite_exp iflag cond
+  | Pexp_assertfalse -> ()
+
+and rewrite_ifbody iflag ghost sifbody =
+  if !instr_if && not ghost then
+    insert_profile rw_exp sifbody
+  else
+    rewrite_exp iflag sifbody
+
+(* called only when !instr_fun *)
+and rewrite_annotate_exp_list l =
+  List.iter
+    (function
+     | {pexp_desc = Pexp_when(scond, sbody)}
+        -> insert_profile rw_exp scond; 
+           insert_profile rw_exp sbody;
+     | {pexp_desc = Pexp_constraint(sbody, _, _)} (* let f x : t = e *)
+        -> insert_profile rw_exp sbody
+     | sexp -> insert_profile rw_exp sexp)
+    l
+
+and rewrite_function iflag = function
+  | [spat, ({pexp_desc = Pexp_function _} as sexp)] -> rewrite_exp iflag sexp
+  | l -> rewrite_funmatching l
+
+and rewrite_funmatching l = 
+  rewrite_annotate_exp_list (List.map snd l)
+
+and rewrite_trymatching l =
+  rewrite_annotate_exp_list (List.map snd l)
+
+(* Rewrite a class definition *)
+
+and rewrite_class_field iflag =
+  function
+    Pcf_inher (cexpr, _)     -> rewrite_class_expr iflag cexpr
+  | Pcf_val (_, _, sexp, _)  -> rewrite_exp iflag sexp
+  | Pcf_meth (_, _, ({pexp_desc = Pexp_function _} as sexp), _) ->
+      rewrite_exp iflag sexp
+  | Pcf_meth (_, _, sexp, loc) ->
+      if !instr_fun && not loc.loc_ghost then insert_profile rw_exp sexp
+      else rewrite_exp iflag sexp
+  | Pcf_let(_, spat_sexp_list, _) ->
+      rewrite_patexp_list iflag spat_sexp_list
+  | Pcf_init sexp ->
+      rewrite_exp iflag sexp
+  | Pcf_virt _ | Pcf_cstr _  -> ()
+
+and rewrite_class_expr iflag cexpr =
+  match cexpr.pcl_desc with
+    Pcl_constr _ -> ()
+  | Pcl_structure (_, fields) ->
+      List.iter (rewrite_class_field iflag) fields
+  | Pcl_fun (_, _, _, cexpr) ->
+      rewrite_class_expr iflag cexpr
+  | Pcl_apply (cexpr, exprs) ->
+      rewrite_class_expr iflag cexpr;
+      List.iter (rewrite_exp iflag) (List.map snd exprs)
+  | Pcl_let (_, spat_sexp_list, cexpr) ->
+      rewrite_patexp_list iflag spat_sexp_list;
+      rewrite_class_expr iflag cexpr
+  | Pcl_constraint (cexpr, _) ->
+      rewrite_class_expr iflag cexpr
+
+and rewrite_class_declaration iflag cl =
+  rewrite_class_expr iflag cl.pci_expr
+
+(* Rewrite a module expression or structure expression *)
+
+and rewrite_mod iflag smod =
+  match smod.pmod_desc with
+    Pmod_ident lid -> ()
+  | Pmod_structure sstr -> List.iter (rewrite_str_item iflag) sstr
+  | Pmod_functor(param, smty, sbody) -> rewrite_mod iflag sbody
+  | Pmod_apply(smod1, smod2) -> rewrite_mod iflag smod1; rewrite_mod iflag smod2
+  | Pmod_constraint(smod, smty) -> rewrite_mod iflag smod
+
+and rewrite_str_item iflag item =
+  match item.pstr_desc with
+    Pstr_eval exp -> rewrite_exp iflag exp
+  | Pstr_value(_, exps)
+     -> List.iter (function (_,exp) -> rewrite_exp iflag exp) exps
+  | Pstr_module(name, smod) -> rewrite_mod iflag smod
+  | Pstr_class classes -> List.iter (rewrite_class_declaration iflag) classes
+  | _ -> ()
+
+(* Rewrite a .ml file *)
+let rewrite_file srcfile add_function =
+  inchan := open_in_bin srcfile;
+  let lb = Lexing.from_channel !inchan in
+  Location.input_name := srcfile;
+  List.iter (rewrite_str_item false) (Parse.implementation lb);
+  final_rewrite add_function;
+  close_in !inchan
+
+(* Copy a non-.ml file without change *)
+let null_rewrite srcfile =
+  inchan := open_in_bin srcfile;
+  copy (in_channel_length !inchan);
+  close_in !inchan
+;;
+
+(* Setting flags from saved config *)
+let set_flags s =
+  for i = 0 to String.length s - 1 do
+    match String.get s i with
+      'f' -> instr_fun := true
+    | 'm' -> instr_match := true
+    | 'i' -> instr_if := true
+    | 'l' -> instr_loops := true
+    | 't' -> instr_try := true
+    | 'a' -> instr_fun := true; instr_match := true;
+             instr_if := true; instr_loops := true;
+             instr_try := true
+    | _ -> ()
+    done
+
+(* Command-line options *)
+
+let modes = ref "fm"
+let dumpfile = ref "ocamlprof.dump"
+
+(* Process a file *)
+
+let process_file filename =
+  if not (Filename.check_suffix filename ".ml") then
+    null_rewrite filename
+  else
+   let modname = Filename.basename(Filename.chop_suffix filename ".ml") in
+   if !instr_mode then begin
+     (* Instrumentation mode *)
+     set_flags !modes;
+     init_rewrite !modes modname;
+     rewrite_file filename (add_incr_counter modname);
+   end else begin
+     (* Results mode *)
+     let ic = open_in_bin !dumpfile in
+     let allcounters =
+       (input_value ic : (string * (string * int array)) list) in
+     close_in ic;
+     let (modes, cv) =
+       try
+         List.assoc modname allcounters
+       with Not_found ->
+         raise(Profiler("Module " ^ modname ^ " not used in this profile."))
+     in
+     counters := cv;
+     set_flags modes;
+     init_rewrite modes modname;
+     rewrite_file filename add_val_counter;
+   end
+
+(* Main function *)
+
+open Format
+
+let usage = "Usage: ocamlprof <options> <files>\noptions are:"
+
+let main () =
+  try
+    Arg.parse [
+       "-f", Arg.String (fun s -> dumpfile := s),
+             "<file>  Use <file> as dump file (default ocamlprof.dump)";
+       "-F", Arg.String (fun s -> special_id := s),
+             "<s>  Insert string <s> with the counts";
+       "-instrument", Arg.Set instr_mode, " (undocumented)";
+       "-m", Arg.String (fun s -> modes := s), "<flags>  (undocumented)"
+      ] process_file usage;
+    exit 0
+  with x ->
+    let report_error ppf = function
+    | Lexer.Error(err, start, stop) ->
+        fprintf ppf "@[%a%a@]@."
+        Location.print {loc_start = start; loc_end = stop; loc_ghost = false}
+        Lexer.report_error err
+    | Syntaxerr.Error err ->
+        fprintf ppf "@[%a@]@."
+        Syntaxerr.report_error err
+    | Profiler msg ->
+        fprintf ppf "@[%s@]@." msg
+(*
+    | Inversion(pos, next) ->
+        print_string "Internal error: inversion at char "; print_int pos;
+        print_string ", "; print_int next
+*)
+    | Sys_error msg ->
+        fprintf ppf "@[I/O error:@ %s@]@." msg
+    | x -> raise x in
+    report_error Format.err_formatter x;
+    exit 2
+
+let _ = main ()
diff --git a/tools/profiling.ml b/tools/profiling.ml
new file mode 100644
index 0000000000..75fe03b96e
--- /dev/null
+++ b/tools/profiling.ml
@@ -0,0 +1,53 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*      Damien Doligez and Francois Rouaix, INRIA Rocquencourt         *)
+(*   Ported to Caml Special Light by John Malecki and Xavier Leroy     *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Run-time library for profiled programs *)
+
+type profiling_counters = (string * (string * int array)) list
+
+let counters = ref ([] : profiling_counters)
+
+exception Bad_profile
+
+let dump_counters () =
+  begin try 
+    let ic = open_in_bin "ocamlprof.dump" in
+    let prevl = (input_value ic : profiling_counters) in
+    close_in ic;
+    List.iter2
+      (fun (curname, (curmodes,curcount)) (prevname, (prevmodes,prevcount)) ->
+        if curname <> prevname
+        || curmodes <> prevmodes
+        || Array.length curcount <> Array.length prevcount
+        then raise Bad_profile)
+      !counters prevl;
+    List.iter2
+      (fun (curname, (_,curcount)) (prevname, (_,prevcount)) ->
+        for i = 0 to Array.length curcount - 1 do
+          curcount.(i) <- curcount.(i) + prevcount.(i)
+        done)
+      !counters prevl
+  with _ -> ()
+  end;
+  begin try
+    let oc = open_out_bin "ocamlprof.dump" in
+    output_value oc !counters;
+    close_out oc
+  with _ -> ()
+  end
+
+let _ = at_exit dump_counters
+
diff --git a/tools/profiling.mli b/tools/profiling.mli
new file mode 100644
index 0000000000..7a6170e966
--- /dev/null
+++ b/tools/profiling.mli
@@ -0,0 +1,19 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*      Damien Doligez and Francois Rouaix, INRIA Rocquencourt         *)
+(*   Ported to Objective Caml by John Malecki and Xavier Leroy         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Run-time library for profiled programs *)
+
+val counters: (string * (string * int array)) list ref
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
new file mode 100644
index 0000000000..a3698137fd
--- /dev/null
+++ b/toplevel/toploop.ml
@@ -0,0 +1,427 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* The interactive toplevel loop *)
+
+open Path
+open Lexing
+open Format
+open Config
+open Misc
+open Parsetree
+open Types
+open Typedtree
+open Outcometree
+
+type directive_fun =
+   | Directive_none of (unit -> unit)
+   | Directive_string of (string -> unit)
+   | Directive_int of (int -> unit)
+   | Directive_ident of (Longident.t -> unit)
+   | Directive_bool of (bool -> unit)
+
+(* The table of toplevel value bindings and its accessors *)
+
+let toplevel_value_bindings =
+  (Hashtbl.create 37 : (string, Obj.t) Hashtbl.t)
+
+let getvalue name =
+  try
+    Hashtbl.find toplevel_value_bindings name
+  with Not_found ->
+    fatal_error (name ^ " unbound at toplevel")
+
+let setvalue name v =
+  Hashtbl.replace toplevel_value_bindings name v
+
+(* Return the value referred to by a path *)
+
+let rec eval_path = function
+  | Pident id ->
+      if Ident.persistent id || Ident.global id then
+        Symtable.get_global_value id
+      else begin
+        let name = Ident.name id in
+        try
+          Hashtbl.find toplevel_value_bindings name
+        with Not_found ->
+          raise (Symtable.Error(Symtable.Undefined_global name))
+      end
+  | Pdot(p, s, pos) ->
+      Obj.field (eval_path p) pos
+  | Papply(p1, p2) ->
+      fatal_error "Toploop.eval_path"
+
+(* To print values *)
+
+module EvalPath = struct
+  type value = Obj.t
+  exception Error
+  let eval_path p = try eval_path p with Symtable.Error _ -> raise Error
+  let same_value v1 v2 = (v1 == v2)
+end
+
+module Printer = Genprintval.Make(Obj)(EvalPath)
+
+let max_printer_depth = ref 100
+let max_printer_steps = ref 300
+
+let print_out_value = ref Printer.print_outval
+let print_out_type = Printtyp.outcome_type
+let print_out_sig_item = Printtyp.outcome_sig_item
+
+let print_untyped_exception ppf obj =
+  !print_out_value ppf (Printer.outval_of_untyped_exception obj)
+let outval_of_value env obj ty =
+  Printer.outval_of_value !max_printer_steps !max_printer_depth
+    (fun _ _ _ -> None) env obj ty
+let print_value env obj ppf ty =
+  !print_out_value ppf (outval_of_value env obj ty)
+
+let install_printer = Printer.install_printer
+let remove_printer = Printer.remove_printer
+
+(* Hooks for parsing functions *)
+
+let parse_toplevel_phrase = ref Parse.toplevel_phrase
+let parse_use_file = ref Parse.use_file
+let print_location = Location.print
+let print_warning = Location.print_warning
+let input_name = Location.input_name
+
+(* Load in-core and execute a lambda term *)
+
+let may_trace = ref false (* Global lock on tracing *)
+type evaluation_outcome = Result of Obj.t | Exception of exn
+
+let load_lambda ppf lam =
+  if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
+  let slam = Simplif.simplify_lambda lam in
+  if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam;
+  let (init_code, fun_code) = Bytegen.compile_phrase slam in
+  if !Clflags.dump_instr then
+    fprintf ppf "%a%a@."
+    Printinstr.instrlist init_code
+    Printinstr.instrlist fun_code;
+  let (code, code_size, reloc) = Emitcode.to_memory init_code fun_code in
+  let can_free = (fun_code = []) in
+  let initial_symtable = Symtable.current_state() in
+  Symtable.patch_object code reloc;
+  Symtable.update_global_table();
+  try
+    may_trace := true;
+    let retval = (Meta.reify_bytecode code code_size) () in
+    may_trace := false;
+    if can_free then Meta.static_free code;
+    Result retval
+  with x ->
+    may_trace := false;
+    if can_free then Meta.static_free code;
+    Symtable.restore_state initial_symtable;
+    Exception x
+
+(* Print the outcome of an evaluation *)
+
+let pr_item env = function
+  | Tsig_value(id, decl) :: rem ->
+      let tree = Printtyp.tree_of_value_description id decl in
+      let valopt =
+        match decl.val_kind with
+        | Val_prim _ -> None
+        | _ ->
+            let v =
+              outval_of_value env (getvalue (Translmod.toplevel_name id))
+                decl.val_type
+            in
+            Some v
+      in
+      Some (tree, valopt, rem)
+  | Tsig_type(id, decl) :: rem ->
+      let tree = Printtyp.tree_of_type_declaration id decl in
+      Some (tree, None, rem)
+  | Tsig_exception(id, decl) :: rem ->
+      let tree = Printtyp.tree_of_exception_declaration id decl in
+      Some (tree, None, rem)
+  | Tsig_module(id, mty) :: rem ->
+      let tree = Printtyp.tree_of_module id mty in
+      Some (tree, None, rem)
+  | Tsig_modtype(id, decl) :: rem ->
+      let tree = Printtyp.tree_of_modtype_declaration id decl in
+      Some (tree, None, rem)
+  | Tsig_class(id, decl) :: cltydecl :: tydecl1 :: tydecl2 :: rem ->
+      let tree = Printtyp.tree_of_class_declaration id decl in
+      Some (tree, None, rem)
+  | Tsig_cltype(id, decl) :: tydecl1 :: tydecl2 :: rem ->
+      let tree = Printtyp.tree_of_cltype_declaration id decl in
+      Some (tree, None, rem)
+  | _ -> None
+
+let rec item_list env = function
+  | [] -> []
+  | items ->
+     match pr_item env items with
+     | None -> []
+     | Some (tree, valopt, items) -> (tree, valopt) :: item_list env items
+
+let rec print_items ppf =
+  function
+  | [] -> ()
+  | (tree, valopt) :: items ->
+      begin match valopt with
+      | Some v ->
+          fprintf ppf "@[<2>%a =@ %a@]" !print_out_sig_item tree
+            !print_out_value v
+      | None ->
+          fprintf ppf "@[%a@]" !print_out_sig_item tree
+      end;
+      if items <> [] then
+        fprintf ppf "@ %a" print_items items;;
+
+(* The current typing environment for the toplevel *)
+
+let toplevel_env = ref Env.empty
+
+(* Print an exception produced by an evaluation *)
+
+let print_out_exception ppf exn outv =
+  match exn with
+  | Sys.Break ->
+      fprintf ppf "Interrupted.@."
+  | Out_of_memory ->
+      fprintf ppf "Out of memory during evaluation.@."
+  | Stack_overflow ->
+      fprintf ppf "Stack overflow during evaluation (looping recursion?).@."
+  | _ ->
+      fprintf ppf "@[Exception:@ %a.@]@." !print_out_value outv
+
+let print_exception_outcome ppf exn =
+  if exn = Out_of_memory then Gc.full_major ();
+  let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in
+  print_out_exception ppf exn outv
+
+(* The table of toplevel directives. 
+   Filled by functions from module topdirs. *)
+
+let directive_table = (Hashtbl.create 13 : (string, directive_fun) Hashtbl.t)
+
+(* Execute a toplevel phrase *)
+
+let print_phrase ppf =
+  function
+  | Ophr_eval (outv, ty) ->
+      fprintf ppf "@[- : %a@ =@ %a@]@."
+        !print_out_type ty !print_out_value outv
+  | Ophr_signature [] -> ()
+  | Ophr_signature items -> fprintf ppf "@[<v>%a@]@." print_items items
+  | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv
+
+let print_out_phrase = ref print_phrase
+
+let execute_phrase print_outcome ppf phr =
+  match phr with
+  | Ptop_def sstr ->
+      let oldenv = !toplevel_env in
+      let (str, sg, newenv) = Typemod.type_structure oldenv sstr in
+      let lam = Translmod.transl_toplevel_definition str in
+      Warnings.check_fatal ();
+      begin try
+        toplevel_env := newenv;
+        let res = load_lambda ppf lam in
+        let out_phr =
+          match res with
+          | Result v ->
+              if print_outcome then
+                match str with
+                | [Tstr_eval exp] ->
+                    let outv = outval_of_value newenv v exp.exp_type in
+                    let ty = Printtyp.tree_of_type_scheme exp.exp_type in
+                    Ophr_eval (outv, ty)
+                | [] -> Ophr_signature []
+                | _ -> Ophr_signature (item_list newenv sg)
+              else Ophr_signature []
+          | Exception exn ->
+              toplevel_env := oldenv;
+              if exn = Out_of_memory then Gc.full_major();
+              let outv =
+                outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn
+              in
+              Ophr_exception (exn, outv)
+        in
+        !print_out_phrase ppf out_phr;
+        begin match out_phr with
+        | Ophr_eval (_, _) | Ophr_signature _ -> true
+        | Ophr_exception _ -> false
+        end
+      with x ->
+        toplevel_env := oldenv; raise x
+      end      
+  | Ptop_dir(dir_name, dir_arg) ->
+      try
+        match (Hashtbl.find directive_table dir_name, dir_arg) with
+        | (Directive_none f, Pdir_none) -> f (); true
+        | (Directive_string f, Pdir_string s) -> f s; true
+        | (Directive_int f, Pdir_int n) -> f n; true
+        | (Directive_ident f, Pdir_ident lid) -> f lid; true
+        | (Directive_bool f, Pdir_bool b) -> f b; true
+        | (_, _) ->
+            fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name;
+            false
+      with Not_found ->
+        fprintf ppf "Unknown directive `%s'.@." dir_name;
+        false
+
+(* Temporary assignment to a reference *)
+
+let protect r newval body =
+  let oldval = !r in
+  try
+    r := newval; 
+    let res = body() in
+    r := oldval;
+    res
+  with x ->
+    r := oldval;
+    raise x
+
+(* Read and execute commands from a file *)
+
+let use_print_results = ref true
+
+let use_file ppf name =
+  try
+    let filename = find_in_path !Config.load_path name in
+    let ic = open_in_bin filename in
+    let lb = Lexing.from_channel ic in
+    (* Skip initial #! line if any *)
+    Lexer.skip_sharp_bang lb;
+    let success =
+      protect Location.input_name filename (fun () ->
+        try
+          List.iter
+            (fun ph ->
+              if !Clflags.dump_parsetree then Printast.top_phrase ppf ph;
+              if not (execute_phrase !use_print_results ppf ph) then raise Exit)
+            (!parse_use_file lb);
+          true
+        with
+        | Exit -> false
+        | Sys.Break -> fprintf ppf "Interrupted.@."; false
+        | x -> Errors.report_error ppf x; false) in
+    close_in ic;
+    success
+  with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
+
+let use_silently ppf name =
+  protect use_print_results false (fun () -> use_file ppf name)
+
+(* Reading function for interactive use *)
+
+let first_line = ref true
+let got_eof = ref false;;
+
+let refill_lexbuf buffer len =
+  if !got_eof then (got_eof := false; 0) else begin
+    let prompt =
+      if !first_line then "# "
+      else if Lexer.in_comment () then "* "
+      else "  "
+    in
+    output_string stdout prompt; flush stdout;
+    first_line := false;
+    let i = ref 0 in
+    try
+      while true do
+        if !i >= len then raise Exit;
+        let c = input_char stdin in
+        buffer.[!i] <- c;
+        incr i;
+        if c = '\n' then raise Exit;
+      done;
+      !i
+    with
+    | End_of_file ->
+        Location.echo_eof ();
+        if !i > 0 then (got_eof := true; !i) else 0
+    | Exit -> !i
+  end
+
+(* Discard everything already in a lexer buffer *)
+
+let empty_lexbuf lb =
+  let l = String.length lb.lex_buffer in
+  lb.lex_abs_pos <- (-l);
+  lb.lex_curr_pos <- l
+
+(* Toplevel initialization. Performed here instead of at the
+   beginning of loop() so that user code linked in with ocamlmktop
+   can call directives from Topdirs. *)
+
+let _ =
+  Sys.interactive := true;
+  Symtable.init_toplevel();
+  Compile.init_path()
+
+let load_ocamlinit ppf =
+  if Sys.file_exists ".ocamlinit" then ignore(use_silently ppf ".ocamlinit")
+
+(* The interactive loop *)
+
+exception PPerror
+
+let loop ppf =
+  fprintf ppf "        Objective Caml version %s@.@." Config.version;
+  (* Add whatever -I options have been specified on the command line,
+     but keep the directories that user code linked in with ocamlmktop
+     may have added to load_path. *)
+  load_path := !load_path @ [Filename.concat Config.standard_library "camlp4"];
+  load_path := "" :: (List.rev !Clflags.include_dirs @ !load_path);
+  Dll.add_path !load_path;
+  toplevel_env := Compile.initial_env();
+  let lb = Lexing.from_function refill_lexbuf in
+  Location.input_name := "";
+  Location.input_lexbuf := Some lb;
+  Sys.catch_break true;
+  load_ocamlinit ppf;
+  while true do
+    try
+      empty_lexbuf lb;
+      Location.reset();
+      first_line := true;
+      let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
+      if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
+      ignore(execute_phrase true ppf phr)
+    with
+    | End_of_file -> exit 0
+    | Sys.Break -> fprintf ppf "Interrupted.@."
+    | PPerror -> ()
+    | x -> Errors.report_error ppf x
+  done
+
+(* Execute a script *)
+
+let run_script ppf name args =
+  let rec find n =
+    if n >= Array.length args then invalid_arg "Toploop.run_script";
+    if args.(n) = name then n else find (n+1) 
+  in
+  let pos = find 0 in
+  let len = Array.length args - pos in
+  if Array.length Sys.argv < len then invalid_arg "Toploop.run_script";
+  Array.blit args pos Sys.argv 0 len;
+  Obj.truncate (Obj.repr Sys.argv) len;
+  Arg.current := 0;
+  Compile.init_path();
+  toplevel_env := Compile.initial_env();
+  Sys.interactive := false;
+  use_silently ppf name
diff --git a/utils/config.mlp b/utils/config.mlp
new file mode 100644
index 0000000000..2ae4b030f5
--- /dev/null
+++ b/utils/config.mlp
@@ -0,0 +1,60 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+let version = "3.04"
+
+let standard_library =
+  try
+    Sys.getenv "OCAMLLIB"
+  with Not_found ->
+  try
+    Sys.getenv "CAMLLIB"
+  with Not_found ->
+    "%%LIBDIR%%"
+
+let standard_runtime = "%%BYTERUN%%"
+let bytecomp_c_compiler = "%%BYTECC%%"
+let bytecomp_c_linker = "%%BYTELINK%%"
+let bytecomp_c_libraries = "%%BYTECCLIBS%%"
+let native_c_compiler = "%%NATIVECC%%"
+let native_c_linker = "%%NATIVELINK%%"
+let native_c_libraries = "%%NATIVECCLIBS%%"
+let native_partial_linker = "%%PARTIALLD%%"
+let ranlib = "%%RANLIBCMD%%"
+
+let exec_magic_number = "Caml1999X007"
+and cmi_magic_number = "Caml1999I008"
+and cmo_magic_number = "Caml1999O004"
+and cma_magic_number = "Caml1999A006"
+and cmx_magic_number = "Caml1999Y006"
+and cmxa_magic_number = "Caml1999Z008"
+and ast_impl_magic_number = "Caml1999M008"
+and ast_intf_magic_number = "Caml1999N007"
+
+let load_path = ref ([] : string list)
+
+let interface_suffix = ref ".mli"
+
+let max_tag = 248
+let max_young_wosize = 256
+let stack_threshold = 256 (* see byterun/config.h *)
+
+let architecture = "%%ARCH%%"
+let model = "%%MODEL%%"
+let system = "%%SYSTEM%%"
+
+let ext_obj = "%%EXT_OBJ%%"
+let ext_asm = "%%EXT_ASM%%"
+let ext_lib = "%%EXT_LIB%%"
+let ext_dll = "%%EXT_DLL%%"