Fusion des modifs faites sur la branche release jusqu'a la release 3.08.0

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

95 files changed, 9501 insertions, 737 deletions

diff --git a/camlp4/unmaintained/format/.depend b/camlp4/unmaintained/format/.depend
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/camlp4/unmaintained/format/.depend
diff --git a/camlp4/unmaintained/format/Makefile b/camlp4/unmaintained/format/Makefile
new file mode 100644
index 000000000..c38872097
--- /dev/null
+++ b/camlp4/unmaintained/format/Makefile
@@ -0,0 +1,61 @@
+#########################################################################
+#                                                                       #
+#                            Objective Caml                             #
+#                                                                       #
+#                                Camlp4                                 #
+#                                                                       #
+#   Copyright 2004 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.                #
+#                                                                       #
+#########################################################################
+#
+# Makefile for pa_format
+# M.Mauny
+#
+
+include ../../config/Makefile.cnf
+
+OCAMLTOP=../../..
+CAMLP4=../../camlp4/camlp4$(EXE)
+
+OCAMLC=$(OCAMLTOP)/ocamlc$(EXE)
+OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE)
+
+P4INCLUDES= -nolib -I ../../lib -I ../../meta -I ../../etc
+OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../lib -I ../../camlp4
+OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES)
+
+SRC=pa_format.ml
+OBJS=$(SRC:.ml=.cmo)
+OBJSX=$(SRC:.ml=.cmx)
+
+all: $(OBJS)
+
+opt: $(OBJSX)
+
+depend:
+	cp .depend .depend.bak
+	> .depend
+	for file in $(SRC); do \
+	  $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \
+	  sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \
+	done
+
+clean:
+	rm -f *.cm* *.$(O) *.bak .*.bak
+
+
+.SUFFIXES: .cmx .cmo .cmi .ml .mli
+
+.mli.cmi:
+	$(OCAMLC) $(OCAMLCFLAGS) -c $<
+
+
+.ml.cmo:
+	$(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $<
+
+.ml.cmx:
+	$(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $<
+
+include .depend
diff --git a/camlp4/unmaintained/format/README b/camlp4/unmaintained/format/README
new file mode 100644
index 000000000..809d42f2a
--- /dev/null
+++ b/camlp4/unmaintained/format/README
@@ -0,0 +1,15 @@
+This is an application of or an extension for Camlp4. Although it is
+currently distributed with OCaml/Camlp4, it may or may not be
+actively maintained.
+
+It probably won't be part of future OCaml/Camlp4 distributions but be
+accessible from the Camlp4 hump. If you are interested in developing
+this package further and/or actively maintain it, please let us know
+(caml@inria.fr)
+
+This package is distributed under the same license as the Objective
+Caml Library (that is, LGPL with a special exception allowing both
+static and dynamic link).
+
+-- Michel Mauny
+
diff --git a/camlp4/unmaintained/format/pa_format.ml b/camlp4/unmaintained/format/pa_format.ml
new file mode 100644
index 000000000..22ecc2b78
--- /dev/null
+++ b/camlp4/unmaintained/format/pa_format.ml
@@ -0,0 +1,52 @@
+(* pa_r.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *)
+(***********************************************************************)
+(*                                                                     *)
+(*                               Camlp4                                *)
+(*                                                                     *)
+(*    Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2002 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 Pcaml;
+
+EXTEND
+  GLOBAL: expr;
+  expr: LEVEL "top"
+    [ [ n = box_type; d = SELF; "begin";
+        el = LIST0 [ e = box_expr; ";" -> e ]; "end" ->
+          let el = [<:expr< Format.$lid:"open_" ^ n$ $d$ >> :: el] in
+          let el = el @ [<:expr< Format.close_box () >>] in
+          <:expr< do { $list:el$ } >>
+      | "hbox"; "begin"; el = LIST0 [ e = box_expr; ";" -> e ]; "end" ->
+          let el = [<:expr< Format.open_hbox () >> :: el] in
+          let el = el @ [<:expr< Format.close_box () >>] in
+          <:expr< do { $list:el$ } >>
+      | "nobox"; "begin"; el = LIST0 [ e = box_expr; ";" -> e ]; "end" ->
+          match el with
+          [ [e] -> e
+          | _ -> <:expr< do { $list:el$ } >> ] ] ]
+  ;
+  box_type:
+    [ [ n = "hovbox" -> n
+      | n = "hvbox" -> n
+      | n = "vbox" -> n
+      | n = "box" -> n ] ]
+  ;
+  box_expr:
+    [ [ s = STRING -> <:expr< Format.print_string $str:s$ >>
+      | UIDENT "STRING"; e = expr -> <:expr< Format.print_string $e$ >>
+      | UIDENT "INT"; e = expr -> <:expr< Format.print_int $e$ >>
+      | "/-" -> <:expr< Format.print_space () >>
+      | "//" -> <:expr< Format.print_cut () >>
+      | "!/" -> <:expr< Format.force_newline () >>
+      | "?/" -> <:expr< Format.print_if_newline () >>
+      | e = expr -> e ] ]
+  ;
+END;
diff --git a/camlp4/unmaintained/lefteval/.depend b/camlp4/unmaintained/lefteval/.depend
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/camlp4/unmaintained/lefteval/.depend
diff --git a/camlp4/unmaintained/lefteval/Makefile b/camlp4/unmaintained/lefteval/Makefile
new file mode 100644
index 000000000..7e5cdd02e
--- /dev/null
+++ b/camlp4/unmaintained/lefteval/Makefile
@@ -0,0 +1,61 @@
+#########################################################################
+#                                                                       #
+#                            Objective Caml                             #
+#                                                                       #
+#                                Camlp4                                 #
+#                                                                       #
+#   Copyright 2004 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.                #
+#                                                                       #
+#########################################################################
+#
+# Makefile for pa_lefteval
+# M.Mauny
+#
+
+include ../../config/Makefile.cnf
+
+OCAMLTOP=../../..
+CAMLP4=../../camlp4/camlp4$(EXE)
+
+OCAMLC=$(OCAMLTOP)/ocamlc$(EXE)
+OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE)
+
+P4INCLUDES= -nolib -I ../../meta -I ../../etc
+OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../camlp4
+OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES)
+
+SRC=pa_lefteval.ml
+OBJS=$(SRC:.ml=.cmo)
+OBJSX=$(SRC:.ml=.cmx)
+
+all: $(OBJS)
+
+opt: $(OBJSX)
+
+depend:
+	cp .depend .depend.bak
+	> .depend
+	for file in $(SRC); do \
+	  $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \
+	  sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \
+	done
+
+clean:
+	rm -f *.cm* *.$(O) *.bak .*.bak
+
+
+.SUFFIXES: .cmx .cmo .cmi .ml .mli
+
+.mli.cmi:
+	$(OCAMLC) $(OCAMLCFLAGS) -c $<
+
+
+.ml.cmo:
+	$(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $<
+
+.ml.cmx:
+	$(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $<
+
+include .depend
diff --git a/camlp4/unmaintained/lefteval/README b/camlp4/unmaintained/lefteval/README
new file mode 100644
index 000000000..809d42f2a
--- /dev/null
+++ b/camlp4/unmaintained/lefteval/README
@@ -0,0 +1,15 @@
+This is an application of or an extension for Camlp4. Although it is
+currently distributed with OCaml/Camlp4, it may or may not be
+actively maintained.
+
+It probably won't be part of future OCaml/Camlp4 distributions but be
+accessible from the Camlp4 hump. If you are interested in developing
+this package further and/or actively maintain it, please let us know
+(caml@inria.fr)
+
+This package is distributed under the same license as the Objective
+Caml Library (that is, LGPL with a special exception allowing both
+static and dynamic link).
+
+-- Michel Mauny
+
diff --git a/camlp4/unmaintained/lefteval/pa_lefteval.ml b/camlp4/unmaintained/lefteval/pa_lefteval.ml
new file mode 100644
index 000000000..89a179f6e
--- /dev/null
+++ b/camlp4/unmaintained/lefteval/pa_lefteval.ml
@@ -0,0 +1,241 @@
+(* pa_r.cmo q_MLast.cmo pr_dump.cmo *)
+(***********************************************************************)
+(*                                                                     *)
+(*                               Camlp4                                *)
+(*                                                                     *)
+(*    Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2002 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$ *)
+
+value not_impl name x =
+  let desc =
+    if Obj.is_block (Obj.repr x) then
+      "tag = " ^ string_of_int (Obj.tag (Obj.repr x))
+    else "int_val = " ^ string_of_int (Obj.magic x)
+  in
+  failwith ("pa_lefteval: not impl: " ^ name ^ "; " ^ desc ^ ">")
+;
+
+value rec expr_fa al =
+  fun
+  [ <:expr< $f$ $a$ >> -> expr_fa [a :: al] f
+  | f -> (f, al) ]
+;
+
+(* generating let..in before functions calls which evaluates
+   several (more than one) of their arguments *)
+
+value no_side_effects_ht =
+  let ht = Hashtbl.create 73 in
+  do {
+    List.iter (fun s -> Hashtbl.add ht s True)
+      ["<"; "="; "@"; "^"; "+"; "-"; "ref"];
+    ht
+  }
+;
+
+value no_side_effects =
+  fun
+  [ <:expr< $uid:_$ >> -> True
+  | <:expr< $uid:_$ . $uid:_$ >> -> True
+  | <:expr< $lid:s$ >> ->
+      try Hashtbl.find no_side_effects_ht s with [ Not_found -> False ]
+  | _ -> False ]
+;
+
+value rec may_side_effect =
+  fun
+  [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $str:_$ >> |
+    <:expr< $chr:_$ >> | <:expr< $int:_$ >> | <:expr< $flo:_$ >> |
+    <:expr< $_$ . $_$ >> | <:expr< fun [ $list:_$ ] >> ->
+      False
+  | <:expr< ($list:el$) >> -> List.exists may_side_effect el
+  | <:expr< $_$ $_$ >> as e ->
+      let (f, el) = expr_fa [] e in
+      not (no_side_effects f) || List.exists may_side_effect el
+  | _ -> True ]
+;
+
+value rec may_be_side_effect_victim =
+  fun
+  [ <:expr< $lid:_$ . $_$ >> -> True
+  | <:expr< $uid:_$ . $e$ >> -> may_be_side_effect_victim e
+  | _ -> False ]
+;
+
+value rec may_depend_on_order el =
+  loop False False el where rec loop
+    side_effect_found side_effect_victim_found =
+    fun
+    [ [e :: el] ->
+        if may_side_effect e then
+          if side_effect_found || side_effect_victim_found then True
+          else loop True True el
+        else if may_be_side_effect_victim e then
+          if side_effect_found then True else loop False True el
+        else loop side_effect_found side_effect_victim_found el
+    | [] -> False ]
+;
+
+value gen_let_in loc expr el =
+  let (pel, el) =
+    loop 0 (List.rev el) where rec loop n =
+      fun
+      [ [e :: el] ->
+          if may_side_effect e || may_be_side_effect_victim e then
+            if n = 0 then
+              let (pel, el) = loop 1 el in
+              (pel, [expr e :: el])
+            else
+              let id = "xxx" ^ string_of_int n in
+              let (pel, el) = loop (n + 1) el in
+              ([(<:patt< $lid:id$ >>, expr e) :: pel],
+               [<:expr< $lid:id$ >> :: el])
+          else
+            let (pel, el) = loop n el in
+            (pel, [expr e :: el])
+      | [] -> ([], []) ]
+  in
+  match List.rev el with
+  [ [e :: el] -> (pel, e, el)
+  | _ -> assert False ]
+;
+
+value left_eval_apply loc expr e1 e2 =
+  let (f, el) = expr_fa [] <:expr< $e1$ $e2$ >> in
+  if not (may_depend_on_order [f :: el]) then <:expr< $expr e1$ $expr e2$ >>
+  else
+    let (pel, e, el) = gen_let_in loc expr [f :: el] in
+    let e = List.fold_left (fun e e1 -> <:expr< $e$ $e1$ >>) e el in
+    List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) e pel
+;
+
+value left_eval_tuple loc expr el =
+  if not (may_depend_on_order el) then <:expr< ($list:List.map expr el$) >>
+  else
+    let (pel, e, el) = gen_let_in loc expr el in
+    List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>)
+      <:expr< ($list:[e :: el]$) >> pel
+;
+
+value left_eval_record loc expr lel =
+  let el = List.map snd lel in
+  if not (may_depend_on_order el) then
+    let lel = List.map (fun (p, e) -> (p, expr e)) lel in
+    <:expr< { $list:lel$ } >>
+  else
+    let (pel, e, el) = gen_let_in loc expr el in
+    let e =
+      let lel = List.combine (List.map fst lel) [e :: el] in
+      <:expr< { $list:lel$ } >>
+    in
+    List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) e pel
+;
+
+value left_eval_assign loc expr e1 e2 = <:expr< $e1$ := $expr e2$ >>;
+
+(* scanning the input tree, calling "left_eval_*" functions if necessary *)
+
+value map_option f =
+  fun
+  [ Some x -> Some (f x)
+  | None -> None ]
+;
+
+value class_infos f ci =
+  {MLast.ciLoc = ci.MLast.ciLoc; MLast.ciVir = ci.MLast.ciVir;
+   MLast.ciPrm = ci.MLast.ciPrm; MLast.ciNam = ci.MLast.ciNam;
+   MLast.ciExp = f ci.MLast.ciExp}
+;
+
+value rec expr x =
+  let loc = MLast.loc_of_expr x in
+  match x with
+  [ <:expr< fun [ $list:pwel$ ] >> ->
+      <:expr< fun [ $list:List.map match_assoc pwel$ ] >>
+  | <:expr< match $e$ with [ $list:pwel$ ] >> ->
+      <:expr< match $expr e$ with [ $list:List.map match_assoc pwel$ ] >>
+  | <:expr< try $e$ with [ $list:pwel$ ] >> ->
+      <:expr< try $expr e$ with [ $list:List.map match_assoc pwel$ ] >>
+  | <:expr< let $opt:rf$ $list:pel$ in $e$ >> ->
+      <:expr< let $opt:rf$ $list:List.map let_binding pel$ in $expr e$ >>
+  | <:expr< let module $s$ = $me$ in $e$ >> ->
+      <:expr< let module $s$ = $module_expr me$ in $expr e$ >>
+  | <:expr< if $e1$ then $e2$ else $e3$ >> ->
+      <:expr< if $expr e1$ then $expr e2$ else $expr e3$ >>
+  | <:expr< while $e$ do { $list:el$ } >> ->
+      <:expr< while $expr e$ do { $list:List.map expr el$ } >>
+  | <:expr< do { $list:el$ } >> -> <:expr< do { $list:List.map expr el$ } >>
+  | <:expr< $e$ # $s$ >> -> <:expr< $expr e$ # $s$ >>
+  | <:expr< ($e$ : $t$) >> -> <:expr< ($expr e$ : $t$) >>
+  | <:expr< $e1$ || $e2$ >> -> <:expr< $expr e1$ || $expr e2$ >>
+  | <:expr< $e1$ && $e2$ >> -> <:expr< $expr e1$ && $expr e2$ >>
+  | <:expr< $e1$ $e2$ >> -> left_eval_apply loc expr e1 e2
+  | <:expr< ($list:el$) >> -> left_eval_tuple loc expr el
+  | <:expr< { $list:lel$ } >> -> left_eval_record loc expr lel
+  | <:expr< $e1$ := $e2$ >> -> left_eval_assign loc expr e1 e2
+  | <:expr< $_$ . $_$ >> | <:expr< $uid:_$ >> | <:expr< $lid:_$ >> |
+    <:expr< $str:_$ >> | <:expr< $chr:_$ >> | <:expr< $int:_$ >> |
+    <:expr< $flo:_$ >> | <:expr< new $list:_$ >> ->
+      x
+  | x -> not_impl "expr" x ]
+and let_binding (p, e) = (p, expr e)
+and match_assoc (p, eo, e) = (p, map_option expr eo, expr e)
+and module_expr x =
+  let loc = MLast.loc_of_module_expr x in
+  match x with
+  [ <:module_expr< functor ($s$ : $mt$) -> $me$ >> ->
+      <:module_expr< functor ($s$ : $mt$) -> $module_expr me$ >>
+  | <:module_expr< ($me$ : $mt$) >> ->
+      <:module_expr< ($module_expr me$ : $mt$) >>
+  | <:module_expr< struct $list:sil$ end >> ->
+      <:module_expr< struct $list:List.map str_item sil$ end >>
+  | <:module_expr< $_$ . $_$ >> | <:module_expr< $_$ $_$ >> |
+    <:module_expr< $uid:_$ >> ->
+      x ]
+and str_item x =
+  let loc = MLast.loc_of_str_item x in
+  match x with
+  [ <:str_item< module $s$ = $me$ >> ->
+      <:str_item< module $s$ = $module_expr me$ >>
+  | <:str_item< value $opt:rf$ $list:pel$ >> ->
+      <:str_item< value $opt:rf$ $list:List.map let_binding pel$ >>
+  | <:str_item< declare $list:sil$ end >> ->
+      <:str_item< declare $list:List.map str_item sil$ end >>
+  | <:str_item< class $list:ce$ >> ->
+      <:str_item< class $list:List.map (class_infos class_expr) ce$ >>
+  | <:str_item< $exp:e$ >> -> <:str_item< $exp:expr e$ >>
+  | <:str_item< open $_$ >> | <:str_item< type $list:_$ >> |
+    <:str_item< exception $_$ of $list:_$ = $_$ >> |
+    <:str_item< module type $_$ = $_$ >> | <:str_item< # $_$ $opt:_$ >> ->
+      x
+  | x -> not_impl "str_item" x ]
+and class_expr x =
+  let loc = MLast.loc_of_class_expr x in
+  match x with
+  [ <:class_expr< object $opt:p$ $list:csil$ end >> ->
+      <:class_expr< object $opt:p$ $list:List.map class_str_item csil$ end >>
+  | x -> not_impl "class_expr" x ]
+and class_str_item x =
+  let loc = MLast.loc_of_class_str_item x in
+  match x with
+  [ <:class_str_item< value $opt:mf$ $s$ = $e$ >> ->
+      <:class_str_item< value $opt:mf$ $s$ = $expr e$ >>
+  | <:class_str_item< method $s$ = $e$ >> ->
+      <:class_str_item< method $s$ = $expr e$ >>
+  | x -> not_impl "class_str_item" x ]
+;
+
+value parse_implem = Pcaml.parse_implem.val;
+value parse_implem_with_left_eval strm =
+  let (r, b) = parse_implem strm in
+  (List.map (fun (si, loc) -> (str_item si, loc)) r, b)
+;
+Pcaml.parse_implem.val := parse_implem_with_left_eval;
diff --git a/camlp4/unmaintained/ocamllex/Makefile b/camlp4/unmaintained/ocamllex/Makefile
new file mode 100644
index 000000000..b232023e5
--- /dev/null
+++ b/camlp4/unmaintained/ocamllex/Makefile
@@ -0,0 +1,59 @@
+#########################################################################
+#                                                                       #
+#                            Objective Caml                             #
+#                                                                       #
+#                                Camlp4                                 #
+#                                                                       #
+#   Copyright 2004 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.                #
+#                                                                       #
+#########################################################################
+#
+# Makefile for pa_ocamllex
+# M.Mauny
+#
+
+include ../../config/Makefile.cnf
+
+OCAMLTOP=../../..
+
+CAMLP4=../../camlp4/camlp4$(EXE)
+
+OCAMLC=$(OCAMLTOP)/ocamlc$(EXE)
+OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE)
+
+P4INCLUDES= -nolib -I ../../etc -I ../../meta
+OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../camlp4 -I ../../lib -I $(OCAMLTOP)/lex
+OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES)
+
+SRC=pa_ocamllex.ml
+OBJS=pa_ocamllex.cmo
+OBJSX=$(OBJS:.cmo=.cmx)
+
+all: $(OBJS) pa_ocamllex.cma
+
+opt: $(OBJSX) pa_ocamllex.cmxa
+
+pa_ocamllex.cma: pa_ocamllex.cmo
+	$(OCAMLC) $(OCAMLCFLAGS) cset.cmo syntax.cmo table.cmo lexgen.cmo compact.cmo pa_ocamllex.cmo -a -o pa_ocamllex.cma
+
+pa_ocamllex.cmxa: pa_ocamllex.cmo
+	$(OCAMLOPT) $(OCAMLCFLAGS) cset.cmx syntax.cmx table.cmx lexgen.cmx compact.cmx pa_ocamllex.cmx -a -o pa_ocamllex.cmxa
+
+clean:
+	rm -f *.cm* *.$(O) *.$(A) *.bak .*.bak
+
+depend:
+
+.SUFFIXES: .cmx .cmo .cmi .ml .mli
+
+.mli.cmi:
+	$(OCAMLC) $(OCAMLCFLAGS) -c $<
+
+
+.ml.cmo:
+	$(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $<
+
+.ml.cmx:
+	$(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $<
diff --git a/camlp4/unmaintained/ocamllex/README b/camlp4/unmaintained/ocamllex/README
new file mode 100644
index 000000000..809d42f2a
--- /dev/null
+++ b/camlp4/unmaintained/ocamllex/README
@@ -0,0 +1,15 @@
+This is an application of or an extension for Camlp4. Although it is
+currently distributed with OCaml/Camlp4, it may or may not be
+actively maintained.
+
+It probably won't be part of future OCaml/Camlp4 distributions but be
+accessible from the Camlp4 hump. If you are interested in developing
+this package further and/or actively maintain it, please let us know
+(caml@inria.fr)
+
+This package is distributed under the same license as the Objective
+Caml Library (that is, LGPL with a special exception allowing both
+static and dynamic link).
+
+-- Michel Mauny
+
diff --git a/camlp4/unmaintained/ocamllex/pa_ocamllex.ml b/camlp4/unmaintained/ocamllex/pa_ocamllex.ml
new file mode 100644
index 000000000..94d553646
--- /dev/null
+++ b/camlp4/unmaintained/ocamllex/pa_ocamllex.ml
@@ -0,0 +1,356 @@
+(* pa_o.cmo q_MLast.cmo pa_extend.cmo pr_dump.cmo *)
+(***********************************************************************)
+(*                                                                     *)
+(*                               Camlp4                                *)
+(*                                                                     *)
+(*     Alain Frisch, projet Cristal, INRIA Rocquencourt                *)
+(*                                                                     *)
+(*  Copyright 2002 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 Syntax
+open Lexgen
+open Compact
+
+(* Adapted from output.ml *)
+(**************************)
+
+(* Output the DFA tables and its entry points *)
+
+(* To output an array of short ints, encoded as a string *)
+
+let output_byte buf b =
+  Buffer.add_char buf '\\';
+  Buffer.add_char buf (Char.chr(48 + b / 100));
+  Buffer.add_char buf (Char.chr(48 + (b / 10) mod 10));
+  Buffer.add_char buf (Char.chr(48 + b mod 10))
+
+let loc = (Lexing.dummy_pos,Lexing.dummy_pos)
+
+let output_array v =
+  let b = Buffer.create (Array.length v * 3) in
+  for i = 0 to Array.length v - 1 do
+    output_byte b (v.(i) land 0xFF);
+    output_byte b ((v.(i) asr 8) land 0xFF);
+    if i land 7 = 7 then Buffer.add_string b "\\\n    "
+  done;
+  let s = Buffer.contents b in
+  <:expr< $str:s$ >>
+
+let output_byte_array v =
+  let b = Buffer.create (Array.length v * 2) in
+  for i = 0 to Array.length v - 1 do
+    output_byte b (v.(i) land 0xFF);
+    if i land 15 = 15 then Buffer.add_string b "\\\n    "
+  done;
+  let s = Buffer.contents b in
+  <:expr< $str:s$ >>
+
+
+
+(* Output the tables *)
+
+let output_tables tbl =
+  <:str_item< value lex_tables = {
+    Lexing.lex_base = $output_array tbl.tbl_base$;
+    Lexing.lex_backtrk = $output_array tbl.tbl_backtrk$;
+    Lexing.lex_default = $output_array tbl.tbl_default$;
+    Lexing.lex_trans = $output_array tbl.tbl_trans$;
+    Lexing.lex_check = $output_array tbl.tbl_check$;
+    Lexing.lex_base_code = $output_array tbl.tbl_base_code$;
+    Lexing.lex_backtrk_code = $output_array tbl.tbl_backtrk_code$;
+    Lexing.lex_default_code = $output_array tbl.tbl_default_code$;
+    Lexing.lex_trans_code = $output_array tbl.tbl_trans_code$;
+    Lexing.lex_check_code = $output_array tbl.tbl_check_code$;
+    Lexing.lex_code = $output_byte_array tbl.tbl_code$
+  } >>
+
+(* Output the entries *)
+
+let rec make_alias n = function
+  | [] -> []
+  | h::t -> 
+      (h, "__ocaml_lex_arg_" ^ (string_of_int n)) :: (make_alias (succ n) t)
+
+let abstraction =
+  List.fold_right (fun (p,a) e -> <:expr< fun ($p$ as $lid:a$) -> $e$ >>)
+
+
+let application =
+  List.fold_left (fun f (_,a) -> <:expr< $f$ $lid:a$ >>)
+
+let int i = <:expr< $int:string_of_int i$ >>
+
+let output_memory_actions acts = 
+  let aux = function
+    | Copy (tgt, src) -> 
+	<:expr< lexbuf.Lexing.lex_mem.($int tgt$) := 
+      lexbuf.Lexing.lex_mem.($int src$) >>
+    | Set tgt ->
+        <:expr< lexbuf.Lexing.lex_mem.($int tgt$) := 
+      lexbuf.Lexing.lex_curr_pos >>
+  in
+  <:expr< do { $list:List.map aux acts$ } >>
+
+let output_base_mem = function
+  | Mem i -> <:expr< lexbuf.Lexing.lex_mem.($int i$) >>
+  | Start -> <:expr< lexbuf.Lexing.lex_start_pos >>
+  | End   -> <:expr< lexbuf.Lexing.lex_curr_pos >>
+
+let output_tag_access = function
+  | Sum (a,0) -> output_base_mem a
+  | Sum (a,i) -> <:expr< $output_base_mem a$ + $int i$ >>
+
+let rec output_env e = function
+  | [] -> e
+  | (x, Ident_string (o,nstart,nend)) :: rem ->
+      <:expr< 
+	  let $lid:x$ = 
+	    Lexing.$lid:if o then "sub_lexeme_opt" else "sub_lexeme"$
+	    lexbuf $output_tag_access nstart$ $output_tag_access nend$
+          in $output_env e rem$
+      >>
+  | (x, Ident_char (o,nstart)) :: rem ->
+      <:expr< 
+	  let $lid:x$ = 
+	    Lexing.$lid: if o then "sub_lexeme_char_opt" else "sub_lexeme_char"$
+	    lexbuf $output_tag_access nstart$
+          in $output_env e rem$
+      >>
+
+let output_entry e =
+  let init_num, init_moves = e.auto_initial_state in
+  let args = make_alias 0 (e.auto_args @ [ <:patt< lexbuf >> ]) in
+  let f = "__ocaml_lex_rec_" ^ e.auto_name ^ "_rec" in
+  let call_f = application <:expr< $lid:f$ >> args in
+  let body_wrapper = 
+    <:expr< 
+      do {
+	lexbuf.Lexing.lex_mem := Array.create $int e.auto_mem_size$ (-1) ;
+	$output_memory_actions init_moves$;
+        $call_f$ $int init_num$
+      } >> in
+  let cases = 
+    List.map
+      (fun (num, env, (loc,e)) ->
+         <:patt< $int:string_of_int num$ >>, 
+	 None, 
+	 output_env <:expr< $e$ >> env
+	     (* Note: the <:expr<...>> above is there to set the location *)
+      ) e.auto_actions @
+    [ <:patt< __ocaml_lex_n >>,
+      None,
+      <:expr< do 
+        { lexbuf.Lexing.refill_buff lexbuf; $call_f$ __ocaml_lex_n  }>> ]
+  in
+  let engine = 
+    if e.auto_mem_size = 0 
+    then <:expr< Lexing.engine >>
+    else <:expr< Lexing.new_engine >> in
+  let body = 
+    <:expr< fun state ->
+      match $engine$ lex_tables state lexbuf with [ $list:cases$ ] >> in
+  [
+    <:patt< $lid:e.auto_name$ >>, (abstraction args body_wrapper);
+    <:patt< $lid:f$ >>, (abstraction args body) 
+  ]
+
+(* Main output function *)
+
+exception Table_overflow
+
+let output_lexdef tables entry_points =
+  Printf.eprintf 
+    "pa_ocamllex: lexer found; %d states, %d transitions, table size %d bytes\n"
+    (Array.length tables.tbl_base)
+    (Array.length tables.tbl_trans)
+    (2 * (Array.length tables.tbl_base + Array.length tables.tbl_backtrk +
+          Array.length tables.tbl_default + Array.length tables.tbl_trans +
+          Array.length tables.tbl_check));
+  let size_groups =
+    (2 * (Array.length tables.tbl_base_code +
+          Array.length tables.tbl_backtrk_code +
+          Array.length tables.tbl_default_code +
+          Array.length tables.tbl_trans_code +
+          Array.length tables.tbl_check_code) +
+    Array.length tables.tbl_code) in
+  if  size_groups > 0 then
+    Printf.eprintf "pa_ocamllex: %d additional bytes used for bindings\n" 
+      size_groups ;
+  flush stderr;
+  if Array.length tables.tbl_trans > 0x8000 then raise Table_overflow;
+
+  let entries = List.map output_entry entry_points in
+  [output_tables tables; <:str_item< value rec $list:List.flatten entries$ >> ]
+
+
+(* Adapted from parser.mly and main.ml *)
+(***************************************)
+
+(* Auxiliaries for the parser. *)
+
+let char s = Char.code (Token.eval_char s)
+
+let named_regexps =
+  (Hashtbl.create 13 : (string, regular_expression) Hashtbl.t)
+
+let regexp_for_string s =
+  let rec re_string n =
+    if n >= String.length s then Epsilon
+    else if succ n = String.length s then
+      Characters (Cset.singleton (Char.code s.[n]))
+    else
+      Sequence
+        (Characters(Cset.singleton (Char.code s.[n])),
+         re_string (succ n))
+  in re_string 0
+
+let char_class c1 c2 = Cset.interval c1 c2
+
+let all_chars = Cset.all_chars
+
+let rec remove_as = function
+  | Bind (e,_) -> remove_as e
+  | Epsilon|Eof|Characters _ as e -> e
+  | Sequence (e1, e2) -> Sequence (remove_as e1, remove_as e2)
+  | Alternative (e1, e2) -> Alternative (remove_as e1, remove_as e2)
+  | Repetition e -> Repetition (remove_as e)
+
+let () =
+  Hashtbl.add named_regexps "eof" (Characters Cset.eof)
+
+(* The parser *)
+
+let let_regexp = Grammar.Entry.create Pcaml.gram "pa_ocamllex let"
+let header = Grammar.Entry.create Pcaml.gram "pa_ocamllex header"
+let lexer_def = Grammar.Entry.create Pcaml.gram "pa_ocaml lexerdef"
+
+EXTEND
+ GLOBAL: Pcaml.str_item let_regexp header lexer_def;
+
+ let_regexp: [
+   [ x = LIDENT; "="; r = regexp ->
+       if Hashtbl.mem named_regexps x then
+         Printf.eprintf 
+           "pa_ocamllex (warning): multiple definition of named regexp '%s'\n"
+           x;
+       Hashtbl.add named_regexps x r;
+   ]
+ ];
+
+ lexer_def: [
+   [ def = LIST0 definition SEP "and" ->
+       (try
+          let (entries, transitions) = make_dfa def in
+          let tables = compact_tables transitions in
+          let output = output_lexdef tables entries in
+          <:str_item< declare $list: output$ end >> 
+        with 
+	  |Table_overflow ->
+             failwith "Transition table overflow in lexer, automaton is too big"
+	  | Lexgen.Memory_overflow ->
+              failwith "Position memory overflow in lexer, too many as variables")
+   ]
+ ];
+
+
+ Pcaml.str_item: [
+   [ "pa_ocamllex"; LIDENT "rule"; d = lexer_def -> d
+   | "pa_ocamllex"; "let"; let_regexp -> 
+       <:str_item< declare $list: []$ end >>
+   ]
+ ];
+ 
+ definition: [
+   [ x=LIDENT; pl = LIST0 Pcaml.patt LEVEL "simple"; "=";
+     short=[ LIDENT "parse" -> false | LIDENT "shortest" -> true ];
+     OPT "|"; l = LIST0 [ r=regexp; a=action -> (r,a) ] SEP "|" ->
+     { name=x ; shortest=short ; args=pl ; clauses = l } ]
+ ];
+
+ action: [
+   [ "{"; e = OPT Pcaml.expr; "}" -> 
+       let e = match e with
+         | Some e -> e
+         | None -> <:expr< () >>
+       in
+       (loc,e)
+   ]
+ ];
+
+ header:  [
+   [ "{"; e = LIST0 [ si = Pcaml.str_item; OPT ";;" -> si ]; "}" -> 
+       [<:str_item< declare $list:e$ end>>, loc] ]
+   | [ -> [] ]
+ ];
+
+ regexp: [
+   [ r = regexp; "as"; i = LIDENT -> Bind (r,i) ]
+ | [ r1 = regexp; "|"; r2 = regexp -> Alternative(r1,r2) ]
+ | [ r1 = regexp; r2 = regexp -> Sequence(r1,r2) ]
+ | [ r = regexp; "*" -> Repetition r
+   | r = regexp; "+" -> Sequence(Repetition (remove_as r), r)
+   | r = regexp; "?" -> Alternative(Epsilon, r)
+   | "("; r = regexp; ")" -> r
+   | "_" -> Characters all_chars
+   | c = CHAR -> Characters (Cset.singleton (char c))
+   | s = STRING -> regexp_for_string (Token.eval_string loc s)
+   | "["; cc = ch_class; "]" ->  Characters cc
+   | x = LIDENT ->
+       try  Hashtbl.find named_regexps x
+       with Not_found ->
+         failwith 
+           ("pa_ocamllex (error): reference to unbound regexp name `"^x^"'")
+   ]
+ ];
+
+ ch_class: [
+   [ "^"; cc = ch_class -> Cset.complement cc]
+ | [ c1 = CHAR; "-"; c2 = CHAR -> Cset.interval (char c1) (char c2)
+   | c = CHAR -> Cset.singleton (char c)
+   | cc1 = ch_class; cc2 = ch_class -> Cset.union cc1 cc2
+   ]
+ ];
+END
+
+(* We have to be careful about "rule"; in standalone mode,
+   it is used as a keyword (otherwise, there is a conflict
+   with named regexp); in normal mode, it is used as LIDENT
+   (we do not want to reserve such an useful identifier).
+
+   Plexer does not like identifiers used as keyword _and_
+   as LIDENT ...
+*)
+
+let standalone =
+  let already = ref false in
+  fun () ->
+    if not (!already) then
+    begin
+      already := true;
+      Printf.eprintf "pa_ocamllex: stand-alone mode\n";
+
+      DELETE_RULE Pcaml.str_item: "pa_ocamllex"; LIDENT "rule";lexer_def END;
+      DELETE_RULE Pcaml.str_item: "pa_ocamllex"; "let"; let_regexp END;
+      let ocamllex = Grammar.Entry.create Pcaml.gram "pa_ocamllex" in
+      EXTEND GLOBAL: ocamllex let_regexp header lexer_def;
+      ocamllex: [
+        [ h = header;
+          l  = [LIST0 ["let"; let_regexp]; "rule"; d = lexer_def -> (d,loc)];
+          t = header; EOI -> h @ (l :: t) ,false
+        ]
+      ];
+      END;
+      Pcaml.parse_implem := Grammar.Entry.parse ocamllex
+    end
+
+let () =
+  Pcaml.add_option "-ocamllex" (Arg.Unit standalone)
+    "Activate (standalone) ocamllex emulation mode."
+
diff --git a/camlp4/unmaintained/olabl/.depend b/camlp4/unmaintained/olabl/.depend
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/camlp4/unmaintained/olabl/.depend
diff --git a/camlp4/unmaintained/olabl/Makefile b/camlp4/unmaintained/olabl/Makefile
new file mode 100644
index 000000000..f928d4589
--- /dev/null
+++ b/camlp4/unmaintained/olabl/Makefile
@@ -0,0 +1,61 @@
+#########################################################################
+#                                                                       #
+#                            Objective Caml                             #
+#                                                                       #
+#                                Camlp4                                 #
+#                                                                       #
+#   Copyright 2004 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.                #
+#                                                                       #
+#########################################################################
+#
+# Makefile for pa_lefteval
+# M.Mauny
+#
+
+include ../../config/Makefile.cnf
+
+OCAMLTOP=../../..
+CAMLP4=../../camlp4/camlp4$(EXE)
+
+OCAMLC=$(OCAMLTOP)/ocamlc$(EXE)
+OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE)
+
+P4INCLUDES= -nolib -I ../../meta -I ../../lib -I ../../etc
+OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../lib -I ../../camlp4
+OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES)
+
+SRC=pa_olabl.ml
+OBJS=$(SRC:.ml=.cmo)
+OBJSX=$(SRC:.ml=.cmx)
+
+all: $(OBJS)
+
+opt: $(OBJSX)
+
+depend:
+	cp .depend .depend.bak
+	> .depend
+	for file in $(SRC); do \
+	  $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \
+	  sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \
+	done
+
+clean:
+	rm -f *.cm* *.$(O) *.bak .*.bak
+
+
+.SUFFIXES: .cmx .cmo .cmi .ml .mli
+
+.mli.cmi:
+	$(OCAMLC) $(OCAMLCFLAGS) -c $<
+
+
+.ml.cmo:
+	$(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $<
+
+.ml.cmx:
+	$(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $<
+
+include .depend
diff --git a/camlp4/unmaintained/olabl/README b/camlp4/unmaintained/olabl/README
new file mode 100644
index 000000000..809d42f2a
--- /dev/null
+++ b/camlp4/unmaintained/olabl/README
@@ -0,0 +1,15 @@
+This is an application of or an extension for Camlp4. Although it is
+currently distributed with OCaml/Camlp4, it may or may not be
+actively maintained.
+
+It probably won't be part of future OCaml/Camlp4 distributions but be
+accessible from the Camlp4 hump. If you are interested in developing
+this package further and/or actively maintain it, please let us know
+(caml@inria.fr)
+
+This package is distributed under the same license as the Objective
+Caml Library (that is, LGPL with a special exception allowing both
+static and dynamic link).
+
+-- Michel Mauny
+
diff --git a/camlp4/unmaintained/olabl/pa_olabl.ml b/camlp4/unmaintained/olabl/pa_olabl.ml
new file mode 100644
index 000000000..aba8bab4b
--- /dev/null
+++ b/camlp4/unmaintained/olabl/pa_olabl.ml
@@ -0,0 +1,2022 @@
+(* pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *)
+(***********************************************************************)
+(*                                                                     *)
+(*                               Camlp4                                *)
+(*                                                                     *)
+(*    Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2002 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 Plexer =
+  struct
+    open Stdpp;
+    open Token;
+    value buff = ref (String.create 80);
+    value store len x =
+      do {
+        if len >= String.length buff.val then
+          buff.val := buff.val ^ String.create (String.length buff.val)
+        else ();
+        buff.val.[len] := x;
+        succ len
+      }
+    ;
+    value mstore len s =
+      add_rec len 0 where rec add_rec len i =
+        if i == String.length s then len
+        else add_rec (store len s.[i]) (succ i)
+    ;
+    value get_buff len = String.sub buff.val 0 len;
+    value rec ident len =
+      parser
+      [ [: `('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
+             '\248'..'\255' | '0'..'9' | '_' | ''' as
+             c)
+            ;
+           s :] ->
+          ident (store len c) s
+      | [: :] -> len ]
+    and ident2 len =
+      parser
+      [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
+             '%' | '.' | ':' | '<' | '>' | '|' as
+             c)
+            ;
+           s :] ->
+          ident2 (store len c) s
+      | [: :] -> len ]
+    and ident3 len =
+      parser
+      [ [: `('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' |
+             '\216'..'\246' | '\248'..'\255' | '_' | '!' | '%' | '&' | '*' |
+             '+' | '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' |
+             '|' | '~' | ''' | '$' as
+             c)
+            ;
+           s :] ->
+          ident3 (store len c) s
+      | [: :] -> len ]
+    and ident4 len =
+      parser
+      [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
+             '%' | '.' | '<' | '>' | '|' as
+             c)
+            ;
+           s :] ->
+          ident4 (store len c) s
+      | [: :] -> len ]
+    and base_number len =
+      parser
+      [ [: `'o' | 'O'; s :] -> octal_digits (store len 'o') s
+      | [: `'x' | 'X'; s :] -> hexa_digits (store len 'x') s
+      | [: `'b' | 'B'; s :] -> binary_digits (store len 'b') s
+      | [: a = number len :] -> a ]
+    and octal_digits len =
+      parser
+      [ [: `('0'..'7' as d); s :] -> octal_digits (store len d) s
+      | [: :] -> ("INT", get_buff len) ]
+    and hexa_digits len =
+      parser
+      [ [: `('0'..'9' | 'a'..'f' | 'A'..'F' as d); s :] ->
+          hexa_digits (store len d) s
+      | [: :] -> ("INT", get_buff len) ]
+    and binary_digits len =
+      parser
+      [ [: `('0'..'1' as d); s :] -> binary_digits (store len d) s
+      | [: :] -> ("INT", get_buff len) ]
+    and number len =
+      parser
+      [ [: `('0'..'9' as c); s :] -> number (store len c) s
+      | [: `'.'; s :] -> decimal_part (store len '.') s
+      | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s
+      | [: :] -> ("INT", get_buff len) ]
+    and decimal_part len =
+      parser
+      [ [: `('0'..'9' as c); s :] -> decimal_part (store len c) s
+      | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s
+      | [: :] -> ("FLOAT", get_buff len) ]
+    and exponent_part len =
+      parser
+      [ [: `('+' | '-' as c); s :] -> end_exponent_part (store len c) s
+      | [: a = end_exponent_part len :] -> a ]
+    and end_exponent_part len =
+      parser
+      [ [: `('0'..'9' as c); s :] -> end_exponent_part (store len c) s
+      | [: :] -> ("FLOAT", get_buff len) ]
+    ;
+    value valch x = Char.code x - Char.code '0';
+    value rec backslash s i =
+      if i = String.length s then raise Not_found
+      else
+        match s.[i] with
+        [ 'n' -> ('\n', i + 1)
+        | 'r' -> ('\r', i + 1)
+        | 't' -> ('\t', i + 1)
+        | 'b' -> ('\b', i + 1)
+        | '\\' -> ('\\', i + 1)
+        | '0'..'9' as c -> backslash1 (valch c) s (i + 1)
+        | _ -> raise Not_found ]
+    and backslash1 cod s i =
+      if i = String.length s then (Char.chr cod, i)
+      else
+        match s.[i] with
+        [ '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1)
+        | _ -> (Char.chr cod, i) ]
+    and backslash2 cod s i =
+      if i = String.length s then (Char.chr cod, i)
+      else
+        match s.[i] with
+        [ '0'..'9' as c -> (Char.chr (10 * cod + valch c), i + 1)
+        | _ -> (Char.chr cod, i) ]
+    ;
+    value rec skip_indent s i =
+      if i = String.length s then i
+      else
+        match s.[i] with
+        [ ' ' | '\t' -> skip_indent s (i + 1)
+        | _ -> i ]
+    ;
+    value skip_opt_linefeed s i =
+      if i = String.length s then i else if s.[i] = '\010' then i + 1 else i
+    ;
+    value char_of_char_token s =
+      if String.length s = 1 then s.[0]
+      else if String.length s = 0 then failwith "invalid char token"
+      else if s.[0] = '\\' then
+        if String.length s = 2 && s.[1] = ''' then '''
+        else
+          try
+            let (c, i) = backslash s 1 in
+            if i = String.length s then c else raise Not_found
+          with
+          [ Not_found -> failwith "invalid char token" ]
+      else failwith "invalid char token"
+    ;
+    value string_of_string_token s =
+      loop 0 0 where rec loop len i =
+        if i = String.length s then get_buff len
+        else
+          let (len, i) =
+            if s.[i] = '\\' then
+              let i = i + 1 in
+              if i = String.length s then failwith "invalid string token"
+              else if s.[i] = '"' then (store len '"', i + 1)
+              else
+                match s.[i] with
+                [ '\010' -> (len, skip_indent s (i + 1))
+                | '\013' -> (len, skip_indent s (skip_opt_linefeed s (i + 1)))
+                | c ->
+                    try
+                      let (c, i) = backslash s i in
+                      (store len c, i)
+                    with
+                    [ Not_found -> (store (store len '\\') c, i + 1) ] ]
+            else (store len s.[i], i + 1)
+          in
+          loop len i
+    ;
+    value rec skip_spaces =
+      parser
+      [ [: `' ' | '\n' | '\r' | '\t' | '\026' | '\012'; s :] -> skip_spaces s
+      | [: :] -> () ]
+    ;
+    value error_on_unknown_keywords = ref False;
+    value next_token_fun find_id_kwd find_spe_kwd fname lnum bolpos =
+      let make_pos p =
+        {Lexing.pos_fname = fname.val; Lexing.pos_lnum = lnum.val;
+         Lexing.pos_bol = bolpos.val; Lexing.pos_cnum = p} in
+      let mkloc (bp, ep) = (make_pos bp, make_pos ep) in
+
+      let err loc msg = raise_with_loc loc (Token.Error msg) in
+      let keyword_or_error (bp,ep) s =
+        try ("", find_spe_kwd s) with
+        [ Not_found ->
+            if error_on_unknown_keywords.val then
+              err (mkloc (bp, ep)) ("illegal token: " ^ s)
+            else ("", s) ]
+      in
+      let rec next_token =
+        parser bp
+        [ [: `('A'..'Z' | 'À'..'Ö' | 'Ø'..'Þ' as c); s :] ->
+            let id = get_buff (ident (store 0 c) s) in
+            try ("", find_id_kwd id) with [ Not_found -> ("UIDENT", id) ]
+        | [: `('a'..'z' | 'ß'..'ö' | 'ø'..'ÿ' | '_' as c); s :] ->
+            let id = get_buff (ident (store 0 c) s) in
+            let is_label =
+              match Stream.peek s with
+              [ Some ':' ->
+                  match Stream.npeek 2 s with
+                  [ [_; ':' | '=' | '>'] -> False
+                  | _ -> True ]
+              | _ -> False ]
+            in
+            if is_label then do { Stream.junk s; ("LABEL", id) }
+            else try ("", find_id_kwd id) with [ Not_found -> ("LIDENT", id) ]
+        | [: `('1'..'9' as c); s :] -> number (store 0 c) s
+        | [: `'0'; s :] -> base_number (store 0 '0') s
+        | [: `'''; s :] ep ->
+            match Stream.npeek 2 s with
+            [ [_; '''] | ['\\'; _] -> ("CHAR", char bp 0 s)
+            | _ -> keyword_or_error (bp, ep) "'" ]
+        | [: `'"'; s :] -> ("STRING", string bp 0 s)
+        | [: `'$'; s :] -> locate_or_antiquot bp 0 s
+        | [: `('!' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
+               '%' as
+               c)
+              ;
+             s :] ->
+            let id = get_buff (ident2 (store 0 c) s) in
+            keyword_or_error (bp, Stream.count s) id
+        | [: `('?' as c); s :] ->
+            let id = get_buff (ident4 (store 0 c) s) in
+            keyword_or_error (bp, Stream.count s) id
+        | [: `'<'; s :] -> less bp s
+        | [: `(':' as c1);
+             (is_label, len) =
+               parser
+               [ [: `(']' | ':' | '=' | '>' as c2) :] ->
+                   (False, store (store 0 c1) c2)
+               | [: `('a'..'z' | 'ß'..'ö' | 'ø'..'ÿ' | '_' as c); s :] ->
+                   (True, ident (store 0 c) s)
+               | [: :] -> (False, store 0 c1) ] :] ep ->
+            let id = get_buff len in
+            if is_label then ("ELABEL", id) else keyword_or_error (bp, ep) id
+        | [: `('>' | '|' as c1);
+             len =
+               parser
+               [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2
+               | [: a = ident2 (store 0 c1) :] -> a ] :] ep ->
+            let id = get_buff len in
+            keyword_or_error (bp, ep) id
+        | [: `('[' | '{' as c1); s :] ->
+            let len =
+              match Stream.npeek 2 s with
+              [ ['<'; '<' | ':'] -> store 0 c1
+              | _ ->
+                  match s with parser
+                  [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2
+                  | [: :] -> store 0 c1 ] ]
+            in
+            let ep = Stream.count s in
+            let id = get_buff len in
+            keyword_or_error (bp, ep) id
+        | [: `'.'; id = parser [ [: `'.' :] -> ".." | [: :] -> "." ] :] ep ->
+            keyword_or_error (bp, ep) id
+        | [: `';'; id = parser [ [: `';' :] -> ";;" | [: :] -> ";" ] :] ep ->
+            keyword_or_error (bp, ep) id
+        | [: `'\\'; s :] -> ("LIDENT", get_buff (ident3 0 s))
+        | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c) ]
+      and less bp =
+        parser
+        [ [: `'<'; s :] -> ("QUOTATION", ":" ^ get_buff (quotation bp 0 s))
+        | [: `':'; i = parser [: len = ident 0 :] -> get_buff len;
+             `'<' ? "character '<' expected"; s :] ->
+            ("QUOTATION", i ^ ":" ^ get_buff (quotation bp 0 s))
+        | [: s :] ep ->
+            let id = get_buff (ident2 (store 0 '<') s) in
+            keyword_or_error (bp, ep) id ]
+      and string bp len =
+        parser
+        [ [: `'"' :] -> get_buff len
+        | [: `'\\'; `c; s :] -> string bp (store (store len '\\') c) s
+        | [: `c; s :] -> string bp (store len c) s
+        | [: :] ep -> err (mkloc (bp, ep)) "string not terminated" ]
+      and char bp len =
+        parser
+        [ [: `'''; s :] ->
+            if len = 0 then char bp (store len ''') s else get_buff len
+        | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s
+        | [: `c; s :] -> char bp (store len c) s
+        | [: :] ep -> err (mkloc(bp,ep)) "char not terminated" ]
+      and locate_or_antiquot bp len =
+        parser
+        [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
+        | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s
+        | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
+        | [: `':'; s :] ->
+            let k = get_buff len in
+            ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
+        | [: `'\\'; `c; s :] ->
+            ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
+        | [: `c; s :] ->
+            ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
+        | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ]
+      and maybe_locate bp len =
+        parser
+        [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
+        | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
+        | [: `':'; s :] ->
+            ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s)
+        | [: `'\\'; `c; s :] ->
+            ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
+        | [: `c; s :] ->
+            ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
+        | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ]
+      and antiquot bp len =
+        parser
+        [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
+        | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] ->
+            antiquot bp (store len c) s
+        | [: `':'; s :] ->
+            let k = get_buff len in
+            ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
+        | [: `'\\'; `c; s :] ->
+            ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
+        | [: `c; s :] ->
+            ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
+        | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ]
+      and locate_or_antiquot_rest bp len =
+        parser
+        [ [: `'$' :] -> get_buff len
+        | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s
+        | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s
+        | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ]
+      and quotation bp len =
+        parser
+        [ [: `'>'; s :] -> maybe_end_quotation bp len s
+        | [: `'<'; s :] ->
+            quotation bp (maybe_nested_quotation bp (store len '<') strm__) s
+        | [: `'\\';
+             len =
+               parser
+               [ [: `('>' | '<' | '\\' as c) :] -> store len c
+               | [: :] -> store len '\\' ];
+             s :] ->
+            quotation bp len s
+        | [: `c; s :] -> quotation bp (store len c) s
+        | [: :] ep -> err (mkloc(bp,ep)) "quotation not terminated" ]
+      and maybe_nested_quotation bp len =
+        parser
+        [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
+        | [: `':'; len = ident (store len ':');
+             a =
+               parser
+               [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
+               | [: :] -> len ] :] ->
+            a
+        | [: :] -> len ]
+      and maybe_end_quotation bp len =
+        parser
+        [ [: `'>' :] -> len
+        | [: a = quotation bp (store len '>') :] -> a ]
+      in
+      let rec next_token_loc =
+        parser bp
+        [ [: `' ' | '\n' | '\r' | '\t' | '\026' | '\012'; s :] ->
+            next_token_loc s
+        | [: `'('; s :] -> maybe_comment bp s
+        | [: `'#'; _ = spaces_tabs; a = linenum bp :] -> a
+        | [: tok = next_token :] ep -> (tok, mkloc(bp, ep))
+        | [: _ = Stream.empty :] -> (("EOI", ""), mkloc(bp, succ bp)) ]
+      and maybe_comment bp =
+        parser
+        [ [: `'*'; s :] -> do { comment bp s; next_token_loc s }
+        | [: :] ep ->
+            let tok = keyword_or_error (bp, ep) "(" in
+            (tok, mkloc(bp, ep)) ]
+      and comment bp =
+        parser
+        [ [: `'('; s :] -> maybe_nested_comment bp s
+        | [: `'*'; s :] -> maybe_end_comment bp s
+        | [: `c; s :] -> comment bp s
+        | [: :] ep -> err (mkloc(bp,ep)) "comment not terminated" ]
+      and maybe_nested_comment bp =
+        parser
+        [ [: `'*'; s :] -> do { comment bp s; comment bp s }
+        | [: a = comment bp :] -> a ]
+      and maybe_end_comment bp =
+        parser [ [: `')' :] -> () | [: a = comment bp :] -> a ]
+      and linenum bp =
+        parser
+        [ [: `'0'..'9'; _ = digits; _ = spaces_tabs; `'"'; _ = any_to_nl;
+             s :] ->
+            next_token_loc s
+        | [: :] -> (keyword_or_error (bp, bp + 1) "#", mkloc(bp, bp + 1)) ]
+      and spaces_tabs =
+        parser [ [: `' ' | '\t'; s :] -> spaces_tabs s | [: :] -> () ]
+      and digits = parser [ [: `'0'..'9'; s :] -> digits s | [: :] -> () ]
+      and any_to_nl =
+        parser
+        [ [: `'\r' | '\n' :] -> ()
+        | [: `_; s :] -> any_to_nl s
+        | [: :] -> () ]
+      in
+      fun cstrm ->
+        try next_token_loc cstrm with
+        [ Stream.Error str ->
+            err (mkloc(Stream.count cstrm, Stream.count cstrm + 1)) str ]
+    ;
+    value locerr () = invalid_arg "Lexer: location function";
+    value loct_create () = ref (Array.create 1024 None);
+    value loct_func loct i =
+      match
+        if i < 0 || i >= Array.length loct.val then None
+        else Array.unsafe_get loct.val i
+      with
+      [ Some loc -> loc
+      | _ -> locerr () ]
+    ;
+    value loct_add loct i loc =
+      do {
+        if i >= Array.length loct.val then do {
+          let new_tmax = Array.length loct.val * 2 in
+          let new_loct = Array.create new_tmax None in
+          Array.blit loct.val 0 new_loct 0 (Array.length loct.val);
+          loct.val := new_loct
+        }
+        else ();
+        loct.val.(i) := Some loc
+      }
+    ;
+    value func kwd_table =
+      let bolpos = ref 0 in
+      let lnum = ref 0 in
+      let fname = ref "" in
+      let find = Hashtbl.find kwd_table in
+      let lex cstrm =
+        let next_token_loc = next_token_fun find find fname lnum bolpos in
+        let loct = loct_create () in
+        let ts =
+          Stream.from
+            (fun i ->
+               let (tok, loc) = next_token_loc cstrm in
+               do { loct_add loct i loc; Some tok })
+        in
+        let locf = loct_func loct in
+        (ts, locf)
+      in
+      lex
+    ;
+    value rec check_keyword_stream =
+      parser [: _ = check; _ = Stream.empty :] -> True
+    and check =
+      parser
+      [ [: `'A'..'Z' | 'a'..'z' | 'À'..'Ö' | 'Ø'..'ö' | 'ø'..'ÿ'; s :] ->
+          check_ident s
+      | [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
+            '%' | '.'
+            ;
+           s :] ->
+          check_ident2 s
+      | [: `'<'; s :] ->
+          match Stream.npeek 1 s with
+          [ [':' | '<'] -> ()
+          | _ -> check_ident2 s ]
+      | [: `':';
+           _ =
+             parser
+             [ [: `']' | ':' | '=' | '>' :] -> ()
+             | [: :] -> () ] :] ep ->
+          ()
+      | [: `'>' | '|';
+           _ =
+             parser
+             [ [: `']' | '}' :] -> ()
+             | [: a = check_ident2 :] -> a ] :] ->
+          ()
+      | [: `'[' | '{'; s :] ->
+          match Stream.npeek 2 s with
+          [ ['<'; '<' | ':'] -> ()
+          | _ ->
+              match s with parser
+              [ [: :] ->
+                  match Stream.peek strm__ with
+                  [ Some ('|' | '<' | ':') -> Stream.junk strm__
+                  | _ -> () ] ] ]
+      | [: `';'; _ = parser [ [: `';' :] -> () | [: :] -> () ] :] -> ()
+      | [: `_ :] -> () ]
+    and check_ident =
+      parser
+      [ [: `'A'..'Z' | 'a'..'z' | 'À'..'Ö' | 'Ø'..'ö' | 'ø'..'ÿ' | '0'..'9' |
+            '_' | '''
+            ;
+           s :] ->
+          check_ident s
+      | [: :] -> () ]
+    and check_ident2 =
+      parser
+      [ [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
+            '%' | '.' | ':' | '<' | '>' | '|'
+            ;
+           s :] ->
+          check_ident2 s
+      | [: :] -> () ]
+    ;
+    value check_keyword s =
+      try check_keyword_stream (Stream.of_string s) with _ -> False
+    ;
+    value using_token kwd_table (p_con, p_prm) =
+      match p_con with
+      [ "" ->
+          try
+            let _ = Hashtbl.find kwd_table p_prm in
+            ()
+          with
+          [ Not_found ->
+              if check_keyword p_prm then Hashtbl.add kwd_table p_prm p_prm
+              else
+                raise
+                  (Token.Error
+                     ("the token \"" ^ p_prm ^
+                        "\" does not respect Plexer rules")) ]
+      | "LIDENT" | "UIDENT" | "INT" | "FLOAT" | "CHAR" | "STRING" |
+        "QUOTATION" | "ANTIQUOT" | "LOCATE" | "LABEL" | "ELABEL" | "EOI" ->
+          ()
+      | _ ->
+          raise
+            (Token.Error
+               ("the constructor \"" ^ p_con ^
+                  "\" is not recognized by Llexer")) ]
+    ;
+    value removing_token kwd_table (p_con, p_prm) =
+      if p_con = "" then Hashtbl.remove kwd_table p_prm else ()
+    ;
+    value text =
+      fun
+      [ ("", t) -> "'" ^ t ^ "'"
+      | ("LIDENT", "") -> "lowercase identifier"
+      | ("LIDENT", t) -> "'" ^ t ^ "'"
+      | ("UIDENT", "") -> "uppercase identifier"
+      | ("UIDENT", t) -> "'" ^ t ^ "'"
+      | ("INT", "") -> "integer"
+      | ("INT", s) -> "'" ^ s ^ "'"
+      | ("FLOAT", "") -> "float"
+      | ("STRING", "") -> "string"
+      | ("CHAR", "") -> "char"
+      | ("QUOTATION", "") -> "quotation"
+      | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\""
+      | ("LOCATE", "") -> "locate"
+      | ("LABEL", "") -> "label"
+      | ("ELABEL", "") -> "elabel"
+      | ("EOI", "") -> "end of input"
+      | (con, "") -> con
+      | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ]
+    ;
+    value eq_before_colon p e =
+      loop 0 where rec loop i =
+        if i == String.length e then
+          failwith "Internal error in Plexer: incorrect ANTIQUOT"
+        else if i == String.length p then e.[i] == ':'
+        else if p.[i] == e.[i] then loop (i + 1)
+        else False
+    ;
+    value after_colon e =
+      try
+        let i = String.index e ':' in
+        String.sub e (i + 1) (String.length e - i - 1)
+      with
+      [ Not_found -> "" ]
+    ;
+    value gmake () =
+      let kwd_table = Hashtbl.create 301 in
+      {tok_func = func kwd_table; tok_using = using_token kwd_table;
+       tok_removing = removing_token kwd_table;
+       tok_match = Token.default_match; tok_text = text; tok_comm = None}
+    ;
+  end
+;
+
+open Stdpp;
+open Pcaml;
+
+Pcaml.no_constructors_arity.val := True;
+
+do {
+  Grammar.Unsafe.gram_reinit gram (Plexer.gmake ());
+  Grammar.Unsafe.clear_entry interf;
+  Grammar.Unsafe.clear_entry implem;
+  Grammar.Unsafe.clear_entry top_phrase;
+  Grammar.Unsafe.clear_entry use_file;
+  Grammar.Unsafe.clear_entry module_type;
+  Grammar.Unsafe.clear_entry module_expr;
+  Grammar.Unsafe.clear_entry sig_item;
+  Grammar.Unsafe.clear_entry str_item;
+  Grammar.Unsafe.clear_entry expr;
+  Grammar.Unsafe.clear_entry patt;
+  Grammar.Unsafe.clear_entry ctyp;
+  Grammar.Unsafe.clear_entry let_binding;
+  Grammar.Unsafe.clear_entry class_type;
+  Grammar.Unsafe.clear_entry class_expr;
+  Grammar.Unsafe.clear_entry class_sig_item;
+  Grammar.Unsafe.clear_entry class_str_item
+};
+
+Pcaml.parse_interf.val := Grammar.Entry.parse interf;
+Pcaml.parse_implem.val := Grammar.Entry.parse implem;
+
+value o2b =
+  fun
+  [ Some _ -> True
+  | None -> False ]
+;
+
+value mkumin loc f arg =
+  match arg with
+  [ <:expr< $int:n$ >> when int_of_string n > 0 ->
+      let n = "-" ^ n in
+      <:expr< $int:n$ >>
+  | <:expr< $flo:n$ >> when float_of_string n > 0.0 ->
+      let n = "-" ^ n in
+      <:expr< $flo:n$ >>
+  | _ ->
+      let f = "~" ^ f in
+      <:expr< $lid:f$ $arg$ >> ]
+;
+
+external loc_of_node : 'a -> MLast.loc = "%field0";
+
+value mklistexp loc last =
+  loop True where rec loop top =
+    fun
+    [ [] ->
+        match last with
+        [ Some e -> e
+        | None -> <:expr< [] >> ]
+    | [e1 :: el] ->
+        let loc = if top then loc else (fst (loc_of_node e1), snd loc) in
+        <:expr< [$e1$ :: $loop False el$] >> ]
+;
+
+value mklistpat loc last =
+  loop True where rec loop top =
+    fun
+    [ [] ->
+        match last with
+        [ Some p -> p
+        | None -> <:patt< [] >> ]
+    | [p1 :: pl] ->
+        let loc = if top then loc else (fst (loc_of_node p1), snd loc) in
+        <:patt< [$p1$ :: $loop False pl$] >> ]
+;
+
+value neg s = string_of_int (- int_of_string s);
+
+value is_operator =
+  let ht = Hashtbl.create 73 in
+  let ct = Hashtbl.create 73 in
+  do {
+    List.iter (fun x -> Hashtbl.add ht x True)
+      ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"];
+    List.iter (fun x -> Hashtbl.add ct x True)
+      ['!'; '&'; '*'; '+'; '-'; '/'; ':'; '<'; '='; '>'; '@'; '^'; '|'; '~';
+       '?'; '%'; '.'];
+    fun x ->
+      try Hashtbl.find ht x with
+      [ Not_found -> try Hashtbl.find ct x.[0] with _ -> False ]
+  }
+;
+
+(*
+value p_operator strm =
+  match Stream.peek strm with
+  [ Some (Token.Tterm "(") ->
+      match Stream.npeek 3 strm with
+      [ [_; Token.Tterm x; Token.Tterm ")"] when is_operator x ->
+          do { Stream.junk strm; Stream.junk strm; Stream.junk strm; x }
+      | _ -> raise Stream.Failure ]
+  | _ -> raise Stream.Failure ]
+;
+
+value operator = Grammar.Entry.of_parser gram "operator" p_operator;
+*)
+
+value operator =
+  Grammar.Entry.of_parser gram "operator"
+    (parser [: `("", x) when is_operator x :] -> x)
+;
+
+value symbolchar =
+  let list =
+    ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?';
+     '@'; '^'; '|'; '~']
+  in
+  let rec loop s i =
+    if i == String.length s then True
+    else if List.mem s.[i] list then loop s (i + 1)
+    else False
+  in
+  loop
+;
+
+value prefixop =
+  let list = ['!'; '?'; '~'] in
+  let excl = ["!="] in
+  Grammar.Entry.of_parser gram "prefixop"
+    (parser
+       [: `("", x)
+           when
+             not (List.mem x excl) && String.length x >= 2 &&
+             List.mem x.[0] list && symbolchar x 1 :] ->
+         x)
+;
+
+value infixop0 =
+  let list = ['='; '<'; '>'; '|'; '&'; '$'] in
+  let excl = ["<-"; "||"; "&&"] in
+  Grammar.Entry.of_parser gram "infixop0"
+    (parser
+       [: `("", x)
+           when
+             not (List.mem x excl) && String.length x >= 2 &&
+             List.mem x.[0] list && symbolchar x 1 :] ->
+         x)
+;
+
+value infixop1 =
+  let list = ['@'; '^'] in
+  Grammar.Entry.of_parser gram "infixop1"
+    (parser
+       [: `("", x)
+           when
+             String.length x >= 2 && List.mem x.[0] list &&
+             symbolchar x 1 :] ->
+         x)
+;
+
+value infixop2 =
+  let list = ['+'; '-'] in
+  Grammar.Entry.of_parser gram "infixop2"
+    (parser
+       [: `("", x)
+           when
+             x <> "->" && String.length x >= 2 && List.mem x.[0] list &&
+             symbolchar x 1 :] ->
+         x)
+;
+
+value infixop3 =
+  let list = ['*'; '/'; '%'] in
+  Grammar.Entry.of_parser gram "infixop3"
+    (parser
+       [: `("", x)
+           when
+             String.length x >= 2 && List.mem x.[0] list &&
+             symbolchar x 1 :] ->
+         x)
+;
+
+value infixop4 =
+  Grammar.Entry.of_parser gram "infixop4"
+    (parser
+       [: `("", x)
+           when
+             String.length x >= 3 && x.[0] == '*' && x.[1] == '*' &&
+             symbolchar x 2 :] ->
+         x)
+;
+
+value test_constr_decl =
+  Grammar.Entry.of_parser gram "test_constr_decl"
+    (fun strm ->
+       match Stream.npeek 1 strm with
+       [ [("UIDENT", _)] ->
+           match Stream.npeek 2 strm with
+           [ [_; ("", ".")] -> raise Stream.Failure
+           | [_; ("", "(")] -> raise Stream.Failure
+           | [_ :: _] -> ()
+           | _ -> raise Stream.Failure ]
+       | [("", "|")] -> ()
+       | _ -> raise Stream.Failure ])
+;
+
+value stream_peek_nth n strm =
+  loop n (Stream.npeek n strm) where rec loop n =
+    fun
+    [ [] -> None
+    | [x] -> if n == 1 then Some x else None
+    | [_ :: l] -> loop (n - 1) l ]
+;
+
+value test_label_eq =
+  let rec test lev strm =
+    match stream_peek_nth lev strm with
+    [ Some (("UIDENT", _) | ("LIDENT", _) | ("", ".")) -> test (lev + 1) strm
+    | Some ("", "=") -> ()
+    | _ -> raise Stream.Failure ]
+  in
+  Grammar.Entry.of_parser gram "test_label_eq" (test 1)
+;
+
+value constr_arity = ref [("Some", 1); ("Match_Failure", 1)];
+
+value rec constr_expr_arity =
+  fun
+  [ <:expr< $uid:c$ >> ->
+      try List.assoc c constr_arity.val with [ Not_found -> 0 ]
+  | <:expr< $uid:_$.$e$ >> -> constr_expr_arity e
+  | _ -> 1 ]
+;
+
+value rec constr_patt_arity =
+  fun
+  [ <:patt< $uid:c$ >> ->
+      try List.assoc c constr_arity.val with [ Not_found -> 0 ]
+  | <:patt< $uid:_$.$p$ >> -> constr_patt_arity p
+  | _ -> 1 ]
+;
+
+value rec get_seq =
+  fun
+  [ <:expr< do { $list:el$ } >> -> el
+  | e -> [e] ]
+;
+
+value choose_tvar tpl =
+  let rec find_alpha v =
+    let s = String.make 1 v in
+    if List.mem_assoc s tpl then
+      if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1))
+    else Some (String.make 1 v)
+  in
+  let rec make_n n =
+    let v = "a" ^ string_of_int n in
+    if List.mem_assoc v tpl then make_n (succ n) else v
+  in
+  match find_alpha 'a' with
+  [ Some x -> x
+  | None -> make_n 1 ]
+;
+
+value rec patt_lid =
+  fun
+  [ <:patt< $lid:i$ $p$ >> -> Some (i, [p])
+  | <:patt< $p1$ $p2$ >> ->
+      match patt_lid p1 with
+      [ Some (i, pl) -> Some (i, [p2 :: pl])
+      | None -> None ]
+  | _ -> None ]
+;
+
+value type_parameter = Grammar.Entry.create gram "type_parameter";
+value fun_def = Grammar.Entry.create gram "fun_def";
+value fun_binding = Grammar.Entry.create gram "fun_binding";
+
+EXTEND
+  GLOBAL: interf implem top_phrase use_file sig_item str_item ctyp patt expr
+    module_type module_expr let_binding type_parameter fun_def fun_binding;
+  (* Main entry points *)
+  interf:
+    [ [ st = LIST0 [ s = sig_item; OPT ";;" -> (s, loc) ]; EOI ->
+          (st, False) ] ]
+  ;
+  implem:
+    [ [ st = LIST0 [ s = str_item; OPT ";;" -> (s, loc) ]; EOI ->
+          (st, False) ] ]
+  ;
+  top_phrase:
+    [ [ ph = phrase; ";;" -> Some ph
+      | EOI -> None ] ]
+  ;
+  use_file:
+    [ [ l = LIST0 [ ph = phrase; OPT ";;" -> ph ]; EOI -> (l, False) ] ]
+  ;
+  phrase:
+    [ [ sti = str_item -> sti
+      | "#"; n = LIDENT; dp = dir_param -> MLast.StDir loc n dp ] ]
+  ;
+  dir_param:
+    [ [ -> None
+      | e = expr -> Some e ] ]
+  ;
+  (* Module expressions *)
+  module_expr:
+    [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->";
+        me = SELF ->
+          <:module_expr< functor ( $i$ : $t$ ) -> $me$ >>
+      | "struct"; st = LIST0 [ s = str_item; OPT ";;" -> s ]; "end" ->
+          <:module_expr< struct $list:st$ end >> ]
+    | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ]
+    | [ i = mod_expr_ident -> i
+      | "("; me = SELF; ":"; mt = module_type; ")" ->
+          <:module_expr< ( $me$ : $mt$ ) >>
+      | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ]
+  ;
+  mod_expr_ident:
+    [ LEFTA
+      [ m1 = SELF; "."; m2 = SELF -> <:module_expr< $m1$ . $m2$ >> ]
+    | [ m = UIDENT -> <:module_expr< $uid:m$ >> ] ]
+  ;
+  str_item:
+    [ "top"
+      [ "exception"; (_, c, tl) = constructor_declaration ->
+          <:str_item< exception $c$ of $list:tl$ >>
+      | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING ->
+          <:str_item< external $i$ : $t$ = $list:pd$ >>
+      | "external"; i = LABEL; t = ctyp; "="; pd = LIST1 STRING ->
+          <:str_item< external $i$ : $t$ = $list:pd$ >>
+      | "external"; "("; i = operator; ")"; ":"; t = ctyp; "=";
+        pd = LIST1 STRING ->
+          <:str_item< external $i$ : $t$ = $list:pd$ >>
+      | "module"; i = UIDENT; mb = module_binding ->
+          <:str_item< module $i$ = $mb$ >>
+      | "module"; "type"; i = UIDENT; "="; mt = module_type ->
+          <:str_item< module type $i$ = $mt$ >>
+      | "open"; i = mod_ident -> <:str_item< open $i$ >>
+      | "type"; tdl = LIST1 type_declaration SEP "and" ->
+          <:str_item< type $list:tdl$ >>
+      | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in";
+        x = expr ->
+          let e = <:expr< let $opt:o2b r$ $list:l$ in $x$ >> in
+          <:str_item< $exp:e$ >>
+      | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and" ->
+          match l with
+          [ [(<:patt< _ >>, e)] -> <:str_item< $exp:e$ >>
+          | _ -> <:str_item< value $opt:o2b r$ $list:l$ >> ]
+      | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr ->
+          <:str_item< let module $m$ = $mb$ in $e$ >>
+      | e = expr -> <:str_item< $exp:e$ >> ] ]
+  ;
+  module_binding:
+    [ RIGHTA
+      [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF ->
+          <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >>
+      | ":"; mt = module_type; "="; me = module_expr ->
+          <:module_expr< ( $me$ : $mt$ ) >>
+      | "="; me = module_expr -> <:module_expr< $me$ >> ] ]
+  ;
+  (* Module types *)
+  module_type:
+    [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF ->
+          <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ]
+    | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" ->
+          <:module_type< $mt$ with $list:wcl$ >> ]
+    | [ "sig"; sg = LIST0 [ s = sig_item; OPT ";;" -> s ]; "end" ->
+          <:module_type< sig $list:sg$ end >>
+      | i = mod_type_ident -> i
+      | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ]
+  ;
+  mod_type_ident:
+    [ LEFTA
+      [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >>
+      | m1 = SELF; "("; m2 = SELF; ")" -> <:module_type< $m1$ $m2$ >> ]
+    | [ m = UIDENT -> <:module_type< $uid:m$ >>
+      | m = LIDENT -> <:module_type< $lid:m$ >> ] ]
+  ;
+  sig_item:
+    [ "top"
+      [ "exception"; (_, c, tl) = constructor_declaration ->
+          <:sig_item< exception $c$ of $list:tl$ >>
+      | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING ->
+          <:sig_item< external $i$ : $t$ = $list:pd$ >>
+      | "external"; i = LABEL; t = ctyp; "="; pd = LIST1 STRING ->
+          <:sig_item< external $i$ : $t$ = $list:pd$ >>
+      | "external"; "("; i = operator; ")"; ":"; t = ctyp; "=";
+        pd = LIST1 STRING ->
+          <:sig_item< external $i$ : $t$ = $list:pd$ >>
+      | "include"; mt = module_type -> <:sig_item< include $mt$ >>
+      | "module"; i = UIDENT; mt = module_declaration ->
+          <:sig_item< module $i$ : $mt$ >>
+      | "module"; "type"; i = UIDENT; "="; mt = module_type ->
+          <:sig_item< module type $i$ = $mt$ >>
+      | "open"; i = mod_ident -> <:sig_item< open $i$ >>
+      | "type"; tdl = LIST1 type_declaration SEP "and" ->
+          <:sig_item< type $list:tdl$ >>
+      | "val"; i = LIDENT; ":"; t = ctyp -> <:sig_item< value $i$ : $t$ >>
+      | "val"; i = LABEL; t = ctyp -> <:sig_item< value $i$ : $t$ >>
+      | "val"; "("; i = operator; ")"; ":"; t = ctyp ->
+          <:sig_item< value $i$ : $t$ >> ] ]
+  ;
+  module_declaration:
+    [ RIGHTA
+      [ ":"; mt = module_type -> <:module_type< $mt$ >>
+      | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF ->
+          <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ]
+  ;
+  (* "with" constraints (additional type equations over signature
+     components) *)
+  with_constr:
+    [ [ "type"; tp = type_parameters; i = mod_ident; "="; t = ctyp ->
+          MLast.WcTyp loc i tp t
+      | "module"; i = mod_ident; "="; me = module_expr ->
+          MLast.WcMod loc i me ] ]
+  ;
+  (* Core expressions *)
+  expr:
+    [ "top" LEFTA
+      [ e1 = SELF; ";"; e2 = SELF ->
+          <:expr< do { $list:[e1 :: get_seq e2]$ } >>
+      | e1 = SELF; ";" -> e1 ]
+    | "expr1"
+      [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; "in";
+        x = expr LEVEL "top" ->
+          <:expr< let $opt:o2b o$ $list:l$ in $x$ >>
+      | "let"; "module"; m = UIDENT; mb = module_binding; "in";
+        e = expr LEVEL "top" ->
+          <:expr< let module $m$ = $mb$ in $e$ >>
+      | "function"; OPT "|"; l = LIST1 match_case SEP "|" ->
+          <:expr< fun [ $list:l$ ] >>
+      | "fun"; p = patt LEVEL "simple"; e = fun_def ->
+          <:expr< fun [$p$ -> $e$] >>
+      | "match"; x = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" ->
+          <:expr< match $x$ with [ $list:l$ ] >>
+      | "try"; x = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" ->
+          <:expr< try $x$ with [ $list:l$ ] >>
+      | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1";
+        e3 = [ "else"; e = expr LEVEL "expr1" -> e | -> <:expr< () >> ] ->
+          <:expr< if $e1$ then $e2$ else $e3$ >>
+      | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF;
+        "do"; e = SELF; "done" ->
+          <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:get_seq e$ } >>
+      | "while"; e1 = SELF; "do"; e2 = SELF; "done" ->
+          <:expr< while $e1$ do { $list:get_seq e2$ } >> ]
+    | [ e = SELF; ","; el = LIST1 NEXT SEP "," ->
+          <:expr< ( $list:[e :: el]$ ) >> ]
+    | ":=" NONA
+      [ e1 = SELF; ":="; e2 = expr LEVEL "expr1" ->
+          <:expr< $e1$.val := $e2$ >>
+      | e1 = SELF; "<-"; e2 = expr LEVEL "expr1" -> <:expr< $e1$ := $e2$ >> ]
+    | "||" RIGHTA
+      [ e1 = SELF; f = [ op = "or" -> op | op = "||" -> op ]; e2 = SELF ->
+          <:expr< $lid:f$ $e1$ $e2$ >> ]
+    | "&&" RIGHTA
+      [ e1 = SELF; f = [ op = "&" -> op | op = "&&" -> op ]; e2 = SELF ->
+          <:expr< $lid:f$ $e1$ $e2$ >> ]
+    | "<" LEFTA
+      [ e1 = SELF;
+        f =
+          [ op = "<" -> op
+          | op = ">" -> op
+          | op = "<=" -> op
+          | op = ">=" -> op
+          | op = "=" -> op
+          | op = "<>" -> op
+          | op = "==" -> op
+          | op = "!=" -> op
+          | op = infixop0 -> op ];
+        e2 = SELF ->
+          <:expr< $lid:f$ $e1$ $e2$ >> ]
+    | "^" RIGHTA
+      [ e1 = SELF;
+        f = [ op = "^" -> op | op = "@" -> op | op = infixop1 -> op ];
+        e2 = SELF ->
+          <:expr< $lid:f$ $e1$ $e2$ >> ]
+    | RIGHTA
+      [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ]
+    | "+" LEFTA
+      [ e1 = SELF;
+        f =
+          [ op = "+" -> op
+          | op = "-" -> op
+          | op = "+." -> op
+          | op = "-." -> op
+          | op = infixop2 -> op ];
+        e2 = SELF ->
+          <:expr< $lid:f$ $e1$ $e2$ >> ]
+    | "*" LEFTA
+      [ e1 = SELF;
+        f =
+          [ op = "*" -> op
+          | op = "/" -> op
+          | op = "*." -> op
+          | op = "/." -> op
+          | op = "land" -> op
+          | op = "lor" -> op
+          | op = "lxor" -> op
+          | op = "mod" -> op
+          | op = infixop3 -> op ];
+        e2 = SELF ->
+          <:expr< $lid:f$ $e1$ $e2$ >> ]
+    | "**" RIGHTA
+      [ e1 = SELF;
+        f =
+          [ op = "**" -> op
+          | op = "asr" -> op
+          | op = "lsl" -> op
+          | op = "lsr" -> op
+          | op = infixop4 -> op ];
+        e2 = SELF ->
+          <:expr< $lid:f$ $e1$ $e2$ >> ]
+    | "unary minus" NONA
+      [ f = [ op = "-" -> op | op = "-." -> op ]; e = SELF ->
+          <:expr< $mkumin loc f e$ >> ]
+    | "apply" LEFTA
+      [ e1 = SELF; e2 = SELF ->
+          match constr_expr_arity e1 with
+          [ 1 -> <:expr< $e1$ $e2$ >>
+          | _ ->
+              match e2 with
+              [ <:expr< ( $list:el$ ) >> ->
+                  List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 el
+              | _ -> <:expr< $e1$ $e2$ >> ] ]
+      | "assert"; e = expr LEVEL "simple" ->
+          match e with
+          [ <:expr< False >> -> MLast.ExAsf loc
+          | _ -> MLast.ExAsr loc e ]
+      | "lazy"; e = SELF ->
+          <:expr< lazy ($e$) >> ]
+    | "simple" LEFTA
+      [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >>
+      | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >>
+      | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >>
+      | "!"; e = SELF -> <:expr< $e$ . val>>
+      | f =
+          [ op = "~-" -> op
+          | op = "~-." -> op
+          | op = "~" -> op
+          | op = prefixop -> op ];
+        e = SELF ->
+          <:expr< $lid:f$ $e$ >>
+      | s = INT -> <:expr< $int:s$ >>
+      | s = FLOAT -> <:expr< $flo:s$ >>
+      | s = STRING -> <:expr< $str:s$ >>
+      | c = CHAR -> <:expr< $chr:c$ >>
+      | i = expr_ident -> i
+      | s = "false" -> <:expr< False >>
+      | s = "true" -> <:expr< True >>
+      | "["; "]" -> <:expr< [] >>
+      | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp loc None el$ >>
+      | "[|"; "|]" -> <:expr< [| |] >>
+      | "[|"; el = expr1_semi_list; "|]" -> <:expr< [| $list:el$ |] >>
+      | "{"; test_label_eq; lel = lbl_expr_list; "}" ->
+          <:expr< { $list:lel$ } >>
+      | "{"; e = expr LEVEL "simple"; "with"; lel = lbl_expr_list; "}" ->
+          <:expr< { ($e$) with $list:lel$ } >>
+      | "("; ")" -> <:expr< () >>
+      | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >>
+      | "("; e = SELF; ")" -> <:expr< $e$ >>
+      | "("; "-"; ")" -> <:expr< $lid:"-"$ >>
+      | "("; "-."; ")" -> <:expr< $lid:"-."$ >>
+      | "("; op = operator; ")" -> <:expr< $lid:op$ >>
+      | "begin"; e = SELF; "end" -> <:expr< $e$ >>
+      | x = LOCATE ->
+          let x =
+            try
+              let i = String.index x ':' in
+              ({Lexing.pos_fname = "";
+                Lexing.pos_lnum = 0;
+                Lexing.pos_bol = 0;
+                Lexing.pos_cnum = int_of_string (String.sub x 0 i)},
+               String.sub x (i + 1) (String.length x - i - 1))
+            with
+            [ Not_found | Failure _ -> (Token.nowhere, x) ]
+          in
+          Pcaml.handle_expr_locate loc x
+      | x = QUOTATION ->
+          let x =
+            try
+              let i = String.index x ':' in
+              (String.sub x 0 i,
+               String.sub x (i + 1) (String.length x - i - 1))
+            with
+            [ Not_found -> ("", x) ]
+          in
+          Pcaml.handle_expr_quotation loc x ] ]
+  ;
+  let_binding:
+    [ [ p = patt; e = fun_binding ->
+          match patt_lid p with
+          [ Some (i, pl) ->
+              let e =
+                List.fold_left (fun e p -> <:expr< fun $p$ -> $e$ >>) e pl
+              in
+              (<:patt< $lid:i$ >>, e)
+          | None -> (p, e) ] ] ]
+  ;
+  fun_binding:
+    [ RIGHTA
+      [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >>
+      | "="; e = expr -> <:expr< $e$ >>
+      | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ]
+  ;
+  match_case:
+    [ [ x1 = patt; w = OPT [ "when"; e = expr -> e ]; "->"; x2 = expr ->
+          (x1, w, x2) ] ]
+  ;
+  lbl_expr_list:
+    [ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel]
+      | le = lbl_expr; ";" -> [le]
+      | le = lbl_expr -> [le] ] ]
+  ;
+  lbl_expr:
+    [ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ]
+  ;
+  expr1_semi_list:
+    [ [ e = expr LEVEL "expr1"; ";"; el = SELF -> [e :: el]
+      | e = expr LEVEL "expr1"; ";" -> [e]
+      | e = expr LEVEL "expr1" -> [e] ] ]
+  ;
+  fun_def:
+    [ RIGHTA
+      [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >>
+      | "->"; e = expr -> <:expr< $e$ >> ] ]
+  ;
+  expr_ident:
+    [ RIGHTA
+      [ i = LIDENT -> <:expr< $lid:i$ >>
+      | i = UIDENT -> <:expr< $uid:i$ >>
+      | m = UIDENT; "."; i = SELF ->
+          let rec loop m =
+            fun
+            [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y
+            | e -> <:expr< $m$ . $e$ >> ]
+          in
+          loop <:expr< $uid:m$ >> i
+      | m = UIDENT; "."; "("; i = operator; ")" ->
+          <:expr< $uid:m$ . $lid:i$ >> ] ]
+  ;
+  (* Patterns *)
+  patt:
+    [ LEFTA
+      [ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ]
+    | LEFTA
+      [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ]
+    | [ p = SELF; ","; pl = LIST1 NEXT SEP "," ->
+          <:patt< ( $list:[p :: pl]$) >> ]
+    | NONA
+      [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ]
+    | RIGHTA
+      [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ]
+    | LEFTA
+      [ p1 = SELF; p2 = SELF ->
+          match constr_patt_arity p1 with
+          [ 1 -> <:patt< $p1$ $p2$ >>
+          | n ->
+              let p2 =
+                match p2 with
+                [ <:patt< _ >> when n > 1 ->
+                    let pl =
+                      loop n where rec loop n =
+                        if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)]
+                    in
+                    <:patt< ( $list:pl$ ) >>
+                | _ -> p2 ]
+              in
+              match p2 with
+              [ <:patt< ( $list:pl$ ) >> ->
+                  List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 pl
+              | _ -> <:patt< $p1$ $p2$ >> ] ] ]
+    | LEFTA
+      [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ]
+    | "simple"
+      [ s = LIDENT -> <:patt< $lid:s$ >>
+      | s = UIDENT -> <:patt< $uid:s$ >>
+      | s = INT -> <:patt< $int:s$ >>
+      | "-"; s = INT -> <:patt< $int:neg s$ >>
+      | s = STRING -> <:patt< $str:s$ >>
+      | s = CHAR -> <:patt< $chr:s$ >>
+      | s = "false" -> <:patt< False >>
+      | s = "true" -> <:patt< True >>
+      | "["; "]" -> <:patt< [] >>
+      | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat loc None pl$ >>
+      | "[|"; "|]" -> <:patt< [| |] >>
+      | "[|"; pl = patt_semi_list; "|]" -> <:patt< [| $list:pl$ |] >>
+      | "{"; lpl = lbl_patt_list; "}" -> <:patt< { $list:lpl$ } >>
+      | "("; ")" -> <:patt< () >>
+      | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
+      | "("; p = SELF; ")" -> <:patt< $p$ >>
+      | "("; "-"; ")" -> <:patt< $lid:"-"$ >>
+      | "("; op = operator; ")" -> <:patt< $lid:op$ >>
+      | "_" -> <:patt< _ >>
+      | x = LOCATE ->
+          let x =
+            try
+              let i = String.index x ':' in
+              ({Lexing.pos_fname = "";
+                Lexing.pos_lnum = 0;
+                Lexing.pos_bol = 0;
+                Lexing.pos_cnum =  int_of_string (String.sub x 0 i)},
+               String.sub x (i + 1) (String.length x - i - 1))
+            with
+            [ Not_found | Failure _ -> (Token.nowhere, x) ]
+          in
+          Pcaml.handle_patt_locate loc x
+      | x = QUOTATION ->
+          let x =
+            try
+              let i = String.index x ':' in
+              (String.sub x 0 i,
+               String.sub x (i + 1) (String.length x - i - 1))
+            with
+            [ Not_found -> ("", x) ]
+          in
+          Pcaml.handle_patt_quotation loc x ] ]
+  ;
+  patt_semi_list:
+    [ [ p = patt; ";"; pl = SELF -> [p :: pl]
+      | p = patt; ";" -> [p]
+      | p = patt -> [p] ] ]
+  ;
+  lbl_patt_list:
+    [ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel]
+      | le = lbl_patt; ";" -> [le]
+      | le = lbl_patt -> [le] ] ]
+  ;
+  lbl_patt:
+    [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ]
+  ;
+  patt_label_ident:
+    [ RIGHTA
+      [ i = UIDENT -> <:patt< $uid:i$ >>
+      | i = LIDENT -> <:patt< $lid:i$ >>
+      | m = UIDENT; "."; i = SELF -> <:patt< $uid:m$ . $i$ >> ] ]
+  ;
+  (* Type declaration *)
+  type_declaration:
+    [ [ tpl = type_parameters; n = type_patt; "="; tk = type_kind;
+        cl = LIST0 constrain ->
+          (n, tpl, tk, cl)
+      | tpl = type_parameters; n = type_patt; cl = LIST0 constrain ->
+          (n, tpl, <:ctyp< '$choose_tvar tpl$ >>, cl) ] ]
+  ;
+  type_patt:
+    [ [ n = LIDENT -> (loc, n) ] ]
+  ;
+  constrain:
+    [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ]
+  ;
+  type_kind:
+    [ [ test_constr_decl; OPT "|";
+        cdl = LIST1 constructor_declaration SEP "|" ->
+          <:ctyp< [ $list:cdl$ ] >>
+      | t = ctyp -> <:ctyp< $t$ >>
+      | t = ctyp; "="; "{"; ldl = label_declarations; "}" ->
+          <:ctyp< $t$ == { $list:ldl$ } >>
+      | t = ctyp; "="; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" ->
+          <:ctyp< $t$ == [ $list:cdl$ ] >>
+      | "{"; ldl = label_declarations; "}" -> <:ctyp< { $list:ldl$ } >> ] ]
+  ;
+  type_parameters:
+    [ [ -> (* empty *) []
+      | tp = type_parameter -> [tp]
+      | "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ]
+  ;
+  type_parameter:
+    [ [ "'"; i = ident -> (i, (False, False)) ] ]
+  ;
+  constructor_declaration:
+    [ [ ci = UIDENT; "of"; cal = LIST1 ctyp LEVEL "ctyp1" SEP "*" ->
+          (loc, ci, cal)
+      | ci = UIDENT -> (loc, ci, []) ] ]
+  ;
+  label_declarations:
+    [ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl]
+      | ld = label_declaration; ";" -> [ld]
+      | ld = label_declaration -> [ld] ] ]
+  ;
+  label_declaration:
+    [ [ i = LIDENT; ":"; t = ctyp -> (loc, i, False, t)
+      | i = LABEL; t = ctyp -> (loc, i, False, t)
+      | "mutable"; i = LIDENT; ":"; t = ctyp -> (loc, i, True, t)
+      | "mutable"; i = LABEL; t = ctyp -> (loc, i, True, t) ] ]
+  ;
+  (* Core types *)
+  ctyp:
+    [ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ]
+    | "arrow" RIGHTA
+      [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ]
+    | [ t = SELF; "*"; tl = LIST1 ctyp LEVEL "ctyp1" SEP "*" ->
+          <:ctyp< ( $list:[t :: tl]$ ) >> ]
+    | "ctyp1"
+      [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ]
+    | "ctyp2"
+      [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >>
+      | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ]
+    | "simple"
+      [ "'"; i = ident -> <:ctyp< '$i$ >>
+      | "_" -> <:ctyp< _ >>
+      | i = LIDENT -> <:ctyp< $lid:i$ >>
+      | i = UIDENT -> <:ctyp< $uid:i$ >>
+      | "("; t = SELF; ","; tl = LIST1 ctyp SEP ","; ")";
+        i = ctyp LEVEL "ctyp2" ->
+          List.fold_left (fun c a -> <:ctyp< $c$ $a$ >>) i [t :: tl]
+      | "("; t = SELF; ")" -> <:ctyp< $t$ >> ] ]
+  ;
+  (* Identifiers *)
+  ident:
+    [ [ i = LIDENT -> i
+      | i = UIDENT -> i ] ]
+  ;
+  mod_ident:
+    [ RIGHTA
+      [ i = UIDENT -> [i]
+      | i = LIDENT -> [i]
+      | m = UIDENT; "."; i = SELF -> [m :: i] ] ]
+  ;
+  (* Miscellaneous *)
+  direction_flag:
+    [ [ "to" -> True
+      | "downto" -> False ] ]
+  ;
+END;
+
+(* Objects and Classes *)
+
+value rec class_type_of_ctyp loc t =
+  match t with
+  [ <:ctyp< $lid:i$ >> -> <:class_type< $list:[i]$ >>
+  | <:ctyp< $uid:m$.$t$ >> -> <:class_type< $list:[m :: type_id_list t]$ >>
+  | _ -> raise_with_loc loc (Stream.Error "lowercase identifier expected") ]
+and type_id_list =
+  fun
+  [ <:ctyp< $uid:m$.$t$ >> -> [m :: type_id_list t]
+  | <:ctyp< $lid:i$ >> -> [i]
+  | t ->
+      raise_with_loc (loc_of_node t)
+        (Stream.Error "lowercase identifier expected") ]
+;
+
+value class_fun_binding = Grammar.Entry.create gram "class_fun_binding";
+
+EXTEND
+  GLOBAL: str_item sig_item expr ctyp class_sig_item class_str_item class_type
+    class_expr class_fun_binding;
+  str_item:
+    [ [ "class"; cd = LIST1 class_declaration SEP "and" ->
+          <:str_item< class $list:cd$ >>
+      | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" ->
+          <:str_item< class type $list:ctd$ >> ] ]
+  ;
+  sig_item:
+    [ [ "class"; cd = LIST1 class_description SEP "and" ->
+          <:sig_item< class $list:cd$ >>
+      | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" ->
+          <:sig_item< class type $list:ctd$ >> ] ]
+  ;
+  (* Class expressions *)
+  class_declaration:
+    [ [ vf = OPT "virtual"; ctp = class_type_parameters; i = LIDENT;
+        cfb = class_fun_binding ->
+          {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
+           MLast.ciNam = i; MLast.ciExp = cfb} ] ]
+  ;
+  class_fun_binding:
+    [ [ "="; ce = class_expr -> ce
+      | ":"; ct = class_type; "="; ce = class_expr ->
+          <:class_expr< ($ce$ : $ct$) >>
+      | p = patt LEVEL "simple"; cfb = SELF ->
+          <:class_expr< fun $p$ -> $cfb$ >> ] ]
+  ;
+  class_type_parameters:
+    [ [ -> (loc, [])
+      | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ]
+  ;
+  class_fun_def:
+    [ [ p = patt LEVEL "simple"; "->"; ce = class_expr ->
+          <:class_expr< fun $p$ -> $ce$ >>
+      | p = patt LEVEL "simple"; cfd = SELF ->
+          <:class_expr< fun $p$ -> $cfd$ >> ] ]
+  ;
+  class_expr:
+    [ "top"
+      [ "fun"; cfd = class_fun_def -> cfd
+      | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in";
+        ce = SELF ->
+          <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ]
+    | "apply" NONA
+      [ ce = SELF; e = expr LEVEL "label" ->
+          <:class_expr< $ce$ $e$ >> ]
+    | "simple"
+      [ "["; ct = ctyp; ","; ctcl = LIST1 ctyp SEP ","; "]";
+        ci = class_longident ->
+          <:class_expr< $list:ci$ [ $list:[ct :: ctcl]$ ] >>
+      | "["; ct = ctyp; "]"; ci = class_longident ->
+          <:class_expr< $list:ci$ [ $ct$ ] >>
+      | ci = class_longident -> <:class_expr< $list:ci$ >>
+      | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" ->
+          <:class_expr< object $opt:cspo$ $list:cf$ end >>
+      | "("; ce = SELF; ":"; ct = class_type; ")" ->
+          <:class_expr< ($ce$ : $ct$) >>
+      | "("; ce = SELF; ")" -> ce ] ]
+  ;
+  class_structure:
+    [ [ cf = LIST0 class_str_item -> cf ] ]
+  ;
+  class_self_patt:
+    [ [ "("; p = patt; ")" -> p
+      | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ]
+  ;
+  class_str_item:
+    [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] ->
+          <:class_str_item< inherit $ce$ $opt:pb$ >>
+      | "val"; (lab, mf, e) = cvalue ->
+          <:class_str_item< value $opt:mf$ $lab$ = $e$ >>
+      | "method"; "private"; "virtual"; l = label; ":"; t = ctyp ->
+          <:class_str_item< method virtual private $l$ : $t$ >>
+      | "method"; "virtual"; "private"; l = label; ":"; t = ctyp ->
+          <:class_str_item< method virtual private $l$ : $t$ >>
+      | "method"; "virtual"; l = label; ":"; t = ctyp ->
+          <:class_str_item< method virtual $l$ : $t$ >>
+      | "method"; "private"; l = label; fb = fun_binding ->
+          <:class_str_item< method private $l$ = $fb$ >>
+      | "method"; l = label; fb = fun_binding ->
+          <:class_str_item< method $l$ = $fb$ >>
+      | "constraint"; t1 = ctyp; "="; t2 = ctyp ->
+          <:class_str_item< type $t1$ = $t2$ >>
+      | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ]
+  ;
+  cvalue:
+    [ [ mf = OPT "mutable"; l = label; "="; e = expr -> (l, o2b mf, e)
+      | mf = OPT "mutable"; l = label; ":"; t = ctyp; "="; e = expr ->
+          (l, o2b mf, <:expr< ($e$ : $t$) >>)
+      | mf = OPT "mutable"; l = label; ":"; t1 = ctyp; ":>"; t2 = ctyp; "=";
+        e = expr ->
+          (l, o2b mf, <:expr< ($e$ : $t1$ :> $t2$) >>)
+      | mf = OPT "mutable"; l = label; ":>"; t = ctyp; "="; e = expr ->
+          (l, o2b mf, <:expr< ($e$ :> $t$) >>) ] ]
+  ;
+  label:
+    [ [ i = LIDENT -> i ] ]
+  ;
+  (* Class types *)
+  class_type:
+    [ [ t = ctyp LEVEL "ctyp1" -> class_type_of_ctyp loc t
+      | t = ctyp LEVEL "ctyp1"; "->"; ct = SELF ->
+          <:class_type< [ $t$ ] -> $ct$ >>
+      | t = ctyp LEVEL "ctyp1"; "*"; tl = LIST1 ctyp LEVEL "simple" SEP "*";
+        "->"; ct = SELF ->
+          <:class_type< [ ($t$ * $list:tl$) ] -> $ct$ >>
+      | cs = class_signature -> cs ] ]
+  ;
+  class_signature:
+    [ [ "["; tl = LIST1 ctyp SEP ","; "]"; id = clty_longident ->
+          <:class_type< $list:id$ [ $list:tl$ ] >>
+      | id = clty_longident -> <:class_type< $list:id$ >>
+      | "object"; cst = OPT class_self_type; csf = LIST0 class_sig_item;
+        "end" ->
+          <:class_type< object $opt:cst$ $list:csf$ end >> ] ]
+  ;
+  class_self_type:
+    [ [ "("; t = ctyp; ")" -> t ] ]
+  ;
+  class_sig_item:
+    [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >>
+      | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
+          <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
+      | "method"; "private"; "virtual"; l = label; ":"; t = ctyp ->
+          <:class_sig_item< method virtual private $l$ : $t$ >>
+      | "method"; "virtual"; "private"; l = label; ":"; t = ctyp ->
+          <:class_sig_item< method virtual private $l$ : $t$ >>
+      | "method"; "virtual"; l = label; ":"; t = ctyp ->
+          <:class_sig_item< method virtual $l$ : $t$ >>
+      | "method"; "private"; l = label; ":"; t = ctyp ->
+          <:class_sig_item< method private $l$ : $t$ >>
+      | "method"; l = label; ":"; t = ctyp ->
+          <:class_sig_item< method $l$ : $t$ >>
+      | "constraint"; t1 = ctyp; "="; t2 = ctyp ->
+          <:class_sig_item< type $t1$ = $t2$ >> ] ]
+  ;
+  class_description:
+    [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; ":";
+        ct = class_type ->
+          {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
+           MLast.ciNam = n; MLast.ciExp = ct}
+      | vf = OPT "virtual"; ctp = class_type_parameters; n = LABEL;
+        ct = class_type ->
+          {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
+           MLast.ciNam = n; MLast.ciExp = ct} ] ]
+  ;
+  class_type_declaration:
+    [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; "=";
+        cs = class_signature ->
+          {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
+           MLast.ciNam = n; MLast.ciExp = cs} ] ]
+  ;
+  (* Expressions *)
+  expr: LEVEL "apply"
+    [ LEFTA
+      [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ]
+  ;
+  expr: LEVEL "simple"
+    [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ]
+  ;
+  expr: LEVEL "simple"
+    [ [ "("; e = SELF; ":"; t1 = ctyp; ":>"; t2 = ctyp; ")" ->
+          <:expr< ($e$ : $t1$ :> $t2$) >>
+      | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >>
+      | "{<"; ">}" -> <:expr< {< >} >>
+      | "{<"; fel = field_expr_list; ">}" -> <:expr< {< $list:fel$ >} >> ] ]
+  ;
+  field_expr_list:
+    [ [ l = label; "="; e = expr LEVEL "expr1"; ";"; fel = SELF ->
+          [(l, e) :: fel]
+      | l = label; "="; e = expr LEVEL "expr1"; ";" -> [(l, e)]
+      | l = label; "="; e = expr LEVEL "expr1" -> [(l, e)] ] ]
+  ;
+  (* Core types *)
+  ctyp: LEVEL "simple"
+    [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >>
+      | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $opt:v$ > >>
+      | "<"; ">" -> <:ctyp< < > >> ] ]
+  ;
+  meth_list:
+    [ [ f = field; ";"; (ml, v) = SELF -> ([f :: ml], v)
+      | f = field; ";" -> ([f], False)
+      | f = field -> ([f], False)
+      | ".." -> ([], True) ] ]
+  ;
+  field:
+    [ [ lab = LIDENT; ":"; t = ctyp -> (lab, t)
+      | lab = LABEL; t = ctyp -> (lab, t) ] ]
+  ;
+  (* Identifiers *)
+  clty_longident:
+    [ [ m = UIDENT; "."; l = SELF -> [m :: l]
+      | i = LIDENT -> [i] ] ]
+  ;
+  class_longident:
+    [ [ m = UIDENT; "."; l = SELF -> [m :: l]
+      | i = LIDENT -> [i] ] ]
+  ;
+END;
+
+(* Labels *)
+
+EXTEND
+  GLOBAL: ctyp expr patt fun_def fun_binding class_type class_fun_binding;
+  ctyp: AFTER "arrow"
+    [ NONA
+      [ i = LABEL; t = SELF -> <:ctyp< ~ $i$ : $t$ >>
+      | "?"; i = LABEL; t = SELF -> <:ctyp< ? $i$ : $t$ >> ] ]
+  ;
+  ctyp: LEVEL "simple"
+    [ [ "["; OPT "|"; rfl = LIST0 row_field SEP "|"; "]" ->
+          <:ctyp< [ = $list:rfl$ ] >>
+      | "["; ">"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" ->
+          <:ctyp< [ > $list:rfl$ ] >>
+      | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" ->
+          <:ctyp< [ < $list:rfl$ ] >>
+      | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; ">";
+        ntl = LIST1 name_tag; "]" ->
+          <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ]
+  ;
+  row_field:
+    [ [ "`"; i = ident -> MLast.RfTag i False []
+      | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" ->
+          MLast.RfTag i (o2b ao) l
+      | "`"; i = ident; "&"; l = LIST1 ctyp SEP "&" -> MLast.RfTag i True l
+      | "`"; i = ident; l = LIST1 ctyp SEP "&" -> MLast.RfTag i False l ] ]
+  ;
+  name_tag:
+    [ [ "`"; i = ident -> i ] ]
+  ;
+  expr: LEVEL "expr1"
+    [ [ "fun"; p = labeled_patt; e = fun_def -> <:expr< fun $p$ -> $e$ >> ] ]
+  ;
+  expr: AFTER "apply"
+    [ "label"
+      [ i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >>
+      | i = ELABEL -> <:expr< ~ $i$ >>
+      | "?"; i = LABEL; e = SELF -> <:expr< ? $i$ : $e$ >>
+      | "?"; i = ELABEL -> <:expr< ? $i$ >> ] ]
+  ;
+  expr: LEVEL "simple"
+    [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ]
+  ;
+  fun_def:
+    [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ]
+  ;
+  fun_binding:
+    [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ]
+  ;
+  patt: LEVEL "simple"
+    [ [ "`"; s = ident -> <:patt< ` $s$ >> ] ]
+  ;
+  labeled_patt:
+    [ [ i = LABEL; p = patt LEVEL "simple" -> <:patt< ~ $i$ : $p$ >>
+      | i = ELABEL -> <:patt< ~ $i$ >>
+      | "?"; i = LABEL; j = LIDENT -> <:patt< ? $i$ : ($lid:j$) >>
+      | "?"; "("; i = LABEL; j = LIDENT; ")" -> <:patt< ? $i$ : ($lid:j$) >>
+      | "?"; "("; i = LABEL; j = LIDENT; "="; e = expr; ")" ->
+          <:patt< ? $i$ : ( $lid:j$ = $e$ ) >>
+      | "?"; i = ELABEL -> <:patt< ? $i$ : ($lid:i$) >>
+      | "?"; "("; i = ELABEL; "="; e = expr; ")" ->
+          <:patt< ? $i$ : ( $lid:i$ = $e$ ) >> ] ]
+  ;
+  class_type:
+    [ [ i = LABEL; t = ctyp LEVEL "ctyp1"; "->"; ct = SELF ->
+          <:class_type< [ ~ $i$ : $t$ ] -> $ct$ >>
+      | "?"; i = LABEL; t = ctyp LEVEL "ctyp1"; "->"; ct = SELF ->
+          <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> ] ]
+  ;
+  class_fun_binding:
+    [ [ p = labeled_patt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ]
+  ;
+  ident:
+    [ [ i = LIDENT -> i
+      | i = UIDENT -> i ] ]
+  ;
+END;
+
+type spat_comp =
+  [ SpTrm of MLast.loc and MLast.patt and option MLast.expr
+  | SpNtr of MLast.loc and MLast.patt and MLast.expr
+  | SpStr of MLast.loc and MLast.patt ]
+;
+type sexp_comp =
+  [ SeTrm of MLast.loc and MLast.expr | SeNtr of MLast.loc and MLast.expr ]
+;
+
+value strm_n = "strm__";
+value peek_fun loc = <:expr< Stream.peek >>;
+value junk_fun loc = <:expr< Stream.junk >>;
+
+(* Parsers. *)
+(* In syntax generated, many cases are optimisations. *)
+
+value rec pattern_eq_expression p e =
+  match (p, e) with
+  [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b
+  | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b
+  | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) ->
+      pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2
+  | _ -> False ]
+;
+
+value is_raise e =
+  match e with
+  [ <:expr< raise $_$ >> -> True
+  | _ -> False ]
+;
+
+value is_raise_failure e =
+  match e with
+  [ <:expr< raise Stream.Failure >> -> True
+  | _ -> False ]
+;
+
+value rec handle_failure e =
+  match e with
+  [ <:expr< try $te$ with [ Stream.Failure -> $e$] >> -> handle_failure e
+  | <:expr< match $me$ with [ $list:pel$ ] >> ->
+      handle_failure me &&
+      List.for_all
+        (fun
+         [ (_, None, e) -> handle_failure e
+         | _ -> False ])
+        pel
+  | <:expr< let $list:pel$ in $e$ >> ->
+      List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e
+  | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> |
+    <:expr< $chr:_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< $uid:_$ >> ->
+      True
+  | <:expr< raise $e$ >> ->
+      match e with
+      [ <:expr< Stream.Failure >> -> False
+      | _ -> True ]
+  | <:expr< $f$ $x$ >> ->
+      is_constr_apply f && handle_failure f && handle_failure x
+  | _ -> False ]
+and is_constr_apply =
+  fun
+  [ <:expr< $uid:_$ >> -> True
+  | <:expr< $lid:_$ >> -> False
+  | <:expr< $x$ $_$ >> -> is_constr_apply x
+  | _ -> False ]
+;
+
+value rec subst v e =
+  let loc = MLast.loc_of_expr e in
+  match e with
+  [ <:expr< $lid:x$ >> ->
+      let x = if x = v then strm_n else x in
+      <:expr< $lid:x$ >>
+  | <:expr< $uid:_$ >> -> e
+  | <:expr< $int:_$ >> -> e
+  | <:expr< $chr:_$ >> -> e
+  | <:expr< $str:_$ >> -> e
+  | <:expr< $_$ . $_$ >> -> e
+  | <:expr< let $opt:rf$ $list:pel$ in $e$ >> ->
+      <:expr< let $opt:rf$ $list:List.map (subst_pe v) pel$ in $subst v e$ >>
+  | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >>
+  | <:expr< ( $list:el$ ) >> -> <:expr< ( $list:List.map (subst v) el$ ) >>
+  | _ -> raise Not_found ]
+and subst_pe v (p, e) =
+  match p with
+  [ <:patt< $lid:v'$ >> -> if v = v' then (p, e) else (p, subst v e)
+  | _ -> raise Not_found ]
+;
+
+value stream_pattern_component skont ckont =
+  fun
+  [ SpTrm loc p wo ->
+      <:expr< match $peek_fun loc$ $lid:strm_n$ with
+              [ Some $p$ $when:wo$ ->
+                  do { $junk_fun loc$ $lid:strm_n$; $skont$ }
+              | _ -> $ckont$ ] >>
+  | SpNtr loc p e ->
+      let e =
+        match e with
+        [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n ->
+            e
+        | _ -> <:expr< $e$ $lid:strm_n$ >> ]
+      in
+      if pattern_eq_expression p skont then
+        if is_raise_failure ckont then e
+        else if handle_failure e then e
+        else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >>
+      else if is_raise_failure ckont then <:expr< let $p$ = $e$ in $skont$ >>
+      else if pattern_eq_expression <:patt< Some $p$ >> skont then
+        <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >>
+      else if is_raise ckont then
+        let tst =
+          if handle_failure e then e
+          else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >>
+        in
+        <:expr< let $p$ = $tst$ in $skont$ >>
+      else
+        <:expr< match try Some $e$ with [ Stream.Failure -> None ] with
+                [ Some $p$ -> $skont$
+                | _ -> $ckont$ ] >>
+  | SpStr loc p ->
+      try
+        match p with
+        [ <:patt< $lid:v$ >> -> subst v skont
+        | _ -> raise Not_found ]
+      with
+      [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ]
+;
+
+value rec stream_pattern loc epo e ekont =
+  fun
+  [ [] ->
+      match epo with
+      [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >>
+      | _ -> e ]
+  | [(spc, err) :: spcl] ->
+      let skont =
+        let ekont err =
+          let str =
+            match err with
+            [ Some estr -> estr
+            | _ -> <:expr< "" >> ]
+          in
+          <:expr< raise (Stream.Error $str$) >>
+        in
+        stream_pattern loc epo e ekont spcl
+      in
+      let ckont = ekont err in
+      stream_pattern_component skont ckont spc ]
+;
+
+value stream_patterns_term loc ekont tspel =
+  let pel =
+    List.map
+      (fun (p, w, loc, spcl, epo, e) ->
+         let p = <:patt< Some $p$ >> in
+         let e =
+           let ekont err =
+             let str =
+               match err with
+               [ Some estr -> estr
+               | _ -> <:expr< "" >> ]
+             in
+             <:expr< raise (Stream.Error $str$) >>
+           in
+           let skont = stream_pattern loc epo e ekont spcl in
+           <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >>
+         in
+         (p, w, e))
+      tspel
+  in
+  let pel = pel @ [(<:patt< _ >>, None, ekont ())] in
+  <:expr< match $peek_fun loc$ $lid:strm_n$ with [ $list:pel$ ] >>
+;
+
+value rec group_terms =
+  fun
+  [ [([(SpTrm loc p w, None) :: spcl], epo, e) :: spel] ->
+      let (tspel, spel) = group_terms spel in
+      ([(p, w, loc, spcl, epo, e) :: tspel], spel)
+  | spel -> ([], spel) ]
+;
+
+value rec parser_cases loc =
+  fun
+  [ [] -> <:expr< raise Stream.Failure >>
+  | spel ->
+      match group_terms spel with
+      [ ([], [(spcl, epo, e) :: spel]) ->
+          stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl
+      | (tspel, spel) ->
+          stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel ] ]
+;
+
+value cparser loc bpo pc =
+  let e = parser_cases loc pc in
+  let e =
+    match bpo with
+    [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >>
+    | None -> e ]
+  in
+  let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in
+  <:expr< fun $p$ -> $e$ >>
+;
+
+value cparser_match loc me bpo pc =
+  let pc = parser_cases loc pc in
+  let e =
+    match bpo with
+    [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
+    | None -> pc ]
+  in
+  <:expr< let $lid:strm_n$ = $me$ in $e$ >>
+;
+
+(* streams *)
+
+value rec not_computing =
+  fun
+  [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> |
+    <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> ->
+      True
+  | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y
+  | _ -> False ]
+and is_cons_apply_not_computing =
+  fun
+  [ <:expr< $uid:_$ >> -> True
+  | <:expr< $lid:_$ >> -> False
+  | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y
+  | _ -> False ]
+;
+
+value slazy loc e =
+  match e with
+  [ <:expr< $f$ () >> ->
+      match f with
+      [ <:expr< $lid:_$ >> -> f
+      | _ -> <:expr< fun _ -> $e$ >> ]
+  | _ -> <:expr< fun _ -> $e$ >> ]
+;
+
+value rec cstream gloc =
+  fun
+  [ [] ->
+      let loc = gloc in
+      <:expr< Stream.sempty >>
+  | [SeTrm loc e] ->
+      if not_computing e then <:expr< Stream.ising $e$ >>
+      else <:expr< Stream.lsing $slazy loc e$ >>
+  | [SeTrm loc e :: secl] ->
+      if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >>
+      else <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >>
+  | [SeNtr loc e] ->
+      if not_computing e then e else <:expr< Stream.slazy $slazy loc e$ >>
+  | [SeNtr loc e :: secl] ->
+      if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >>
+      else <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ]
+;
+
+(* Syntax extensions in Ocaml grammar *)
+
+EXTEND
+  GLOBAL: expr;
+  expr: LEVEL "expr1"
+    [ [ "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" ->
+          <:expr< $cparser loc po pcl$ >>
+      | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; OPT "|";
+        pcl = LIST1 parser_case SEP "|" ->
+          <:expr< $cparser_match loc e po pcl$ >> ] ]
+  ;
+  parser_case:
+    [ [ "[<"; sp = stream_patt; ">]"; po = OPT ipatt; "->"; e = expr ->
+          (sp, po, e) ] ]
+  ;
+  stream_patt:
+    [ [ spc = stream_patt_comp -> [(spc, None)]
+      | spc = stream_patt_comp; ";" -> [(spc, None)]
+      | spc = stream_patt_comp; ";"; sp = stream_patt_comp_err_list ->
+          [(spc, None) :: sp]
+      | -> (* empty *) [] ] ]
+  ;
+  stream_patt_comp_err_list:
+    [ [ spc = stream_patt_comp_err -> [spc]
+      | spc = stream_patt_comp_err; ";" -> [spc]
+      | spc = stream_patt_comp_err; ";"; sp = SELF -> [spc :: sp] ] ]
+  ;
+  stream_patt_comp:
+    [ [ "'"; p = patt; eo = OPT [ "when"; e = expr LEVEL "expr1" -> e ] ->
+          SpTrm loc p eo
+      | p = patt; "="; e = expr LEVEL "expr1" -> SpNtr loc p e
+      | p = patt -> SpStr loc p ] ]
+  ;
+  stream_patt_comp_err:
+    [ [ spc = stream_patt_comp;
+        eo = OPT [ "?"; e = expr LEVEL "expr1" -> e ] ->
+          (spc, eo) ] ]
+  ;
+  ipatt:
+    [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ]
+  ;
+  expr: LEVEL "simple"
+    [ [ "[<"; ">]" -> <:expr< $cstream loc []$ >>
+      | "[<"; sel = stream_expr_comp_list; ">]" ->
+          <:expr< $cstream loc sel$ >> ] ]
+  ;
+  stream_expr_comp_list:
+    [ [ se = stream_expr_comp; ";"; sel = SELF -> [se :: sel]
+      | se = stream_expr_comp; ";" -> [se]
+      | se = stream_expr_comp -> [se] ] ]
+  ;
+  stream_expr_comp:
+    [ [ "'"; e = expr LEVEL "expr1" -> SeTrm loc e
+      | e = expr LEVEL "expr1" -> SeNtr loc e ] ]
+  ;
+END;
diff --git a/camlp4/unmaintained/scheme/.depend b/camlp4/unmaintained/scheme/.depend
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/camlp4/unmaintained/scheme/.depend
diff --git a/camlp4/unmaintained/scheme/Makefile b/camlp4/unmaintained/scheme/Makefile
new file mode 100644
index 000000000..a26ed8b14
--- /dev/null
+++ b/camlp4/unmaintained/scheme/Makefile
@@ -0,0 +1,85 @@
+#########################################################################
+#                                                                       #
+#                            Objective Caml                             #
+#                                                                       #
+#                                Camlp4                                 #
+#                                                                       #
+#   Copyright 2004 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.                #
+#                                                                       #
+#########################################################################
+#
+# Makefile for pa_lefteval
+# M.Mauny
+#
+
+include ../../config/Makefile.cnf
+
+OCAMLTOP=../../..
+CAMLP4=../../camlp4/camlp4$(EXE)
+
+OCAMLC=$(OCAMLTOP)/ocamlc$(EXE)
+OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE)
+
+P4INCLUDES= -nolib -I ../../meta -I ../../etc
+OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../camlp4 -I ../../lib -I ../../etc
+OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES)
+
+SCHSRC=pa_scheme.sc
+SRC=pa_scheme.ml  pr_scheme.ml  pr_schp_main.ml
+OBJS=$(SRC:.ml=.cmo)
+OBJSX=$(OCAMLSRC:.ml=.cmx)
+
+all: $(OBJS) pr_schemep.cmo camlp4sch$(EXE)
+
+opt: all
+
+bootstrap: camlp4sch$(EXE) save
+	./camlp4sch$(EXE) ../../etc/q_phony.cmo ../../meta/pa_extend.cmo ../../etc/pr_r.cmo ../../etc/pr_extend.cmo ../../etc/pr_rp.cmo -impl pa_scheme.sc \
+	  | sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' \
+		-e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' > pa_scheme.ml
+	@if cmp -s pa_scheme.ml SAVED/pa_scheme.ml; then \
+		echo 'pa_scheme.ml and SAVED/pa_scheme.ml are identical' ; \
+	 else \
+		echo '**** Note: pa_scheme.ml differs from SAVED/pa_scheme.ml'; \
+	 fi
+
+save:
+	test -d SAVED || mkdir SAVED
+	mkdir SAVED.$$$$ && mv SAVED pa_scheme.ml SAVED.$$$$ && mv SAVED.$$$$ SAVED
+
+restore:
+	mv SAVED SAVED.$$$$ && mv SAVED.$$$$/* . && rmdir SAVED.$$$$
+
+depend:
+	cp .depend .depend.bak
+	> .depend
+	for file in $(SRC); do \
+	  $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \
+	  sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \
+	done
+
+clean:
+	rm -f camlp4sch$(EXE) *.cm* *.$(O) *.bak .*.bak
+
+camlp4sch: pa_scheme.cmo
+	rm -f camlp4sch
+	DIR=`pwd` && cd ../../camlp4 && $(MAKE) CAMLP4=$$DIR/camlp4sch CAMLP4M="-I $$DIR pa_scheme.cmo ../meta/pr_dump.cmo"
+
+pr_schemep.cmo: pr_schp_main.cmo
+	$(OCAMLC) ../../etc/parserify.cmo pr_schp_main.cmo -a -o $@
+
+.SUFFIXES: .cmx .cmo .cmi .ml .mli
+
+.mli.cmi:
+	$(OCAMLC) $(OCAMLCFLAGS) -c $<
+
+
+.ml.cmo:
+	$(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $<
+
+.ml.cmx:
+	$(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES)  `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $<
+
+include .depend
diff --git a/camlp4/unmaintained/scheme/README b/camlp4/unmaintained/scheme/README
new file mode 100644
index 000000000..809d42f2a
--- /dev/null
+++ b/camlp4/unmaintained/scheme/README
@@ -0,0 +1,15 @@
+This is an application of or an extension for Camlp4. Although it is
+currently distributed with OCaml/Camlp4, it may or may not be
+actively maintained.
+
+It probably won't be part of future OCaml/Camlp4 distributions but be
+accessible from the Camlp4 hump. If you are interested in developing
+this package further and/or actively maintain it, please let us know
+(caml@inria.fr)
+
+This package is distributed under the same license as the Objective
+Caml Library (that is, LGPL with a special exception allowing both
+static and dynamic link).
+
+-- Michel Mauny
+
diff --git a/camlp4/unmaintained/scheme/pa_scheme.ml b/camlp4/unmaintained/scheme/pa_scheme.ml
new file mode 100644
index 000000000..45b97e3c4
--- /dev/null
+++ b/camlp4/unmaintained/scheme/pa_scheme.ml
@@ -0,0 +1,1093 @@
+(* pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *)
+(* ********************************************************************** *)
+(*                                                                        *)
+(*                                Camlp4                                  *)
+(*                                                                        *)
+(*     Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2002 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.                                                   *)
+(*                                                                        *)
+(* ********************************************************************** *)
+(* File generated by pretty print; do not edit! *)
+
+open Pcaml;
+open Stdpp;
+
+type choice 'a 'b =
+  [ Left of 'a
+  | Right of 'b ]
+;
+
+(* Buffer *)
+
+module Buff =
+  struct
+    value buff = ref (String.create 80);
+    value store len x =
+      do {
+        if len >= String.length buff.val then
+          buff.val := buff.val ^ String.create (String.length buff.val)
+        else ();
+        buff.val.[len] := x;
+        succ len
+      }
+    ;
+    value get len = String.sub buff.val 0 len;
+  end
+;
+
+(* Lexer *)
+
+value rec skip_to_eol =
+  parser
+  [ [: `'\n' | '\r' :] -> ()
+  | [: `_; s :] -> skip_to_eol s ]
+;
+
+value no_ident = ['('; ')'; '['; ']'; '{'; '}'; ' '; '\t'; '\n'; '\r'; ';'];
+
+value rec ident len =
+  parser
+  [ [: `'.' :] -> (Buff.get len, True)
+  | [: `x when not (List.mem x no_ident); s :] -> ident (Buff.store len x) s
+  | [: :] -> (Buff.get len, False) ]
+;
+
+value identifier kwt (s, dot) =
+  let con =
+    try do { (Hashtbl.find kwt s : unit); "" } with
+    [ Not_found ->
+        match s.[0] with
+        [ 'A'..'Z' -> if dot then "UIDENTDOT" else "UIDENT"
+        | _ -> if dot then "LIDENTDOT" else "LIDENT" ] ]
+  in
+  (con, s)
+;
+
+value rec string len =
+  parser
+  [ [: `'"' :] -> Buff.get len
+  | [: `'\\'; `c; s :] -> string (Buff.store (Buff.store len '\\') c) s
+  | [: `x; s :] -> string (Buff.store len x) s ]
+;
+
+value rec end_exponent_part_under len =
+  parser
+  [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (Buff.store len c) s
+  | [: :] -> ("FLOAT", Buff.get len) ]
+;
+
+value end_exponent_part len =
+  parser
+  [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (Buff.store len c) s
+  | [: :] -> raise (Stream.Error "ill-formed floating-point constant") ]
+;
+
+value exponent_part len =
+  parser
+  [ [: `('+' | '-' as c); s :] -> end_exponent_part (Buff.store len c) s
+  | [: a = end_exponent_part len :] -> a ]
+;
+
+value rec decimal_part len =
+  parser
+  [ [: `('0'..'9' as c); s :] -> decimal_part (Buff.store len c) s
+  | [: `'e' | 'E'; s :] -> exponent_part (Buff.store len 'E') s
+  | [: :] -> ("FLOAT", Buff.get len) ]
+;
+
+value rec number len =
+  parser
+  [ [: `('0'..'9' as c); s :] -> number (Buff.store len c) s
+  | [: `'.'; s :] -> decimal_part (Buff.store len '.') s
+  | [: `'e' | 'E'; s :] -> exponent_part (Buff.store len 'E') s
+  | [: :] -> ("INT", Buff.get len) ]
+;
+
+value binary = parser [: `('0'..'1' as c) :] -> c;
+
+value octal = parser [: `('0'..'7' as c) :] -> c;
+
+value hexa = parser [: `('0'..'9' | 'a'..'f' | 'A'..'F' as c) :] -> c;
+
+value rec digits_under kind len =
+  parser
+  [ [: d = kind; s :] -> digits_under kind (Buff.store len d) s
+  | [: :] -> Buff.get len ]
+;
+
+value digits kind bp len =
+  parser
+  [ [: d = kind; s :] -> ("INT", digits_under kind (Buff.store len d) s)
+  | [: s :] ep ->
+      raise_with_loc
+        (Reloc.shift_pos bp Reloc.zero_loc, Reloc.shift_pos ep Reloc.zero_loc)
+        (Failure "ill-formed integer constant") ]
+;
+
+value base_number kwt bp len =
+  parser
+  [ [: `'b' | 'B'; s :] -> digits binary bp (Buff.store len 'b') s
+  | [: `'o' | 'O'; s :] -> digits octal bp (Buff.store len 'o') s
+  | [: `'x' | 'X'; s :] -> digits hexa bp (Buff.store len 'x') s
+  | [: id = ident (Buff.store 0 '#') :] -> identifier kwt id ]
+;
+
+value rec operator len =
+  parser
+  [ [: `'.' :] -> Buff.get (Buff.store len '.')
+  | [: :] -> Buff.get len ]
+;
+
+value char_or_quote_id x =
+  parser
+  [ [: `''' :] -> ("CHAR", String.make 1 x)
+  | [: s :] ep ->
+      if List.mem x no_ident then
+        Stdpp.raise_with_loc
+          (Reloc.shift_pos (ep - 2) Reloc.zero_loc,
+           Reloc.shift_pos (ep - 1) Reloc.zero_loc)
+          (Stream.Error "bad quote")
+      else
+        let len = Buff.store (Buff.store 0 ''') x in
+        let (s, dot) = ident len s in
+        (if dot then "LIDENTDOT" else "LIDENT", s) ]
+;
+
+value rec char len =
+  parser
+  [ [: `''' :] -> len
+  | [: `x; s :] -> char (Buff.store len x) s ]
+;
+
+value quote =
+  parser
+  [ [: `'\\'; len = char (Buff.store 0 '\\') :] -> ("CHAR", Buff.get len)
+  | [: `x; s :] -> char_or_quote_id x s ]
+;
+
+(* The system with LIDENTDOT and UIDENTDOT is not great (it would be *)
+(* better to have a token DOT (actually SPACEDOT and DOT)) but it is *)
+(* the only way (that I have found) to have a good behaviour in the *)
+(* toplevel (not expecting tokens after a phrase). Drawbacks: 1/ to be *)
+(* complete, we should have STRINGDOT, RIGHTPARENDOT, and so on 2/ the *)
+(* parser rule with dot is right associative and we have to reverse *)
+(* the resulting tree (using the function leftify). *)
+(* This is a complicated issue: the behaviour of the OCaml toplevel *)
+(* is strange, anyway. For example, even without Camlp4, The OCaml *)
+(* toplevel accepts that: *)
+(*     # let x = 32;; foo bar match let ) *)
+
+value rec lexer kwt = parser [: t = lexer0 kwt; _ = no_dot :] -> t
+and no_dot =
+  parser
+  [ [: `'.' :] ep ->
+      Stdpp.raise_with_loc
+        (Reloc.shift_pos (ep - 1) Reloc.zero_loc,
+         Reloc.shift_pos ep Reloc.zero_loc)
+        (Stream.Error "bad dot")
+  | [: :] -> () ]
+and lexer0 kwt =
+  parser bp
+  [ [: `'\t' | '\n' | '\r'; s :] -> lexer0 kwt s
+  | [: `' '; s :] -> after_space kwt s
+  | [: `';'; _ = skip_to_eol; s :] -> lexer kwt s
+  | [: `'(' :] -> (("", "("), (bp, bp + 1))
+  | [: `')'; s :] ep -> (("", rparen s), (bp, ep))
+  | [: `'[' :] -> (("", "["), (bp, bp + 1))
+  | [: `']' :] -> (("", "]"), (bp, bp + 1))
+  | [: `'{' :] -> (("", "{"), (bp, bp + 1))
+  | [: `'}' :] -> (("", "}"), (bp, bp + 1))
+  | [: `'"'; s = string 0 :] ep -> (("STRING", s), (bp, ep))
+  | [: `'''; tok = quote :] ep -> (tok, (bp, ep))
+  | [: `'<'; tok = less kwt :] ep -> (tok, (bp, ep))
+  | [: `'-'; tok = minus kwt :] ep -> (tok, (bp, ep))
+  | [: `'~'; tok = tilde :] ep -> (tok, (bp, ep))
+  | [: `'?'; tok = question :] ep -> (tok, (bp, ep))
+  | [: `'#'; tok = base_number kwt bp (Buff.store 0 '0') :] ep ->
+      (tok, (bp, ep))
+  | [: `('0'..'9' as c); tok = number (Buff.store 0 c) :] ep ->
+      (tok, (bp, ep))
+  | [: `('+' | '*' | '/' as c); id = operator (Buff.store 0 c) :] ep ->
+      (identifier kwt (id, False), (bp, ep))
+  | [: `x; id = ident (Buff.store 0 x) :] ep -> (identifier kwt id, (bp, ep))
+  | [: :] -> (("EOI", ""), (bp, bp + 1)) ]
+and rparen =
+  parser
+  [ [: `'.' :] -> ")."
+  | [: ___ :] -> ")" ]
+and after_space kwt =
+  parser
+  [ [: `'.' :] ep -> (("", "."), (ep - 1, ep))
+  | [: x = lexer0 kwt :] -> x ]
+and tilde =
+  parser
+  [ [: `('a'..'z' as c); (s, dot) = ident (Buff.store 0 c) :] ->
+      ("TILDEIDENT", s)
+  | [: :] -> ("LIDENT", "~") ]
+and question =
+  parser
+  [ [: `('a'..'z' as c); (s, dot) = ident (Buff.store 0 c) :] ->
+      ("QUESTIONIDENT", s)
+  | [: :] -> ("LIDENT", "?") ]
+and minus kwt =
+  parser
+  [ [: `'.' :] -> identifier kwt ("-.", False)
+  | [: `('0'..'9' as c); n = number (Buff.store (Buff.store 0 '-') c) :] ep ->
+      n
+  | [: id = ident (Buff.store 0 '-') :] -> identifier kwt id ]
+and less kwt =
+  parser
+  [ [: `':'; lab = label 0; `'<' ? "'<' expected"; q = quotation 0 :] ->
+      ("QUOT", lab ^ ":" ^ q)
+  | [: id = ident (Buff.store 0 '<') :] -> identifier kwt id ]
+and label len =
+  parser
+  [ [: `('a'..'z' | 'A'..'Z' | '_' as c); s :] -> label (Buff.store len c) s
+  | [: :] -> Buff.get len ]
+and quotation len =
+  parser
+  [ [: `'>'; s :] -> quotation_greater len s
+  | [: `x; s :] -> quotation (Buff.store len x) s
+  | [: :] -> failwith "quotation not terminated" ]
+and quotation_greater len =
+  parser
+  [ [: `'>' :] -> Buff.get len
+  | [: a = quotation (Buff.store len '>') :] -> a ]
+;
+
+value lexer_using kwt (con, prm) =
+  match con with
+  [ "CHAR" | "EOI" | "INT" | "FLOAT" | "LIDENT" | "LIDENTDOT" |
+    "QUESTIONIDENT" | "QUOT" | "STRING" | "TILDEIDENT" | "UIDENT" |
+    "UIDENTDOT" ->
+      ()
+  | "ANTIQUOT" -> ()
+  | "" ->
+      try Hashtbl.find kwt prm with [ Not_found -> Hashtbl.add kwt prm () ]
+  | _ ->
+      raise
+        (Token.Error
+           ("the constructor \"" ^ con ^ "\" is not recognized by Plexer")) ]
+;
+
+value lexer_text (con, prm) =
+  if con = "" then "'" ^ prm ^ "'"
+  else if prm = "" then con
+  else con ^ " \"" ^ prm ^ "\""
+;
+
+value lexer_gmake () =
+  let kwt = Hashtbl.create 89 in
+  {Token.tok_func =
+     Token.lexer_func_of_parser
+       (fun s ->
+          let (r, (bp, ep)) = lexer kwt s in
+          (r,
+           (Reloc.shift_pos bp Reloc.zero_loc,
+            Reloc.shift_pos ep Reloc.zero_loc)));
+   Token.tok_using = lexer_using kwt; Token.tok_removing = fun [];
+   Token.tok_match = Token.default_match; Token.tok_text = lexer_text;
+   Token.tok_comm = None}
+;
+
+(* Building AST *)
+
+type sexpr =
+  [ Sacc of MLast.loc and sexpr and sexpr
+  | Schar of MLast.loc and string
+  | Sexpr of MLast.loc and list sexpr
+  | Sint of MLast.loc and string
+  | Sfloat of MLast.loc and string
+  | Slid of MLast.loc and string
+  | Slist of MLast.loc and list sexpr
+  | Sqid of MLast.loc and string
+  | Squot of MLast.loc and string and string
+  | Srec of MLast.loc and list sexpr
+  | Sstring of MLast.loc and string
+  | Stid of MLast.loc and string
+  | Suid of MLast.loc and string ]
+;
+
+value loc_of_sexpr =
+  fun [
+    Sacc loc _ _ | Schar loc _ | Sexpr loc _ | Sint loc _ | Sfloat loc _ |
+    Slid loc _ | Slist loc _ | Sqid loc _ | Squot loc _ _ | Srec loc _ |
+    Sstring loc _ | Stid loc _ | Suid loc _ ->
+    loc ]
+;
+value error_loc loc err =
+  raise_with_loc loc (Stream.Error (err ^ " expected"))
+;
+value error se err = error_loc (loc_of_sexpr se) err;
+
+value strm_n = "strm__";
+value peek_fun loc = <:expr< Stream.peek >>;
+value junk_fun loc = <:expr< Stream.junk >>;
+
+value assoc_left_parsed_op_list =
+  ["+"; "*"; "+."; "*."; "land"; "lor"; "lxor"]
+;
+value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"];
+value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="];
+
+value op_apply loc e1 e2 =
+  fun
+  [ "and" -> <:expr< $e1$ && $e2$ >>
+  | "or" -> <:expr< $e1$ || $e2$ >>
+  | x -> <:expr< $lid:x$ $e1$ $e2$ >> ]
+;
+
+value string_se =
+  fun
+  [ Sstring loc s -> s
+  | se -> error se "string" ]
+;
+
+value mod_ident_se =
+  fun
+  [ Suid _ s -> [Pcaml.rename_id.val s]
+  | Slid _ s -> [Pcaml.rename_id.val s]
+  | se -> error se "mod_ident" ]
+;
+
+value lident_expr loc s =
+  if String.length s > 1 && s.[0] = '`' then
+    let s = String.sub s 1 (String.length s - 1) in
+    <:expr< ` $s$ >>
+  else <:expr< $lid:(Pcaml.rename_id.val s)$ >>
+;
+
+value rec module_expr_se =
+  fun
+  [ Sexpr loc [Slid _ "functor"; Suid _ s; se1; se2] ->
+      let s = Pcaml.rename_id.val s in
+      let mt = module_type_se se1 in
+      let me = module_expr_se se2 in
+      <:module_expr< functor ($s$ : $mt$) -> $me$ >>
+  | Sexpr loc [Slid _ "struct" :: sl] ->
+      let mel = List.map str_item_se sl in
+      <:module_expr< struct $list:mel$ end >>
+  | Sexpr loc [se1; se2] ->
+      let me1 = module_expr_se se1 in
+      let me2 = module_expr_se se2 in
+      <:module_expr< $me1$ $me2$ >>
+  | Suid loc s -> <:module_expr< $uid:(Pcaml.rename_id.val s)$ >>
+  | se -> error se "module expr" ]
+and module_type_se =
+  fun
+  [ Sexpr loc [Slid _ "functor"; Suid _ s; se1; se2] ->
+      let s = Pcaml.rename_id.val s in
+      let mt1 = module_type_se se1 in
+      let mt2 = module_type_se se2 in
+      <:module_type< functor ($s$ : $mt1$) -> $mt2$ >>
+  | Sexpr loc [Slid _ "sig" :: sel] ->
+      let sil = List.map sig_item_se sel in
+      <:module_type< sig $list:sil$ end >>
+  | Sexpr loc [Slid _ "with"; se; Sexpr _ sel] ->
+      let mt = module_type_se se in
+      let wcl = List.map with_constr_se sel in
+      <:module_type< $mt$ with $list:wcl$ >>
+  | Suid loc s -> <:module_type< $uid:(Pcaml.rename_id.val s)$ >>
+  | se -> error se "module type" ]
+and with_constr_se =
+  fun
+  [ Sexpr loc [Slid _ "type"; se1; se2] ->
+      let tn = mod_ident_se se1 in
+      let te = ctyp_se se2 in
+      MLast.WcTyp loc tn [] te
+  | se -> error se "with constr" ]
+and sig_item_se =
+  fun
+  [ Sexpr loc [Slid _ "type" :: sel] ->
+      let tdl = type_declaration_list_se sel in
+      <:sig_item< type $list:tdl$ >>
+  | Sexpr loc [Slid _ "exception"; Suid _ c :: sel] ->
+      let c = Pcaml.rename_id.val c in
+      let tl = List.map ctyp_se sel in
+      <:sig_item< exception $c$ of $list:tl$ >>
+  | Sexpr loc [Slid _ "value"; Slid _ s; se] ->
+      let s = Pcaml.rename_id.val s in
+      let t = ctyp_se se in
+      <:sig_item< value $s$ : $t$ >>
+  | Sexpr loc [Slid _ "external"; Slid _ i; se :: sel] ->
+      let i = Pcaml.rename_id.val i in
+      let pd = List.map string_se sel in
+      let t = ctyp_se se in
+      <:sig_item< external $i$ : $t$ = $list:pd$ >>
+  | Sexpr loc [Slid _ "module"; Suid _ s; se] ->
+      let s = Pcaml.rename_id.val s in
+      let mb = module_type_se se in
+      <:sig_item< module $s$ : $mb$ >>
+  | Sexpr loc [Slid _ "moduletype"; Suid _ s; se] ->
+      let s = Pcaml.rename_id.val s in
+      let mt = module_type_se se in
+      <:sig_item< module type $s$ = $mt$ >>
+  | se -> error se "sig item" ]
+and str_item_se se =
+  match se with
+  [ Sexpr loc [Slid _ "open"; se] ->
+      let s = mod_ident_se se in
+      <:str_item< open $s$ >>
+  | Sexpr loc [Slid _ "type" :: sel] ->
+      let tdl = type_declaration_list_se sel in
+      <:str_item< type $list:tdl$ >>
+  | Sexpr loc [Slid _ "exception"; Suid _ c :: sel] ->
+      let c = Pcaml.rename_id.val c in
+      let tl = List.map ctyp_se sel in
+      <:str_item< exception $c$ of $list:tl$ >>
+  | Sexpr loc [Slid _ ("define" | "definerec" as r); se :: sel] ->
+      let r = r = "definerec" in
+      let (p, e) = fun_binding_se se (begin_se loc sel) in
+      <:str_item< value $opt:r$ $p$ = $e$ >>
+  | Sexpr loc [Slid _ ("define*" | "definerec*" as r) :: sel] ->
+      let r = r = "definerec*" in
+      let lbs = List.map let_binding_se sel in
+      <:str_item< value $opt:r$ $list:lbs$ >>
+  | Sexpr loc [Slid _ "external"; Slid _ i; se :: sel] ->
+      let i = Pcaml.rename_id.val i in
+      let pd = List.map string_se sel in
+      let t = ctyp_se se in
+      <:str_item< external $i$ : $t$ = $list:pd$ >>
+  | Sexpr loc [Slid _ "module"; Suid _ i; se] ->
+      let i = Pcaml.rename_id.val i in
+      let mb = module_binding_se se in
+      <:str_item< module $i$ = $mb$ >>
+  | Sexpr loc [Slid _ "moduletype"; Suid _ s; se] ->
+      let s = Pcaml.rename_id.val s in
+      let mt = module_type_se se in
+      <:str_item< module type $s$ = $mt$ >>
+  | _ ->
+      let loc = loc_of_sexpr se in
+      let e = expr_se se in
+      <:str_item< $exp:e$ >> ]
+and module_binding_se se = module_expr_se se
+and expr_se =
+  fun
+  [ Sacc loc se1 se2 ->
+      let e1 = expr_se se1 in
+      match se2 with
+      [ Slist loc [se2] ->
+          let e2 = expr_se se2 in
+          <:expr< $e1$ .[ $e2$ ] >>
+      | Sexpr loc [se2] ->
+          let e2 = expr_se se2 in
+          <:expr< $e1$ .( $e2$ ) >>
+      | _ ->
+          let e2 = expr_se se2 in
+          <:expr< $e1$ . $e2$ >> ]
+  | Slid loc s -> lident_expr loc s
+  | Suid loc s -> <:expr< $uid:(Pcaml.rename_id.val s)$ >>
+  | Sint loc s -> <:expr< $int:s$ >>
+  | Sfloat loc s -> <:expr< $flo:s$ >>
+  | Schar loc s -> <:expr< $chr:s$ >>
+  | Sstring loc s -> <:expr< $str:s$ >>
+  | Stid loc s -> <:expr< ~ $(Pcaml.rename_id.val s)$ >>
+  | Sqid loc s -> <:expr< ? $(Pcaml.rename_id.val s)$ >>
+  | Sexpr loc [] -> <:expr< () >>
+  | Sexpr loc [Slid _ s; e1 :: ([_ :: _] as sel)]
+    when List.mem s assoc_left_parsed_op_list ->
+      let rec loop e1 =
+        fun
+        [ [] -> e1
+        | [e2 :: el] -> loop (op_apply loc e1 e2 s) el ]
+      in
+      loop (expr_se e1) (List.map expr_se sel)
+  | Sexpr loc [Slid _ s :: ([_; _ :: _] as sel)]
+    when List.mem s assoc_right_parsed_op_list ->
+      let rec loop =
+        fun
+        [ [] -> assert False
+        | [e1] -> e1
+        | [e1 :: el] ->
+            let e2 = loop el in
+            op_apply loc e1 e2 s ]
+      in
+      loop (List.map expr_se sel)
+  | Sexpr loc [Slid _ s :: ([_; _ :: _] as sel)]
+    when List.mem s and_by_couple_op_list ->
+      let rec loop =
+        fun
+        [ [] | [_] -> assert False
+        | [e1; e2] -> <:expr< $lid:s$ $e1$ $e2$ >>
+        | [e1 :: ([e2; _ :: _] as el)] ->
+            let a1 = op_apply loc e1 e2 s in
+            let a2 = loop el in
+            <:expr< $a1$ && $a2$ >> ]
+      in
+      loop (List.map expr_se sel)
+  | Sexpr loc [Stid _ s; se] ->
+      let e = expr_se se in
+      <:expr< ~ $s$ : $e$ >>
+  | Sexpr loc [Slid _ "-"; se] ->
+      let e = expr_se se in
+      <:expr< - $e$ >>
+  | Sexpr loc [Slid _ "if"; se; se1] ->
+      let e = expr_se se in
+      let e1 = expr_se se1 in
+      <:expr< if $e$ then $e1$ else () >>
+  | Sexpr loc [Slid _ "if"; se; se1; se2] ->
+      let e = expr_se se in
+      let e1 = expr_se se1 in
+      let e2 = expr_se se2 in
+      <:expr< if $e$ then $e1$ else $e2$ >>
+  | Sexpr loc [Slid _ "cond" :: sel] ->
+      let rec loop =
+        fun
+        [ [Sexpr loc [Slid _ "else" :: sel]] -> begin_se loc sel
+        | [Sexpr loc [se1 :: sel1] :: sel] ->
+            let e1 = expr_se se1 in
+            let e2 = begin_se loc sel1 in
+            let e3 = loop sel in
+            <:expr< if $e1$ then $e2$ else $e3$ >>
+        | [] -> <:expr< () >>
+        | [se :: _] -> error se "cond clause" ]
+      in
+      loop sel
+  | Sexpr loc [Slid _ "while"; se :: sel] ->
+      let e = expr_se se in
+      let el = List.map expr_se sel in
+      <:expr< while $e$ do { $list:el$ } >>
+  | Sexpr loc [Slid _ "for"; Slid _ i; se1; se2 :: sel] ->
+      let i = Pcaml.rename_id.val i in
+      let e1 = expr_se se1 in
+      let e2 = expr_se se2 in
+      let el = List.map expr_se sel in
+      <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >>
+  | Sexpr loc [Slid loc1 "lambda"] -> <:expr< fun [] >>
+  | Sexpr loc [Slid loc1 "lambda"; sep :: sel] ->
+      let e = begin_se loc1 sel in
+      match ipatt_opt_se sep with
+      [ Left p -> <:expr< fun $p$ -> $e$ >>
+      | Right (se, sel) ->
+          List.fold_right
+            (fun se e ->
+               let p = ipatt_se se in
+               <:expr< fun $p$ -> $e$ >>)
+            [se :: sel] e ]
+  | Sexpr loc [Slid _ "lambda_match" :: sel] ->
+      let pel = List.map (match_case loc) sel in
+      <:expr< fun [ $list:pel$ ] >>
+  | Sexpr loc [Slid _ ("let" | "letrec" as r) :: sel] ->
+      match sel with
+      [ [Sexpr _ sel1 :: sel2] ->
+          let r = r = "letrec" in
+          let lbs = List.map let_binding_se sel1 in
+          let e = begin_se loc sel2 in
+          <:expr< let $opt:r$ $list:lbs$ in $e$ >>
+      | [Slid _ n; Sexpr _ sl :: sel] ->
+          let n = Pcaml.rename_id.val n in
+          let (pl, el) =
+            List.fold_right
+              (fun se (pl, el) ->
+                 match se with
+                 [ Sexpr _ [se1; se2] ->
+                     ([patt_se se1 :: pl], [expr_se se2 :: el])
+                 | se -> error se "named let" ])
+              sl ([], [])
+          in
+          let e1 =
+            List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl
+              (begin_se loc sel)
+          in
+          let e2 =
+            List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>)
+              <:expr< $lid:n$ >> el
+          in
+          <:expr< let rec $lid:n$ = $e1$ in $e2$ >>
+      | [se :: _] -> error se "let_binding"
+      | _ -> error_loc loc "let_binding" ]
+  | Sexpr loc [Slid _ "let*" :: sel] ->
+      match sel with
+      [ [Sexpr _ sel1 :: sel2] ->
+          List.fold_right
+            (fun se ek ->
+               let (p, e) = let_binding_se se in
+               <:expr< let $p$ = $e$ in $ek$ >>)
+            sel1 (begin_se loc sel2)
+      | [se :: _] -> error se "let_binding"
+      | _ -> error_loc loc "let_binding" ]
+  | Sexpr loc [Slid _ "match"; se :: sel] ->
+      let e = expr_se se in
+      let pel = List.map (match_case loc) sel in
+      <:expr< match $e$ with [ $list:pel$ ] >>
+  | Sexpr loc [Slid _ "parser" :: sel] ->
+      let e =
+        match sel with
+        [ [(Slid _ _ as se) :: sel] ->
+            let p = patt_se se in
+            let pc = parser_cases_se loc sel in
+            <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >>
+        | _ -> parser_cases_se loc sel ]
+      in
+      <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >>
+  | Sexpr loc [Slid _ "match_with_parser"; se :: sel] ->
+      let me = expr_se se in
+      let (bpo, sel) =
+        match sel with
+        [ [(Slid _ _ as se) :: sel] -> (Some (patt_se se), sel)
+        | _ -> (None, sel) ]
+      in
+      let pc = parser_cases_se loc sel in
+      let e =
+        match bpo with
+        [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
+        | None -> pc ]
+      in
+      match me with
+      [ <:expr< $lid:x$ >> when x = strm_n -> e
+      | _ -> <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> ]
+  | Sexpr loc [Slid _ "try"; se :: sel] ->
+      let e = expr_se se in
+      let pel = List.map (match_case loc) sel in
+      <:expr< try $e$ with [ $list:pel$ ] >>
+  | Sexpr loc [Slid _ "begin" :: sel] ->
+      let el = List.map expr_se sel in
+      <:expr< do { $list:el$ } >>
+  | Sexpr loc [Slid _ ":="; se1; se2] ->
+      let e1 = expr_se se1 in
+      let e2 = expr_se se2 in
+      <:expr< $e1$ := $e2$ >>
+  | Sexpr loc [Slid _ "values" :: sel] ->
+      let el = List.map expr_se sel in
+      <:expr< ( $list:el$ ) >>
+  | Srec loc [Slid _ "with"; se :: sel] ->
+      let e = expr_se se in
+      let lel = List.map (label_expr_se loc) sel in
+      <:expr< { ($e$) with $list:lel$ } >>
+  | Srec loc sel ->
+      let lel = List.map (label_expr_se loc) sel in
+      <:expr< { $list:lel$ } >>
+  | Sexpr loc [Slid _ ":"; se1; se2] ->
+      let e = expr_se se1 in
+      let t = ctyp_se se2 in
+      <:expr< ( $e$ : $t$ ) >>
+  | Sexpr loc [se] ->
+      let e = expr_se se in
+      <:expr< $e$ () >>
+  | Sexpr loc [Slid _ "assert"; Suid _ "False"] -> <:expr< assert False >>
+  | Sexpr loc [Slid _ "assert"; se] ->
+      let e = expr_se se in
+      <:expr< assert $e$ >>
+  | Sexpr loc [Slid _ "lazy"; se] ->
+      let e = expr_se se in
+      <:expr< lazy $e$ >>
+  | Sexpr loc [se :: sel] ->
+      List.fold_left
+        (fun e se ->
+           let e1 = expr_se se in
+           <:expr< $e$ $e1$ >>)
+        (expr_se se) sel
+  | Slist loc sel ->
+      let rec loop =
+        fun
+        [ [] -> <:expr< [] >>
+        | [se1; Slid _ "."; se2] ->
+            let e = expr_se se1 in
+            let el = expr_se se2 in
+            <:expr< [$e$ :: $el$] >>
+        | [se :: sel] ->
+            let e = expr_se se in
+            let el = loop sel in
+            <:expr< [$e$ :: $el$] >> ]
+      in
+      loop sel
+  | Squot loc typ txt -> Pcaml.handle_expr_quotation loc (typ, txt) ]
+and begin_se loc =
+  fun
+  [ [] -> <:expr< () >>
+  | [se] -> expr_se se
+  | sel ->
+      let el = List.map expr_se sel in
+      let loc = (fst (loc_of_sexpr (List.hd sel)), snd loc) in
+      <:expr< do { $list:el$ } >> ]
+and let_binding_se =
+  fun
+  [ Sexpr loc [se :: sel] ->
+      let e = begin_se loc sel in
+      match ipatt_opt_se se with
+      [ Left p -> (p, e)
+      | Right _ -> fun_binding_se se e ]
+  | se -> error se "let_binding" ]
+and fun_binding_se se e =
+  match se with
+  [ Sexpr _ [Slid _ "values" :: _] -> (ipatt_se se, e)
+  | Sexpr _ [Slid loc s :: sel] ->
+      let s = Pcaml.rename_id.val s in
+      let e =
+        List.fold_right
+          (fun se e ->
+             let loc = (fst (loc_of_sexpr se), snd (MLast.loc_of_expr e)) in
+             let p = ipatt_se se in
+             <:expr< fun $p$ -> $e$ >>)
+          sel e
+      in
+      let p = <:patt< $lid:s$ >> in
+      (p, e)
+  | _ -> (ipatt_se se, e) ]
+and match_case loc =
+  fun
+  [ Sexpr loc [Sexpr _ [Slid _ "when"; se; sew] :: sel] ->
+      (patt_se se, Some (expr_se sew), begin_se loc sel)
+  | Sexpr loc [se :: sel] -> (patt_se se, None, begin_se loc sel)
+  | se -> error se "match_case" ]
+and label_expr_se loc =
+  fun
+  [ Sexpr _ [se1; se2] -> (patt_se se1, expr_se se2)
+  | se -> error se "label_expr" ]
+and label_patt_se loc =
+  fun
+  [ Sexpr _ [se1; se2] -> (patt_se se1, patt_se se2)
+  | se -> error se "label_patt" ]
+and parser_cases_se loc =
+  fun
+  [ [] -> <:expr< raise Stream.Failure >>
+  | [Sexpr loc [Sexpr _ spsel :: act] :: sel] ->
+      let ekont _ = parser_cases_se loc sel in
+      let act =
+        match act with
+        [ [se] -> expr_se se
+        | [sep; se] ->
+            let p = patt_se sep in
+            let e = expr_se se in
+            <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >>
+        | _ -> error_loc loc "parser_case" ]
+      in
+      stream_pattern_se loc act ekont spsel
+  | [se :: _] -> error se "parser_case" ]
+and stream_pattern_se loc act ekont =
+  fun
+  [ [] -> act
+  | [se :: sel] ->
+      let ckont err = <:expr< raise (Stream.Error $err$) >> in
+      let skont = stream_pattern_se loc act ckont sel in
+      stream_pattern_component skont ekont <:expr< "" >> se ]
+and stream_pattern_component skont ekont err =
+  fun
+  [ Sexpr loc [Slid _ "`"; se :: wol] ->
+      let wo =
+        match wol with
+        [ [se] -> Some (expr_se se)
+        | [] -> None
+        | _ -> error_loc loc "stream_pattern_component" ]
+      in
+      let e = peek_fun loc in
+      let p = patt_se se in
+      let j = junk_fun loc in
+      let k = ekont err in
+      <:expr< match $e$ $lid:strm_n$ with
+               [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ }
+               | _ -> $k$ ] >>
+  | Sexpr loc [se1; se2] ->
+      let p = patt_se se1 in
+      let e =
+        let e = expr_se se2 in
+        <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>
+      in
+      let k = ekont err in
+      <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >>
+  | Sexpr loc [Slid _ "?"; se1; se2] ->
+      stream_pattern_component skont ekont (expr_se se2) se1
+  | Slid loc s ->
+      let s = Pcaml.rename_id.val s in
+      <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>
+  | se -> error se "stream_pattern_component" ]
+and patt_se =
+  fun
+  [ Sacc loc se1 se2 ->
+      let p1 = patt_se se1 in
+      let p2 = patt_se se2 in
+      <:patt< $p1$ . $p2$ >>
+  | Slid loc "_" -> <:patt< _ >>
+  | Slid loc s -> <:patt< $lid:(Pcaml.rename_id.val s)$ >>
+  | Suid loc s -> <:patt< $uid:(Pcaml.rename_id.val s)$ >>
+  | Sint loc s -> <:patt< $int:s$ >>
+  | Sfloat loc s -> <:patt< $flo:s$ >>
+  | Schar loc s -> <:patt< $chr:s$ >>
+  | Sstring loc s -> <:patt< $str:s$ >>
+  | Stid loc _ -> error_loc loc "patt"
+  | Sqid loc _ -> error_loc loc "patt"
+  | Srec loc sel ->
+      let lpl = List.map (label_patt_se loc) sel in
+      <:patt< { $list:lpl$ } >>
+  | Sexpr loc [Slid _ ":"; se1; se2] ->
+      let p = patt_se se1 in
+      let t = ctyp_se se2 in
+      <:patt< ($p$ : $t$) >>
+  | Sexpr loc [Slid _ "or"; se :: sel] ->
+      List.fold_left
+        (fun p se ->
+           let p1 = patt_se se in
+           <:patt< $p$ | $p1$ >>)
+        (patt_se se) sel
+  | Sexpr loc [Slid _ "range"; se1; se2] ->
+      let p1 = patt_se se1 in
+      let p2 = patt_se se2 in
+      <:patt< $p1$ .. $p2$ >>
+  | Sexpr loc [Slid _ "values" :: sel] ->
+      let pl = List.map patt_se sel in
+      <:patt< ( $list:pl$ ) >>
+  | Sexpr loc [Slid _ "as"; se1; se2] ->
+      let p1 = patt_se se1 in
+      let p2 = patt_se se2 in
+      <:patt< ($p1$ as $p2$) >>
+  | Sexpr loc [se :: sel] ->
+      List.fold_left
+        (fun p se ->
+           let p1 = patt_se se in
+           <:patt< $p$ $p1$ >>)
+        (patt_se se) sel
+  | Sexpr loc [] -> <:patt< () >>
+  | Slist loc sel ->
+      let rec loop =
+        fun
+        [ [] -> <:patt< [] >>
+        | [se1; Slid _ "."; se2] ->
+            let p = patt_se se1 in
+            let pl = patt_se se2 in
+            <:patt< [$p$ :: $pl$] >>
+        | [se :: sel] ->
+            let p = patt_se se in
+            let pl = loop sel in
+            <:patt< [$p$ :: $pl$] >> ]
+      in
+      loop sel
+  | Squot loc typ txt -> Pcaml.handle_patt_quotation loc (typ, txt) ]
+and ipatt_se se =
+  match ipatt_opt_se se with
+  [ Left p -> p
+  | Right (se, _) -> error se "ipatt" ]
+and ipatt_opt_se =
+  fun
+  [ Slid loc "_" -> Left <:patt< _ >>
+  | Slid loc s -> Left <:patt< $lid:(Pcaml.rename_id.val s)$ >>
+  | Stid loc s -> Left <:patt< ~ $(Pcaml.rename_id.val s)$ >>
+  | Sqid loc s -> Left <:patt< ? $(Pcaml.rename_id.val s)$ >>
+  | Sexpr loc [Sqid _ s; se] ->
+      let s = Pcaml.rename_id.val s in
+      let e = expr_se se in
+      Left <:patt< ? ( $lid:s$ = $e$ ) >>
+  | Sexpr loc [Slid _ ":"; se1; se2] ->
+      let p = ipatt_se se1 in
+      let t = ctyp_se se2 in
+      Left <:patt< ($p$ : $t$) >>
+  | Sexpr loc [Slid _ "values" :: sel] ->
+      let pl = List.map ipatt_se sel in
+      Left <:patt< ( $list:pl$ ) >>
+  | Sexpr loc [] -> Left <:patt< () >>
+  | Sexpr loc [se :: sel] -> Right (se, sel)
+  | se -> error se "ipatt" ]
+and type_declaration_list_se =
+  fun
+  [ [se1; se2 :: sel] ->
+      let (n1, loc1, tpl) =
+        match se1 with
+        [ Sexpr _ [Slid loc n :: sel] ->
+            (n, loc, List.map type_parameter_se sel)
+        | Slid loc n -> (n, loc, [])
+        | se -> error se "type declaration" ]
+      in
+      [((loc1, Pcaml.rename_id.val n1), tpl, ctyp_se se2, []) ::
+       type_declaration_list_se sel]
+  | [] -> []
+  | [se :: _] -> error se "type_declaration" ]
+and type_parameter_se =
+  fun
+  [ Slid _ s when String.length s >= 2 && s.[0] = ''' ->
+      (String.sub s 1 (String.length s - 1), (False, False))
+  | se -> error se "type_parameter" ]
+and ctyp_se =
+  fun
+  [ Sexpr loc [Slid _ "sum" :: sel] ->
+      let cdl = List.map constructor_declaration_se sel in
+      <:ctyp< [ $list:cdl$ ] >>
+  | Srec loc sel ->
+      let ldl = List.map label_declaration_se sel in
+      <:ctyp< { $list:ldl$ } >>
+  | Sexpr loc [Slid _ "->" :: ([_; _ :: _] as sel)] ->
+      let rec loop =
+        fun
+        [ [] -> assert False
+        | [se] -> ctyp_se se
+        | [se :: sel] ->
+            let t1 = ctyp_se se in
+            let loc = (fst (loc_of_sexpr se), snd loc) in
+            let t2 = loop sel in
+            <:ctyp< $t1$ -> $t2$ >> ]
+      in
+      loop sel
+  | Sexpr loc [Slid _ "*" :: sel] ->
+      let tl = List.map ctyp_se sel in
+      <:ctyp< ($list:tl$) >>
+  | Sexpr loc [se :: sel] ->
+      List.fold_left
+        (fun t se ->
+           let t2 = ctyp_se se in
+           <:ctyp< $t$ $t2$ >>)
+        (ctyp_se se) sel
+  | Sacc loc se1 se2 ->
+      let t1 = ctyp_se se1 in
+      let t2 = ctyp_se se2 in
+      <:ctyp< $t1$ . $t2$ >>
+  | Slid loc "_" -> <:ctyp< _ >>
+  | Slid loc s ->
+      if s.[0] = ''' then
+        let s = String.sub s 1 (String.length s - 1) in
+        <:ctyp< '$s$ >>
+      else <:ctyp< $lid:(Pcaml.rename_id.val s)$ >>
+  | Suid loc s -> <:ctyp< $uid:(Pcaml.rename_id.val s)$ >>
+  | se -> error se "ctyp" ]
+and constructor_declaration_se =
+  fun
+  [ Sexpr loc [Suid _ ci :: sel] ->
+      (loc, Pcaml.rename_id.val ci, List.map ctyp_se sel)
+  | se -> error se "constructor_declaration" ]
+and label_declaration_se =
+  fun
+  [ Sexpr loc [Slid _ lab; Slid _ "mutable"; se] ->
+      (loc, Pcaml.rename_id.val lab, True, ctyp_se se)
+  | Sexpr loc [Slid _ lab; se] ->
+      (loc, Pcaml.rename_id.val lab, False, ctyp_se se)
+  | se -> error se "label_declaration" ]
+;
+
+value directive_se =
+  fun
+  [ Sexpr _ [Slid _ s] -> (s, None)
+  | Sexpr _ [Slid _ s; se] ->
+      let e = expr_se se in
+      (s, Some e)
+  | se -> error se "directive" ]
+;
+
+(* Parser *)
+
+Pcaml.syntax_name.val := "Scheme";
+Pcaml.no_constructors_arity.val := False;
+
+do {
+  Grammar.Unsafe.gram_reinit gram (lexer_gmake ());
+  Grammar.Unsafe.clear_entry interf;
+  Grammar.Unsafe.clear_entry implem;
+  Grammar.Unsafe.clear_entry top_phrase;
+  Grammar.Unsafe.clear_entry use_file;
+  Grammar.Unsafe.clear_entry module_type;
+  Grammar.Unsafe.clear_entry module_expr;
+  Grammar.Unsafe.clear_entry sig_item;
+  Grammar.Unsafe.clear_entry str_item;
+  Grammar.Unsafe.clear_entry expr;
+  Grammar.Unsafe.clear_entry patt;
+  Grammar.Unsafe.clear_entry ctyp;
+  Grammar.Unsafe.clear_entry let_binding;
+  Grammar.Unsafe.clear_entry type_declaration;
+  Grammar.Unsafe.clear_entry class_type;
+  Grammar.Unsafe.clear_entry class_expr;
+  Grammar.Unsafe.clear_entry class_sig_item;
+  Grammar.Unsafe.clear_entry class_str_item
+};
+
+Pcaml.parse_interf.val := Grammar.Entry.parse interf;
+Pcaml.parse_implem.val := Grammar.Entry.parse implem;
+
+value sexpr = Grammar.Entry.create gram "sexpr";
+
+value rec leftify =
+  fun
+  [ Sacc loc1 se1 se2 ->
+      match leftify se2 with
+      [ Sacc loc2 se2 se3 -> Sacc loc1 (Sacc loc2 se1 se2) se3
+      | se2 -> Sacc loc1 se1 se2 ]
+  | x -> x ]
+;
+
+EXTEND
+  GLOBAL: implem interf top_phrase use_file str_item sig_item expr patt sexpr;
+  implem:
+    [ [ "#"; se = sexpr ->
+          let (n, dp) = directive_se se in
+          ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True)
+      | si = str_item; x = SELF ->
+          let (sil, stopped) = x in
+          let loc = MLast.loc_of_str_item si in
+          ([(si, loc) :: sil], stopped)
+      | EOI -> ([], False) ] ]
+  ;
+  interf:
+    [ [ "#"; se = sexpr ->
+          let (n, dp) = directive_se se in
+          ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True)
+      | si = sig_item; x = SELF ->
+          let (sil, stopped) = x in
+          let loc = MLast.loc_of_sig_item si in
+          ([(si, loc) :: sil], stopped)
+      | EOI -> ([], False) ] ]
+  ;
+  top_phrase:
+    [ [ "#"; se = sexpr ->
+          let (n, dp) = directive_se se in
+          Some <:str_item< # $n$ $opt:dp$ >>
+      | se = sexpr -> Some (str_item_se se)
+      | EOI -> None ] ]
+  ;
+  use_file:
+    [ [ "#"; se = sexpr ->
+          let (n, dp) = directive_se se in
+          ([<:str_item< # $n$ $opt:dp$ >>], True)
+      | si = str_item; x = SELF ->
+          let (sil, stopped) = x in
+          ([si :: sil], stopped)
+      | EOI -> ([], False) ] ]
+  ;
+  str_item:
+    [ [ se = sexpr -> str_item_se se
+      | e = expr -> <:str_item< $exp:e$ >> ] ]
+  ;
+  sig_item:
+    [ [ se = sexpr -> sig_item_se se ] ]
+  ;
+  expr:
+    [ "top"
+      [ se = sexpr -> expr_se se ] ]
+  ;
+  patt:
+    [ [ se = sexpr -> patt_se se ] ]
+  ;
+  sexpr:
+    [ [ se1 = sexpr_dot; se2 = SELF -> leftify (Sacc loc se1 se2) ]
+    | [ "("; sl = LIST0 sexpr; ")" -> Sexpr loc sl
+      | "("; sl = LIST0 sexpr; ")."; se = SELF ->
+          leftify (Sacc loc (Sexpr loc sl) se)
+      | "["; sl = LIST0 sexpr; "]" -> Slist loc sl
+      | "{"; sl = LIST0 sexpr; "}" -> Srec loc sl
+      | a = pa_extend_keyword -> Slid loc a
+      | s = LIDENT -> Slid loc s
+      | s = UIDENT -> Suid loc s
+      | s = TILDEIDENT -> Stid loc s
+      | s = QUESTIONIDENT -> Sqid loc s
+      | s = INT -> Sint loc s
+      | s = FLOAT -> Sfloat loc s
+      | s = CHAR -> Schar loc s
+      | s = STRING -> Sstring loc s
+      | s = QUOT ->
+          let i = String.index s ':' in
+          let typ = String.sub s 0 i in
+          let txt = String.sub s (i + 1) (String.length s - i - 1) in
+          Squot loc typ txt ] ]
+  ;
+  sexpr_dot:
+    [ [ s = LIDENTDOT -> Slid loc s
+      | s = UIDENTDOT -> Suid loc s ] ]
+  ;
+  pa_extend_keyword:
+    [ [ "_" -> "_"
+      | "," -> ","
+      | "=" -> "="
+      | ":" -> ":"
+      | "." -> "."
+      | "/" -> "/" ] ]
+  ;
+END;
diff --git a/camlp4/unmaintained/scheme/pa_scheme.sc b/camlp4/unmaintained/scheme/pa_scheme.sc
new file mode 100644
index 000000000..be458594a
--- /dev/null
+++ b/camlp4/unmaintained/scheme/pa_scheme.sc
@@ -0,0 +1,1030 @@
+; pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo
+; **********************************************************************
+;                                                                       
+;                                Camlp4                                 
+;                                                                       
+;     Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt          
+;                                                                       
+;   Copyright 2002 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 Pcaml)
+(open Stdpp)
+
+(type (choice 'a 'b) (sum (Left 'a) (Right 'b)))
+
+; Buffer
+
+(module Buff
+ (struct
+  (define buff (ref (String.create 80)))
+  (define (store len x)
+    (if (>= len (String.length buff.val))
+        (:= buff.val (^ buff.val (String.create (String.length buff.val)))))
+    (:= buff.val.[len] x)
+    (succ len))
+  (define (get len) (String.sub buff.val 0 len))))
+
+; Lexer
+
+(definerec skip_to_eol
+  (parser
+   (((` (or '\n' '\r'))) ())
+   (((` _) s) (skip_to_eol s))))
+
+(define no_ident ['(' ')' '[' ']' '{' '}' ' ' '\t' '\n' '\r' ';'])
+
+(definerec (ident len)
+  (parser
+   (((` '.')) (values (Buff.get len) True))
+   (((` x (not (List.mem x no_ident))) s) (ident (Buff.store len x) s))
+   (() (values (Buff.get len) False))))
+
+(define (identifier kwt (values s dot))
+  (let ((con
+          (try (begin (: (Hashtbl.find kwt s) unit) "")
+           (Not_found
+            (match s.[0]
+             ((range 'A' 'Z') (if dot "UIDENTDOT" "UIDENT"))
+             (_ (if dot "LIDENTDOT" "LIDENT")))))))
+     (values con s)))
+
+(definerec (string len)
+  (parser
+   (((` '"')) (Buff.get len))
+   (((` '\\') (` c) s) (string (Buff.store (Buff.store len '\\') c) s))
+   (((` x) s) (string (Buff.store len x) s))))
+
+(definerec (end_exponent_part_under len)
+  (parser
+   (((` (as (range '0' '9') c)) s)
+    (end_exponent_part_under (Buff.store len c) s))
+   (() (values "FLOAT" (Buff.get len)))))
+
+(define (end_exponent_part len)
+  (parser
+   (((` (as (range '0' '9') c)) s)
+    (end_exponent_part_under (Buff.store len c) s))
+   (() (raise (Stream.Error "ill-formed floating-point constant")))))
+
+(define (exponent_part len)
+  (parser
+   (((` (as (or '+' '-') c)) s) (end_exponent_part (Buff.store len c) s))
+   (((a (end_exponent_part len))) a)))
+
+(definerec (decimal_part len)
+  (parser
+   (((` (as (range '0' '9') c)) s) (decimal_part (Buff.store len c) s))
+   (((` (or 'e' 'E')) s) (exponent_part (Buff.store len 'E') s))
+   (() (values "FLOAT" (Buff.get len)))))
+
+(definerec (number len)
+  (parser
+   (((` (as (range '0' '9') c)) s) (number (Buff.store len c) s))
+   (((` '.') s) (decimal_part (Buff.store len '.') s))
+   (((` (or 'e' 'E')) s) (exponent_part (Buff.store len 'E') s))
+   (() (values "INT" (Buff.get len)))))
+
+(define binary
+  (parser
+   (((` (as (range '0' '1') c))) c)))
+
+(define octal
+  (parser
+   (((` (as (range '0' '7') c))) c)))
+
+(define hexa
+  (parser
+   (((` (as (or (range '0' '9') (range 'a' 'f') (range 'A' 'F')) c))) c)))
+
+(definerec (digits_under kind len)
+  (parser
+   (((d kind) s) (digits_under kind (Buff.store len d) s))
+   (() (Buff.get len))))
+
+(define (digits kind bp len)
+  (parser
+   (((d kind) s) (values "INT" (digits_under kind (Buff.store len d) s)))
+   ((s) ep
+    (raise_with_loc (values
+                       (Reloc.shift_pos bp Reloc.zero_loc)
+                       (Reloc.shift_pos ep Reloc.zero_loc))
+       (Failure "ill-formed integer constant")))))
+
+(define (base_number kwt bp len)
+  (parser
+   (((` (or 'b' 'B')) s) (digits binary bp (Buff.store len 'b') s))
+   (((` (or 'o' 'O')) s) (digits octal bp (Buff.store len 'o') s))
+   (((` (or 'x' 'X')) s) (digits hexa bp (Buff.store len 'x') s))
+   (((id (ident (Buff.store 0 '#')))) (identifier kwt id))))
+
+(definerec (operator len)
+  (parser
+   (((` '.')) (Buff.get (Buff.store len '.')))
+   (() (Buff.get len))))
+
+(define (char_or_quote_id x)
+  (parser
+   (((` ''')) (values "CHAR" (String.make 1 x)))
+   ((s) ep
+    (if (List.mem x no_ident)
+        (Stdpp.raise_with_loc (values
+                                 (Reloc.shift_pos (- ep 2) Reloc.zero_loc)
+                                 (Reloc.shift_pos (- ep 1) Reloc.zero_loc))
+         (Stream.Error "bad quote"))
+        (let* ((len (Buff.store (Buff.store 0 ''') x))
+               ((values s dot) (ident len s)))
+          (values (if dot "LIDENTDOT" "LIDENT") s))))))
+
+(definerec (char len)
+  (parser
+   (((` ''')) len)
+   (((` x) s) (char (Buff.store len x) s))))
+
+(define quote
+  (parser
+   (((` '\\') (len (char (Buff.store 0 '\\'))))
+    (values "CHAR" (Buff.get len)))
+   (((` x) s) (char_or_quote_id x s))))
+
+; The system with LIDENTDOT and UIDENTDOT is not great (it would be
+; better to have a token DOT (actually SPACEDOT and DOT)) but it is
+; the only way (that I have found) to have a good behaviour in the
+; toplevel (not expecting tokens after a phrase). Drawbacks: 1/ to be
+; complete, we should have STRINGDOT, RIGHTPARENDOT, and so on 2/ the
+; parser rule with dot is right associative and we have to reverse
+; the resulting tree (using the function leftify).
+; This is a complicated issue: the behaviour of the OCaml toplevel
+; is strange, anyway. For example, even without Camlp4, The OCaml
+; toplevel accepts that:
+;     # let x = 32;; foo bar match let )
+
+(definerec*
+  ((lexer kwt)
+     (parser
+      (((t (lexer0 kwt))
+       (_ no_dot)) t)))
+  (no_dot
+    (parser
+     (((` '.')) ep
+      (Stdpp.raise_with_loc (values
+                               (Reloc.shift_pos (- ep 1) Reloc.zero_loc)
+                               (Reloc.shift_pos ep Reloc.zero_loc))
+         (Stream.Error "bad dot")))
+     (() ())))
+  ((lexer0 kwt)
+    (parser bp
+     (((` (or '\t' '\n' '\r')) s) (lexer0 kwt s))
+     (((` ' ') s) (after_space kwt s))
+     (((` ';') (_ skip_to_eol) s) (lexer kwt s))
+     (((` '(')) (values (values "" "(") (values bp (+ bp 1))))
+     (((` ')') s) ep (values (values "" (rparen s)) (values bp ep)))
+     (((` '[')) (values (values "" "[") (values bp (+ bp 1))))
+     (((` ']')) (values (values "" "]") (values bp (+ bp 1))))
+     (((` '{')) (values (values "" "{") (values bp (+ bp 1))))
+     (((` '}')) (values (values "" "}") (values bp (+ bp 1))))
+     (((` '"') (s (string 0))) ep
+      (values (values "STRING" s) (values bp ep)))
+     (((` ''') (tok quote)) ep (values tok (values bp ep)))
+     (((` '<') (tok (less kwt))) ep (values tok (values bp ep)))
+     (((` '-') (tok (minus kwt))) ep (values tok (values bp ep)))
+     (((` '~') (tok tilde)) ep (values tok (values bp ep)))
+     (((` '?') (tok question)) ep (values tok (values bp ep)))
+     (((` '#') (tok (base_number kwt bp (Buff.store 0 '0')))) ep
+      (values tok (values bp ep)))
+     (((` (as (range '0' '9') c)) (tok (number (Buff.store 0 c)))) ep
+      (values tok (values bp ep)))
+     (((` (as (or '+' '*' '/') c)) (id (operator (Buff.store 0 c)))) ep
+      (values (identifier kwt (values id False)) (values bp ep)))
+     (((` x) (id (ident (Buff.store 0 x)))) ep
+      (values (identifier kwt id) (values bp ep)))
+     (() (values (values "EOI" "") (values bp (+ bp 1))))))
+  (rparen
+   (parser
+    (((` '.')) ").")
+    ((_) ")")))
+  ((after_space kwt)
+    (parser
+     (((` '.')) ep (values (values "" ".") (values (- ep 1) ep)))
+     (((x (lexer0 kwt))) x)))
+  (tilde
+    (parser
+     (((` (as (range 'a' 'z') c)) ((values s dot) (ident (Buff.store 0 c))))
+      (values "TILDEIDENT" s))
+     (() (values "LIDENT" "~"))))
+  (question
+    (parser
+     (((` (as (range 'a' 'z') c)) ((values s dot) (ident (Buff.store 0 c))))
+      (values "QUESTIONIDENT" s))
+     (() (values "LIDENT" "?"))))
+  ((minus kwt)
+    (parser
+     (((` '.')) (identifier kwt (values "-." False)))
+     (((` (as (range '0' '9') c))
+      (n (number (Buff.store (Buff.store 0 '-') c)))) ep n)
+     (((id (ident (Buff.store 0 '-')))) (identifier kwt id))))
+  ((less kwt)
+    (parser
+     (((` ':') (lab (label 0)) (? (` '<') "'<' expected") (q (quotation 0)))
+      (values "QUOT" (^ lab ":" q)))
+     (((id (ident (Buff.store 0 '<')))) (identifier kwt id))))
+  ((label len)
+    (parser
+     (((` (as (or (range 'a' 'z') (range 'A' 'Z') '_') c)) s)
+      (label (Buff.store len c) s))
+     (() (Buff.get len))))
+  ((quotation len)
+    (parser
+     (((` '>') s) (quotation_greater len s))
+     (((` x) s) (quotation (Buff.store len x) s))
+     (() (failwith "quotation not terminated"))))
+  ((quotation_greater len)
+    (parser
+     (((` '>')) (Buff.get len))
+     (((a (quotation (Buff.store len '>')))) a))))
+
+(define (lexer_using kwt (values con prm))
+  (match con
+   ((or "CHAR" "EOI" "INT" "FLOAT" "LIDENT" "LIDENTDOT" "QUESTIONIDENT"
+     "QUOT" "STRING" "TILDEIDENT" "UIDENT" "UIDENTDOT")
+    ())
+   ("ANTIQUOT" ())
+   ("" (try (Hashtbl.find kwt prm) (Not_found (Hashtbl.add kwt prm ()))))
+   (_
+    (raise
+     (Token.Error
+      (^ "the constructor \"" con "\" is not recognized by Plexer"))))))
+
+(define (lexer_text (values con prm))
+  (cond
+   ((= con "") (^ "'"prm "'"))
+   ((= prm "") con)
+   (else (^ con " \"" prm "\""))))
+
+(define (lexer_gmake ())
+  (let ((kwt (Hashtbl.create 89)))
+     {(Token.tok_func
+       (Token.lexer_func_of_parser
+        (lambda (s)
+          (let (((values r (values bp ep)) (lexer kwt s)))
+            (values r (values (Reloc.shift_pos bp Reloc.zero_loc)
+                              (Reloc.shift_pos ep Reloc.zero_loc)))))))
+      (Token.tok_using (lexer_using kwt))
+      (Token.tok_removing (lambda))
+      (Token.tok_match Token.default_match)
+      (Token.tok_text lexer_text)
+      (Token.tok_comm None)}))
+
+; Building AST
+
+(type sexpr
+  (sum
+   (Sacc MLast.loc sexpr sexpr)
+   (Schar MLast.loc string)
+   (Sexpr MLast.loc (list sexpr))
+   (Sint MLast.loc string)
+   (Sfloat MLast.loc string)
+   (Slid MLast.loc string)
+   (Slist MLast.loc (list sexpr))
+   (Sqid MLast.loc string)
+   (Squot MLast.loc string string)
+   (Srec MLast.loc (list sexpr))
+   (Sstring MLast.loc string)
+   (Stid MLast.loc string)
+   (Suid MLast.loc string)))
+
+(define loc_of_sexpr
+  (lambda_match
+   ((or (Sacc loc _ _) (Schar loc _) (Sexpr loc _) (Sint loc _)
+     (Sfloat loc _) (Slid loc _) (Slist loc _) (Sqid loc _) (Squot loc _ _)
+     (Srec loc _) (Sstring loc _) (Stid loc _) (Suid loc _))
+    loc)))
+(define (error_loc loc err)
+  (raise_with_loc loc (Stream.Error (^ err " expected"))))
+(define (error se err) (error_loc (loc_of_sexpr se) err))
+
+(define strm_n "strm__")
+(define (peek_fun loc) <:expr< Stream.peek >>)
+(define (junk_fun loc) <:expr< Stream.junk >>)
+
+(define assoc_left_parsed_op_list ["+" "*" "+." "*." "land" "lor" "lxor"])
+(define assoc_right_parsed_op_list ["and" "or" "^" "@"])
+(define and_by_couple_op_list ["=" "<>" "<" ">" "<=" ">=" "==" "!="])
+
+(define (op_apply loc e1 e2)
+  (lambda_match
+   ("and" <:expr< $e1$ && $e2$ >>)
+   ("or" <:expr< $e1$ || $e2$ >>)
+   (x <:expr< $lid:x$ $e1$ $e2$ >>)))
+
+(define string_se
+  (lambda_match
+     ((Sstring loc s) s)
+     (se (error se "string"))))
+
+(define mod_ident_se
+  (lambda_match
+   ((Suid _ s) [(Pcaml.rename_id.val s)])
+   ((Slid _ s) [(Pcaml.rename_id.val s)])
+   (se (error se "mod_ident"))))
+
+(define (lident_expr loc s)
+  (if (&& (> (String.length s) 1) (= s.[0] '`'))
+     (let ((s (String.sub s 1 (- (String.length s) 1))))
+        <:expr< ` $s$ >>)
+     <:expr< $lid:(Pcaml.rename_id.val s)$ >>))
+
+(definerec*
+  (module_expr_se
+    (lambda_match
+     ((Sexpr loc [(Slid _ "functor") (Suid _ s) se1 se2])
+      (let* ((s (Pcaml.rename_id.val s))
+             (mt (module_type_se se1))
+             (me (module_expr_se se2)))
+         <:module_expr< functor ($s$ : $mt$) -> $me$ >>))
+     ((Sexpr loc [(Slid _ "struct") . sl])
+      (let ((mel (List.map str_item_se sl)))
+         <:module_expr< struct $list:mel$ end >>))
+     ((Sexpr loc [se1 se2])
+      (let* ((me1 (module_expr_se se1))
+             (me2 (module_expr_se se2)))
+         <:module_expr< $me1$ $me2$ >>))
+     ((Suid loc s) <:module_expr< $uid:(Pcaml.rename_id.val s)$ >>)
+     (se (error se "module expr"))))
+  (module_type_se
+    (lambda_match
+     ((Sexpr loc [(Slid _ "functor") (Suid _ s) se1 se2])
+      (let* ((s (Pcaml.rename_id.val s))
+             (mt1 (module_type_se se1))
+             (mt2 (module_type_se se2)))
+         <:module_type< functor ($s$ : $mt1$) -> $mt2$ >>))
+     ((Sexpr loc [(Slid _ "sig") . sel])
+      (let ((sil (List.map sig_item_se sel)))
+         <:module_type< sig $list:sil$ end >>))
+     ((Sexpr loc [(Slid _ "with") se (Sexpr _ sel)])
+      (let* ((mt (module_type_se se))
+             (wcl (List.map with_constr_se sel)))
+         <:module_type< $mt$ with $list:wcl$ >>))
+     ((Suid loc s) <:module_type< $uid:(Pcaml.rename_id.val s)$ >>)
+     (se (error se "module type"))))
+  (with_constr_se
+    (lambda_match
+     ((Sexpr loc [(Slid _ "type") se1 se2])
+      (let* ((tn (mod_ident_se se1))
+             (te (ctyp_se se2)))
+         (MLast.WcTyp loc tn [] te)))
+     (se (error se "with constr"))))
+  (sig_item_se
+    (lambda_match
+     ((Sexpr loc [(Slid _ "type") . sel])
+      (let ((tdl (type_declaration_list_se sel)))
+         <:sig_item< type $list:tdl$ >>))
+     ((Sexpr loc [(Slid _ "exception") (Suid _ c) . sel])
+      (let* ((c (Pcaml.rename_id.val c))
+             (tl (List.map ctyp_se sel)))
+         <:sig_item< exception $c$ of $list:tl$ >>))
+     ((Sexpr loc [(Slid _ "value") (Slid _ s) se])
+      (let* ((s (Pcaml.rename_id.val s))
+             (t (ctyp_se se)))
+         <:sig_item< value $s$ : $t$ >>))
+     ((Sexpr loc [(Slid _ "external") (Slid _ i) se . sel])
+      (let* ((i (Pcaml.rename_id.val i))
+             (pd (List.map string_se sel))
+             (t (ctyp_se se)))
+         <:sig_item< external $i$ : $t$ = $list:pd$ >>))
+     ((Sexpr loc [(Slid _ "module") (Suid _ s) se])
+      (let* ((s (Pcaml.rename_id.val s))
+             (mb (module_type_se se)))
+         <:sig_item< module $s$ : $mb$ >>))
+     ((Sexpr loc [(Slid _ "moduletype") (Suid _ s) se])
+      (let* ((s (Pcaml.rename_id.val s))
+             (mt (module_type_se se)))
+         <:sig_item< module type $s$ = $mt$ >>))
+     (se (error se "sig item"))))
+  ((str_item_se se)
+    (match se
+     ((Sexpr loc [(Slid _ "open") se])
+      (let ((s (mod_ident_se se))) <:str_item< open $s$ >>))
+     ((Sexpr loc [(Slid _ "type") . sel])
+      (let ((tdl (type_declaration_list_se sel)))
+         <:str_item< type $list:tdl$ >>))
+     ((Sexpr loc [(Slid _ "exception") (Suid _ c) . sel])
+      (let* ((c (Pcaml.rename_id.val c))
+             (tl (List.map ctyp_se sel)))
+         <:str_item< exception $c$ of $list:tl$ >>))
+     ((Sexpr loc [(Slid _ (as (or "define" "definerec") r)) se . sel])
+      (let* ((r (= r "definerec"))
+             ((values p e) (fun_binding_se se (begin_se loc sel))))
+         <:str_item< value $opt:r$ $p$ = $e$ >>))
+     ((Sexpr loc [(Slid _ (as (or "define*" "definerec*") r)) . sel])
+      (let* ((r (= r "definerec*"))
+             (lbs (List.map let_binding_se sel)))
+         <:str_item< value $opt:r$ $list:lbs$ >>))
+     ((Sexpr loc [(Slid _ "external") (Slid _ i) se . sel])
+      (let* ((i (Pcaml.rename_id.val i))
+             (pd (List.map string_se sel))
+             (t (ctyp_se se)))
+         <:str_item< external $i$ : $t$ = $list:pd$ >>))
+     ((Sexpr loc [(Slid _ "module") (Suid _ i) se])
+      (let* ((i (Pcaml.rename_id.val i))
+             (mb (module_binding_se se)))
+         <:str_item< module $i$ = $mb$ >>))
+     ((Sexpr loc [(Slid _ "moduletype") (Suid _ s) se])
+      (let* ((s (Pcaml.rename_id.val s))
+             (mt (module_type_se se)))
+         <:str_item< module type $s$ = $mt$ >>))
+     (_
+      (let* ((loc (loc_of_sexpr se))
+             (e (expr_se se)))
+         <:str_item< $exp:e$ >>))))
+  ((module_binding_se se) (module_expr_se se))
+  (expr_se
+    (lambda_match
+     ((Sacc loc se1 se2)
+      (let ((e1 (expr_se se1)))
+         (match se2
+          ((Slist loc [se2])
+           (let ((e2 (expr_se se2))) <:expr< $e1$ .[ $e2$ ] >>))
+          ((Sexpr loc [se2])
+           (let ((e2 (expr_se se2))) <:expr< $e1$ .( $e2$ ) >>))
+          (_ (let ((e2 (expr_se se2))) <:expr< $e1$ . $e2$ >>)))))
+     ((Slid loc s) (lident_expr loc s))
+     ((Suid loc s) <:expr< $uid:(Pcaml.rename_id.val s)$ >>)
+     ((Sint loc s) <:expr< $int:s$ >>)
+     ((Sfloat loc s) <:expr< $flo:s$ >>)
+     ((Schar loc s) <:expr< $chr:s$ >>)
+     ((Sstring loc s) <:expr< $str:s$ >>)
+     ((Stid loc s) <:expr< ~ $(Pcaml.rename_id.val s)$ >>)
+     ((Sqid loc s) <:expr< ? $(Pcaml.rename_id.val s)$ >>)
+     ((Sexpr loc []) <:expr< () >>)
+     ((when (Sexpr loc [(Slid _ s) e1 . (as [_ . _] sel)])
+      (List.mem s assoc_left_parsed_op_list))
+      (letrec
+       (((loop e1)
+          (lambda_match
+           ([] e1)
+           ([e2 . el] (loop (op_apply loc e1 e2 s) el)))))
+       (loop (expr_se e1) (List.map expr_se sel))))
+     ((when (Sexpr loc [(Slid _ s) . (as [_ _ . _] sel)])
+      (List.mem s assoc_right_parsed_op_list))
+      (letrec
+       ((loop
+          (lambda_match
+           ([]
+            (assert False))
+           ([e1] e1)
+           ([e1 . el] (let ((e2 (loop el))) (op_apply loc e1 e2 s))))))
+       (loop (List.map expr_se sel))))
+     ((when (Sexpr loc [(Slid _ s) . (as [_ _ . _] sel)])
+      (List.mem s and_by_couple_op_list))
+      (letrec
+       ((loop
+          (lambda_match
+           ((or [] [_]) (assert False))
+           ([e1 e2] <:expr< $lid:s$ $e1$ $e2$ >>)
+           ([e1 . (as [e2 _ . _] el)]
+            (let* ((a1 (op_apply loc e1 e2 s))
+                   (a2 (loop el)))
+               <:expr< $a1$ && $a2$ >>)))))
+       (loop (List.map expr_se sel))))
+     ((Sexpr loc [(Stid _ s) se])
+      (let ((e (expr_se se))) <:expr< ~ $s$ : $e$ >>))
+     ((Sexpr loc [(Slid _ "-") se])
+      (let ((e (expr_se se))) <:expr< - $e$ >>))
+     ((Sexpr loc [(Slid _ "if") se se1])
+      (let* ((e (expr_se se))
+             (e1 (expr_se se1)))
+         <:expr< if $e$ then $e1$ else () >>))
+     ((Sexpr loc [(Slid _ "if") se se1 se2])
+      (let* ((e (expr_se se))
+             (e1 (expr_se se1))
+             (e2 (expr_se se2)))
+         <:expr< if $e$ then $e1$ else $e2$ >>))
+     ((Sexpr loc [(Slid _ "cond") . sel])
+      (letrec
+       ((loop
+          (lambda_match
+           ([(Sexpr loc [(Slid _ "else") . sel])] (begin_se loc sel))
+           ([(Sexpr loc [se1 . sel1]) . sel]
+            (let* ((e1 (expr_se se1))
+                   (e2 (begin_se loc sel1))
+                   (e3 (loop sel)))
+               <:expr< if $e1$ then $e2$ else $e3$ >>))
+           ([] <:expr< () >>)
+           ([se . _] (error se "cond clause")))))
+       (loop sel)))
+     ((Sexpr loc [(Slid _ "while") se . sel])
+      (let* ((e (expr_se se))
+             (el (List.map expr_se sel)))
+         <:expr< while $e$ do { $list:el$ } >>))
+     ((Sexpr loc [(Slid _ "for") (Slid _ i) se1 se2 . sel])
+      (let* ((i (Pcaml.rename_id.val i))
+             (e1 (expr_se se1))
+             (e2 (expr_se se2))
+             (el (List.map expr_se sel)))
+         <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >>))
+     ((Sexpr loc [(Slid loc1 "lambda")]) <:expr< fun [] >>)
+     ((Sexpr loc [(Slid loc1 "lambda") sep . sel])
+      (let ((e (begin_se loc1 sel)))
+         (match (ipatt_opt_se sep)
+          ((Left p) <:expr< fun $p$ -> $e$ >>)
+          ((Right (values se sel))
+           (List.fold_right
+            (lambda (se e)
+              (let ((p (ipatt_se se))) <:expr< fun $p$ -> $e$ >>))
+            [se . sel] e)))))
+     ((Sexpr loc [(Slid _ "lambda_match") . sel])
+      (let ((pel (List.map (match_case loc) sel)))
+         <:expr< fun [ $list:pel$ ] >>))
+     ((Sexpr loc [(Slid _ (as (or "let" "letrec") r)) . sel])
+      (match sel
+       ([(Sexpr _ sel1) . sel2]
+        (let* ((r (= r "letrec"))
+               (lbs (List.map let_binding_se sel1))
+               (e (begin_se loc sel2)))
+           <:expr< let $opt:r$ $list:lbs$ in $e$ >>))
+       ([(Slid _ n) (Sexpr _ sl) . sel]
+        (let* ((n (Pcaml.rename_id.val n))
+               ((values pl el)
+                 (List.fold_right
+                  (lambda (se (values pl el))
+                    (match se
+                           ((Sexpr _ [se1 se2])
+                            (values [(patt_se se1) . pl]
+                                    [(expr_se se2) . el]))
+                           (se (error se "named let"))))
+                  sl (values [] [])))
+               (e1
+                 (List.fold_right
+                  (lambda (p e) <:expr< fun $p$ -> $e$ >>)
+                  pl (begin_se loc sel)))
+               (e2
+                 (List.fold_left
+                  (lambda (e1 e2) <:expr< $e1$ $e2$ >>)
+                  <:expr< $lid:n$ >> el)))
+           <:expr< let rec $lid:n$ = $e1$ in $e2$ >>))
+       ([se . _] (error se "let_binding"))
+       (_ (error_loc loc "let_binding"))))
+     ((Sexpr loc [(Slid _ "let*") . sel])
+      (match sel
+       ([(Sexpr _ sel1) . sel2]
+        (List.fold_right
+         (lambda (se ek)
+           (let (((values p e) (let_binding_se se)))
+              <:expr< let $p$ = $e$ in $ek$ >>))
+         sel1 (begin_se loc sel2)))
+       ([se . _] (error se "let_binding"))
+       (_ (error_loc loc "let_binding"))))
+     ((Sexpr loc [(Slid _ "match") se . sel])
+      (let* ((e (expr_se se))
+             (pel (List.map (match_case loc) sel)))
+         <:expr< match $e$ with [ $list:pel$ ] >>))
+     ((Sexpr loc [(Slid _ "parser") . sel])
+      (let ((e
+              (match sel
+               ([(as (Slid _ _) se) . sel]
+                (let* ((p (patt_se se))
+                       (pc (parser_cases_se loc sel)))
+                   <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >>))
+               (_ (parser_cases_se loc sel)))))
+         <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >>))
+     ((Sexpr loc [(Slid _ "match_with_parser") se . sel])
+      (let* ((me (expr_se se))
+             ((values bpo sel)
+               (match sel
+                ([(as (Slid _ _) se) . sel] (values (Some (patt_se se)) sel))
+                (_ (values None sel))))
+             (pc (parser_cases_se loc sel))
+             (e
+               (match bpo
+                ((Some bp)
+                 <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>)
+                (None pc))))
+         (match me
+          ((when <:expr< $lid:x$ >> (= x strm_n)) e)
+          (_ <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >>))))
+     ((Sexpr loc [(Slid _ "try") se . sel])
+      (let* ((e (expr_se se))
+             (pel (List.map (match_case loc) sel)))
+         <:expr< try $e$ with [ $list:pel$ ] >>))
+     ((Sexpr loc [(Slid _ "begin") . sel])
+      (let ((el (List.map expr_se sel))) <:expr< do { $list:el$ } >>))
+     ((Sexpr loc [(Slid _ ":=") se1 se2])
+      (let* ((e1 (expr_se se1))
+             (e2 (expr_se se2)))
+         <:expr< $e1$ := $e2$ >>))
+     ((Sexpr loc [(Slid _ "values") . sel])
+      (let ((el (List.map expr_se sel))) <:expr< ( $list:el$ ) >>))
+     ((Srec loc [(Slid _ "with") se . sel])
+      (let* ((e (expr_se se))
+             (lel (List.map (label_expr_se loc) sel)))
+         <:expr< { ($e$) with $list:lel$ } >>))
+     ((Srec loc sel)
+      (let ((lel (List.map (label_expr_se loc) sel)))
+         <:expr< { $list:lel$ } >>))
+     ((Sexpr loc [(Slid _ ":") se1 se2])
+      (let* ((e (expr_se se1)) (t (ctyp_se se2))) <:expr< ( $e$ : $t$ ) >>))
+     ((Sexpr loc [se]) (let ((e (expr_se se))) <:expr< $e$ () >>))
+     ((Sexpr loc [(Slid _ "assert") (Suid _ "False")])
+        <:expr< assert False >>)
+     ((Sexpr loc [(Slid _ "assert") se])
+        (let ((e (expr_se se))) <:expr< assert $e$ >>))
+     ((Sexpr loc [(Slid _ "lazy") se])
+        (let ((e (expr_se se))) <:expr< lazy $e$ >>))
+     ((Sexpr loc [se . sel])
+      (List.fold_left
+       (lambda (e se) (let ((e1 (expr_se se))) <:expr< $e$ $e1$ >>))
+       (expr_se se) sel))
+     ((Slist loc sel)
+      (letrec ((loop
+                 (lambda_match
+                  ([] <:expr< [] >>)
+                  ([se1 (Slid _ ".") se2]
+                   (let* ((e (expr_se se1))
+                          (el (expr_se se2)))
+                     <:expr< [$e$ :: $el$] >>))
+                  ([se . sel]
+                   (let* ((e (expr_se se))
+                          (el (loop sel)))
+                     <:expr< [$e$ :: $el$] >>)))))
+           (loop sel)))
+     ((Squot loc typ txt)
+      (Pcaml.handle_expr_quotation loc (values typ txt)))))
+  ((begin_se loc)
+   (lambda_match
+    ([] <:expr< () >>)
+    ([se] (expr_se se))
+    ((sel)
+      (let* ((el (List.map expr_se sel))
+             (loc (values (fst (loc_of_sexpr (List.hd sel))) (snd loc))))
+         <:expr< do { $list:el$ } >>))))
+  (let_binding_se
+   (lambda_match
+    ((Sexpr loc [se . sel])
+       (let ((e (begin_se loc sel)))
+         (match (ipatt_opt_se se)
+           ((Left p) (values p e))
+           ((Right _) (fun_binding_se se e)))))
+    (se (error se "let_binding"))))
+  ((fun_binding_se se e)
+   (match se
+          ((Sexpr _ [(Slid _ "values") . _]) (values (ipatt_se se) e))
+          ((Sexpr _ [(Slid loc s) . sel])
+           (let* ((s (Pcaml.rename_id.val s))
+                  (e
+                   (List.fold_right
+                    (lambda (se e)
+                      (let* ((loc
+                              (values (fst (loc_of_sexpr se))
+                                      (snd (MLast.loc_of_expr e))))
+                             (p (ipatt_se se)))
+                        <:expr< fun $p$ -> $e$ >>))
+                    sel e))
+                  (p <:patt< $lid:s$ >>))
+             (values p e)))
+          ((_) (values (ipatt_se se) e))))
+  ((match_case loc)
+   (lambda_match
+    ((Sexpr loc [(Sexpr _ [(Slid _ "when") se sew]) . sel])
+     (values (patt_se se) (Some (expr_se sew)) (begin_se loc sel)))
+    ((Sexpr loc [se . sel])
+     (values (patt_se se) None (begin_se loc sel)))
+    (se (error se "match_case"))))
+  ((label_expr_se loc)
+   (lambda_match
+    ((Sexpr _ [se1 se2]) (values (patt_se se1) (expr_se se2)))
+    (se (error se "label_expr"))))
+  ((label_patt_se loc)
+   (lambda_match
+    ((Sexpr _ [se1 se2]) (values (patt_se se1) (patt_se se2)))
+    (se (error se "label_patt"))))
+  ((parser_cases_se loc)
+   (lambda_match
+    ([] <:expr< raise Stream.Failure >>)
+    ([(Sexpr loc [(Sexpr _ spsel) . act]) . sel]
+      (let* ((ekont (lambda _ (parser_cases_se loc sel)))
+             (act (match act
+                         ([se] (expr_se se))
+                         ([sep se]
+                               (let* ((p (patt_se sep))
+                                      (e (expr_se se)))
+                        <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >>))
+                         (_ (error_loc loc "parser_case")))))
+        (stream_pattern_se loc act ekont spsel)))
+    ([se . _]
+         (error se "parser_case"))))
+  ((stream_pattern_se loc act ekont)
+   (lambda_match
+    ([] act)
+    ([se . sel]
+         (let* ((ckont (lambda err <:expr< raise (Stream.Error $err$) >>))
+                (skont (stream_pattern_se loc act ckont sel)))
+           (stream_pattern_component skont ekont <:expr< "" >> se)))))
+  ((stream_pattern_component skont ekont err)
+   (lambda_match
+    ((Sexpr loc [(Slid _ "`") se . wol])
+     (let* ((wo (match wol
+                       ([se] (Some (expr_se se)))
+                       ([] None)
+                       (_ (error_loc loc "stream_pattern_component"))))
+            (e (peek_fun loc))
+            (p (patt_se se))
+            (j (junk_fun loc))
+            (k (ekont err)))
+       <:expr< match $e$ $lid:strm_n$ with
+               [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ }
+               | _ -> $k$ ] >>))
+    ((Sexpr loc [se1 se2])
+     (let* ((p (patt_se se1))
+            (e (let ((e (expr_se se2)))
+       <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>))
+            (k (ekont err)))
+       <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >>))
+    ((Sexpr loc [(Slid _ "?") se1 se2])
+     (stream_pattern_component skont ekont (expr_se se2) se1))
+    ((Slid loc s)
+     (let ((s (Pcaml.rename_id.val s)))
+        <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>))
+    (se
+     (error se "stream_pattern_component"))))
+  (patt_se
+   (lambda_match
+    ((Sacc loc se1 se2)
+     (let* ((p1 (patt_se se1)) (p2 (patt_se se2))) <:patt< $p1$ . $p2$ >>))
+    ((Slid loc "_") <:patt< _ >>)
+    ((Slid loc s) <:patt< $lid:(Pcaml.rename_id.val s)$ >>)
+    ((Suid loc s) <:patt< $uid:(Pcaml.rename_id.val s)$ >>)
+    ((Sint loc s) <:patt< $int:s$ >>)
+    ((Sfloat loc s) <:patt< $flo:s$ >>)
+    ((Schar loc s) <:patt< $chr:s$ >>)
+    ((Sstring loc s) <:patt< $str:s$ >>)
+    ((Stid loc _) (error_loc loc "patt"))
+    ((Sqid loc _) (error_loc loc "patt"))
+    ((Srec loc sel)
+     (let ((lpl (List.map (label_patt_se loc) sel)))
+        <:patt< { $list:lpl$ } >>))
+    ((Sexpr loc [(Slid _ ":") se1 se2])
+     (let* ((p (patt_se se1)) (t (ctyp_se se2))) <:patt< ($p$ : $t$) >>))
+    ((Sexpr loc [(Slid _ "or") se . sel])
+     (List.fold_left
+      (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ | $p1$ >>))
+      (patt_se se) sel))
+    ((Sexpr loc [(Slid _ "range") se1 se2])
+     (let* ((p1 (patt_se se1)) (p2 (patt_se se2))) <:patt< $p1$ .. $p2$ >>))
+    ((Sexpr loc [(Slid _ "values") . sel])
+     (let ((pl (List.map patt_se sel))) <:patt< ( $list:pl$ ) >>))
+    ((Sexpr loc [(Slid _ "as") se1 se2])
+     (let* ((p1 (patt_se se1))
+            (p2 (patt_se se2)))
+       <:patt< ($p1$ as $p2$) >>))
+    ((Sexpr loc [se . sel])
+     (List.fold_left
+      (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ $p1$ >>))
+      (patt_se se) sel))
+    ((Sexpr loc []) <:patt< () >>)
+    ((Slist loc sel)
+     (letrec ((loop
+                (lambda_match
+                 ([] <:patt< [] >>)
+                 ([se1 (Slid _ ".") se2]
+                  (let* ((p (patt_se se1))
+                         (pl (patt_se se2)))
+                    <:patt< [$p$ :: $pl$] >>))
+                 ([se . sel]
+                  (let* ((p (patt_se se))
+                         (pl (loop sel)))
+                    <:patt< [$p$ :: $pl$] >>)))))
+          (loop sel)))
+    ((Squot loc typ txt)
+     (Pcaml.handle_patt_quotation loc (values typ txt)))))
+  ((ipatt_se se)
+   (match (ipatt_opt_se se)
+          ((Left p) p)
+          ((Right (values se _)) (error se "ipatt"))))
+  (ipatt_opt_se
+   (lambda_match
+    ((Slid loc "_") (Left <:patt< _ >>))
+    ((Slid loc s) (Left <:patt< $lid:(Pcaml.rename_id.val s)$ >>))
+    ((Stid loc s) (Left <:patt< ~ $(Pcaml.rename_id.val s)$ >>))
+    ((Sqid loc s) (Left <:patt< ? $(Pcaml.rename_id.val s)$ >>))
+    ((Sexpr loc [(Sqid _ s) se])
+     (let* ((s (Pcaml.rename_id.val s))
+            (e (expr_se se)))
+        (Left <:patt< ? ( $lid:s$ = $e$ ) >>)))
+    ((Sexpr loc [(Slid _ ":") se1 se2])
+     (let* ((p (ipatt_se se1)) (t (ctyp_se se2)))
+        (Left <:patt< ($p$ : $t$) >>)))
+    ((Sexpr loc [(Slid _ "values") . sel])
+     (let ((pl (List.map ipatt_se sel))) (Left <:patt< ( $list:pl$ ) >>)))
+    ((Sexpr loc []) (Left <:patt< () >>))
+    ((Sexpr loc [se . sel]) (Right (values se sel)))
+    (se (error se "ipatt"))))
+  (type_declaration_list_se
+   (lambda_match
+    ([se1 se2 . sel]
+     (let (((values n1 loc1 tpl)
+            (match se1
+                   ((Sexpr _ [(Slid loc n) . sel])
+                    (values n loc (List.map type_parameter_se sel)))
+                   ((Slid loc n)
+                    (values n loc []))
+                   ((se)
+                    (error se "type declaration")))))
+       [(values (values loc1 (Pcaml.rename_id.val n1)) tpl (ctyp_se se2) []) .
+        (type_declaration_list_se sel)]))
+    ([] [])
+    ([se . _] (error se "type_declaration"))))
+  (type_parameter_se
+   (lambda_match
+    ((when (Slid _ s) (and (>= (String.length s) 2) (= s.[0] ''')))
+     (values (String.sub s 1 (- (String.length s) 1)) (values False False)))
+    (se
+     (error se "type_parameter"))))
+  (ctyp_se
+   (lambda_match
+    ((Sexpr loc [(Slid _ "sum") . sel])
+     (let ((cdl (List.map constructor_declaration_se sel)))
+       <:ctyp< [ $list:cdl$ ] >>))
+    ((Srec loc sel)
+     (let ((ldl (List.map label_declaration_se sel)))
+       <:ctyp< { $list:ldl$ } >>))
+    ((Sexpr loc [(Slid _ "->") . (as [_ _ . _] sel)])
+     (letrec
+        ((loop
+            (lambda_match
+             ([] (assert False))
+             ([se] (ctyp_se se))
+             ([se . sel]
+               (let* ((t1 (ctyp_se se))
+                      (loc (values (fst (loc_of_sexpr se)) (snd loc)))
+                      (t2 (loop sel)))
+                   <:ctyp< $t1$ -> $t2$ >>)))))
+        (loop sel)))
+    ((Sexpr loc [(Slid _ "*") . sel])
+     (let ((tl (List.map ctyp_se sel))) <:ctyp< ($list:tl$) >>))
+    ((Sexpr loc [se . sel])
+     (List.fold_left
+      (lambda (t se) (let ((t2 (ctyp_se se))) <:ctyp< $t$ $t2$ >>))
+      (ctyp_se se) sel))
+    ((Sacc loc se1 se2)
+     (let* ((t1 (ctyp_se se1)) (t2 (ctyp_se se2))) <:ctyp< $t1$ . $t2$ >>))
+    ((Slid loc "_") <:ctyp< _ >>)
+    ((Slid loc s)
+     (if (= s.[0] ''')
+         (let ((s (String.sub s 1 (- (String.length s) 1))))
+           <:ctyp< '$s$ >>)
+         <:ctyp< $lid:(Pcaml.rename_id.val s)$ >>))
+    ((Suid loc s) <:ctyp< $uid:(Pcaml.rename_id.val s)$ >>)
+    (se (error se "ctyp"))))
+  (constructor_declaration_se
+   (lambda_match
+    ((Sexpr loc [(Suid _ ci) . sel])
+     (values loc (Pcaml.rename_id.val ci) (List.map ctyp_se sel)))
+    (se
+     (error se "constructor_declaration"))))
+  (label_declaration_se
+   (lambda_match
+    ((Sexpr loc [(Slid _ lab) (Slid _ "mutable") se])
+     (values loc (Pcaml.rename_id.val lab) True (ctyp_se se)))
+    ((Sexpr loc [(Slid _ lab) se])
+     (values loc (Pcaml.rename_id.val lab) False (ctyp_se se)))
+    (se
+     (error se "label_declaration")))))
+
+(define directive_se
+  (lambda_match
+   ((Sexpr _ [(Slid _ s)]) (values s None))
+   ((Sexpr _ [(Slid _ s) se]) (let ((e (expr_se se))) (values s (Some e))))
+   (se (error se "directive"))))
+
+; Parser
+
+(:= Pcaml.syntax_name.val "Scheme")
+(:= Pcaml.no_constructors_arity.val False)
+
+(begin
+ (Grammar.Unsafe.gram_reinit gram (lexer_gmake ()))
+ (Grammar.Unsafe.clear_entry interf)
+ (Grammar.Unsafe.clear_entry implem)
+ (Grammar.Unsafe.clear_entry top_phrase)
+ (Grammar.Unsafe.clear_entry use_file)
+ (Grammar.Unsafe.clear_entry module_type)
+ (Grammar.Unsafe.clear_entry module_expr)
+ (Grammar.Unsafe.clear_entry sig_item)
+ (Grammar.Unsafe.clear_entry str_item)
+ (Grammar.Unsafe.clear_entry expr)
+ (Grammar.Unsafe.clear_entry patt)
+ (Grammar.Unsafe.clear_entry ctyp)
+ (Grammar.Unsafe.clear_entry let_binding)
+ (Grammar.Unsafe.clear_entry type_declaration)
+ (Grammar.Unsafe.clear_entry class_type)
+ (Grammar.Unsafe.clear_entry class_expr)
+ (Grammar.Unsafe.clear_entry class_sig_item)
+ (Grammar.Unsafe.clear_entry class_str_item))
+
+(:= Pcaml.parse_interf.val (Grammar.Entry.parse interf))
+(:= Pcaml.parse_implem.val (Grammar.Entry.parse implem))
+
+(define sexpr (Grammar.Entry.create gram "sexpr"))
+
+(definerec leftify
+  (lambda_match
+    ((Sacc loc1 se1 se2)
+     (match (leftify se2)
+       ((Sacc loc2 se2 se3) (Sacc loc1 (Sacc loc2 se1 se2) se3))
+       (se2 (Sacc loc1 se1 se2))))
+    (x x)))
+
+EXTEND
+  GLOBAL : implem interf top_phrase use_file str_item sig_item expr
+    patt sexpr /
+  implem :
+    [ [ "#" / se = sexpr ->
+          (let (((values n dp) (directive_se se)))
+             (values [(values <:str_item< # $n$ $opt:dp$ >> loc)] True))
+      | si = str_item / x = SELF ->
+          (let* (((values sil stopped) x)
+                 (loc (MLast.loc_of_str_item si)))
+             (values [(values si loc) . sil] stopped))
+      | EOI -> (values [] False) ] ]
+  /
+  interf :
+    [ [ "#" / se = sexpr ->
+          (let (((values n dp) (directive_se se)))
+             (values [(values <:sig_item< # $n$ $opt:dp$ >> loc)] True))
+      | si = sig_item / x = SELF ->
+          (let* (((values sil stopped) x)
+                 (loc (MLast.loc_of_sig_item si)))
+             (values [(values si loc) . sil] stopped))
+      | EOI -> (values [] False) ] ]
+  /
+  top_phrase :
+    [ [ "#" / se = sexpr ->
+          (let (((values n dp) (directive_se se)))
+             (Some <:str_item< # $n$ $opt:dp$ >>))
+      | se = sexpr -> (Some (str_item_se se))
+      | EOI -> None ] ]
+  /
+  use_file :
+    [ [ "#" / se = sexpr ->
+          (let (((values n dp) (directive_se se)))
+             (values [<:str_item< # $n$ $opt:dp$ >>] True))
+      | si = str_item / x = SELF ->
+          (let (((values sil stopped) x)) (values [si . sil] stopped))
+      | EOI -> (values [] False) ] ]
+  /
+  str_item :
+    [ [ se = sexpr -> (str_item_se se)
+      | e = expr -> <:str_item< $exp:e$ >> ] ]
+  /
+  sig_item :
+    [ [ se = sexpr -> (sig_item_se se) ] ]
+  /
+  expr :
+    [ "top"
+      [ se = sexpr -> (expr_se se) ] ]
+  /
+  patt :
+    [ [ se = sexpr -> (patt_se se) ] ]
+  /
+  sexpr :
+    [ [ se1 = sexpr_dot / se2 = sexpr -> (leftify (Sacc loc se1 se2)) ]
+    | [ "(" / sl = LIST0 sexpr / ")" -> (Sexpr loc sl)
+      | "(" / sl = LIST0 sexpr / ")." / se = sexpr ->
+          (leftify (Sacc loc (Sexpr loc sl) se))
+      | "[" / sl = LIST0 sexpr / "]" -> (Slist loc sl)
+      | "{" / sl = LIST0 sexpr / "}" -> (Srec loc sl)
+      | a = pa_extend_keyword -> (Slid loc a)
+      | s = LIDENT -> (Slid loc s)
+      | s = UIDENT -> (Suid loc s)
+      | s = TILDEIDENT -> (Stid loc s)
+      | s = QUESTIONIDENT -> (Sqid loc s)
+      | s = INT -> (Sint loc s)
+      | s = FLOAT -> (Sfloat loc s)
+      | s = CHAR -> (Schar loc s)
+      | s = STRING -> (Sstring loc s)
+      | s = QUOT ->
+          (let* ((i (String.index s ':'))
+                 (typ (String.sub s 0 i))
+                 (txt (String.sub s (+ i 1) (- (- (String.length s) i) 1))))
+            (Squot loc typ txt)) ] ]
+  /
+  sexpr_dot :
+    [ [ s = LIDENTDOT -> (Slid loc s)
+      | s = UIDENTDOT -> (Suid loc s) ] ]
+  /
+  pa_extend_keyword :
+    [ [ "_" -> "_"
+      | "," -> ","
+      | "=" -> "="
+      | ":" -> ":"
+      | "." -> "."
+      | "/" -> "/" ] ]
+  /
+END
diff --git a/camlp4/unmaintained/scheme/pr_scheme.ml b/camlp4/unmaintained/scheme/pr_scheme.ml
new file mode 100644
index 000000000..149b6c7cf
--- /dev/null
+++ b/camlp4/unmaintained/scheme/pr_scheme.ml
@@ -0,0 +1,826 @@
+(* pa_r.cmo q_MLast.cmo pa_extfun.cmo pr_dump.cmo *)
+(***********************************************************************)
+(*                                                                     *)
+(*                               Camlp4                                *)
+(*                                                                     *)
+(*    Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2002 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 Pcaml;
+open Format;
+
+type printer_t 'a =
+  { pr_fun : mutable string -> next 'a;
+    pr_levels : mutable list (pr_level 'a) }
+and pr_level 'a =
+  { pr_label : string;
+    pr_box : formatter -> (formatter -> unit) -> 'a -> unit;
+    pr_rules : mutable pr_rule 'a }
+and pr_rule 'a =
+  Extfun.t 'a (formatter -> curr 'a -> next 'a -> string -> kont -> unit)
+and curr 'a = formatter -> ('a * string * kont) -> unit
+and next 'a = formatter -> ('a * string * kont) -> unit
+and kont = formatter -> unit;
+
+value not_impl name x ppf k =
+  let desc =
+    if Obj.is_block (Obj.repr x) then
+      "tag = " ^ string_of_int (Obj.tag (Obj.repr x))
+    else "int_val = " ^ string_of_int (Obj.magic x)
+  in
+  fprintf ppf "<pr_scheme: not impl: %s; %s>%t" name desc k
+;
+
+value pr_fun name pr lab =
+  loop False pr.pr_levels where rec loop app =
+    fun
+    [ [] -> fun ppf (x, dg, k) -> failwith ("unable to print " ^ name)
+    | [lev :: levl] ->
+        if app || lev.pr_label = lab then
+          let next = loop True levl in
+          let rec curr ppf (x, dg, k) =
+            Extfun.apply lev.pr_rules x ppf curr next dg k
+          in
+          fun ppf ((x, _, _) as n) -> lev.pr_box ppf (fun ppf -> curr ppf n) x
+        else loop app levl ]
+;
+
+value rec find_pr_level lab =
+  fun
+  [ [] -> failwith ("level " ^ lab ^ " not found")
+  | [lev :: levl] ->
+      if lev.pr_label = lab then lev else find_pr_level lab levl ]
+;
+
+value pr_constr_decl = {pr_fun = fun []; pr_levels = []};
+value constr_decl ppf (x, k) = pr_constr_decl.pr_fun "top" ppf (x, "", k);
+pr_constr_decl.pr_fun := pr_fun "constr_decl" pr_constr_decl;
+
+value pr_ctyp = {pr_fun = fun []; pr_levels = []};
+pr_ctyp.pr_fun := pr_fun "ctyp" pr_ctyp;
+value ctyp ppf (x, k) = pr_ctyp.pr_fun "top" ppf (x, "", k);
+
+value pr_expr = {pr_fun = fun []; pr_levels = []};
+pr_expr.pr_fun := pr_fun "expr" pr_expr;
+value expr ppf (x, k) = pr_expr.pr_fun "top" ppf (x, "", k);
+
+value pr_label_decl = {pr_fun = fun []; pr_levels = []};
+value label_decl ppf (x, k) = pr_label_decl.pr_fun "top" ppf (x, "", k);
+pr_label_decl.pr_fun := pr_fun "label_decl" pr_label_decl;
+
+value pr_let_binding = {pr_fun = fun []; pr_levels = []};
+pr_let_binding.pr_fun := pr_fun "let_binding" pr_let_binding;
+value let_binding ppf (x, k) = pr_let_binding.pr_fun "top" ppf (x, "", k);
+
+value pr_match_assoc = {pr_fun = fun []; pr_levels = []};
+pr_match_assoc.pr_fun := pr_fun "match_assoc" pr_match_assoc;
+value match_assoc ppf (x, k) = pr_match_assoc.pr_fun "top" ppf (x, "", k);
+
+value pr_mod_ident = {pr_fun = fun []; pr_levels = []};
+pr_mod_ident.pr_fun := pr_fun "mod_ident" pr_mod_ident;
+value mod_ident ppf (x, k) = pr_mod_ident.pr_fun "top" ppf (x, "", k);
+
+value pr_module_binding = {pr_fun = fun []; pr_levels = []};
+pr_module_binding.pr_fun := pr_fun "module_binding" pr_module_binding;
+value module_binding ppf (x, k) =
+  pr_module_binding.pr_fun "top" ppf (x, "", k);
+
+value pr_module_expr = {pr_fun = fun []; pr_levels = []};
+pr_module_expr.pr_fun := pr_fun "module_expr" pr_module_expr;
+value module_expr ppf (x, k) = pr_module_expr.pr_fun "top" ppf (x, "", k);
+
+value pr_module_type = {pr_fun = fun []; pr_levels = []};
+pr_module_type.pr_fun := pr_fun "module_type" pr_module_type;
+value module_type ppf (x, k) = pr_module_type.pr_fun "top" ppf (x, "", k);
+
+value pr_patt = {pr_fun = fun []; pr_levels = []};
+pr_patt.pr_fun := pr_fun "patt" pr_patt;
+value patt ppf (x, k) = pr_patt.pr_fun "top" ppf (x, "", k);
+
+value pr_sig_item = {pr_fun = fun []; pr_levels = []};
+pr_sig_item.pr_fun := pr_fun "sig_item" pr_sig_item;
+value sig_item ppf (x, k) = pr_sig_item.pr_fun "top" ppf (x, "", k);
+
+value pr_str_item = {pr_fun = fun []; pr_levels = []};
+pr_str_item.pr_fun := pr_fun "str_item" pr_str_item;
+value str_item ppf (x, k) = pr_str_item.pr_fun "top" ppf (x, "", k);
+
+value pr_type_decl = {pr_fun = fun []; pr_levels = []};
+value type_decl ppf (x, k) = pr_type_decl.pr_fun "top" ppf (x, "", k);
+pr_type_decl.pr_fun := pr_fun "type_decl" pr_type_decl;
+
+value pr_type_params = {pr_fun = fun []; pr_levels = []};
+value type_params ppf (x, k) = pr_type_params.pr_fun "top" ppf (x, "", k);
+pr_type_params.pr_fun := pr_fun "type_params" pr_type_params;
+
+value pr_with_constr = {pr_fun = fun []; pr_levels = []};
+value with_constr ppf (x, k) = pr_with_constr.pr_fun "top" ppf (x, "", k);
+pr_with_constr.pr_fun := pr_fun "with_constr" pr_with_constr;
+
+(* general functions *)
+
+value nok ppf = ();
+value ks s k ppf = fprintf ppf "%s%t" s k;
+
+value rec list f ppf (l, k) =
+  match l with
+  [ [] -> k ppf
+  | [x] -> f ppf (x, k)
+  | [x :: l] -> fprintf ppf "%a@ %a" f (x, nok) (list f) (l, k) ]
+;
+
+value rec listwb b f ppf (l, k) =
+  match l with
+  [ [] -> k ppf
+  | [x] -> f ppf ((b, x), k)
+  | [x :: l] -> fprintf ppf "%a@ %a" f ((b, x), nok) (listwb "" f) (l, k) ]
+;
+
+(* specific functions *)
+
+value rec is_irrefut_patt =
+  fun
+  [ <:patt< $lid:_$ >> -> True
+  | <:patt< () >> -> True
+  | <:patt< _ >> -> True
+  | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y
+  | <:patt< { $list:fpl$ } >> ->
+      List.for_all (fun (_, p) -> is_irrefut_patt p) fpl
+  | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p
+  | <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl
+  | <:patt< ? $_$ : ( $p$ ) >> -> is_irrefut_patt p
+  | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p
+  | <:patt< ~ $_$ >> -> True
+  | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p
+  | _ -> False ]
+;
+
+value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge;
+
+pr_expr_fun_args.val :=
+  extfun Extfun.empty with
+  [ <:expr< fun [$p$ -> $e$] >> as ge ->
+      if is_irrefut_patt p then
+        let (pl, e) = expr_fun_args e in
+        ([p :: pl], e)
+      else ([], ge)
+  | ge -> ([], ge) ];
+
+value sequence ppf (e, k) =
+  match e with
+  [ <:expr< do { $list:el$ } >> ->
+      fprintf ppf "@[<hv>%a@]" (list expr) (el, k)
+  | _ -> expr ppf (e, k) ]
+;
+
+value string ppf (s, k) = fprintf ppf "\"%s\"%t" s k;
+
+value int_repr s =
+  if String.length s > 2 && s.[0] = '0' then
+    match s.[1] with
+    [ 'b' | 'o' | 'x' | 'B' | 'O' | 'X' ->
+        "#" ^ String.sub s 1 (String.length s - 1)
+    | _ -> s ]
+  else s  
+;
+
+value assoc_left_parsed_op_list = ["+"; "*"; "land"; "lor"; "lxor"];
+value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"];
+value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="];
+
+(* extensible pretty print functions *)
+
+pr_constr_decl.pr_levels :=
+  [{pr_label = "top";
+    pr_box ppf f x = fprintf ppf "@[%t@]" f;
+    pr_rules =
+      extfun Extfun.empty with
+      [ (loc, c, []) as x ->
+          fun ppf curr next dg k -> fprintf ppf "(@[<hv>%s%t@]" c (ks ")" k)
+      | (loc, c, tl) ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[<hv>%s@ %a@]" c (list ctyp) (tl, ks ")" k) ]}];
+
+pr_ctyp.pr_levels :=
+  [{pr_label = "top";
+    pr_box ppf f x = fprintf ppf "@[%t@]" f;
+    pr_rules =
+      extfun Extfun.empty with
+      [ <:ctyp< [ $list:cdl$ ] >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[<hv>sum@ %a@]" (list constr_decl) (cdl, ks ")" k)
+      | <:ctyp< { $list:cdl$ } >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "{@[<hv>%a@]" (list label_decl) (cdl, ks "}" k)
+      | <:ctyp< ( $list:tl$ ) >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[* @[<hv>%a@]@]" (list ctyp) (tl, ks ")" k)
+      | <:ctyp< $t1$ -> $t2$ >> ->
+          fun ppf curr next dg k ->
+            let tl =
+              loop t2 where rec loop =
+                fun
+                [ <:ctyp< $t1$ -> $t2$ >> -> [t1 :: loop t2]
+                | t -> [t] ]
+            in
+            fprintf ppf "(@[-> @[<hv>%a@]@]" (list ctyp)
+              ([t1 :: tl], ks ")" k)
+      | <:ctyp< $t1$ $t2$ >> ->
+          fun ppf curr next dg k ->
+            let (t, tl) =
+              loop [t2] t1 where rec loop tl =
+                fun
+                [ <:ctyp< $t1$ $t2$ >> -> loop [t2 :: tl] t1
+                | t1 -> (t1, tl) ]
+            in
+            fprintf ppf "(@[%a@ %a@]" ctyp (t, nok) (list ctyp) (tl, ks ")" k)
+      | <:ctyp< $t1$ . $t2$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "%a.%a" ctyp (t1, nok) ctyp (t2, k)
+      | <:ctyp< $lid:s$ >> | <:ctyp< $uid:s$ >> ->
+          fun ppf curr next dg k -> fprintf ppf "%s%t" s k
+      | <:ctyp< ' $s$ >> ->
+          fun ppf curr next dg k -> fprintf ppf "'%s%t" s k
+      | <:ctyp< _ >> ->
+          fun ppf curr next dg k -> fprintf ppf "_%t" k
+      | x ->
+          fun ppf curr next dg k -> not_impl "ctyp" x ppf k ]}];
+
+pr_expr.pr_levels :=
+  [{pr_label = "top";
+    pr_box ppf f x = fprintf ppf "@[%t@]" f;
+    pr_rules =
+      extfun Extfun.empty with
+      [ <:expr< fun [] >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(lambda%t" (ks ")" k)
+      | <:expr< fun $lid:s$ -> $e$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(lambda@ %s@;<1 1>%a" s expr (e, ks ")" k)
+      | <:expr< fun [ $list:pwel$ ] >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[<hv>lambda_match@ %a@]" (list match_assoc)
+              (pwel, ks ")" k)
+      | <:expr< match $e$ with [ $list:pwel$ ] >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[<hv>@[<b 2>match@ %a@]@ %a@]" expr (e, nok)
+              (list match_assoc) (pwel, ks ")" k)
+      | <:expr< try $e$ with [ $list:pwel$ ] >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[<hv>@[<b 2>try@ %a@]@ %a@]" expr (e, nok)
+              (list match_assoc) (pwel, ks ")" k)
+      | <:expr< let $p1$ = $e1$ in $e2$ >> ->
+          fun ppf curr next dg k ->
+            let (pel, e) =
+              loop [(p1, e1)] e2 where rec loop pel =
+                fun
+                [ <:expr< let $p1$ = $e1$ in $e2$ >> ->
+                    loop [(p1, e1) :: pel] e2
+                | e -> (List.rev pel, e) ]
+            in
+            let b =
+              match pel with
+              [ [_] -> "let"
+              | _ -> "let*" ]
+            in
+            fprintf ppf "(@[@[%s (@[<v>%a@]@]@;<1 2>%a@]" b
+              (listwb "" let_binding) (pel, ks ")" nok)
+                 sequence (e, ks ")" k)
+      | <:expr< let $opt:rf$ $list:pel$ in $e$ >> ->
+          fun ppf curr next dg k ->
+            let b = if rf then "letrec" else "let" in
+            fprintf ppf "(@[<hv>%s@ (@[<hv>%a@]@ %a@]" b
+              (listwb "" let_binding) (pel, ks ")" nok) expr (e, ks ")" k)
+      | <:expr< if $e1$ then $e2$ else () >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(if @[%a@;<1 0>%a@]" expr (e1, nok)
+              expr (e2, ks ")" k)
+      | <:expr< if $e1$ then $e2$ else $e3$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(if @[%a@ %a@ %a@]" expr (e1, nok)
+              expr (e2, nok) expr (e3, ks ")" k)
+      | <:expr< do { $list:el$ } >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(begin@;<1 1>@[<hv>%a@]" (list expr) (el, ks ")" k)
+      | <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[for %s@ %a@ %a %a@]" i expr (e1, nok)
+              expr (e2, nok) (list expr) (el, ks ")" k)
+      | <:expr< ($e$ : $t$) >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(:@ %a@ %a" expr (e, nok) ctyp (t, ks ")" k)
+      | <:expr< ($list:el$) >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(values @[%a@]" (list expr) (el, ks ")" k)
+      | <:expr< { $list:fel$ } >> ->
+          fun ppf curr next dg k ->
+            let record_binding ppf ((p, e), k) =
+              fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k)
+            in
+            fprintf ppf "{@[<hv>%a@]" (list record_binding) (fel, ks "}" k)
+      | <:expr< { ($e$) with $list:fel$ } >> ->
+          fun ppf curr next dg k ->
+            let record_binding ppf ((p, e), k) =
+              fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k)
+            in
+            fprintf ppf "{@[@[with@ %a@]@ @[%a@]@]" expr (e, nok)
+              (list record_binding) (fel, ks "}" k)
+      | <:expr< $e1$ := $e2$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(:=@;<1 1>%a@;<1 1>%a" expr (e1, nok)
+              expr (e2, ks ")" k)
+      | <:expr< [$_$ :: $_$] >> as e ->
+          fun ppf curr next dg k ->
+            let (el, c) =
+              make_list e where rec make_list e =
+                match e with
+                [ <:expr< [$e$ :: $y$] >> ->
+                    let (el, c) = make_list y in
+                    ([e :: el], c)
+                | <:expr< [] >> -> ([], None)
+                | x -> ([], Some e) ]
+            in
+            match c with
+            [ None ->
+                fprintf ppf "[%a" (list expr) (el, ks "]" k)
+            | Some x ->
+                fprintf ppf "[%a@ %a" (list expr) (el, ks " ." nok)
+                  expr (x, ks "]" k) ]
+      | <:expr< lazy ($x$) >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[lazy@ %a@]" expr (x, ks ")" k)
+      | <:expr< $lid:s$ $e1$ $e2$ >>
+        when List.mem s assoc_right_parsed_op_list ->
+          fun ppf curr next dg k ->
+            let el =
+              loop [e1] e2 where rec loop el =
+                fun
+                [ <:expr< $lid:s1$ $e1$ $e2$ >> when s1 = s ->
+                    loop [e1 :: el] e2
+                | e -> List.rev [e :: el] ]
+            in
+            fprintf ppf "(@[%s %a@]" s (list expr) (el, ks ")" k)
+      | <:expr< $e1$ $e2$ >> ->
+          fun ppf curr next dg k ->
+            let (f, el) =
+              loop [e2] e1 where rec loop el =
+                fun
+                [ <:expr< $e1$ $e2$ >> -> loop [e2 :: el] e1
+                | e1 -> (e1, el) ]
+            in
+            fprintf ppf "(@[%a@ %a@]" expr (f, nok) (list expr) (el, ks ")" k)
+      | <:expr< ~ $s$ : ($e$) >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(~%s@ %a" s expr (e, ks ")" k)
+      | <:expr< $e1$ .[ $e2$ ] >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "%a.[%a" expr (e1, nok) expr (e2, ks "]" k)
+      | <:expr< $e1$ .( $e2$ ) >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "%a.(%a" expr (e1, nok) expr (e2, ks ")" k)
+      | <:expr< $e1$ . $e2$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "%a.%a" expr (e1, nok) expr (e2, k)
+      | <:expr< $int:s$ >> ->
+          fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k
+      | <:expr< $lid:s$ >> | <:expr< $uid:s$ >> ->
+          fun ppf curr next dg k -> fprintf ppf "%s%t" s k
+      | <:expr< ` $s$ >> ->
+          fun ppf curr next dg k -> fprintf ppf "`%s%t" s k
+      | <:expr< $str:s$ >> ->
+          fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k
+      | <:expr< $chr:s$ >> ->
+          fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k
+      | x ->
+          fun ppf curr next dg k -> not_impl "expr" x ppf k ]}];
+
+pr_label_decl.pr_levels :=
+  [{pr_label = "top";
+    pr_box ppf f x = fprintf ppf "@[%t@]" f;
+    pr_rules =
+      extfun Extfun.empty with
+      [ (loc, f, m, t) ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[<hv>%s%t@ %a@]" f
+              (fun ppf -> if m then fprintf ppf "@ mutable" else ())
+              ctyp (t, ks ")" k) ]}];
+
+pr_let_binding.pr_levels :=
+  [{pr_label = "top";
+    pr_box ppf f x = fprintf ppf "@[%t@]" f;
+    pr_rules =
+      extfun Extfun.empty with
+      [ (b, (p, e)) ->
+          fun ppf curr next dg k ->
+            let (pl, e) = expr_fun_args e in
+            match pl with
+            [ [] ->
+                fprintf ppf "(@[<b 1>%s%s%a@ %a@]" b
+                  (if b = "" then "" else " ") patt (p, nok)
+                  sequence (e, ks ")" k)
+            | _ ->
+                fprintf ppf "(@[<b 1>%s%s(%a)@ %a@]" b
+                  (if b = "" then "" else " ") (list patt) ([p :: pl], nok)
+                  sequence (e, ks ")" k) ] ]}];
+
+pr_match_assoc.pr_levels :=
+  [{pr_label = "top";
+    pr_box ppf f x = fprintf ppf "@[%t@]" f;
+    pr_rules =
+      extfun Extfun.empty with
+      [ (p, we, e) ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[%t@ %a@]"
+              (fun ppf ->
+                 match we with
+                 [ Some e ->
+                     fprintf ppf "(when@ %a@ %a" patt (p, nok)
+                       expr (e, ks ")" nok)
+                 | None -> patt ppf (p, nok) ])
+              sequence (e, ks ")" k) ]}];
+
+pr_mod_ident.pr_levels :=
+  [{pr_label = "top";
+    pr_box ppf f x = fprintf ppf "@[%t@]" f;
+    pr_rules =
+      extfun Extfun.empty with
+      [ [s] ->
+          fun ppf curr next dg k ->
+            fprintf ppf "%s%t" s k
+      | [s :: sl] ->
+          fun ppf curr next dg k ->
+            fprintf ppf "%s.%a" s curr (sl, "", k)
+      | x ->
+          fun ppf curr next dg k -> not_impl "mod_ident" x ppf k ]}];
+
+pr_module_binding.pr_levels :=
+  [{pr_label = "top";
+    pr_box ppf f x = fprintf ppf "@[%t@]" f;
+    pr_rules =
+      extfun Extfun.empty with
+      [ (b, s, me) ->
+          fun ppf curr next dg k ->
+            fprintf ppf "%s@ %s@ %a" b s module_expr (me, k) ]}];
+
+pr_module_expr.pr_levels :=
+  [{pr_label = "top";
+    pr_box ppf f x = fprintf ppf "@[%t@]" f;
+    pr_rules =
+      extfun Extfun.empty with
+      [ <:module_expr< functor ($i$ : $mt$) -> $me$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]"
+              i module_type (mt, nok) module_expr (me, ks ")" k)
+      | <:module_expr< struct $list:sil$ end >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[struct@ @[<hv>%a@]@]" (list str_item)
+              (sil, ks ")" k)
+      | <:module_expr< $me1$ $me2$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[%a@ %a@]" module_expr (me1, nok)
+              module_expr (me2, ks ")" k)
+      | <:module_expr< $uid:s$ >> ->
+          fun ppf curr next dg k -> fprintf ppf "%s%t" s k
+      | x ->
+          fun ppf curr next dg k -> not_impl "module_expr" x ppf k ]}];
+
+pr_module_type.pr_levels :=
+  [{pr_label = "top";
+    pr_box ppf f x = fprintf ppf "@[%t@]" f;
+    pr_rules =
+      extfun Extfun.empty with
+      [ <:module_type< functor ($i$ : $mt1$) -> $mt2$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]"
+              i module_type (mt1, nok) module_type (mt2, ks ")" k)
+      | <:module_type< sig $list:sil$ end >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[sig@ @[<hv>%a@]@]" (list sig_item) (sil, ks ")" k)
+      | <:module_type< $mt$ with $list:wcl$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[with@;<1 2>@[%a@ (%a@]@]" module_type (mt, nok)
+              (list with_constr) (wcl, ks "))" k)
+      | <:module_type< $uid:s$ >> ->
+          fun ppf curr next dg k -> fprintf ppf "%s%t" s k
+      | x ->
+          fun ppf curr next dg k -> not_impl "module_type" x ppf k ]}];
+
+pr_patt.pr_levels :=
+  [{pr_label = "top";
+    pr_box ppf f x = fprintf ppf "@[%t@]" f;
+    pr_rules =
+      extfun Extfun.empty with
+      [ <:patt< $p1$ | $p2$ >> ->
+          fun ppf curr next dg k ->
+            let (f, pl) =
+              loop [p2] p1 where rec loop pl =
+                fun
+                [ <:patt< $p1$ | $p2$ >> -> loop [p2 :: pl] p1
+                | p1 -> (p1, pl) ]
+            in
+            fprintf ppf "(@[or@ %a@ %a@]" patt (f, nok) (list patt)
+              (pl, ks ")" k)
+      | <:patt< ($p1$ as $p2$) >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[as@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k)
+      | <:patt< $p1$ .. $p2$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[range@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k)
+      | <:patt< [$_$ :: $_$] >> as p ->
+          fun ppf curr next dg k ->
+            let (pl, c) =
+              make_list p where rec make_list p =
+                match p with
+                [ <:patt< [$p$ :: $y$] >> ->
+                    let (pl, c) = make_list y in
+                    ([p :: pl], c)
+                | <:patt< [] >> -> ([], None)
+                | x -> ([], Some p) ]
+            in
+            match c with
+            [ None ->
+                fprintf ppf "[%a" (list patt) (pl, ks "]" k)
+            | Some x ->
+                fprintf ppf "[%a@ %a" (list patt) (pl, ks " ." nok)
+                  patt (x, ks "]" k) ]
+      | <:patt< $p1$ $p2$ >> ->
+          fun ppf curr next dg k ->
+            let pl =
+              loop [p2] p1 where rec loop pl =
+                fun
+                [ <:patt< $p1$ $p2$ >> -> loop [p2 :: pl] p1
+                | p1 -> [p1 :: pl] ]
+            in
+            fprintf ppf "(@[%a@]" (list patt) (pl, ks ")" k)
+      | <:patt< ($p$ : $t$) >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(:@ %a@ %a" patt (p, nok) ctyp (t, ks ")" k)
+      | <:patt< ($list:pl$) >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(values @[%a@]" (list patt) (pl, ks ")" k)
+      | <:patt< { $list:fpl$ } >> ->
+          fun ppf curr next dg k ->
+            let record_binding ppf ((p1, p2), k) =
+              fprintf ppf "(@[%a@ %a@]" patt (p1, nok) patt (p2, ks ")" k)
+            in
+            fprintf ppf "(@[<hv>{}@ %a@]" (list record_binding) (fpl, ks ")" k)
+      | <:patt< ? $x$ >> ->
+          fun ppf curr next dg k -> fprintf ppf "?%s%t" x k
+      | <:patt< ? ($lid:x$ = $e$) >> ->
+          fun ppf curr next dg k -> fprintf ppf "(?%s@ %a" x expr (e, ks ")" k)
+      | <:patt< $p1$ . $p2$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "%a.%a" patt (p1, nok) patt (p2, k)
+      | <:patt< $lid:s$ >> | <:patt< $uid:s$ >> ->
+          fun ppf curr next dg k -> fprintf ppf "%s%t" s k
+      | <:patt< $str:s$ >> ->
+          fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k
+      | <:patt< $chr:s$ >> ->
+          fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k
+      | <:patt< $int:s$ >> ->
+          fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k
+      | <:patt< $flo:s$ >> ->
+          fun ppf curr next dg k -> fprintf ppf "%s%t" s k
+      | <:patt< _ >> ->
+          fun ppf curr next dg k -> fprintf ppf "_%t" k
+      | x ->
+          fun ppf curr next dg k -> not_impl "patt" x ppf k ]}];
+
+pr_sig_item.pr_levels :=
+  [{pr_label = "top";
+    pr_box ppf f x = fprintf ppf "@[%t@]" f;
+    pr_rules =
+      extfun Extfun.empty with
+      [ <:sig_item< type $list:tdl$ >> ->
+          fun ppf curr next dg k ->
+            match tdl with
+            [ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k)
+            | tdl ->
+                fprintf ppf "(@[<hv>type@ %a@]" (listwb "" type_decl)
+                  (tdl, ks ")" k) ]
+      | <:sig_item< exception $c$ of $list:tl$ >> ->
+          fun ppf curr next dg k ->
+            match tl with
+            [ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k)
+            | tl ->
+                fprintf ppf "(@[@[exception@ %s@]@ %a@]" c
+                  (list ctyp) (tl, ks ")" k) ]
+      | <:sig_item< value $i$ : $t$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[@[value %s@]@ %a@]" i ctyp (t, ks ")" k)
+      | <:sig_item< external $i$ : $t$ = $list:pd$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[@[external@ %s@]@ %a@ %a@]" i ctyp (t, nok)
+              (list string) (pd, ks ")" k)
+      | <:sig_item< module $s$ : $mt$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[@[module@ %s@]@ %a@]" s
+              module_type (mt, ks ")" k)
+      | <:sig_item< module type $s$ = $mt$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s
+              module_type (mt, ks ")" k)
+      | <:sig_item< declare $list:s$ end >> ->
+          fun ppf curr next dg k ->
+            if s = [] then fprintf ppf "; ..."
+            else fprintf ppf "%a" (list sig_item) (s, k)
+      | MLast.SgUse _ _ _ ->
+          fun ppf curr next dg k -> ()
+      | x ->
+          fun ppf curr next dg k -> not_impl "sig_item" x ppf k ]}];
+
+pr_str_item.pr_levels :=
+  [{pr_label = "top";
+    pr_box ppf f x = fprintf ppf "@[%t@]" f;
+    pr_rules =
+      extfun Extfun.empty with
+      [ <:str_item< open $i$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(open@ %a" mod_ident (i, ks ")" k)
+      | <:str_item< type $list:tdl$ >> ->
+          fun ppf curr next dg k ->
+            match tdl with
+            [ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k)
+            | tdl ->
+                fprintf ppf "(@[<hv>type@ %a@]" (listwb "" type_decl)
+                  (tdl, ks ")" k) ]
+      | <:str_item< exception $c$ of $list:tl$ >> ->
+          fun ppf curr next dg k ->
+            match tl with
+            [ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k)
+            | tl ->
+                fprintf ppf "(@[@[exception@ %s@]@ %a@]" c
+                  (list ctyp) (tl, ks ")" k) ]
+      | <:str_item< value $opt:rf$ $list:pel$ >> ->
+          fun ppf curr next dg k ->
+            let b = if rf then "definerec" else "define" in
+            match pel with
+            [ [(p, e)] ->
+                fprintf ppf "%a" let_binding ((b, (p, e)), k)
+            | pel ->
+                fprintf ppf "(@[<hv 1>%s*@ %a@]" b (listwb "" let_binding)
+                  (pel, ks ")" k) ]
+      | <:str_item< module $s$ = $me$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(%a" module_binding (("module", s, me), ks ")" k)
+      | <:str_item< module type $s$ = $mt$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s
+              module_type (mt, ks ")" k)
+      | <:str_item< external $i$ : $t$ = $list:pd$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(@[external@ %s@ %a@ %a@]" i ctyp (t, nok)
+              (list string) (pd, ks ")" k)
+      | <:str_item< $exp:e$ >> ->
+          fun ppf curr next dg k ->
+            fprintf ppf "%a" expr (e, k)
+      | <:str_item< # $s$ $opt:x$ >> ->
+          fun ppf curr next dg k ->
+            match x with
+            [ Some e -> fprintf ppf "; # (%s %a" s expr (e, ks ")" k)
+            | None -> fprintf ppf "; # (%s%t" s (ks ")" k) ]
+      | <:str_item< declare $list:s$ end >> ->
+          fun ppf curr next dg k ->
+            if s = [] then fprintf ppf "; ..."
+            else fprintf ppf "%a" (list str_item) (s, k)
+      | MLast.StUse _ _ _ ->
+          fun ppf curr next dg k -> ()
+      | x ->
+          fun ppf curr next dg k -> not_impl "str_item" x ppf k ]}];
+
+pr_type_decl.pr_levels :=
+  [{pr_label = "top";
+    pr_box ppf f x = fprintf ppf "@[%t@]" f;
+    pr_rules =
+      extfun Extfun.empty with
+      [ (b, ((_, tn), tp, te, cl)) ->
+          fun ppf curr next dg k ->
+            fprintf ppf "%t%t@;<1 1>%a"
+              (fun ppf ->
+                 if b <> "" then fprintf ppf "%s@ " b
+                 else ())
+              (fun ppf ->
+                 match tp with
+                 [ [] -> fprintf ppf "%s" tn
+                 | tp -> fprintf ppf "(%s%a)" tn type_params (tp, nok) ])
+               ctyp (te, k) ]}];
+
+pr_type_params.pr_levels :=
+  [{pr_label = "top";
+    pr_box ppf f x = fprintf ppf "@[%t@]" f;
+    pr_rules =
+      extfun Extfun.empty with
+      [ [(s, vari) :: tpl] ->
+          fun ppf curr next dg k ->
+            fprintf ppf "@ '%s%a" s type_params (tpl, k)
+      | [] ->
+          fun ppf curr next dg k -> () ]}];
+
+pr_with_constr.pr_levels :=
+  [{pr_label = "top";
+    pr_box ppf f x = fprintf ppf "@[%t@]" f;
+    pr_rules =
+      extfun Extfun.empty with
+      [ MLast.WcTyp _ m tp te ->
+          fun ppf curr next dg k ->
+            fprintf ppf "(type@ %t@;<1 1>%a"
+              (fun ppf ->
+                 match tp with
+                 [ [] -> fprintf ppf "%a" mod_ident (m, nok)
+                 | tp ->
+                     fprintf ppf "(%a@ %a)" mod_ident (m, nok)
+                       type_params (tp, nok) ])
+               ctyp (te, ks ")" k)
+      | x ->
+          fun ppf curr next dg k -> not_impl "with_constr" x ppf k ]}];
+
+(* main *)
+
+value output_string_eval ppf s =
+  loop 0 where rec loop i =
+    if i == String.length s then ()
+    else if i == String.length s - 1 then pp_print_char ppf s.[i]
+    else
+      match (s.[i], s.[i + 1]) with
+      [ ('\\', 'n') -> do { pp_print_char ppf '\n'; loop (i + 2) }
+      | (c, _) -> do { pp_print_char ppf c; loop (i + 1) } ]
+;
+
+value sep = Pcaml.inter_phrases;
+
+value input_source ic len =
+  let buff = Buffer.create 20 in
+  try
+    let rec loop i =
+      if i >= len then Buffer.contents buff
+      else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) }
+    in
+    loop 0
+  with
+  [ End_of_file ->
+      let s = Buffer.contents buff in
+      if s = "" then
+        match sep.val with
+        [ Some s -> s
+        | None -> "\n" ]
+      else s ]
+;
+
+value copy_source ppf (ic, first, bp, ep) =
+  match sep.val with
+  [ Some str ->
+      if first then ()
+      else if ep == in_channel_length ic then pp_print_string ppf "\n"
+      else output_string_eval ppf str
+  | None ->
+      do {
+        seek_in ic bp;
+        let s = input_source ic (ep - bp) in pp_print_string ppf s
+      } ]
+;
+
+value copy_to_end ppf (ic, first, bp) =
+  let ilen = in_channel_length ic in
+  if bp < ilen then copy_source ppf (ic, first, bp, ilen)
+  else pp_print_string ppf "\n"
+;
+
+value apply_printer printer ast =
+  let ppf = std_formatter in
+  if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do {
+    let ic = open_in_bin Pcaml.input_file.val in
+    try
+      let (first, last_pos) =
+        List.fold_left
+          (fun (first, last_pos) (si, (bp, ep)) ->
+             do {
+               fprintf ppf "@[%a@]@?" copy_source (ic, first, last_pos.Lexing.pos_cnum, bp.Lexing.pos_cnum);
+               fprintf ppf "@[%a@]@?" printer (si, nok);
+               (False, ep)
+             })
+          (True, Token.nowhere) ast
+      in
+      fprintf ppf "@[%a@]@?" copy_to_end (ic, first, last_pos.Lexing.pos_cnum)
+    with x ->
+      do { fprintf ppf "@."; close_in ic; raise x };
+    close_in ic;
+  }
+  else failwith "not implemented"
+;
+
+Pcaml.print_interf.val := apply_printer sig_item;
+Pcaml.print_implem.val := apply_printer str_item;
+
+Pcaml.add_option "-l" (Arg.Int (fun x -> set_margin x))
+  "<length> Maximum line length for pretty printing.";
+
+Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x))
+  "<string> Use this string between phrases instead of reading source.";
diff --git a/camlp4/unmaintained/scheme/pr_schp_main.ml b/camlp4/unmaintained/scheme/pr_schp_main.ml
new file mode 100644
index 000000000..52001a71b
--- /dev/null
+++ b/camlp4/unmaintained/scheme/pr_schp_main.ml
@@ -0,0 +1,132 @@
+(* pa_r.cmo q_MLast.cmo pa_extfun.cmo pr_dump.cmo *)
+(***********************************************************************)
+(*                                                                     *)
+(*                               Camlp4                                *)
+(*                                                                     *)
+(*    Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2002 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 Format;
+open Pcaml;
+open Parserify;
+
+value nok = Pr_scheme.nok;
+value ks = Pr_scheme.ks;
+value patt = Pr_scheme.patt;
+value expr = Pr_scheme.expr;
+value find_pr_level = Pr_scheme.find_pr_level;
+value pr_expr = Pr_scheme.pr_expr;
+type printer_t 'a = Pr_scheme.printer_t 'a ==
+  { pr_fun : mutable string -> Pr_scheme.next 'a;
+    pr_levels : mutable list (pr_level 'a) }
+and pr_level 'a = Pr_scheme.pr_level 'a ==
+  { pr_label : string;
+    pr_box : formatter -> (formatter -> unit) -> 'a -> unit;
+    pr_rules : mutable Pr_scheme.pr_rule 'a }
+;
+
+(* extensions for rebuilding syntax of parsers *)
+
+value parser_cases ppf (spel, k) =
+  let rec parser_cases ppf (spel, k) =
+    match spel with
+    [ [] -> fprintf ppf "[: `HVbox [: b; k :] :]"
+    | [(sp, epo, e)] -> parser_case ppf (sp, epo, e, k)
+    | [(sp, epo, e) :: spel] ->
+        fprintf ppf "%a@ %a" parser_case (sp, epo, e, nok)
+          parser_cases (spel, k) ]
+  and parser_case ppf (sp, epo, e, k) =
+    fprintf ppf "(@[@[(%a)%t@]@ %a@]" stream_patt (sp, nok)
+      (fun ppf ->
+         match epo with
+         [ Some p -> fprintf ppf "@ %a" patt (p, nok)
+         | None -> () ])
+      expr (e, ks ")" k)
+  and stream_patt ppf (sp, k) =
+    match sp with
+    [ [] -> k ppf
+    | [(spc, None)] -> fprintf ppf "%a" stream_patt_comp (spc, k)
+    | [(spc, Some e)] ->
+        fprintf ppf "(@[? %a@ %a@]" stream_patt_comp (spc, nok)
+          expr (e, ks ")" k)
+    | [(spc, None) :: spcl] ->
+        fprintf ppf "%a@ %a" stream_patt_comp (spc, nok) stream_patt (spcl, k)
+    | [(spc, Some e) :: spcl] ->
+        fprintf ppf "(@[? %a@ %a@]@ %a" stream_patt_comp (spc, nok)
+          expr (e, ks ")" nok) stream_patt (spcl, k) ]
+  and stream_patt_comp ppf (spc, k) =
+    match spc with
+    [ SPCterm (p, w) ->
+        match w with
+        [ Some e ->
+            fprintf ppf "(` %a@ %a" patt (p, nok) expr (e, ks ")" k)
+        | None -> fprintf ppf "(` %a" patt (p, ks ")" k) ]
+    | SPCnterm p e ->
+        fprintf ppf "(@[%a %a@]" patt (p, nok) expr (e, ks ")" k)
+    | SPCsterm p -> fprintf ppf "%a" patt (p, k)  ]
+  in
+  parser_cases ppf (spel, k)
+;
+
+value parser_body ppf (e, k) =
+  let (bp, e) =
+    match e with
+    [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e)
+    | e -> (None, e) ]
+  in
+  match parser_of_expr e with
+  [ [] ->
+      fprintf ppf "(parser%t%t"
+        (fun ppf ->
+           match bp with
+           [ Some p -> fprintf ppf "@ %a" patt (p, nok)
+           | _ -> ()])
+        (ks ")" k)
+  | spel ->
+      fprintf ppf "(@[<v>@[parser%t@]@ @[<v 0>%a@]@]"
+        (fun ppf ->
+           match bp with
+           [ Some p -> fprintf ppf "@ %a" patt (p, nok)
+           | _ -> ()])
+        parser_cases (spel, ks ")" k) ]
+;
+
+value pmatch ppf (e, k) =
+  let (me, e) =
+    match e with
+    [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e)
+    | _ -> failwith "Pr_schp_main.pmatch" ]
+  in
+  let (bp, e) =
+    match e with
+    [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e)
+    | e -> (None, e) ]
+  in
+  let spel = parser_of_expr e in
+  fprintf ppf "(@[@[match_with_parser@ %a@]%t@ @[<v 0>%a@]@]" expr (me, nok)
+    (fun ppf ->
+       match bp with
+       [ Some p -> fprintf ppf "@ %a" patt (p, nok)
+       | _ -> () ])
+    parser_cases (spel, ks ")" k)
+;
+
+pr_expr_fun_args.val :=
+  extfun pr_expr_fun_args.val with
+  [ <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ];
+
+let lev = find_pr_level "top" pr_expr.pr_levels in
+lev.pr_rules :=
+  extfun lev.pr_rules with
+  [ <:expr< fun (strm__ : $_$) -> $x$ >> ->
+      fun ppf curr next dg k -> fprintf ppf "%a" parser_body (x, k)
+  | <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e ->
+      fun ppf curr next dg k -> fprintf ppf "%a" pmatch (e, k) ];
diff --git a/camlp4/unmaintained/sml/.depend b/camlp4/unmaintained/sml/.depend
new file mode 100644
index 000000000..e69de29bb
--- /dev/null
+++ b/camlp4/unmaintained/sml/.depend
diff --git a/camlp4/unmaintained/sml/Makefile b/camlp4/unmaintained/sml/Makefile
new file mode 100644
index 000000000..ea3980bef
--- /dev/null
+++ b/camlp4/unmaintained/sml/Makefile
@@ -0,0 +1,68 @@
+#########################################################################
+#                                                                       #
+#                            Objective Caml                             #
+#                                                                       #
+#                                Camlp4                                 #
+#                                                                       #
+#   Copyright 2004 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.                #
+#                                                                       #
+#########################################################################
+#
+# Makefile for pa_sml
+# M.Mauny
+#
+
+include ../../config/Makefile.cnf
+
+OCAMLTOP=../../..
+
+OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) -nostdlib -I $(OCAMLTOP)/stdlib
+OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) -nostdlib -I $(OCAMLTOP)/stdlib
+
+P4INCLUDES=-I ../../meta -I ../../etc -I ../../lib -I ../../camlp4
+OCAMLINCLUDES=-I ../../meta -I ../../lib  -I ../../camlp4
+
+CAMLP4=camlp4$(EXE) -nolib
+OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES)
+
+SRC=pa_sml.ml
+OBJS=$(SRC:.ml=.cmo)
+OBJSX=$(SRC:.ml=.cmx)
+
+all: $(OBJS) smllib.cmo
+
+opt: $(OBJSX) smllib.cmx
+
+depend:
+	cp .depend .depend.bak
+	> .depend
+	for file in $(SRC); do \
+	  $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \
+	  sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \
+	done
+
+clean:
+	rm -f *.cm* *.o *.bak .*.bak
+
+
+.SUFFIXES: .cmx .cmo .cmi .ml .mli .sml
+
+.mli.cmi:
+	$(OCAMLC) $(OCAMLCFLAGS) -c $<
+
+
+.sml.cmo:
+	$(OCAMLC) -I ../../../otherlibs/unix -pp "$(CAMLP4) ./pa_sml.cmo ../../meta/pr_dump.cmo -impl" -c -o $*.cmo -impl $<
+
+.sml.cmx:
+	$(OCAMLOPT)  -I ../../../otherlibs/unix -pp "$(CAMLP4) ./pa_sml.cmo ../../meta/pr_dump.cmo -impl" -c -o $*.cmx -impl $<
+
+.ml.cmo:
+	$(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4)  $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $<
+
+.ml.cmx:
+	$(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4)  $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $<
+
+include .depend
diff --git a/camlp4/unmaintained/sml/README b/camlp4/unmaintained/sml/README
new file mode 100644
index 000000000..809d42f2a
--- /dev/null
+++ b/camlp4/unmaintained/sml/README
@@ -0,0 +1,15 @@
+This is an application of or an extension for Camlp4. Although it is
+currently distributed with OCaml/Camlp4, it may or may not be
+actively maintained.
+
+It probably won't be part of future OCaml/Camlp4 distributions but be
+accessible from the Camlp4 hump. If you are interested in developing
+this package further and/or actively maintain it, please let us know
+(caml@inria.fr)
+
+This package is distributed under the same license as the Objective
+Caml Library (that is, LGPL with a special exception allowing both
+static and dynamic link).
+
+-- Michel Mauny
+
diff --git a/camlp4/unmaintained/sml/pa_sml.ml b/camlp4/unmaintained/sml/pa_sml.ml
new file mode 100644
index 000000000..eb20019d3
--- /dev/null
+++ b/camlp4/unmaintained/sml/pa_sml.ml
@@ -0,0 +1,952 @@
+(* pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *)
+(***********************************************************************)
+(*                                                                     *)
+(*                               Camlp4                                *)
+(*                                                                     *)
+(*    Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2002 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 Stdpp;
+open Pcaml;
+
+value ocaml_records = ref False;
+
+Pcaml.no_constructors_arity.val := True;
+
+value lexer = Plexer.gmake ();
+
+do {
+  Grammar.Unsafe.gram_reinit gram lexer;
+  Grammar.Unsafe.clear_entry interf;
+  Grammar.Unsafe.clear_entry implem;
+  Grammar.Unsafe.clear_entry top_phrase;
+  Grammar.Unsafe.clear_entry use_file;
+  Grammar.Unsafe.clear_entry module_type;
+  Grammar.Unsafe.clear_entry module_expr;
+  Grammar.Unsafe.clear_entry sig_item;
+  Grammar.Unsafe.clear_entry str_item;
+  Grammar.Unsafe.clear_entry expr;
+  Grammar.Unsafe.clear_entry patt;
+  Grammar.Unsafe.clear_entry ctyp;
+  Grammar.Unsafe.clear_entry let_binding;
+};
+
+Pcaml.parse_interf.val := Grammar.Entry.parse interf;
+Pcaml.parse_implem.val := Grammar.Entry.parse implem;
+
+value not_impl loc s =
+  raise_with_loc loc (Stream.Error ("not implemented feature [" ^ s ^ "]"))
+;
+
+type altern 'a 'b = [ Left of 'a | Right of 'b ];
+
+value get_seq =
+  fun
+  [ <:expr< do { $list:el$ } >> -> el
+  | e -> [e] ]
+;
+
+value choose_tvar tpl =
+  let rec find_alpha v =
+    let s = String.make 1 v in
+    if List.mem_assoc s tpl then
+      if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1))
+    else Some (String.make 1 v)
+  in
+  let rec make_n n =
+    let v = "a" ^ string_of_int n in
+    if List.mem_assoc v tpl then make_n (succ n) else v
+  in
+  match find_alpha 'a' with
+  [ Some x -> x
+  | None -> make_n 1 ]
+;
+
+value mklistexp loc last =
+  loop True where rec loop top =
+    fun
+    [ [] ->
+        match last with
+        [ Some e -> e
+        | None -> <:expr< [] >> ]
+    | [e1 :: el] ->
+        let loc = if top then loc else (fst (MLast.loc_of_expr e1), snd loc) in
+        <:expr< [$e1$ :: $loop False el$] >> ]
+;
+
+value mklistpat loc last =
+  loop True where rec loop top =
+    fun
+    [ [] ->
+        match last with
+        [ Some p -> p
+        | None -> <:patt< [] >> ]
+    | [p1 :: pl] ->
+        let loc = if top then loc else (fst (MLast.loc_of_patt p1), snd loc) in
+        <:patt< [$p1$ :: $loop False pl$] >> ]
+;
+
+value expr_of_patt p =
+  let loc = MLast.loc_of_patt p in
+  match p with
+  [ <:patt< $lid:x$ >> -> <:expr< $lid:x$ >>
+  | _ -> Stdpp.raise_with_loc loc (Stream.Error "identifier expected") ]
+;
+
+value apply_bind loc e bl =
+  let rec loop e =
+    fun
+    [ [] -> e
+    | [<:str_item< value $p1$ = $e1$ >> :: list] ->
+        loop_let e [(p1, e1)] list
+    | [<:str_item< value rec $p1$ = $e1$ >> :: list] ->
+        loop_letrec e [(p1, e1)] list
+    | [<:str_item< module $s$ = $me$ >> :: list] ->
+        let e = <:expr< let module $s$ = $me$ in $e$ >> in
+        loop e list
+    | [si :: list] ->
+        raise Exit ]
+  and loop_let e pel =
+    fun
+    [ [<:str_item< value $p1$ = $e1$ >> :: list] ->
+        loop_let e [(p1, e1) :: pel] list
+    | list ->
+        let e = <:expr< let $list:pel$ in $e$ >> in
+        loop e list ]
+  and loop_letrec e pel =
+    fun
+    [ [<:str_item< value rec $p1$ = $e1$ >> :: list] ->
+        loop_letrec e [(p1, e1) :: pel] list
+    | list ->
+        let e = <:expr< let rec $list:pel$ in $e$ >> in
+        loop e list ]
+  in
+  loop e (List.rev bl)
+;
+
+value make_local loc sl1 sl2 =
+  try
+    let pl =
+      List.map
+        (fun
+         [ <:str_item< value $opt:_$ $p$ = $_$ >> -> p
+         | _ -> raise Exit ])
+        sl2
+      in
+    let e1 =
+      match List.map expr_of_patt pl with
+      [ [e] -> e
+      | el -> <:expr< ($list:el$) >> ]
+    in
+    let p1 =
+      match pl with
+      [ [p] -> p
+      | pl -> <:patt< ($list:pl$) >> ]
+    in
+    let e = apply_bind loc e1 sl2 in
+    let e = apply_bind loc e sl1 in
+    <:str_item< value $p1$ = $e$ >>
+  with
+  [ Exit ->
+      do {
+        Printf.eprintf "\
+*** Warning: a 'local' statement will be defined global because of bindings
+which cannot be defined as first class values (modules, exceptions, ...)\n";
+        flush stderr;
+        <:str_item< declare $list:sl1 @ sl2$ end >>
+      } ]
+;
+
+value str_declare loc =
+  fun
+  [ [d] -> d
+  | dl -> <:str_item< declare $list:dl$ end >> ]
+;
+
+value sig_declare loc =
+  fun
+  [ [d] -> d
+  | dl -> <:sig_item< declare $list:dl$ end >> ]
+;
+
+value extract_label_types loc tn tal cdol =
+  let (cdl, aux) =
+    List.fold_right
+      (fun (loc, c, tl, aux_opt) (cdl, aux) ->
+         match aux_opt with
+         [ Some anon_record_type ->
+             let new_tn = tn ^ "_" ^ c in
+             let loc = MLast.loc_of_ctyp anon_record_type in
+             let aux_def = ((loc, new_tn), [], anon_record_type, []) in
+             let tl = [<:ctyp< $lid:new_tn$ >>] in
+             ([(loc, c, tl) :: cdl], [aux_def :: aux])
+         | None -> ([(loc, c, tl) :: cdl], aux) ])
+      cdol ([], [])
+  in
+  [((loc, tn), tal, <:ctyp< [ $list:cdl$ ] >>, []) :: aux]
+;
+
+value function_of_clause_list loc xl =
+  let (fname, fname_loc, nbpat, l) =
+    List.fold_left
+      (fun (fname, fname_loc, nbpat, l) ((x1, loc), x2, x3, x4) ->
+         let (fname, fname_loc, nbpat) =
+           if fname = "" then (x1, loc, List.length x2)
+           else if x1 <> fname then
+             raise_with_loc loc
+               (Stream.Error ("'" ^ fname ^ "' expected"))
+           else if List.length x2 <> nbpat then
+             raise_with_loc loc
+               (Stream.Error "bad number of patterns in that clause")
+           else (fname, fname_loc, nbpat)
+         in
+         let x4 =
+           match x3 with
+           [ Some t -> <:expr< ($x4$ : $t$) >>
+           | _ -> x4 ]
+         in
+         let l = [(x2, x4) :: l] in
+         (fname, fname_loc, nbpat, l))
+      ("", loc, 0, []) xl
+  in
+  let l = List.rev l in
+  let e =
+    match l with
+    [ [(pl, e)] ->
+        List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl e
+    | _ ->
+        if nbpat = 1 then
+          let pwel =
+            List.map
+              (fun (pl, e) -> (<:patt< $List.hd pl$ >>, None, e)) l
+          in
+          <:expr< fun [ $list:pwel$ ] >>
+        else
+          let sl =
+            loop 0 where rec loop n =
+              if n = nbpat then []
+              else ["a" ^ string_of_int (n + 1) :: loop (n + 1)]
+          in
+          let e =
+            let el = List.map (fun s -> <:expr< $lid:s$ >>) sl in
+            let pwel =
+              List.map
+                (fun (pl, e) -> (<:patt< ($list:pl$) >>, None, e)) l
+            in
+            <:expr< match ($list:el$) with [ $list:pwel$ ] >>
+          in
+          List.fold_right (fun s e -> <:expr< fun $lid:s$ -> $e$ >>) sl e ]
+  in
+  (let loc = fname_loc in <:patt< $lid:fname$ >>, e)
+;
+
+value record_expr loc x1 =
+  if ocaml_records.val then <:expr< { $list:x1$ } >>
+  else
+    let list1 =
+      List.map
+        (fun (l, v) ->
+           let id =
+             match l with
+             [ <:patt< $lid:l$ >> -> l
+             | _ -> "" ]
+           in
+           let loc = MLast.loc_of_expr v in
+           <:class_str_item< value $id$ = $v$ >>)
+        x1
+    in
+    let list2 =
+      List.map
+        (fun (l, v) ->
+           let id =
+             match l with
+             [ <:patt< $lid:l$ >> -> l
+             | _ -> "" ]
+           in
+           let loc = MLast.loc_of_patt l in
+           <:class_str_item< method $id$ = $lid:id$ >>)
+        x1
+    in
+    <:expr<
+      let module M =
+        struct
+          class a = object $list:list1 @ list2$ end; 
+        end
+      in
+      new M.a
+    >>
+;
+
+value record_match_assoc loc lpl e =
+  if ocaml_records.val then (<:patt< { $list:lpl$ } >>, e)
+  else
+    let pl = List.map (fun (_, p) -> p) lpl in
+    let e =
+      let el =
+        List.map
+          (fun (l, _) ->
+             let s =
+               match l with
+               [ <:patt< $lid:l$ >> -> l
+               | _ -> "" ]
+             in
+             let loc = MLast.loc_of_patt l in
+             <:expr< v # $lid:s$ >>)
+          lpl
+      in
+      let loc = MLast.loc_of_expr e in
+      <:expr< let v = $e$ in ($list:el$) >>
+    in
+    let p = <:patt< ($list:pl$) >> in
+    (p, e)
+;
+
+value op =
+  Grammar.Entry.of_parser gram "op"
+    (parser [: `("", "op"); `(_, x) :] -> x)
+;
+lexer.Token.tok_using ("", "op");
+
+value special x =
+  if String.length x >= 2 then
+    match x.[0] with
+    [ '+' | '<' | '^' -> True
+    | _ -> False ]
+  else False
+;
+
+value idd =
+  let p =
+    parser
+    [ [: `("LIDENT", x) :] -> x
+    | [: `("UIDENT", x) :] -> x
+    | [: `("", "op"); `(_, x) :] -> x
+    | [: `("", x) when special x :] -> x ]
+  in
+  Grammar.Entry.of_parser Pcaml.gram "ID" p
+;
+
+value uncap s = String.uncapitalize s;
+
+EXTEND
+  GLOBAL: implem interf top_phrase use_file sig_item str_item ctyp patt expr
+    module_type module_expr;
+
+  implem:
+    [ [ x = interdec; EOI -> x ] ]
+  ;
+  interf:
+    [ [ x = LIST1 [ s = sig_item; OPT ";" -> (s, loc) ] -> (x, False) ] ]
+  ;
+  top_phrase:
+    [ [ ph = phrase; ";" -> Some ph
+      | EOI -> None ] ]
+  ;
+  use_file:
+    [ [ l = LIST0 phrase; EOI -> (l, False) ] ]
+  ;
+  phrase:
+    [ [ x = str_item -> x
+      | x = expr -> <:str_item< $exp:x$ >>
+      | "#"; n = LIDENT; dp = dir_param -> MLast.StDir loc n dp ] ]
+  ;
+  dir_param:
+    [ [ -> None
+      | e = expr -> Some e ] ]
+  ;
+  sdecs:
+    [ [ x = sdec; l = sdecs -> [x :: l]
+      | ";"; l = sdecs -> l
+      | -> [] ] ]
+  ;
+
+  fsigb: [ [ -> not_impl loc "fsigb" ] ];
+  fsigconstraint_op: [ [ -> not_impl loc "fsigconstraint_op" ] ];
+  fct_exp: [ [ -> not_impl loc "fct_exp" ] ];
+  exp_pa: [ [ -> not_impl loc "exp_pa" ] ];
+  rvb: [ [ -> not_impl loc "rvb" ] ];
+  tyvarseq: [ [ -> not_impl loc "tyvarseq" ] ];
+
+  tyvar_pc:
+    [ [ "'"; x1 = LIDENT -> [(x1, (False, False))]
+      | "'"; x1 = LIDENT; ","; l = tyvar_pc -> [(x1, (False, False)) :: l] ] ]
+  ;
+  id:
+    [ [ x1 = idd -> x1
+      | "*" -> "*" ] ]
+  ;
+  ident:
+    [ [ x1 = idd -> x1
+      | "*" -> "*"
+      | "=" -> "="
+      | "<" -> "<"
+      | ">" -> ">"
+      | "<=" -> "<="
+      | ">=" -> ">="
+      | "^" -> "^" ] ]
+  ;
+  op_op:
+    [ [ x1 = op -> not_impl loc "op_op 1"
+      | -> () ] ]
+  ;
+  qid:
+    [ [ x1 = idd; "."; x2 = qid -> <:module_expr< $uid:x1$ . $x2$ >>
+      | x1 = idd -> <:module_expr< $uid:x1$ >>
+      | x1 = "*" -> <:module_expr< $uid:x1$ >>
+      | x1 = "=" -> <:module_expr< $uid:x1$ >> ] ]
+  ;
+  eqid:
+    [ [ x1 = UIDENT; "."; x2 = eqid -> <:expr< $uid:x1$ . $x2$ >>
+      | x1 = UIDENT -> <:expr< $uid:x1$ >>
+      | x1 = idd -> <:expr< $lid:x1$ >>
+      | x1 = "*" -> <:expr< $lid:x1$ >>
+      | x1 = "=" -> <:expr< $lid:x1$ >> ] ]
+  ;
+  sqid:
+    [ [ x1 = idd; "."; x2 = sqid -> [x1 :: x2]
+      | x1 = idd -> [x1]
+      | x1 = "*" -> [x1]
+      | x1 = "=" -> [x1] ] ]
+  ;
+  tycon:
+    [ [ LIDENT "real" -> <:ctyp< float >>
+      | x1 = idd; "."; x2 = tycon ->
+          let r = <:ctyp< $uid:x1$ . $x2$ >> in
+          loop r where rec loop =
+            fun
+            [ <:ctyp< $a$ . ($b$ . $c$) >> -> <:ctyp< $a$ . $b$ . $loop c$ >>
+            | x -> x ]
+      | x1 = idd -> <:ctyp< $lid:uncap x1$ >> ] ]
+  ;
+  selector:
+    [ [ x1 = id -> x1
+      | x1 = INT -> not_impl loc "selector 1" ] ]
+  ;
+  tlabel:
+    [ [ x1 = selector; ":"; x2 = ctyp -> (loc, x1, False, x2) ] ]
+  ;
+  tuple_ty:
+    [ [ x1 = ctyp LEVEL "ty'"; "*"; x2 = tuple_ty -> [x1 :: x2]
+      | x1 = ctyp LEVEL "ty'" -> [x1] ] ]
+  ;
+  ctyp:
+    [ RIGHTA
+      [ x1 = ctyp; "->"; x2 = ctyp -> <:ctyp< $x1$ -> $x2$ >> ]
+    | [ x1 = ctyp; "*"; x2 = tuple_ty -> <:ctyp< ($list:[x1 :: x2]$) >> ]
+    | "ty'"
+      [ "'"; x1 = LIDENT -> <:ctyp< '$x1$ >>
+      | "'"; "'"; x1 = LIDENT -> <:ctyp< '$x1$ >>
+      | "{"; x1 = LIST1 tlabel SEP ","; "}" ->
+          if ocaml_records.val then <:ctyp< { $list:x1$ } >>
+          else
+            let list = List.map (fun (_, l, _, t) -> (l, t)) x1 in
+            <:ctyp< < $list:list$ > >>
+      | "{"; "}" -> not_impl loc "ty' 3"
+      | "("; x1 = ctyp; ","; x2 = LIST1 ctyp SEP ","; ")"; x3 = tycon ->
+          List.fold_left (fun t1 t2 -> <:ctyp< $t1$ $t2$ >>) x3 [x1 :: x2]
+      | "("; x1 = ctyp; ")" -> x1
+      | x1 = ctyp; x2 = tycon -> <:ctyp< $x2$ $x1$ >>
+      | x1 = tycon -> x1 ] ]
+  ;
+  rule:
+    [ [ x1 = patt; "=>"; x2 = expr -> (x1, None, x2) ] ]
+  ;
+  elabel:
+    [ [ x1 = selector; "="; x2 = expr -> (<:patt< $lid:x1$ >>, x2) ] ]
+  ;
+  exp_ps:
+    [ [ x1 = expr -> x1
+      | x1 = expr; ";"; x2 = exp_ps ->
+          <:expr< do { $list:[x1 :: get_seq x2]$ } >> ] ]
+  ;
+  expr:
+    [ [ "if"; x1 = expr; "then"; x2 = expr; "else"; x3 = expr ->
+          <:expr< if $x1$ then $x2$ else $x3$ >>
+      | "fn"; x1 = LIST1 rule SEP "|" -> <:expr< fun [$list:x1$] >>
+      | "case"; x1 = expr; "of"; x2 = LIST1 rule SEP "|" ->
+          <:expr< match $x1$ with [$list:x2$] >>
+      | "while"; x1 = expr; "do"; x2 = expr ->
+          <:expr< while $x1$ do { $x2$ } >>
+      | x1 = expr; "handle"; x2 = LIST1 rule SEP "|" ->
+          <:expr< try $x1$ with [$list:x2$] >> ]
+    | RIGHTA
+      [ "raise"; x1 = expr -> <:expr< raise $x1$ >> ]
+    | [ e1 = expr; ":="; e2 = expr -> <:expr< $e1$.val := $e2$ >> ]
+    | LEFTA
+      [ x1 = expr; "orelse"; x2 = expr -> <:expr< $x1$ || $x2$ >> ]
+    | LEFTA
+      [ x1 = expr; "andalso"; x2 = expr -> <:expr< $x1$ && $x2$ >> ]
+    | LEFTA
+      [ x1 = expr; ":"; x2 = ctyp -> <:expr< ($x1$ : $x2$) >> ]
+    | "4" NONA
+      [ x1 = expr; "<"; x2 = expr -> <:expr< $x1$ < $x2$ >>
+      | x1 = expr; ">"; x2 = expr -> <:expr< $x1$ > $x2$ >>
+      | x1 = expr; "<>"; x2 = expr -> <:expr< $x1$ <> $x2$ >>
+      | x1 = expr; "="; x2 = expr -> <:expr< $x1$ = $x2$ >>
+      | x1 = expr; ">="; x2 = expr -> <:expr< $x1$ >= $x2$ >>
+      | x1 = expr; "<="; x2 = expr -> <:expr< $x1$ <= $x2$ >> ]
+    | RIGHTA
+      [ x1 = expr; "^"; x2 = expr -> <:expr< $x1$ ^ $x2$ >>
+      | x1 = expr; "@"; x2 = expr -> <:expr< $x1$ @ $x2$ >>
+      | x1 = expr; "o"; x2 = expr -> <:expr< ooo $x1$ $x2$ >> ]
+    | "5" RIGHTA
+      [ x1 = expr; "::"; x2 = expr -> <:expr< [$x1$ :: $x2$] >> ]
+    | "6" LEFTA
+      [ x1 = expr; "+"; x2 = expr -> <:expr< $x1$ + $x2$ >>
+      | x1 = expr; "-"; x2 = expr -> <:expr< $x1$ - $x2$ >> ]
+    | "7" LEFTA
+      [ x1 = expr; "*"; x2 = expr -> <:expr< $x1$ * $x2$ >>
+      | x1 = expr; "/"; x2 = expr -> <:expr< $x1$ / $x2$ >>
+      | x1 = expr; "div"; x2 = expr -> <:expr< $x1$ / $x2$ >>
+      | x1 = expr; "mod"; x2 = expr -> <:expr< $x1$ mod $x2$ >> ]
+    | LEFTA
+      [ x1 = expr; x2 = expr -> <:expr< $x1$ $x2$ >> ]
+    | [ "#"; x1 = STRING -> <:expr< $chr:x1$ >>
+      | "#"; x1 = selector; x2 = expr ->
+          if ocaml_records.val then <:expr< $x2$ . $lid:x1$ >>
+          else <:expr< $x2$ # $lid:x1$ >>
+      | x1 = expr; "ocaml_record_access"; x2 = expr -> <:expr< $x1$ . $x2$ >> ]
+    | [ "!"; x1 = expr -> <:expr< $x1$ . val >>
+      | "~"; x1 = expr -> <:expr< - $x1$ >> ]
+    | [ x1 = LIDENT ->
+          match x1 with
+          [ "true" | "false" -> <:expr< $uid:String.capitalize x1$ >>
+          | "nil" -> <:expr< [] >>
+          | _ -> <:expr< $lid:x1$ >> ]
+      | x1 = UIDENT -> <:expr< $uid:x1$ >>
+      | x1 = UIDENT; "."; x2 = eqid -> <:expr< $uid:x1$ . $x2$ >>
+      | x1 = INT -> <:expr< $int:x1$ >>
+      | x1 = FLOAT -> <:expr< $flo:x1$ >>
+      | x1 = STRING -> <:expr< $str:x1$ >>
+      | "~"; x1 = INT -> <:expr< $int:"-"^x1$ >>
+      | i = op ->
+          if i = "::" then <:expr< fun (x, y) -> [x :: y] >>
+          else <:expr< fun (x, y) -> $lid:i$ x y >>
+      | "let"; x1 = ldecs; "in"; x2 = exp_ps; "end" ->
+          List.fold_right
+            (fun pel x2 ->
+               let loc =
+                 match pel with
+                 [ [(p, _) :: _] ->
+                     (fst (MLast.loc_of_patt p), snd (MLast.loc_of_expr x2))
+                 | _ -> loc ]
+               in
+               match pel with
+               [ [(_, <:expr< fun [$list:_$] >>) :: _] ->
+                   <:expr< let rec $list:pel$ in $x2$ >>
+               | _ ->
+                   let pel =
+                     List.map
+                       (fun (p, e) ->
+                          match p with
+                          [ <:patt< { $list:lpl$ } >> ->
+                              record_match_assoc (MLast.loc_of_patt p) lpl e
+                          | _ -> (p, e) ])
+                       pel
+                   in
+                   <:expr< let $list:pel$ in $x2$ >> ])
+            x1 x2
+      | "{"; x1 = LIST1 elabel SEP ","; "}" -> record_expr loc x1
+      | "["; "]" -> <:expr< [] >>
+      | "["; x1 = expr; "]" -> <:expr< [$x1$] >>
+      | "["; x1 = expr; ","; x2 = LIST1 SELF SEP ","; "]" ->
+          mklistexp loc None [x1 :: x2]
+      | "("; ")" -> <:expr< () >>
+      | "("; x1 = expr; ","; x2 = LIST1 SELF SEP ","; ")" ->
+          <:expr< ($list:[x1::x2]$) >>
+      | "("; x1 = expr; ";"; x2 = LIST1 SELF SEP ";"; ")" ->
+          <:expr< do { $list:[x1::x2]$ } >>
+      | "("; x1 = expr; ")" -> x1 ] ]
+  ;
+  fixity:
+    [ [ "infix" -> ("infix", None)
+      | "infix"; x1 = INT -> not_impl loc "fixity 2"
+      | "infixr" -> not_impl loc "fixity 3"
+      | "infixr"; x1 = INT -> ("infixr", Some x1)
+      | "nonfix" -> not_impl loc "fixity 5" ] ]
+  ;
+  patt:
+    [ [ x1 = patt; "as"; x2 = patt -> <:patt< ($x1$ as $x2$) >> ]
+    | LEFTA
+      [ x1 = patt; ":"; x2 = ctyp -> <:patt< ($x1$ : $x2$) >> ]
+    | RIGHTA
+      [ x1 = patt; "::"; x2 = patt -> <:patt< [$x1$ :: $x2$] >> ]
+    | [ x1 = patt; x2 = patt ->
+          match x1 with
+          [ <:patt< ref >> -> <:patt< {contents = $x2$} >>
+          | _ -> <:patt< $x1$ $x2$ >> ] ]
+    | "apat"
+      [ x1 = patt; "."; x2 = patt -> <:patt< $x1$ . $x2$ >>
+      | x1 = INT -> <:patt< $int:x1$ >>
+      | x1 = UIDENT -> <:patt< $uid:x1$ >>
+      | x1 = STRING -> <:patt< $str:x1$ >>
+      | "#"; x1 = STRING -> <:patt< $chr:x1$ >>
+      | "~"; x1 = INT -> <:patt< $int:"-"^x1$ >>
+      | LIDENT "nil" -> <:patt< [] >>
+      | LIDENT "false" -> <:patt< False >>
+      | LIDENT "true" -> <:patt< True >>
+      | x1 = id -> <:patt< $lid:x1$ >>
+      | x1 = op -> <:patt< $lid:x1$ >>
+      | "_" -> <:patt< _ >>
+      | "["; "]" -> <:patt< [] >>
+      | "["; x1 = patt; "]" -> <:patt< [$x1$] >>
+      | "["; x1 = patt; ","; x2 = LIST1 SELF SEP ","; "]" ->
+          mklistpat loc None [x1 :: x2]
+      | "{"; x1 = LIST1 plabel SEP ","; "}" -> <:patt< {$list:x1$} >>
+      | "("; ")" -> <:patt< () >>
+      | "("; x1 = patt; ","; x2 = LIST1 SELF SEP ","; ")" ->
+          <:patt< ($list:[x1::x2]$) >>
+      | "("; x1 = patt; ")" -> x1 ] ]
+  ;
+  plabel:
+    [ [ x1 = selector; "="; x2 = patt -> (<:patt< $lid:x1$ >>, x2)
+      | x1 = selector -> (<:patt< $lid:x1$ >>, <:patt< $lid:x1$ >>) ] ]
+  ;
+  vb:
+    [ [ "lazy"; x1 = patt; "="; x2 = expr -> not_impl loc "vb 1"
+      | x1 = patt; "="; x2 = expr -> (x1, x2) ] ]
+  ;
+  constrain:
+    [ [ -> None
+      | ":"; x1 = ctyp -> Some x1 ] ]
+  ;
+  fb:
+    [ [ xl = LIST1 clause SEP "|" -> function_of_clause_list loc xl
+      | "lazy"; x1 = LIST1 clause SEP "|" -> not_impl loc "fb 2" ] ]
+  ;
+  clause:
+    [ [ x1 = patt LEVEL "apat"; x2 = LIST1 (patt LEVEL "apat");
+        x3 = constrain; "="; x4 = expr ->
+          let x1 =
+            match x1 with
+            [ <:patt< $lid:id$ >> -> (id, MLast.loc_of_patt x1)
+            | _ -> not_impl loc "clause 1" ]
+          in
+          (x1, x2, x3, x4) ] ]
+  ;
+  tb:
+    [ [ x1 = tyvars; x2 = idd; "="; x3 = ctyp ->
+          ((loc, uncap x2), x1, x3, [])
+      | x1 = tyvars; x2 = idd; "="; x3 = ctyp; "=="; x4 = dbrhs ->
+          let x4 = List.map (fun (loc, c, tl, _) -> (loc, c, tl)) x4 in
+          ((loc, uncap x2), x1, <:ctyp< $x3$ == [ $list:x4$ ] >>, []) ] ]
+  ;
+  tyvars:
+    [ [ "'"; x1 = LIDENT -> [(x1, (False, False))]
+      | "("; x1 = tyvar_pc; ")" -> x1
+      | -> [] ] ]
+  ;
+  db1:
+    [ [ x1 = tyvars; x2 = ident; "="; x3 = dbrhs ->
+          let x2 = uncap x2 in
+          extract_label_types loc x2 x1 x3
+      | "lazy"; x1 = tyvars; x2 = ident; "="; x3 = dbrhs ->
+          not_impl loc "db 2" ] ]
+  ;
+  db:
+    [ [ x1 = LIST1 db1 SEP "and" ->
+          List.fold_right (fun td tdl -> td @ tdl) x1 [] ] ]
+  ;
+  dbrhs:
+    [ [ x1 = LIST1 constr SEP "|"  -> x1
+      | "datatype"; x1 = tycon -> not_impl loc "dbrhs 2" ] ]
+  ;
+  constr:
+    [ [ x1 = op_op; x2 = ident -> (loc, x2, [], None)
+      | x1 = op_op; x2 = ident; "of"; x3 = ctyp ->
+          match x3 with
+          [ <:ctyp< {$list:_$} >> -> (loc, x2, [], Some x3)
+          | _ -> (loc, x2, [x3], None) ] ] ]
+  ;
+  eb:
+    [ [ x1 = op_op; x2 = ident -> (x2, [], [])
+      | x1 = op_op; x2 = ident; "of"; x3 = ctyp -> (x2, [x3], [])
+      | x1 = op_op; x2 = ident; "="; x3 = sqid -> (x2, [], x3) ] ]
+  ;
+  ldec1:
+    [ [ "val"; x1 = LIST1 vb SEP "and" -> x1
+      | "fun"; x1 = LIST1 fb SEP "and" -> x1 ] ]
+  ;
+  ldecs:
+    [ [ -> []
+      | x1 = ldec1; x2 = ldecs -> [x1 :: x2]
+      | ";"; x1 = ldecs -> x1
+      | "local"; x1 = ldecs; "in"; x2 = ldecs; "end"; x3 = ldecs ->
+          not_impl loc "ldecs 4" ] ]
+  ;
+  spec_s:
+    [ [ -> []
+      | x1 = spec; x2 = spec_s -> [x1 :: x2]
+      | ";"; x1 = spec_s -> x1 ] ]
+  ;
+  spec:
+   [ [ "structure"; x1 = LIST1 strspec SEP "and" -> sig_declare loc x1
+     | "functor"; x1 = LIST1 fctspec SEP "and" -> sig_declare loc x1
+     | "datatype"; x1 = db -> <:sig_item< type $list:x1$ >>
+     | "type"; x1 = LIST1 tyspec SEP "and" -> <:sig_item< type $list:x1$ >>
+     | "eqtype"; x1 = LIST1 tyspec SEP "and" -> <:sig_item< type $list:x1$ >>
+     | "val"; x1 = LIST1 valspec SEP "and" -> sig_declare loc x1
+     | "exception"; x1 = LIST1 exnspec SEP "and" -> sig_declare loc x1
+     | "sharing"; x1 = LIST1 sharespec SEP "and" -> <:sig_item< declare end >>
+     | "include"; x1 = module_type -> <:sig_item< include $x1$ >> ] ]
+  ;
+  sig_item:
+    [ [ x = spec -> x ] ]
+  ;
+  strspec:
+    [ [ x1 = ident; ":"; x2 = module_type; x3 = LIST0 sharing_def ->
+          let x2 =
+            List.fold_left
+              (fun mt sdl ->
+                 List.fold_right
+                   (fun spl mt ->
+                      match spl with
+                      [ Right ([m1], m2) ->
+                          let (m1, m2) =
+                            match m2 with
+                            [ <:module_expr< $uid:x$ . $_$ >> ->
+                                if x = x1 then (m2, m1) else (m1, m2)
+                            | _ -> (m1, m2) ]
+                          in
+                          let m1 =
+                            loop m1 where rec loop =
+                              fun
+                              [ <:module_expr< $uid:x$ >> -> x
+                              | <:module_expr< $uid:x$ . $y$ >> -> loop y
+                              | _ -> not_impl loc "strspec 2" ]
+                          in
+                          <:module_type< $mt$ with module $[m1]$ = $m2$ >>
+                      | _ -> not_impl loc "strspec 1" ])
+                   sdl mt)
+              x2 x3
+          in
+          <:sig_item< module $x1$ : $x2$ >> ] ]
+  ;
+  sharing_def:
+    [ [ "sharing"; x3 = LIST1 sharespec SEP "and" -> x3 ] ]
+  ;
+  fctspec:
+    [ [ x1 = ident; x2 = fsig -> <:sig_item< module $x1$ : $x2$ >> ] ]
+  ;
+  tyspec:
+    [ [ x1 = tyvars; x2 = idd ->
+          ((loc, uncap x2), x1, <:ctyp< '$choose_tvar x1$ >>, [])
+      | x1 = tyvars; x2 = idd; "="; x3 = ctyp ->
+          ((loc, uncap x2), x1, x3, []) ] ]
+  ;
+  valspec:
+    [ [ x1 = op_op; x2 = ident; ":"; x3 = ctyp ->
+          <:sig_item< value $x2$ : $x3$ >> ] ]
+  ;
+  exnspec:
+    [ [ x1 = ident -> <:sig_item< exception $x1$ >>
+      | x1 = ident; "of"; x2 = ctyp ->
+          <:sig_item< exception $x1$ of $x2$ >> ] ]
+  ;
+  sharespec:
+    [ [ "type"; x1 = patheqn -> Left x1
+      | x1 = patheqn -> Right x1 ] ]
+  ;
+  patheqn:
+    [ [ l = patheqn1 -> l ] ]
+  ;
+  patheqn1:
+    [ [ (l, y) = patheqn1; "="; x = qid -> ([y :: l], x)
+      | x = qid -> ([], x) ] ]
+  ;
+  whspec:
+    [ [ "type"; x1 = tyvars; x2 = sqid; "="; x3 = ctyp ->
+          MLast.WcTyp loc x2 x1 x3
+      | x1 = sqid; "="; x2 = qid -> MLast.WcMod loc x1 x2 ] ]
+  ;
+  module_type:
+    [ [ x1 = ident -> <:module_type< $uid:x1$ >>
+      | "sig"; x1 = spec_s; "end" -> <:module_type< sig $list:x1$ end >>
+      | x1 = module_type; "where"; x2 = LIST1 whspec SEP "and" ->
+          <:module_type< $x1$ with $list:x2$ >> ] ]
+  ;
+  sigconstraint_op:
+    [ [ -> None
+      | ":"; x1 = module_type -> Some x1
+      | ":>"; x1 = module_type -> not_impl loc "sigconstraint_op 3" ] ]
+  ;
+  sigb:
+    [ [ x1 = ident; "="; x2 = module_type ->
+          <:str_item< module type $x1$ = $x2$ >> ] ]
+  ;
+  fsig:
+    [ [ ":"; x1 = ident -> not_impl loc "fsig 1"
+      | x1 = fparamList; ":"; x2 = module_type -> not_impl loc "fsig 2" ] ]
+  ;
+  module_expr:
+    [ [ x1 = qid -> x1
+      | "struct"; x1 = strdecs; "end" -> <:module_expr< struct $list:x1$ end >>
+      | x1 = qid; x2 = arg_fct ->
+          match x2 with
+          [ Left [] -> x1
+          | Left x2 -> <:module_expr< $x1$ (struct $list:x2$ end) >>
+          | Right x2 -> <:module_expr< $x1$ $x2$ >> ]
+      | "let"; x1 = strdecs; "in"; x2 = module_expr; "end" ->
+          not_impl loc "str 4"
+      | x1 = module_expr; ":"; x2 = module_type -> not_impl loc "str 5"
+      | x1 = module_expr; x2 = ":>"; x3 = module_type ->
+          not_impl loc "str 6" ] ]
+  ;
+  arg_fct:
+    [ [ "("; x1 = strdecs; ")"; x2 = arg_fct -> not_impl loc "arg_fct 1"
+      | "("; x1 = module_expr; ")"; x2 = arg_fct -> not_impl loc "arg_fct 2"
+      | "("; x1 = module_expr; ")" -> Right x1
+      | "("; x2 = strdecs; ")" -> Left x2 ] ]
+  ;
+  strdecs:
+    [ [ x1 = str_item LEVEL "strdec"; x2 = strdecs -> [x1 :: x2]
+      | ";"; x1 = strdecs -> x1
+      | -> [] ] ]
+  ;
+  str_item:
+    [ [ "signature"; x1 = LIST1 sigb SEP "and" -> str_declare loc x1
+      | "funsig"; x1 = fsigb -> not_impl loc "sdec 3" ]
+    | "strdec"
+      [ "structure"; x1 = LIST1 strb SEP "and" -> str_declare loc x1
+      | "functor"; x1 = LIST1 fctb SEP "and" -> str_declare loc x1
+      | "local"; x1 = sdecs; "in"; x2 = sdecs; "end" ->
+          make_local loc x1 x2 ]
+    | [ "val"; x1 = LIST1 vb SEP "and" -> <:str_item< value $list:x1$ >>
+      | "val"; x1 = tyvarseq; x3 = LIST1 vb SEP "and" ->
+          not_impl loc "ldec 2"
+      | "val"; "rec"; x1 = rvb -> not_impl loc "ldec 3"
+      | "val"; "rec"; x1 = tyvarseq; x2 = rvb -> not_impl loc "ldec 4"
+      | "fun"; x1 = LIST1 fb SEP "and" -> <:str_item< value rec $list:x1$ >>
+      | "fun"; x1 = tyvarseq; x2 = fb -> not_impl loc "ldec 6"
+      | "type"; x1 = LIST1 tb SEP "and" -> <:str_item< type $list:x1$ >>
+      | "datatype"; x1 = db -> <:str_item< type $list:x1$ >>
+      | "datatype"; x1 = db; "withtype"; x2 = tb ->
+          <:str_item< type $list:x1 @ [x2]$ >>
+      | "abstype"; x1 = db; "with"; x2 = ldecs; "end" -> not_impl loc "ldec 10"
+      | "abstype"; x1 = db; "withtype"; x2 = tb; "with"; x3 = ldecs; "end" ->
+          not_impl loc "ldec 11"
+      | "exception"; x1 = LIST1 eb SEP "and" ->
+          let dl =
+            List.map
+              (fun (s, tl, eqn) ->
+                 <:str_item< exception $s$ of $list:tl$ = $eqn$ >>)
+              x1
+          in
+          str_declare loc dl
+      | "open"; x1 = LIST1 sqid ->
+          let dl = List.map (fun sl -> <:str_item< open $sl$ >>) x1 in
+          str_declare loc dl
+      | LIDENT "use"; s = STRING ->
+          <:str_item< #use $str:s$ >>
+      | x1 = fixity; list = LIST1 idd ->
+          match x1 with
+          [ ("infixr", Some n) ->
+              do {
+                List.iter
+                  (fun s ->
+                     EXTEND
+                       expr: LEVEL $n$
+                         [ [ x1 = expr; $s$; x2 = expr ->
+                               <:expr< $lid:s$ ($x1$, $x2$) >> ] ]
+                       ;
+                     END)
+                  list;
+                  str_declare loc []
+              }
+          | ("infix", None) ->
+              do {
+                List.iter
+                  (fun s ->
+                     EXTEND
+                       expr: LEVEL "4"
+                         [ [ x1 = expr; $s$; x2 = expr ->
+                               <:expr< $lid:s$ ($x1$, $x2$) >> ] ]
+                       ;
+                       clause:
+                         [ [ x1 = patt LEVEL "apat"; $s$;
+                             x2 = patt LEVEL "apat"; "="; x4 = expr ->
+                               ((s, loc), [<:patt< ($x1$, $x2$) >>],
+                                None, x4) ] ]
+                       ;
+                     END)
+                  list;
+                  str_declare loc []
+              }
+          | _ -> not_impl loc "ldec 14" ]
+      | "overload"; x1 = ident; ":"; x2 = ctyp; "as"; x3 = exp_pa ->
+          not_impl loc "ldec 15"
+      | x = expr -> <:str_item< $exp:x$ >> ] ]
+  ;
+  sdec:
+    [ [ x = str_item -> x ] ]
+  ;
+  strb:
+    [ [ x1 = ident; x2 = sigconstraint_op; "="; x3 = module_expr ->
+          let x3 =
+            match x2 with
+            [ Some x2 -> <:module_expr< ($x3$ : $x2$) >>
+            | None -> x3 ]
+          in
+          <:str_item< module $x1$ = $x3$ >> ] ]
+  ;
+  fparam:
+    [ [ x1 = idd; ":"; x2 = module_type -> [<:sig_item< module $x1$ : $x2$ >>]
+      | x1 = spec_s -> x1 ] ]
+  ;
+  fparamList:
+    [ [ "("; x1 = fparam; ")" -> [x1]
+      | "("; x1 = fparam; ")"; x2 = fparamList -> [x1 :: x2] ] ]
+  ;
+  fctb:
+    [ [ x1 = ident; x2 = fparamList; x3 = sigconstraint_op; "=";
+        x4 = module_expr ->
+          let list = List.flatten x2 in
+          let x4 =
+            if list = [] then x4
+            else
+              match x4 with
+              [ <:module_expr< struct $list:list$ end >> ->
+                  let si =
+                    let loc = (Token.nowhere, Token.nowhere) in
+                    <:str_item< open AAA >> in
+                  <:module_expr< struct $list:[si :: list]$ end >>
+              | _ -> not_impl loc "fctb 1" ]
+          in
+          let x4 =
+            match x3 with
+            [ Some x3 -> <:module_expr< ($x4$ : $x3$) >>
+            | None -> x4 ]
+          in
+          let x4 =
+            if list = [] then x4
+            else
+              let mt =
+                let loc =
+                  (fst (MLast.loc_of_sig_item (List.hd list)),
+                   snd (MLast.loc_of_sig_item (List.hd (List.rev list))))
+                in
+                <:module_type< sig $list:list$ end >>
+              in
+              <:module_expr< functor (AAA : $mt$) -> $x4$ >>
+          in
+          <:str_item< module $x1$ = $x4$ >>
+      | x1 = ident; x2 = fsigconstraint_op; "="; x3 = fct_exp ->
+          not_impl loc "fctb 2" ] ]
+  ;
+  interdec:
+    [ [ x = LIST1 [ s = str_item; OPT ";" -> (s, loc) ] -> (x, False)
+      | x = expr; OPT ";" -> not_impl loc "interdec 2" ] ]
+  ;
+END;
+
+Pcaml.add_option "-records" (Arg.Set ocaml_records)
+  "Convert record into OCaml records, instead of objects";
diff --git a/camlp4/unmaintained/sml/smllib.sml b/camlp4/unmaintained/sml/smllib.sml
new file mode 100644
index 000000000..d0a8468f5
--- /dev/null
+++ b/camlp4/unmaintained/sml/smllib.sml
@@ -0,0 +1,395 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                             Camlp4                                  *)
+(*                                                                     *)
+(*        Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt     *)
+(*                                                                     *)
+(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
+(*  Automatique.  Distributed only by permission.                      *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+datatype 'a option = SOME of 'a | NONE
+exception Fail of string
+exception Domain
+exception Subscript
+type 'a vector = 'a array
+
+structure OCaml =
+  struct
+    structure List = List
+    structure String = String
+  end
+
+structure Time =
+  struct
+    datatype time = TIME of { sec : int, usec : int }
+    fun toString _ = failwith "not implemented Time.toString"
+    fun now _ = failwith "not implemented Time.now"
+  end
+
+datatype cpu_timer =
+  CPUT of { gc : Time.time, sys : Time.time, usr : Time.time }
+
+datatype real_timer =
+  RealT of Time.time
+
+structure Char =
+  struct
+    val ord = Char.code
+  end
+
+structure General =
+  struct
+    datatype order = LESS | EQUAL | GREATER
+  end
+type order = General.order == LESS | EQUAL | GREATER
+
+structure OS =
+  struct
+    exception SysErr
+    structure Path =
+      struct
+        fun dir s =
+          let val r = Filename.dirname s in
+            if r = "." then "" else r
+          end
+        val file = Filename.basename
+        fun ext s =
+          let fun loop i =
+            if i < 0 then NONE
+            else if String.get s i = #"." then
+              let val len = String.length s - i - 1 in
+                if len = 0 then NONE else SOME (String.sub s (i + 1) len)
+              end
+            else loop (i - 1)
+          in
+            loop (String.length s - 1)
+          end
+        fun splitDirFile s =
+          {dir = Filename.dirname s,
+           file = Filename.basename s}
+        fun joinDirFile x =
+          let val {dir,file} = x in Filename.concat dir file end
+      end
+    structure FileSys =
+      struct
+        datatype access_mode = A_READ | A_WRITE | A_EXEC
+        val chDir = Sys.chdir
+        fun isDir s =
+          (Unix.stat s) ocaml_record_access Unix.st_kind = Unix.S_DIR
+          handle Unix.Unix_error _ => raise SysErr
+        fun access (s, accs) =
+          let val st = Unix.stat s
+              val prm = st ocaml_record_access Unix.st_perm
+              val prm =
+                if st ocaml_record_access Unix.st_uid = Unix.getuid () then
+                  lsr prm 6
+                else if st ocaml_record_access Unix.st_uid = Unix.getgid ()
+                then
+                  lsr prm 3
+                else prm
+              val rf =
+                if List.mem A_READ accs then land prm 4 <> 0 else true
+              val wf =
+                if List.mem A_WRITE accs then land prm 2 <> 0 else true
+              val xf =
+                if List.mem A_EXEC accs then land prm 1 <> 0 else true
+          in
+            rf andalso wf andalso xf
+          end
+          handle Unix.Unix_error (_, f, _) =>
+            if f = "stat" then false else raise SysErr
+      end
+    structure Process =
+      struct
+        fun system s = (flush stdout; flush stderr; Sys.command s)
+        fun getEnv s = SOME (Sys.getenv s) handle Not_found => NONE
+        val success = 0
+      end
+  end
+
+exception SysErr = OS.SysErr
+
+structure IO =
+  struct
+    exception Io of {cause:exn, function:string, name:string}
+  end
+
+structure TextIO =
+  struct
+    type instream = in_channel * char option option ref
+    type outstream = out_channel
+    type elem = char
+    type vector = string
+    fun openIn fname =
+      (open_in fname, ref NONE) handle exn =>
+        raise IO.Io {cause = exn, function = "openIn", name = fname}
+    val openOut = open_out
+    fun closeIn (ic, ahc) = (ahc := SOME NONE; close_in ic)
+    val closeOut = close_out
+    val stdIn = (stdin, ref (NONE : char option option))
+    fun endOfStream (ic, _) = pos_in ic = in_channel_length ic
+    fun inputLine (ic, ahc) =
+      case !ahc of
+        NONE =>
+          (input_line ic ^ "\n" handle End_of_file => (ahc := SOME NONE; ""))
+      | SOME NONE => ""
+      | SOME (SOME c) =>
+          (ahc := NONE;
+           if c = #"\n" then "\n"
+           else
+             String.make 1 c ^ input_line ic ^ "\n" handle
+               End_of_file => (ahc := SOME NONE; ""))
+    fun input1 (ic, ahc) =
+      case !ahc of
+        NONE =>
+          (SOME (input_char ic) handle End_of_file => (ahc := SOME NONE; NONE))
+      | SOME NONE => NONE
+      | SOME x => (ahc := NONE; x)
+    fun inputN (ins, n) =
+      let fun loop n =
+        if n <= 0 then ""
+        else
+          case input1 ins of
+            SOME c => String.make 1 c ^ loop (n - 1)
+          | NONE => ""
+      in
+        loop n
+      end
+    fun output (oc, v) = output_string oc v
+    fun inputAll ic = failwith "not implemented TextIO.inputAll"
+    fun lookahead (ic, ahc) =
+      case !ahc of
+        NONE => let val r = SOME (input_char ic) in ahc := SOME r; r end
+      | SOME x => x
+    fun print s = (print_string s; flush stdout)
+  end
+
+structure Timer =
+  struct
+    fun startRealTimer () = failwith "not implemented Timer.startRealTimer"
+    fun startCPUTimer () = failwith "not implemented Timer.startCPUTimer"
+    fun checkRealTimer _ = failwith "not implemented Timer.checkRealTimer"
+    fun checkCPUTimer _ = failwith "not implemented Timer.checkCPUTimer"
+  end
+
+structure Date =
+  struct
+    datatype month =
+      Jan | Feb | Mar | Apr | May | Jun | Jul | Sep | Oct | Nov | Dec
+    datatype wday = Sun | Mon | Tue | Wed | Thu | Fri | Sat
+    datatype date =
+      DATE of
+        {day : int, hour : int, isDst : bool option, minute : int,
+         month : month, offset : int option, second : int, wday : wday,
+         yday : int, year : int}
+    fun fmt _ _ = failwith "not implemented Date.fmt"
+    fun fromTimeLocal _ = failwith "not implemented Date.fromTimeLocal"
+  end
+
+structure Posix =
+  struct
+    structure ProcEnv =
+      struct
+        fun getenv s = SOME (Sys.getenv s) handle Not_found => NONE
+      end
+  end
+
+structure SMLofNJ =
+  struct
+    fun exportML s = failwith ("not implemented exportML " ^ s)
+  end
+
+fun null x = x = []
+fun explode s =
+  let fun loop i =
+    if i = String.length s then []
+    else String.get s i :: loop (i + 1)
+  in
+    loop 0
+  end
+
+val app = List.iter
+fun implode [] = ""
+  | implode (c :: l) = String.make 1 c ^ implode l
+
+fun ooo f g x = f (g x)
+
+structure Array =
+  struct
+    fun array (len, v) = Array.create len v
+    fun sub _ = failwith "not implemented Array.sub"
+    fun update _ = failwith "not implemented Array.update"
+    (* for make the profiler work *)
+    val set = Array.set
+    val get = Array.get
+  end
+
+structure Vector =
+  struct
+    fun tabulate _ = failwith "not implemented Vector.tabulate"
+    fun sub _ = failwith "not implemented Vector.sub"
+  end
+
+structure Bool =
+  struct
+    val toString = string_of_bool
+  end
+
+structure String =
+  struct
+    val size = String.length
+    fun substring (s, beg, len) =
+      String.sub s beg len handle Invalid_argument _ => raise Subscript
+    val concat = String.concat ""
+    fun sub (s, i) = String.get s i
+    val str = String.make 1
+    fun compare (s1, s2) =
+      if s1 < s2 then LESS
+      else if s1 > s2 then GREATER
+      else EQUAL
+    fun isPrefix s1 s2 =
+      let fun loop i1 i2 =
+        if i1 >= String.length s1 then true
+        else if i2 >= String.length s2 then false
+        else if String.get s1 i1 = String.get s2 i2 then loop (i1 + 1) (i2 + 1)
+        else false
+      in
+        loop 0 0
+      end
+    fun tokens p s =
+      let fun loop tok i =
+        if i >= String.length s then
+          if tok = "" then [] else [tok]
+        else if p (String.get s i) then
+          if tok <> "" then tok :: loop "" (i + 1)
+          else loop "" (i + 1)
+        else loop (tok ^ String.make 1 (String.get s i)) (i + 1)
+      in
+        loop "" 0
+      end
+    fun extract _ = failwith "not implemented String.extract"
+  end
+
+structure Substring =
+  struct
+    type substring = string * int * int
+    fun string (s : substring) = String.substring s
+    fun all s : substring = (s, 0, String.size s)
+    fun splitl f ((s, beg, len) : substring) : substring * substring =
+      let fun loop di =
+        if di = len then ((s, beg, len), (s, 0, 0))
+        else if f (String.sub (s, beg + di)) then loop (di + 1)
+        else ((s, beg, di), (s, beg + di, len - di))
+      in
+        loop 0
+      end
+    fun getc (s, i, len) =
+      if len > 0 andalso i < String.size s then
+        SOME (String.sub (s, i), (s, i+1, len-1))
+      else NONE
+    fun slice _ = failwith "not implemented: Substring.slice"
+    fun isEmpty (s, beg, len) = len = 0
+    fun concat sl = String.concat (List.map string sl)
+  end
+type substring = Substring.substring
+
+structure StringCvt =
+  struct
+    datatype radix = BIN | OCT | DEC | HEX
+    type ('a, 'b) reader = 'b -> ('a * 'b) option 
+  end
+
+structure ListPair =
+  struct
+    fun zip (a1::l1, a2::l2) = (a1, a2) :: zip (l1, l2)
+      | zip _ = []
+    val unzip = List.split
+    fun all f (x1 :: l1, x2 :: l2) = f (x1, x2) andalso all f (l1, l2)
+      | all _ _ = true
+    fun map f (a1::l1, a2::l2) =
+          let val r = f (a1, a2) in r :: map f (l1, l2) end
+      | map _ _ = []
+  end
+
+structure ListMergeSort =
+  struct
+    fun uniqueSort cmp l =
+      List.sort
+       (fn x => fn y =>
+          case cmp (x, y) of
+            LESS => ~1
+          | EQUAL => 0
+          | GREATER => 1)
+       l
+  end
+
+structure List =
+  struct
+    exception Empty
+    fun hd [] = raise Empty
+      | hd (x :: l) = x
+    fun tl [] = raise Empty
+      | tl (x :: l) = l
+    fun foldr f a l =
+      let fun loop a [] = a
+            | loop a (x :: l) = loop (f (x, a)) l
+      in
+        loop a (List.rev l)
+      end
+    fun foldl f a l = List.fold_left (fn a => fn x => f (x, a)) a l
+    val concat = List.flatten
+    val exists = List.exists
+    val filter = List.filter
+    val length = List.length
+    val map = List.map
+    val rev = List.rev
+    val all = List.for_all
+    fun find f [] = NONE
+      | find f (x :: l) = if f x then SOME x else find f l
+    fun last s =
+      case List.rev s of
+        [] => raise Empty
+      | x :: _ => x
+    fun take _ = failwith "not implemented: List.take"
+    fun partition _ = failwith "not implemented: List.partition"
+    fun mapPartial f [] = []
+      | mapPartial f (x :: l) =
+          case f x of
+            NONE => mapPartial f l
+          | SOME y => y :: mapPartial f l
+    fun op @ l1 l2 = List.rev_append (List.rev l1) l2
+  end
+
+structure Int =
+  struct
+    type int1 = int
+    type int = int1
+    val toString = string_of_int
+    fun fromString s = SOME (int_of_string s) handle Failure _ => NONE
+    fun min (x, y) = if x < y then x else y
+    fun max (x, y) = if x > y then x else y
+    fun scan radix getc src = failwith "not impl: Int.scan"
+  end
+
+val foldr = List.foldr
+val exists = List.exists
+val size = String.size
+val substring = String.substring
+val concat = String.concat
+val length = List.length
+val op @ = List.op @
+val hd = List.hd
+val tl = List.tl
+val map = List.map
+val rev = List.rev
+val use_hook = ref (fn (s : string) => (failwith "no defined directive use" : unit))
+fun use s = !use_hook s
+fun isSome (SOME _) = true
+  | isSome NONE = false
+fun valOf (SOME x) = x
+  | valOf NONE = failwith "valOf"
+val print = TextIO.print
diff --git a/debugger/.depend b/debugger/.depend
index 33eae2f14..930900400 100644
--- a/debugger/.depend
+++ b/debugger/.depend
@@ -10,8 +10,8 @@ frames.cmi: ../bytecomp/instruct.cmi primitives.cmi
 input_handling.cmi: primitives.cmi 
 lexer.cmi: parser.cmi 
 loadprinter.cmi: ../otherlibs/dynlink/dynlink.cmi ../parsing/longident.cmi 
-parser_aux.cmi: ../parsing/longident.cmi primitives.cmi 
 parser.cmi: ../parsing/longident.cmi parser_aux.cmi 
+parser_aux.cmi: ../parsing/longident.cmi primitives.cmi 
 pattern_matching.cmi: debugcom.cmi parser_aux.cmi ../typing/typedtree.cmi 
 pos.cmi: ../bytecomp/instruct.cmi 
 primitives.cmi: ../otherlibs/unix/unix.cmi 
diff --git a/lex/.depend b/lex/.depend
index b21bfd936..f90d6dc6e 100644
--- a/lex/.depend
+++ b/lex/.depend
@@ -16,9 +16,9 @@ lexer.cmo: parser.cmi syntax.cmi lexer.cmi
 lexer.cmx: parser.cmx syntax.cmx lexer.cmi 
 lexgen.cmo: cset.cmi syntax.cmi table.cmi lexgen.cmi 
 lexgen.cmx: cset.cmx syntax.cmx table.cmx lexgen.cmi 
-main.cmo: common.cmi compact.cmi lexer.cmi lexgen.cmi output.cmi \
+main.cmo: common.cmi compact.cmi cset.cmi lexer.cmi lexgen.cmi output.cmi \
     outputbis.cmi parser.cmi syntax.cmi 
-main.cmx: common.cmx compact.cmx lexer.cmx lexgen.cmx output.cmx \
+main.cmx: common.cmx compact.cmx cset.cmx lexer.cmx lexgen.cmx output.cmx \
     outputbis.cmx parser.cmx syntax.cmx 
 output.cmo: common.cmi compact.cmi lexgen.cmi syntax.cmi output.cmi 
 output.cmx: common.cmx compact.cmx lexgen.cmx syntax.cmx output.cmi 
diff --git a/man/ocamlc.m b/man/ocamlc.m
index 2f25d54e4..bc133e76f 100644
--- a/man/ocamlc.m
+++ b/man/ocamlc.m
@@ -44,7 +44,8 @@ These executable files are then run by the bytecode interpreter
 The 
 .BR ocamlc (1)
 command has a command-line interface similar to the one of
-most C compilers. It accepts several types of arguments:
+most C compilers. It accepts several types of arguments and processes them
+sequentially:
 
 Arguments ending in .mli are taken to be source files for
 compilation unit interfaces. Interfaces specify the names exported by
@@ -118,7 +119,7 @@ flag is set (see the description of
 .B \-custom
 below).
 
-Arguments ending in .o or.a are assumed to be C object files and
+Arguments ending in .o or .a are assumed to be C object files and
 libraries. They are passed to the C linker when linking in 
 .B \-custom
 mode (see the description of 
diff --git a/man/ocamldoc.m b/man/ocamldoc.m
index 26000f37d..fbffa7496 100644
--- a/man/ocamldoc.m
+++ b/man/ocamldoc.m
@@ -301,6 +301,13 @@ Use
 as the title for the generated documentation.
 
 .TP
+.BI \-intro \ file
+Use content of
+.I file
+as ocamldoc text to use as introduction (HTML, \LaTeX and TeXinfo only).
+For HTML, the file is used to create the whole "index.html" file.
+
+.TP
 .B \-v
 Verbose mode. Display progress information.
 
@@ -490,7 +497,7 @@ option:
 
 .TP
 .B \-man-mini
-Generate man pages only for modules, module types, clases and class types,
+Generate man pages only for modules, module types, classes and class types,
 instead of pages for all elements.
 
 .TP
diff --git a/man/ocamlopt.m b/man/ocamlopt.m
index 6ef10f811..da7c59974 100644
--- a/man/ocamlopt.m
+++ b/man/ocamlopt.m
@@ -44,7 +44,8 @@ The
 command has a command-line interface very close to that
 of 
 .BR ocamlc (1).
-It accepts the same types of arguments:
+It accepts the same types of arguments and processes them
+sequentially:
 
 Arguments ending in .mli are taken to be source files for
 compilation unit interfaces. Interfaces specify the names exported by
diff --git a/man/ocamlprof.m b/man/ocamlprof.m
index 0e1a68092..abc5301dd 100644
--- a/man/ocamlprof.m
+++ b/man/ocamlprof.m
@@ -41,7 +41,7 @@ The default is the file ocamlprof.dump in the current directory.
 Specifies an additional string to be output with profiling information.
 By default,
 .B ocamlprof
-will annotate progams with comments of the form
+will annotate programs with comments of the form
 .BI (* \ n \ *)
 where
 .I n
diff --git a/ocamldoc/.depend b/ocamldoc/.depend
index 46b98481e..d8c49f427 100644
--- a/ocamldoc/.depend
+++ b/ocamldoc/.depend
@@ -1,3 +1,11 @@
+odoc.cmo: ../utils/clflags.cmo ../utils/config.cmi ../utils/misc.cmi \
+    odoc_analyse.cmi odoc_args.cmi odoc_config.cmi odoc_dot.cmo \
+    odoc_global.cmi odoc_html.cmo odoc_info.cmi odoc_latex.cmo odoc_man.cmo \
+    odoc_messages.cmo odoc_texi.cmo ../typing/typedtree.cmi 
+odoc.cmx: ../utils/clflags.cmx ../utils/config.cmx ../utils/misc.cmx \
+    odoc_analyse.cmx odoc_args.cmx odoc_config.cmx odoc_dot.cmx \
+    odoc_global.cmx odoc_html.cmx odoc_info.cmx odoc_latex.cmx odoc_man.cmx \
+    odoc_messages.cmx odoc_texi.cmx ../typing/typedtree.cmx 
 odoc_analyse.cmo: ../utils/ccomp.cmi ../utils/clflags.cmo ../utils/config.cmi \
     ../typing/ctype.cmi ../typing/env.cmi ../typing/includemod.cmi \
     ../parsing/lexer.cmi ../parsing/location.cmi ../utils/misc.cmi \
@@ -44,14 +52,14 @@ odoc_class.cmo: odoc_name.cmi odoc_parameter.cmo odoc_types.cmi \
     odoc_value.cmo ../typing/types.cmi 
 odoc_class.cmx: odoc_name.cmx odoc_parameter.cmx odoc_types.cmx \
     odoc_value.cmx ../typing/types.cmx 
-odoc_comments_global.cmo: odoc_comments_global.cmi 
-odoc_comments_global.cmx: odoc_comments_global.cmi 
 odoc_comments.cmo: odoc_comments_global.cmi odoc_global.cmi odoc_lexer.cmo \
     odoc_messages.cmo odoc_parser.cmi odoc_see_lexer.cmo odoc_text.cmi \
     odoc_types.cmi odoc_comments.cmi 
 odoc_comments.cmx: odoc_comments_global.cmx odoc_global.cmx odoc_lexer.cmx \
     odoc_messages.cmx odoc_parser.cmx odoc_see_lexer.cmx odoc_text.cmx \
     odoc_types.cmx odoc_comments.cmi 
+odoc_comments_global.cmo: odoc_comments_global.cmi 
+odoc_comments_global.cmx: odoc_comments_global.cmi 
 odoc_config.cmo: ../utils/config.cmi odoc_config.cmi 
 odoc_config.cmx: ../utils/config.cmx odoc_config.cmi 
 odoc_cross.cmo: odoc_class.cmo odoc_exception.cmo odoc_messages.cmo \
@@ -122,14 +130,6 @@ odoc_misc.cmo: ../typing/btype.cmi ../typing/ctype.cmi ../typing/ident.cmi \
 odoc_misc.cmx: ../typing/btype.cmx ../typing/ctype.cmx ../typing/ident.cmx \
     ../parsing/longident.cmx odoc_messages.cmx odoc_types.cmx \
     ../typing/path.cmx ../typing/types.cmx odoc_misc.cmi 
-odoc.cmo: ../utils/clflags.cmo ../utils/config.cmi ../utils/misc.cmi \
-    odoc_analyse.cmi odoc_args.cmi odoc_config.cmi odoc_dot.cmo \
-    odoc_global.cmi odoc_html.cmo odoc_info.cmi odoc_latex.cmo odoc_man.cmo \
-    odoc_messages.cmo odoc_texi.cmo ../typing/typedtree.cmi 
-odoc.cmx: ../utils/clflags.cmx ../utils/config.cmx ../utils/misc.cmx \
-    odoc_analyse.cmx odoc_args.cmx odoc_config.cmx odoc_dot.cmx \
-    odoc_global.cmx odoc_html.cmx odoc_info.cmx odoc_latex.cmx odoc_man.cmx \
-    odoc_messages.cmx odoc_texi.cmx ../typing/typedtree.cmx 
 odoc_module.cmo: odoc_class.cmo odoc_exception.cmo odoc_name.cmi \
     odoc_type.cmo odoc_types.cmi odoc_value.cmo ../typing/types.cmi 
 odoc_module.cmx: odoc_class.cmx odoc_exception.cmx odoc_name.cmx \
@@ -188,14 +188,14 @@ odoc_test.cmo: odoc_info.cmi
 odoc_test.cmx: odoc_info.cmx 
 odoc_texi.cmo: odoc_info.cmi odoc_messages.cmo odoc_to_text.cmo 
 odoc_texi.cmx: odoc_info.cmx odoc_messages.cmx odoc_to_text.cmx 
-odoc_text_lexer.cmo: odoc_text_parser.cmi 
-odoc_text_lexer.cmx: odoc_text_parser.cmx 
 odoc_text.cmo: odoc_text_lexer.cmo odoc_text_parser.cmi odoc_types.cmi \
     odoc_text.cmi 
 odoc_text.cmx: odoc_text_lexer.cmx odoc_text_parser.cmx odoc_types.cmx \
     odoc_text.cmi 
-odoc_text_parser.cmo: odoc_types.cmi odoc_text_parser.cmi 
-odoc_text_parser.cmx: odoc_types.cmx odoc_text_parser.cmi 
+odoc_text_lexer.cmo: odoc_text_parser.cmi 
+odoc_text_lexer.cmx: odoc_text_parser.cmx 
+odoc_text_parser.cmo: odoc_misc.cmi odoc_types.cmi odoc_text_parser.cmi 
+odoc_text_parser.cmx: odoc_misc.cmx odoc_types.cmx odoc_text_parser.cmi 
 odoc_to_text.cmo: odoc_info.cmi odoc_messages.cmo 
 odoc_to_text.cmx: odoc_info.cmx odoc_messages.cmx 
 odoc_type.cmo: odoc_name.cmi odoc_types.cmi ../typing/types.cmi 
diff --git a/ocamldoc/Changes.txt b/ocamldoc/Changes.txt
index 1f9a41d05..e4b6bfe5b 100644
--- a/ocamldoc/Changes.txt
+++ b/ocamldoc/Changes.txt
@@ -1,65 +1,71 @@
-Current :
-OK - latex: style latex pour indenter dans les module kind et les class kind
-OK - latex: il manque la génération des paramètres de classe
-OK - parse des {!modules: } et {!indexlist}
-OK - gestion des Module_list et Index_list
-OK - no need to Dynlink.add_available_units any more
-OK - generate html from module_kind rather than from module_type
-OK   + same for classes and class types
-OK - add the kind to module parameters (the way the parameter was build in the parsetree)
-OK - fix: the generated ocamldoc.sty is more robust for paragraphs in
+TODO:
+ - need to fix display of type parameters for inherited classes/class types
+ - latex: types variant polymorphes dépassent de la page quand ils sont trop longs
+ - utilisation nouvelles infos de Xavier: "début de rec", etc.
+
+=====
+Release 3.08:
+ - fix: method parameters names in signature are now retrieved correctly
+   (fix of Odoc_value.parameter_list_from_arrows to handle Tpoly for methods)
+ - ajout à la doc de Module_list et Index_list (utilisé dans le html seulement)
+ - ajout à la doc: fichier de l'option -intro utilisé pour l'index en html
+ - fix: create a Module_with instead of a Module_alias when we encounter
+     module A : Foo in a signature
+ - latex: style latex pour indenter dans les module kind et les class kind
+ - latex: il manque la génération des paramètres de classe
+ - parse des {!modules: } et {!indexlist}
+ - gestion des Module_list et Index_list
+ - no need to Dynlink.add_available_units any more
+ - generate html from module_kind rather than from module_type
+   + same for classes and class types
+ - add the kind to module parameters (the way the parameter was build in the parsetree)
+ - fix: the generated ocamldoc.sty is more robust for paragraphs in
      ocamldocdescription environment
-OK - fix: when generating separated files in latex, generate them in
+ - fix: when generating separated files in latex, generate them in
      the same directory than the main file, (the one specified by -o)
-OK - mod: one section per to module in latex output + improve latex output
-OK - mod: odoc_latex: use buffers instead of string concatenation
-OK - add: new ocamldoc man page, thanks to Samuel Mimram
-OK - fix: useless parenthesis around agruments of arguments of a type constructor in
+ - mod: one section per to module in latex output + improve latex output
+ - mod: odoc_latex: use buffers instead of string concatenation
+ - add: new ocamldoc man page, thanks to Samuel Mimram
+ - fix: useless parenthesis around agruments of arguments of a type constructor in
      type definitions, and aournd arguments of exceptions in exception definitions.
-OK - fix: blank lines in verbatim, latex, code pre, code and ele ref modes
+ - fix: blank lines in verbatim, latex, code pre, code and ele ref modes
      are now accepted
-OK - fix: html generator: included module names were displayed with their simple
+ - fix: html generator: included module names were displayed with their simple
      name rather than their fully qualified name
-OK - fix: use a formatter from a buffer rather Format.str_formatter in
+ - fix: use a formatter from a buffer rather Format.str_formatter in
      Odoc_mist.sting_of_module_type, to avoid too much blanks
-OK - new module odoc_print, will work when Format.pp_print_flush is fixed
-OK - odoc_html: use buffers instead of string concatenation
-OK - odoc_man: use buffers instead of string concatenation
-OK - odoc_cross.ml: use hash tables modified on the fly to resolve 
+ - new module odoc_print, will work when Format.pp_print_flush is fixed
+ - odoc_html: use buffers instead of string concatenation
+ - odoc_man: use buffers instead of string concatenation
+ - odoc_cross.ml: use hash tables modified on the fly to resolve 
     (module | module type | exception) name aliases
-OK - odoc_html: replace some calls to Str. by specific functions on strings
-OK - odoc_cross.ml: use a Map to associate a complete name to
+ - odoc_html: replace some calls to Str. by specific functions on strings
+ - odoc_cross.ml: use a Map to associate a complete name to
     the known elements with this name, instead of searching each time
     through the whole list of modules -> a gain of more than 90% in speed
     for cross-referencing (Odoc_cross.associate)
-OK - fix: Odoc_name.cut printed a '(' instead of a '.' OK - add: new option -customdir
-OK - add: new option -i (to add a path to the directory where 
+ - fix: Odoc_name.cut printed a '(' instead of a '.' 
+ - add: new option -customdir
+ - add: new option -i (to add a path to the directory where 
      to look for custom generators)
-OK - add: add odoc_config.ml{,i}
-OK - add: keep_code in Odoc_info.Args interface
-OK - add: m_code_intf and m_code fields for modules, fit when the
+ - add: add odoc_config.ml{,i}
+ - add: keep_code in Odoc_info.Args interface
+ - add: m_code_intf and m_code fields for modules, fit when the
    Odoc_args.keep_code option is set, and fit for all modules, not
    only toplevel ones
-OK - fix: bug preventing to get the code in a .mli
-OK - fix: missing spaces after carriage return in types (Odoc_misc.string_of_type_expr)
-OK - fixes: some bugs in the text parser 
+ - fix: bug preventing to get the code in a .mli
+ - fix: missing spaces after carriage return in types (Odoc_misc.string_of_type_expr)
+ - fixes: some bugs in the text parser 
      ( ]} meaning end of code and somehting else instead of end of precode)
-OK - add: in Odoc_info: text_of_string, text_string_of_text, info_of_string
-OK - fix: better output of titles in html (use more the style)
-OK - add: -intro option to use a file content as ocamldoc comment to use as
-OK   introduction for LaTeX document and HTML index page
-OK - add: the HTML generator generates the code of the module if available
-OK - add: field m_code for modules, to keep the code of top modules
-OK - fix: display "include Foo" instead of "include module Foo" in Latex, Man, Texi
-OK - fix: not display comments associated to include directives
-OK - fix: bad display of type parameters for class and class types
-
-TODO:
- - need to fix display of type parameters for inherited classes/class types
- - latex: types variant polymorphes dépassent de la page quand ils sont trop longs
- - ajout à la doc de Module_list et Index_list (utilisé dans le html seulement)
- - ajout ds la doc: fichier de l'option -intro utilisé pour l'index en html
- - utilisation nouvelles infos de Xavier: "début de rec", etc.
+ - add: in Odoc_info: text_of_string, text_string_of_text, info_of_string
+ - fix: better output of titles in html (use more the style)
+ - add: -intro option to use a file content as ocamldoc comment to use as
+   introduction for LaTeX document and HTML index page
+ - add: the HTML generator generates the code of the module if available
+ - add: field m_code for modules, to keep the code of top modules
+ - fix: display "include Foo" instead of "include module Foo" in Latex, Man, Texi
+ - fix: not display comments associated to include directives
+ - fix: bad display of type parameters for class and class types
 
 ======
 
diff --git a/ocamldoc/ocamldoc.hva b/ocamldoc/ocamldoc.hva
index c78417f36..454cee9e7 100644
--- a/ocamldoc/ocamldoc.hva
+++ b/ocamldoc/ocamldoc.hva
@@ -7,4 +7,13 @@
 \newcommand\textasciicircum{\^{}}
 \newcommand\sharp{#}
 
-
+\let\ocamldocvspace\vspace
+\newenvironment{ocamldocindent}{\list{}{}\item\relax}{\endlist}
+\newenvironment{ocamldocsigend}
+     {\noindent\quad\texttt{sig}\ocamldocindent}
+     {\endocamldocindent\vskip -\lastskip
+      \noindent\quad\texttt{end}\medskip}
+\newenvironment{ocamldocobjectend}
+     {\noindent\quad\texttt{object}\ocamldocindent}
+     {\endocamldocindent\vskip -\lastskip
+      \noindent\quad\texttt{end}\medskip}
diff --git a/ocamldoc/odoc.ml b/ocamldoc/odoc.ml
index f4970bfd5..1d4df9c6a 100644
--- a/ocamldoc/odoc.ml
+++ b/ocamldoc/odoc.ml
@@ -38,7 +38,7 @@ let (cmo_or_cma_opt, paths) =
     | _ :: q ->
         iter (f_opt, inc) q
   in
-  iter (None, [Odoc_config.custom_generators_path]) arg_list
+  iter (None, []) arg_list
 
 let _ = print_DEBUG "Fin analyse des arguments pour le dynamic load"
 
@@ -50,7 +50,7 @@ let get_real_filename name =
      name
    else
      (
-      let paths = Filename.current_dir_name :: paths in
+      let paths = Filename.current_dir_name :: paths @ [Odoc_config.custom_generators_path] in
       try
 	let d = List.find
 	    (fun d -> Sys.file_exists (Filename.concat d name))
diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml
index 518e7f69b..7b8554305 100644
--- a/ocamldoc/odoc_args.ml
+++ b/ocamldoc/odoc_args.ml
@@ -12,6 +12,7 @@
 (* cvsid $Id$ *)
 
 (** Command-line arguments. *)
+
 open Clflags
 
 module M = Odoc_messages
@@ -37,7 +38,7 @@ let dot_types = ref false
 
 let dot_reduce = ref false
 
-let dot_colors  = ref M.default_dot_colors
+let dot_colors  = ref (List.flatten M.default_dot_colors)
 
 let man_suffix = ref M.default_man_suffix
 
@@ -224,7 +225,9 @@ let options = ref [
   "-t", Arg.String (fun s -> title := Some s), M.option_title ;
   "-intro", Arg.String (fun s -> intro_file := Some s), M.option_intro ;
   "-hide", Arg.String add_hidden_modules, M.hide_modules ;
-  "-m", Arg.String (fun s -> merge_options := !merge_options @ (analyse_merge_options s)), M.merge_options^"\n" ;
+  "-m", Arg.String (fun s -> merge_options := !merge_options @ (analyse_merge_options s)), 
+  M.merge_options ^
+  "\n\n *** choosing a generator ***\n";
 
 (* generators *)
   "-html", Arg.Unit (fun () -> set_doc_generator !default_html_generator), M.generate_html ;
@@ -237,13 +240,15 @@ let options = ref [
   "-i", Arg.String (fun s -> if !bytecode_mode then () else (prerr_endline (M.option_not_in_native_code "-i"); exit 1)),
   M.add_load_dir ;
   "-g", Arg.String (fun s -> if !bytecode_mode then () else (prerr_endline (M.option_not_in_native_code "-g"); exit 1)),
-  M.load_file^"\n" ;
+  M.load_file ^
+  "\n\n *** HTML options ***\n";
 
 (* html only options *)
   "-all-params", Arg.Set with_parameter_list, M.with_parameter_list ;
   "-css-style", Arg.String (fun s -> css_style := Some s), M.css_style ;
   "-index-only", Arg.Set index_only, M.index_only ;
-  "-colorize-code", Arg.Set colorize_code, M.colorize_code^"\n" ;
+  "-colorize-code", Arg.Set colorize_code, M.colorize_code ^
+  "\n\n *** LaTeX options ***\n";
 
 (* latex only options *)
   "-noheader", Arg.Unit (fun () -> with_header := false), M.no_header ;
@@ -259,19 +264,24 @@ let options = ref [
   "-latex-module-type-prefix", Arg.String (fun s -> latex_module_type_prefix := s), M.latex_module_type_prefix ;
   "-latex-class-prefix", Arg.String (fun s -> latex_class_prefix := s), M.latex_class_prefix ;
   "-latex-class-type-prefix", Arg.String (fun s -> latex_class_type_prefix := s), M.latex_class_type_prefix ;
-  "-notoc", Arg.Unit (fun () -> with_toc := false), M.no_toc^"\n" ;
+  "-notoc", Arg.Unit (fun () -> with_toc := false), 
+  M.no_toc ^
+  "\n\n *** texinfo options ***\n";
 
 (* tex only options *)
   "-noindex", Arg.Clear with_index, M.no_index ;
   "-esc8", Arg.Set esc_8bits, M.esc_8bits ;
   "-info-section", Arg.String ((:=) info_section), M.info_section ;
-  "-info-entry", Arg.String (fun s -> info_entry := !info_entry @ [ s ]), M.info_entry ;
+  "-info-entry", Arg.String (fun s -> info_entry := !info_entry @ [ s ]), 
+  M.info_entry ^ 
+  "\n\n *** dot options ***\n";
 
 (* dot only options *)
   "-dot-colors", Arg.String (fun s -> dot_colors := Str.split (Str.regexp_string ",") s), M.dot_colors ;
   "-dot-include-all", Arg.Set dot_include_all, M.dot_include_all ;
   "-dot-types", Arg.Set dot_types, M.dot_types ;
-  "-dot-reduce", Arg.Set dot_reduce, M.dot_reduce ;
+  "-dot-reduce", Arg.Set dot_reduce, M.dot_reduce^
+  "\n\n *** man pages options ***\n";
 
 (* man only options *)
   "-man-mini", Arg.Set man_mini, M.man_mini ;
diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml
index cbba5228f..98fb090ee 100644
--- a/ocamldoc/odoc_html.ml
+++ b/ocamldoc/odoc_html.ml
@@ -2408,7 +2408,6 @@ class html =
 	  (fun acc mt -> StringSet.add mt.mt_name acc) 
 	  known_modules_names 
 	  module_types ;
-
       (* generate html for each module *)
       if not !Args.index_only then 
         self#generate_elements self#generate_for_module module_list ;
diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml
index 757b83797..2363ea127 100644
--- a/ocamldoc/odoc_latex.ml
+++ b/ocamldoc/odoc_latex.ml
@@ -560,7 +560,7 @@ class latex =
               e :: (iter q)
         in
         (iter defs2) @
-        [Latex ("\\index{"^(self#type_label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @
+        [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @
         (self#text_of_info t.ty_info)
       in
       self#latex_of_text fmt
@@ -700,16 +700,18 @@ class latex =
 	  self#latex_of_text fmt [Latex "\\end{ocamldocobjectend}\n"]
 
     method latex_for_module_index fmt m =
+      let s_name = Name.simple m.m_name in
       self#latex_of_text fmt 
-	[Latex ("\\index{"^(self#module_label m.m_name)^"@\\verb`"^
-		(self#label ~no_:false m.m_name)^"`}\n"
+	[Latex ("\\index{"^(self#label s_name)^"@\\verb`"^
+		(self#label ~no_:false s_name)^"`}\n"
 	       )
 	]
 
     method latex_for_module_type_index fmt mt =
+      let s_name = Name.simple mt.mt_name in
       self#latex_of_text fmt 
-	[Latex ("\\index{"^(self#module_type_label mt.mt_name)^"@\\verb`"^
-		(self#label ~no_:false mt.mt_name)^"`}\n"
+	[Latex ("\\index{"^(self#label s_name)^"@\\verb`"^
+		(self#label ~no_:false (Name.simple s_name))^"`}\n"
 	       )
 	]
 
@@ -721,16 +723,18 @@ class latex =
 
 
     method latex_for_class_index fmt c =
+      let s_name = Name.simple c.cl_name in
       self#latex_of_text fmt 
-	[Latex ("\\index{"^(self#class_label c.cl_name)^"@\\verb`"^
-		(self#label ~no_:false c.cl_name)^"`}\n"
+	[Latex ("\\index{"^(self#label s_name)^"@\\verb`"^
+		(self#label ~no_:false s_name)^"`}\n"
 	       )
 	]
 
     method latex_for_class_type_index fmt ct =
+      let s_name = Name.simple ct.clt_name in
       self#latex_of_text fmt 
-	[Latex ("\\index{"^(self#class_type_label ct.clt_name)^"@\\verb`"^
-		(self#label ~no_:false ct.clt_name)^"`}\n"
+	[Latex ("\\index{"^(self#label s_name)^"@\\verb`"^
+		(self#label ~no_:false s_name)^"`}\n"
 	       )
 	]
 
diff --git a/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml
index bac8df08f..bb5d73d42 100644
--- a/ocamldoc/odoc_messages.ml
+++ b/ocamldoc/odoc_messages.ml
@@ -23,7 +23,7 @@ let message_version = software^" "^config_version
 
 let usage = "Usage : "^(Sys.argv.(0))^" [options] <files>\n"
 let options_are = "Options are :"
-let option_version = " Print version and exit"
+let option_version = "\tPrint version and exit"
 let bytecode_only = "(bytecode version only)"
 let latex_only = "(LaTeX only)"
 let texi_only = "(TeXinfo only)"
@@ -32,100 +32,130 @@ let html_only = "(HTML only)"
 let html_latex_only = "(HTML and LaTeX only)"
 let html_latex_texi_only = "(HTML, LaTeX and TeXinfo only)"
 let man_only = "(man only)"
-let verbose_mode = " verbose mode"
-let include_dirs = "<dir>  Add <dir> to the list of include directories"
-let rectypes = " Allow arbitrary recursive types"
-let preprocess = "<command>  Pipe sources through preprocessor <command>"
-let display_custom_generators_dir = " Display custom generators standard directory and exit"
-let add_load_dir = "<dir>  Add the given directory to the search path for custom generators "^bytecode_only
-let load_file = "<file.cm[o|a]>  Load file defining a new documentation generator "^bytecode_only
-let nolabels = " Ignore non-optional labels in types"
-let werr = "Treat ocamldoc warnings as errors"
-let target_dir = "<dir>  Generate files in directory <dir>, rather than in current directory (for man and HTML generators)"
-let dump = "<file>  Dump collected information into <file>"
-let load = "<file>  Load information from <file> ; may be used several times"
-let css_style = "<file>  Use content of <file> as CSS style definition "^html_only
-let index_only = " Generate index files only "^html_only
-let colorize_code = "Colorize code even in documentation pages "^html_only
-let generate_html = " Generate HTML documentation"
-let generate_latex = " Generate LaTeX documentation"
-let generate_texinfo = " Generate TeXinfo documentation"
-let generate_man = " Generate man pages"
-let generate_dot = " Generate dot code of top modules dependencies"
+let verbose_mode = "\t\tverbose mode"
+let include_dirs = "<dir>\tAdd <dir> to the list of include directories"
+let rectypes = "\tAllow arbitrary recursive types"
+let preprocess = "<command>\tPipe sources through preprocessor <command>"
+let display_custom_generators_dir = "\tDisplay custom generators standard directory and exit"
+let add_load_dir = "<dir>\tAdd the given directory to the search path for custom\n"^
+  "\t\tgenerators "^bytecode_only
+let load_file = "<file.cm[o|a]>\n\t\tLoad file defining a new documentation generator\n\t\t"^bytecode_only
+let nolabels = "\tIgnore non-optional labels in types"
+let werr = "\tTreat ocamldoc warnings as errors"
+let target_dir = "<dir>\tGenerate files in directory <dir>, rather than in current\n"^
+  "\t\tdirectory (for man and HTML generators)"
+let dump = "<file>\tDump collected information into <file>"
+let load = "<file>\tLoad information from <file> ; may be used several times"
+let css_style = "<file>\n\t\tUse content of <file> as CSS style definition "^html_only
+let index_only = "\tGenerate index files only "^html_only
+let colorize_code = "\n\t\tColorize code even in documentation pages "^html_only
+let generate_html = "\tGenerate HTML documentation"
+let generate_latex = "\tGenerate LaTeX documentation"
+let generate_texinfo = "\tGenerate TeXinfo documentation"
+let generate_man = "\t\tGenerate man pages"
+let generate_dot = "\t\tGenerate dot code of top modules dependencies"
 
 let option_not_in_native_code op = "Option "^op^" not available in native code version."
 
 let default_out_file = "ocamldoc.out"
-let out_file = "<file> Set the ouput file name, used by texi, latex and dot generators "^
-  "(default is "^default_out_file^")"
-
-let dot_include_all = " include all modules in the dot output,\n"^
-  "        not only the modules given on the command line"
-let dot_types = " generate dependency graph for types instead of modules"
-let default_dot_colors = [ "darkturquoise" ; "darkgoldenrod2" ; "cyan" ; "green" ; "magenta" ; "yellow" ;
-                           "burlywood1" ; "aquamarine" ; "floralwhite" ; "lightpink" ;
-                           "lightblue" ; "mediumturquoise" ; "salmon" ; "slategray3" ;
-                         ] 
-let dot_colors = "<c1,c2,...,cn>  use colors c1,c1,...,cn in the dot output\n"^
-  "        (default list is "^(String.concat "," default_dot_colors)^")"
-let dot_reduce = " perform a transitive reduction on the selected dependency graph before the dot output\n"
-
-let man_mini = " Generate man pages only for modules, module types,\n"^
-  "        classes and class types "^man_only
+let out_file = 
+  "<file>\tSet the ouput file name, used by texi, latex and dot generators\n"^
+  "\t\t(default is "^default_out_file^")"
+
+let dot_include_all = 
+  "\n\t\tInclude all modules in the dot output, not only the\n"^
+  "\t\tmodules given on the command line"
+let dot_types = "\tGenerate dependency graph for types instead of modules"
+let default_dot_colors = 
+  [ [ "darkturquoise" ; "darkgoldenrod2" ; "cyan" ; "green" ; ] ;
+    [ "magenta" ; "yellow" ; "burlywood1" ; "aquamarine" ; "floralwhite" ; "lightpink" ] ;
+    [ "lightblue" ; "mediumturquoise" ; "salmon" ; "slategray3"] ;
+  ] 
+
+let dot_colors = 
+  "<c1,c2,...,cn>\n\t\tUse colors c1,c1,...,cn in the dot output\n"^
+  "\t\t(default list is "^
+  (String.concat ",\n\t\t" (List.map (String.concat ", ") default_dot_colors))^")"
+
+let dot_reduce = 
+  "\tPerform a transitive reduction on the selected dependency graph\n"^
+  "\t\tbefore the dot output"
+
+let man_mini = "\tGenerate man pages only for modules, module types, classes\n"^
+  "\t\tand class types "^man_only
 let default_man_suffix = "o"
-let man_suffix = "<suffix>  use <suffix> for man page files "^
+let man_suffix = "<suffix>\n\t\tUse <suffix> for man page files "^
   "(default is "^default_man_suffix^") "^man_only^"\n"
 
-let option_title = "<title>  use <title> as title for the generated documentation"
+let option_title = "<title>\tUse <title> as title for the generated documentation"
 let option_intro = 
-  "<file>  use content of <file> as ocamldoc text to use as introduction "^(html_latex_texi_only)
-let with_parameter_list = " display the complete list of parameters for functions and methods "^html_only
-let hide_modules = " <M1,M2.M3,...> Hide the given complete module names in generated doc"
-let no_header = " Suppress header in generated documentation "^latex_texi_only
-let no_trailer = " Suppress trailer in generated documentation "^latex_texi_only
-let separate_files = " Generate one file per toplevel module "^latex_only
+  "<file>\tUse content of <file> as ocamldoc text to use as introduction\n"^
+  "\t\t"^(html_latex_texi_only)
+let with_parameter_list = "\tDisplay the complete list of parameters for functions and\n"^
+  "\t\tmethods "^html_only
+let hide_modules = "<M1,M2.M3,...>\n\t\tHide the given complete module names in generated doc"
+let no_header = "\tSuppress header in generated documentation\n\t\t"^latex_texi_only
+let no_trailer = "\tSuppress trailer in generated documentation\n\t\t"^latex_texi_only
+let separate_files = "\tGenerate one file per toplevel module "^latex_only
 let latex_title ref_titles = 
-  "n,style  associate {n } to the given sectionning style\n"^
-  "              (e.g. 'section') in the latex output "^latex_only^"\n"^
-  "              Default sectionning is:\n"^
-  (String.concat "\n"
-     (List.map (fun (n,t) -> Printf.sprintf "                %d -> %s" n t) !ref_titles))
+  "n,style\n\t\tAssociate {n } to the given sectionning style\n"^
+  "\t\t(e.g. 'section') in the latex output "^latex_only^"\n"^
+  "\t\tDefault sectionning is:\n\t\t"^
+  (String.concat "\n\t\t"
+     (List.map (fun (n,t) -> Printf.sprintf " %d -> %s" n t) !ref_titles))
 
 let default_latex_value_prefix = "val:"
-let latex_value_prefix = "<string>  use <string> as prefix for the LaTeX labels of values. "^
-  "(default is \""^default_latex_value_prefix^"\")"
+let latex_value_prefix = 
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of values.\n"^
+  "\t\t(default is \""^default_latex_value_prefix^"\")"
+
 let default_latex_type_prefix = "type:"
-let latex_type_prefix = "<string>  use <string> as prefix for the LaTeX labels of types. "^
-  "(default is \""^default_latex_type_prefix^"\")"
+let latex_type_prefix = 
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of types.\n"^
+  "\t\t(default is \""^default_latex_type_prefix^"\")"
+
 let default_latex_exception_prefix = "exception:"
-let latex_exception_prefix = "<string>  use <string> as prefix for the LaTeX labels of exceptions. "^
-  "(default is \""^default_latex_exception_prefix^"\")"
+let latex_exception_prefix = 
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of exceptions.\n"^
+  "\t\t(default is \""^default_latex_exception_prefix^"\")"
+
 let default_latex_module_prefix = "module:"
-let latex_module_prefix = "<string>  use <string> as prefix for the LaTeX labels of modules. "^
-  "(default is \""^default_latex_module_prefix^"\")"
+let latex_module_prefix = 
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of modules.\n"^
+  "\t\t(default is \""^default_latex_module_prefix^"\")"
+
 let default_latex_module_type_prefix = "moduletype:"
-let latex_module_type_prefix = "<string>  use <string> as prefix for the LaTeX labels of module types. "^
-  "(default is \""^default_latex_module_type_prefix^"\")"
+let latex_module_type_prefix = 
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of module types.\n"^
+  "\t\t(default is \""^default_latex_module_type_prefix^"\")"
+
 let default_latex_class_prefix = "class:"
-let latex_class_prefix = "<string>  use <string> as prefix for the LaTeX labels of classes. "^
-  "(default is \""^default_latex_class_prefix^"\")"
+let latex_class_prefix = 
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of classes.\n"^
+  "\t\t(default is \""^default_latex_class_prefix^"\")"
+
 let default_latex_class_type_prefix = "classtype:"
-let latex_class_type_prefix = "<string>  use <string> as prefix for the LaTeX labels of class types. "^
-  "(default is \""^default_latex_class_type_prefix^"\")"
+let latex_class_type_prefix = 
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of class types.\n"^
+  "\t\t(default is \""^default_latex_class_type_prefix^"\")"
+
 let default_latex_attribute_prefix = "val:"
-let latex_attribute_prefix = "<string>  use <string> as prefix for the LaTeX labels of attributes. "^
-  "(default is \""^default_latex_attribute_prefix^"\")"
+let latex_attribute_prefix = 
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of attributes.\n"^
+  "\t\t(default is \""^default_latex_attribute_prefix^"\")"
+
 let default_latex_method_prefix = "method:"
-let latex_method_prefix = "<string>  use <string> as prefix for the LaTeX labels of methods. "^
-  "(default is \""^default_latex_method_prefix^"\")"
-
-let no_toc = " Do not generate table of contents "^latex_only
-let sort_modules = " Sort the list of top modules before generating the documentation"
-let no_stop = " Do not stop at (**/**) comments"
-let no_custom_tags = " Do not allow custom @-tags"
-let remove_stars = " Remove beginning blanks of comment lines, until the first '*'"
-let keep_code = " Always keep code when available"
-let inverse_merge_ml_mli = "Inverse implementations and interfaces when merging"
+let latex_method_prefix = 
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of methods.\n"^
+  "\t\t(default is \""^default_latex_method_prefix^"\")"
+
+let no_toc = "\tDo not generate table of contents "^latex_only
+let sort_modules = "\tSort the list of top modules before generating the documentation"
+let no_stop = "\tDo not stop at (**/**) comments"
+let no_custom_tags = "\n\t\tDo not allow custom @-tags"
+let remove_stars = "\tRemove beginning blanks of comment lines, until the first '*'"
+let keep_code = "\tAlways keep code when available"
+let inverse_merge_ml_mli = "\n\t\tInverse implementations and interfaces when merging"
 let merge_description = ('d', "merge description")
 let merge_author = ('a', "merge @author")
 let merge_version = ('v', "merge @version")
@@ -138,19 +168,19 @@ let merge_return_value = ('r', "merge @return")
 let merge_custom = ('c', "merge custom @-tags")
 let merge_all = ('A', "merge all")
 
-let no_index = " Do not build index for Info files "^texi_only
-let esc_8bits = " Escape accentuated characters in Info files "^texi_only
+let no_index = "\tDo not build index for Info files "^texi_only
+let esc_8bits = "\tEscape accentuated characters in Info files "^texi_only
 let info_section = "Specify section of Info directory "^texi_only
-let info_entry = "Specify Info directory entry "^texi_only^"\n"
+let info_entry = "\tSpecify Info directory entry "^texi_only
 
-let options_can_be = "        <options> can be one or more of the following characters:"
+let options_can_be = "<options> can be one or more of the following characters:"
 let string_of_options_list l = 
-  List.fold_left (fun acc -> fun (c, m) -> acc^"\n        "^(String.make 1 c)^"  "^m)
+  List.fold_left (fun acc -> fun (c, m) -> acc^"\n\t\t"^(String.make 1 c)^"  "^m)
     ""
     l
 
 let merge_options = 
-  "<options>  specify merge options between .mli and .ml\n"^
+  "<options>\tspecify merge options between .mli and .ml\n\t\t"^
   options_can_be^
   (string_of_options_list
      [ merge_description ;
@@ -179,7 +209,7 @@ let bad_magic_number =
   "This dump was not created by this version of OCamldoc."
 
 let not_a_module_name s = s^" is not a valid module name"
-let load_file_error f e = "Error while loading file "^f^":\n"^e^"\n"
+let load_file_error f e = "Error while loading file "^f^":\n"^e
 let wrong_format s = "Wrong format for \""^s^"\""
 let errors_occured n = (string_of_int n)^" error(s) encountered"
 let parse_error = "Parse error"
@@ -191,7 +221,7 @@ let text_parse_error l c s =
   (String.make c ' ')^"^"
 
 let file_not_found_in_paths paths name =
-  Printf.sprintf "No file %s was found in the load paths: \n%s\n"
+  Printf.sprintf "No file %s found in the load paths: \n%s"
     name
     (String.concat "\n" paths)
 
diff --git a/ocamldoc/odoc_module.ml b/ocamldoc/odoc_module.ml
index a12545b23..f2f457299 100644
--- a/ocamldoc/odoc_module.ml
+++ b/ocamldoc/odoc_module.ml
@@ -205,48 +205,55 @@ let included_modules l =
    @param trans indicates if, for aliased modules, we must perform a transitive search.*)
 let rec module_elements ?(trans=true) m =
   let rec iter_kind = function
-    Module_struct l -> l
-  | Module_alias ma -> 
-      if trans then
-        match ma.ma_module with
-          None -> []
-        | Some (Mod m) -> module_elements m
-        | Some (Modtype mt) -> module_type_elements mt
-      else
-        []
-  | Module_functor (_, k) 
-  | Module_apply (k, _) -> iter_kind k
-  | Module_with (tk,_) ->
-      module_type_elements ~trans: trans
-        { mt_name = "" ; mt_info = None ; mt_type = None ;
-          mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
-          mt_loc = Odoc_types.dummy_loc ;
-        }
-  | Module_constraint (k, tk) ->
+      Module_struct l -> 
+	print_DEBUG "Odoc_module.module_element: Module_struct";
+	l
+    | Module_alias ma -> 
+	print_DEBUG "Odoc_module.module_element: Module_alias";
+	if trans then
+          match ma.ma_module with
+            None -> []
+          | Some (Mod m) -> module_elements m
+          | Some (Modtype mt) -> module_type_elements mt
+	else
+          []
+    | Module_functor (_, k) 
+    | Module_apply (k, _) -> 
+	print_DEBUG "Odoc_module.module_element: Module_functor ou Module_apply";
+	iter_kind k
+    | Module_with (tk,_) ->
+	print_DEBUG "Odoc_module.module_element: Module_with";
+	module_type_elements ~trans: trans
+          { mt_name = "" ; mt_info = None ; mt_type = None ;
+            mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
+            mt_loc = Odoc_types.dummy_loc ;
+          }
+    | Module_constraint (k, tk) ->
+	print_DEBUG "Odoc_module.module_element: Module_constraint";
       (* A VOIR : utiliser k ou tk ? *)
-      module_elements ~trans: trans
-        { m_name = "" ; 
-	  m_info = None ; 
-	  m_type = Types.Tmty_signature [] ;
-          m_is_interface = false ; m_file = "" ; m_kind = k ;
-          m_loc = Odoc_types.dummy_loc ;
-          m_top_deps = [] ;
-	  m_code = None ;
-	  m_code_intf = None ;
-        }
+	module_elements ~trans: trans
+          { m_name = "" ; 
+	    m_info = None ; 
+	    m_type = Types.Tmty_signature [] ;
+            m_is_interface = false ; m_file = "" ; m_kind = k ;
+            m_loc = Odoc_types.dummy_loc ;
+            m_top_deps = [] ;
+	    m_code = None ;
+	    m_code_intf = None ;
+          }
 (*
-      module_type_elements ~trans: trans
-        { mt_name = "" ; mt_info = None ; mt_type = None ;
-          mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
-          mt_loc = Odoc_types.dummy_loc }
+   module_type_elements ~trans: trans
+   { mt_name = "" ; mt_info = None ; mt_type = None ;
+   mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
+   mt_loc = Odoc_types.dummy_loc }
 *)
   in
   iter_kind m.m_kind 
 
 (** Returns the list of elements of a module type. 
-  @param trans indicates if, for aliased modules, we must perform a transitive search.*)
+   @param trans indicates if, for aliased modules, we must perform a transitive search.*)
 and module_type_elements ?(trans=true) mt =
-   let rec iter_kind = function
+  let rec iter_kind = function
     | None -> []
     | Some (Module_type_struct l) -> l
     | Some (Module_type_functor (_, k)) -> iter_kind (Some k)
@@ -256,12 +263,12 @@ and module_type_elements ?(trans=true) mt =
         else
           []
     | Some (Module_type_alias mta) -> 
-       if trans then
-         match mta.mta_module with
-           None -> []
-         | Some mt -> module_type_elements mt
-       else
-        []
+	if trans then
+          match mta.mta_module with
+            None -> []
+          | Some mt -> module_type_elements mt
+	else
+          []
   in
   iter_kind mt.mt_kind
 
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index 20ee0ed69..278afad84 100644
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -332,7 +332,6 @@ module Analyser =
         met.met_value.val_info <- merge_infos met.met_value.val_info info_after_opt ;
         (* update the parameter description *)
         Odoc_value.update_value_parameters_text met.met_value;
-
         (met, maybe_more)
       in
       let rec f last_pos class_type_field_list =
@@ -1121,15 +1120,9 @@ module Analyser =
     (** Analyse of a Parsetree.module_type and a Types.module_type.*)
     and analyse_module_kind env current_module_name module_type sig_module_type =
       match module_type.Parsetree.pmty_desc with
-        Parsetree.Pmty_ident longident (*of Longident.t*) -> 
-          let name = 
-            match sig_module_type with
-              Types.Tmty_ident path -> Name.from_path path
-            | _ -> 
-                Name.from_longident longident 
-          in
-          Module_alias { ma_name = Odoc_env.full_module_or_module_type_name env name ; 
-                         ma_module = None }
+        Parsetree.Pmty_ident longident ->
+	  let k = analyse_module_type_kind env current_module_name module_type sig_module_type in
+          Module_with ( k, "" )
 
       | Parsetree.Pmty_signature signature ->
           (
diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml
index 5eb18ca60..dabf769f6 100644
--- a/ocamldoc/odoc_texi.ml
+++ b/ocamldoc/odoc_texi.ml
@@ -372,7 +372,7 @@ class text =
 
   end
 
-
+exception Aliased_node
 
 (** This class is used to create objects which can generate a simple
     Texinfo documentation. *)
@@ -391,7 +391,15 @@ class texi =
 
     val mutable indices_to_build = [ `Module ]
 
+    (** Keep a set of nodes we create. If we try to create one
+        a second time, that means it is some kind of alias, so
+        don't do it, just link to the previous one *)
+    val node_tbl = Hashtbl.create 37
+
     method node depth name = 
+      if Hashtbl.mem node_tbl name
+      then raise Aliased_node ;
+      Hashtbl.add node_tbl name () ;
       if depth <= maxdepth 
       then Verbatim ("@node " ^ (Texi.fix_nodename name) ^ ",\n")
       else nothing
@@ -414,7 +422,8 @@ class texi =
           (function
             | Newline -> Raw "\n"
             | Raw s -> Raw (Str.global_replace re "\n" s)
-            | List tel | Enum tel -> List (List.map self#fix_linebreaks tel)
+            | List tel -> List (List.map self#fix_linebreaks tel)
+            | Enum tel -> Enum (List.map self#fix_linebreaks tel)
             | te -> te) t
 
     method private soft_fix_linebreaks = 
@@ -863,6 +872,7 @@ class texi =
     (** Generate the Texinfo code for the given class, 
        in the given out channel. *)
     method generate_for_class chanout c =
+     try
       Odoc_info.reset_type_names () ;
       let depth = Name.depth c.cl_name in
       let title = [ 
@@ -888,11 +898,13 @@ class texi =
         (fun ele -> puts chanout
             (self#texi_of_class_element c.cl_name ele))
         (Class.class_elements ~trans:false c)
+     with Aliased_node -> ()
 
 
     (** Generate the Texinfo code for the given class type, 
        in the given out channel. *)
     method generate_for_class_type chanout ct =
+     try
       Odoc_info.reset_type_names () ;
       let depth = Name.depth ct.clt_name in
       let title = [ 
@@ -918,12 +930,13 @@ class texi =
         (fun ele -> puts chanout
             (self#texi_of_class_element ct.clt_name ele))
         (Class.class_type_elements ~trans:false ct)
-
+     with Aliased_node -> ()
 
 
     (** Generate the Texinfo code for the given module type, 
        in the given out channel. *)
     method generate_for_module_type chanout mt =
+     try
       let depth = Name.depth mt.mt_name in
       let title = [ 
         self#node depth mt.mt_name ;
@@ -966,11 +979,12 @@ class texi =
           | `Class c -> self#generate_for_class chanout c
           | `Class_type ct -> self#generate_for_class_type chanout ct)
         subparts
-
+     with Aliased_node -> ()
 
     (** Generate the Texinfo code for the given module, 
        in the given out channel. *)
     method generate_for_module chanout m =
+     try
       Odoc_info.verbose ("Generate for module " ^ m.m_name) ;
       let depth = Name.depth m.m_name in
       let title = [ 
@@ -1015,7 +1029,7 @@ class texi =
           | `Class c -> self#generate_for_class chanout c
           | `Class_type ct -> self#generate_for_class_type chanout ct )
         subparts
-
+     with Aliased_node -> ()
 
 
     (** Writes the header of the TeXinfo document. *)
@@ -1169,6 +1183,7 @@ class texi =
     (** Generate the Texinfo file from a module list, 
        in the {!Odoc_info.Args.out_file} file. *)
     method generate module_list =
+      Hashtbl.clear node_tbl ;
       let filename = 
 	if !Args.out_file = Odoc_messages.default_out_file
 	then "ocamldoc.texi"
diff --git a/ocamldoc/odoc_to_text.ml b/ocamldoc/odoc_to_text.ml
index 426432a65..057b0d89f 100644
--- a/ocamldoc/odoc_to_text.ml
+++ b/ocamldoc/odoc_to_text.ml
@@ -269,7 +269,7 @@ class virtual to_text =
 	Format.flush_str_formatter ()
       in
       [ CodePre s ] @ 
-      [Latex ("\\index{"^(self#label name)^"@\\verb`"^(self#label ~no_:false name)^"`}\n")] @
+      [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @
       (self#text_of_info v.val_info)
 
     (** @return [text] value for a class attribute. *)
diff --git a/ocamldoc/odoc_value.ml b/ocamldoc/odoc_value.ml
index b001f1464..62cf0ccf4 100644
--- a/ocamldoc/odoc_value.ml
+++ b/ocamldoc/odoc_value.ml
@@ -72,7 +72,18 @@ let parameter_list_from_arrows typ =
     match t.Types.desc with
       Types.Tarrow (l, t1, t2, _) ->
         (l, t1) :: (iter t2)
-    | _ ->
+    | Types.Tlink texp 
+    | Types.Tsubst texp ->
+	iter texp
+    | Types.Tpoly (texp, _) -> iter texp
+    | Types.Tvar
+    | Types.Ttuple _ 
+    | Types.Tconstr _ 
+    | Types.Tobject _
+    | Types.Tfield _ 
+    | Types.Tnil
+    | Types.Tunivar
+    | Types.Tvariant _ ->
         []
   in
   iter typ
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 5e543e83c..7567d7362 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -316,6 +316,8 @@ let edit_source ~file ~path ~sign =
 (* List of windows to destroy by Close All *)
 let top_widgets = ref []
 
+let dummy_item = Tsig_modtype (Ident.create "dummy", Tmodtype_abstract)
+
 let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign =
   let env =
     match path with None -> env
@@ -451,7 +453,8 @@ and view_type_decl path ~env =
         {desc = Tobject _} ->
           let clt = find_cltype path env in
           view_signature_item ~path ~env
-            [Tsig_cltype(ident_of_path path ~default:"ct", clt, Trec_first)]
+            [Tsig_cltype(ident_of_path path ~default:"ct", clt, Trec_first);
+             dummy_item; dummy_item]
       | _ -> raise Not_found
   with Not_found ->
     view_signature_item ~path ~env
@@ -464,12 +467,14 @@ and view_type_id li ~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, Trec_first)]
+     [Tsig_class(ident_of_path path ~default:"c", cl, Trec_first);
+      dummy_item; dummy_item; dummy_item]
 
 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, Trec_first)]
+     [Tsig_cltype(ident_of_path path ~default:"ct", clt, Trec_first);
+      dummy_item; dummy_item]
 
 and view_modtype_id li ~env =
   let path, td = lookup_modtype li env in
diff --git a/otherlibs/labltk/camltk/Makefile.gen b/otherlibs/labltk/camltk/Makefile.gen
index 1e4f50a10..d0d81230c 100644
--- a/otherlibs/labltk/camltk/Makefile.gen
+++ b/otherlibs/labltk/camltk/Makefile.gen
@@ -3,7 +3,7 @@ include ../support/Makefile.common
 all: cTk.ml camltk.ml .depend
 
 _tkgen.ml: ../Widgets.src ../compiler/tkcompiler
-	cd ..; ../../boot/ocamlrun compiler/tkcompiler -camltk -outdir camltk
+	cd ..; $(CAMLRUNGEN) compiler/tkcompiler -camltk -outdir camltk
 
 cTk.ml camltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp #../builtin/builtin_*.ml
 	(echo '##define CAMLTK'; \
diff --git a/otherlibs/labltk/labltk/Makefile.gen b/otherlibs/labltk/labltk/Makefile.gen
index a7f85082e..a93fe155b 100644
--- a/otherlibs/labltk/labltk/Makefile.gen
+++ b/otherlibs/labltk/labltk/Makefile.gen
@@ -3,7 +3,7 @@ include ../support/Makefile.common
 all: tk.ml labltk.ml .depend
 
 _tkgen.ml: ../Widgets.src ../compiler/tkcompiler
-	cd ..; ../../boot/ocamlrun compiler/tkcompiler -outdir labltk
+	cd ..; $(CAMLRUNGEN) compiler/tkcompiler -outdir labltk
 
 # dependencies are broken: wouldn't work with gmake 3.77
 
diff --git a/otherlibs/labltk/support/Makefile.common b/otherlibs/labltk/support/Makefile.common
index 8745fee80..7e8bfadba 100644
--- a/otherlibs/labltk/support/Makefile.common
+++ b/otherlibs/labltk/support/Makefile.common
@@ -24,3 +24,4 @@ COMPFLAGS=
 LINKFLAGS=
 CAMLOPTLIBR=$(CAMLOPT) -a
 MKLIB=$(CAMLRUN) $(TOPDIR)/tools/ocamlmklib
+CAMLRUNGEN=../../boot/ocamlrun
diff --git a/otherlibs/systhreads/posix.c b/otherlibs/systhreads/posix.c
index b65534f61..a34266dfa 100644
--- a/otherlibs/systhreads/posix.c
+++ b/otherlibs/systhreads/posix.c
@@ -27,6 +27,7 @@
 #include <sys/time.h>
 #ifdef __linux__
 #include <unistd.h>
+#include <sys/utsname.h>
 #endif
 #include "alloc.h"
 #include "backtrace.h"
@@ -96,12 +97,20 @@ struct caml_thread_struct {
 typedef struct caml_thread_struct * caml_thread_t;
 
 /* The descriptor for the currently executing thread */
-
 static caml_thread_t curr_thread = NULL;
 
-/* The global mutex used to ensure that at most one thread is running
-   Caml code */
-static pthread_mutex_t caml_mutex;
+/* Track whether one thread is running Caml code.  There can be
+   at most one such thread at any time. */
+static volatile int caml_runtime_busy = 1;
+
+/* Number of threads waiting to run Caml code. */
+static volatile int caml_runtime_waiters = 0;
+
+/* Mutex that protects the two variables above. */
+static pthread_mutex_t caml_runtime_mutex = PTHREAD_MUTEX_INITIALIZER;
+
+/* Condition signaled when caml_runtime_busy becomes 0 */
+static pthread_cond_t caml_runtime_is_free = PTHREAD_COND_INITIALIZER;
 
 /* The key used for storing the thread descriptor in the specific data
    of the corresponding Posix thread. */
@@ -113,11 +122,15 @@ static pthread_key_t last_channel_locked_key;
 /* Identifier for next thread creation */
 static long thread_next_ident = 0;
 
+/* Whether to use sched_yield() or not */
+static int broken_sched_yield = 0;
+
 /* Forward declarations */
 value caml_threadstatus_new (void);
 void caml_threadstatus_terminate (value);
 int caml_threadstatus_wait (value);
 static void caml_pthread_check (int, char *);
+static void caml_thread_sysdeps_initialize(void);
 
 /* Imports for the native-code compiler */
 extern struct longjmp_buffer caml_termination_jmpbuf;
@@ -182,14 +195,24 @@ static void caml_thread_enter_blocking_section(void)
   curr_thread->backtrace_buffer = backtrace_buffer;
   curr_thread->backtrace_last_exn = backtrace_last_exn;
 #endif
-  /* Release the global mutex */
-  pthread_mutex_unlock(&caml_mutex);
+  /* Tell other threads that the runtime is free */
+  pthread_mutex_lock(&caml_runtime_mutex);
+  caml_runtime_busy = 0;
+  pthread_mutex_unlock(&caml_runtime_mutex);
+  pthread_cond_signal(&caml_runtime_is_free);
 }
 
 static void caml_thread_leave_blocking_section(void)
 {
-  /* Re-acquire the global mutex */
-  pthread_mutex_lock(&caml_mutex);
+  /* Wait until the runtime is free */
+  pthread_mutex_lock(&caml_runtime_mutex);
+  while (caml_runtime_busy) {
+    caml_runtime_waiters++;
+    pthread_cond_wait(&caml_runtime_is_free, &caml_runtime_mutex);
+    caml_runtime_waiters--;
+  }
+  caml_runtime_busy = 1;
+  pthread_mutex_unlock(&caml_runtime_mutex);
   /* Update curr_thread to point to the thread descriptor corresponding
      to the thread currently executing */
   curr_thread = pthread_getspecific(thread_descriptor_key);
@@ -314,10 +337,8 @@ value caml_thread_initialize(value unit)   /* ML */
   /* Protect against repeated initialization (PR#1325) */
   if (curr_thread != NULL) return Val_unit;
   Begin_root (mu);
-    /* Initialize the main mutex */
-    caml_pthread_check(pthread_mutex_init(&caml_mutex, NULL),
-                       "Thread.init");
-    pthread_mutex_lock(&caml_mutex);
+    /* OS-specific initialization */
+    caml_thread_sysdeps_initialize();
     /* Initialize the keys */
     pthread_key_create(&thread_descriptor_key, NULL);
     pthread_key_create(&last_channel_locked_key, NULL);
@@ -378,9 +399,12 @@ static void caml_thread_stop(void)
   /* Remove th from the doubly-linked list of threads */
   th->next->prev = th->prev;
   th->prev->next = th->next;
-  /* Release the main mutex (forever) */
+  /* Release the runtime system */
   async_signal_mode = 1;
-  pthread_mutex_unlock(&caml_mutex);
+  pthread_mutex_lock(&caml_runtime_mutex);
+  caml_runtime_busy = 0;
+  pthread_mutex_unlock(&caml_runtime_mutex);
+  pthread_cond_signal(&caml_runtime_is_free);
 #ifndef NATIVE_CODE
   /* Free the memory resources */
   stat_free(th->stack_low);
@@ -539,8 +563,9 @@ value caml_thread_exit(value unit)   /* ML */
 
 value caml_thread_yield(value unit)        /* ML */
 {
+  if (caml_runtime_waiters == 0) return Val_unit;
   enter_blocking_section();
-  sched_yield();
+  if (! broken_sched_yield) sched_yield();
   leave_blocking_section();
   return Val_unit;
 }
@@ -820,3 +845,21 @@ static void caml_pthread_check(int retcode, char *msg)
   memmove (&Byte(str, msglen + 2), err, errlen);
   raise_sys_error(str);
 }
+
+/* OS-specific initialization */
+
+static void caml_thread_sysdeps_initialize(void)
+{
+#ifdef __linux__
+  /* sched_yield() doesn't do what we want in kernel 2.6 and up (PR#2663) */
+  struct utsname un;
+  if (uname(&un) == -1) return;
+  broken_sched_yield =
+    un.release[1] != '.' || un.release[0] >= '3'   /* version 3 and up */
+    || (un.release[0] == '2' &&
+        (un.release[3] != '.' || un.release[2] >= '6')); /* 2.6 and up */
+  caml_gc_message(0x100, "POSIX threads.  Avoid sched_yield: %d\n",
+                  broken_sched_yield);
+#endif
+}
+
diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml
index 5d6fd60e0..10320bb60 100644
--- a/otherlibs/threads/pervasives.ml
+++ b/otherlibs/threads/pervasives.ml
@@ -499,12 +499,20 @@ module LargeFile =
 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
 external format_of_string :
  ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 = "%identity"
-external string_of_format : ('a, 'b, 'c, 'd) format4 -> string = "%identity"
-
+external string_of_format_sys :
+ ('a, 'b, 'c, 'd) format4 -> string = "%identity"
 external string_to_format : string -> ('a, 'b, 'c, 'd) format4 = "%identity"
+
 let (( ^^ ) : ('a, 'b, 'c, 'd) format4 -> ('d, 'b, 'c, 'e) format4 ->
               ('a, 'b, 'c, 'e) format4) = fun fmt1 fmt2 ->
-  string_to_format (string_of_format fmt1 ^ string_of_format fmt2);;
+  string_to_format (string_of_format_sys fmt1 ^ string_of_format_sys fmt2);;
+
+let string_of_format f =
+  let s = string_of_format_sys f in
+  let l = string_length s in
+  let r = string_create l in
+  string_blit s 0 r 0 l;
+  r
 
 (* Miscellaneous *)
 
diff --git a/otherlibs/threads/thread.mli b/otherlibs/threads/thread.mli
index 17a6260b3..8da968a80 100644
--- a/otherlibs/threads/thread.mli
+++ b/otherlibs/threads/thread.mli
@@ -70,7 +70,7 @@ val wait_write : Unix.file_descr -> unit
    on the given Unix file descriptor. *)
 
 val wait_timed_read : Unix.file_descr -> float -> bool
-(** See {!Thread.wait_timed_read}.*)
+(** See {!Thread.wait_timed_write}.*)
 
 val wait_timed_write : Unix.file_descr -> float -> bool
 (** Same as {!Thread.wait_read} and {!Thread.wait_write}, but wait for at most
diff --git a/otherlibs/threads/threadUnix.ml b/otherlibs/threads/threadUnix.ml
index 2510bdd99..66a3704c1 100644
--- a/otherlibs/threads/threadUnix.ml
+++ b/otherlibs/threads/threadUnix.ml
@@ -23,6 +23,7 @@ let waitpid = Unix.waitpid
 let system = Unix.system
 let read = Unix.read
 let write = Unix.write
+let single_write = Unix.single_write
 let select = Unix.select
 let pipe = Unix.pipe
 let open_process_in = Unix.open_process_in
diff --git a/otherlibs/threads/threadUnix.mli b/otherlibs/threads/threadUnix.mli
index e0a4a82b7..1b4dde29b 100644
--- a/otherlibs/threads/threadUnix.mli
+++ b/otherlibs/threads/threadUnix.mli
@@ -34,6 +34,7 @@ val system : string -> Unix.process_status
 
 val read : Unix.file_descr -> string -> int -> int -> int
 val write : Unix.file_descr -> string -> int -> int -> int
+val single_write : Unix.file_descr -> string -> int -> int -> int
 
 (** {6 Input/output with timeout} *)
 
diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml
index beec810aa..30c2c58c6 100644
--- a/otherlibs/threads/unix.ml
+++ b/otherlibs/threads/unix.ml
@@ -201,7 +201,10 @@ external openfile : string -> open_flag list -> file_perm -> file_descr
 
 external close : file_descr -> unit = "unix_close"
 external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read"
-external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write"
+external unsafe_write : file_descr -> string -> int -> int -> int
+    = "unix_write"
+external unsafe_single_write : file_descr -> string -> int -> int -> int 
+    = "unix_single_write"
 
 let rec read fd buf ofs len =
   try
@@ -219,6 +222,14 @@ let rec write fd buf ofs len =
   with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
     wait_write fd; write fd buf ofs len
 
+let rec single_write fd buf ofs len =
+  try
+    if ofs < 0 || len < 0 || ofs > String.length buf - len
+    then invalid_arg "Unix.partial_write"
+    else unsafe_single_write fd buf ofs len
+  with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
+    wait_write fd; single_write fd buf ofs len
+
 external in_channel_of_descr : file_descr -> in_channel
                              = "caml_ml_open_descriptor_in"
 external out_channel_of_descr : file_descr -> out_channel
diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend
index 4179e3e9b..045cd7f71 100644
--- a/otherlibs/unix/.depend
+++ b/otherlibs/unix/.depend
@@ -1,233 +1,359 @@
-accept.o: accept.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h unixsupport.h socketaddr.h
-access.o: access.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-addrofstr.o: addrofstr.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h socketaddr.h
-alarm.o: alarm.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+accept.o: accept.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \
+  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \
+  socketaddr.h
+access.o: access.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h
+addrofstr.o: addrofstr.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/fail.h \
+  unixsupport.h socketaddr.h
+alarm.o: alarm.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-bind.o: bind.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+bind.o: bind.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h socketaddr.h
-chdir.o: chdir.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+chdir.o: chdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-chmod.o: chmod.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+chmod.o: chmod.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-chown.o: chown.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+chown.o: chown.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-chroot.o: chroot.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-close.o: close.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+chroot.o: chroot.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-closedir.o: closedir.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-connect.o: connect.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h socketaddr.h
-cst2constr.o: cst2constr.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h cst2constr.h
-cstringv.o: cstringv.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
+close.o: close.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+closedir.o: closedir.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h unixsupport.h
+connect.o: connect.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/signals.h \
+  unixsupport.h socketaddr.h
+cst2constr.o: cst2constr.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/fail.h cst2constr.h
+cstringv.o: cstringv.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/memory.h \
+  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h unixsupport.h
-dup2.o: dup2.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+dup.o: dup.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-dup.o: dup.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+dup2.o: dup2.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-envir.o: envir.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h
-errmsg.o: errmsg.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h
-execv.o: execv.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h
-execve.o: execve.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \
+envir.o: envir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h
+errmsg.o: errmsg.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h
+execv.o: execv.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \
   ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h unixsupport.h
-execvp.o: execvp.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \
+execve.o: execve.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \
   ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h unixsupport.h
-exit.o: exit.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+execvp.o: execvp.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \
+  ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h unixsupport.h
+exit.o: exit.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-fchmod.o: fchmod.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-fchown.o: fchown.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-fcntl.o: fcntl.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+fchmod.o: fchmod.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-fork.o: fork.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+fchown.o: fchown.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-ftruncate.o: ftruncate.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-getaddrinfo.o: getaddrinfo.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h unixsupport.h cst2constr.h socketaddr.h
-getcwd.o: getcwd.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-getegid.o: getegid.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-geteuid.o: geteuid.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-getgid.o: getgid.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-getgr.o: getgr.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.h \
+fcntl.o: fcntl.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+fork.o: fork.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+ftruncate.o: ftruncate.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/io.h unixsupport.h
+getaddrinfo.o: getaddrinfo.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
+  ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \
+  ../../byterun/signals.h unixsupport.h cst2constr.h socketaddr.h
+getcwd.o: getcwd.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h
+getegid.o: getegid.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h unixsupport.h
+geteuid.o: geteuid.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h unixsupport.h
+getgid.o: getgid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+getgr.o: getgr.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/fail.h ../../byterun/alloc.h \
+  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
   ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h
-getgroups.o: getgroups.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-gethost.o: gethost.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h unixsupport.h socketaddr.h
-gethostname.o: gethostname.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-getlogin.o: getlogin.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-getnameinfo.o: getnameinfo.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h unixsupport.h socketaddr.h
-getpeername.o: getpeername.c ../../byterun/config.h ../../config/m.h \
+getgroups.o: getgroups.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h
+gethost.o: gethost.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
+  ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \
+  ../../byterun/signals.h unixsupport.h socketaddr.h
+gethostname.o: gethostname.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h
+getlogin.o: getlogin.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h
+getnameinfo.o: getnameinfo.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
+  ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \
+  ../../byterun/signals.h unixsupport.h socketaddr.h
+getpeername.o: getpeername.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
   ../../config/s.h ../../byterun/misc.h unixsupport.h socketaddr.h
-getpid.o: getpid.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-getppid.o: getppid.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-getproto.o: getproto.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h unixsupport.h
-getpw.o: getpw.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h
-getserv.o: getserv.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h unixsupport.h
-getsockname.o: getsockname.c ../../byterun/config.h ../../config/m.h \
+getpid.o: getpid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+getppid.o: getppid.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h unixsupport.h
+getproto.o: getproto.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
+  ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \
+  unixsupport.h
+getpw.o: getpw.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \
+  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h
+getserv.o: getserv.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
+  ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \
+  unixsupport.h
+getsockname.o: getsockname.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
   ../../config/s.h ../../byterun/misc.h unixsupport.h socketaddr.h
-gettimeofday.o: gettimeofday.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-getuid.o: getuid.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-gmtime.o: gmtime.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
+gettimeofday.o: gettimeofday.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h
+getuid.o: getuid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+gmtime.o: gmtime.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \
+  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h unixsupport.h
-itimer.o: itimer.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
+itimer.o: itimer.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \
+  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h unixsupport.h
-kill.o: kill.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+kill.o: kill.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/fail.h unixsupport.h \
+  ../../byterun/signals.h
+link.o: link.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-link.o: link.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+listen.o: listen.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-listen.o: listen.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-lockf.o: lockf.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+lockf.o: lockf.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/signals.h unixsupport.h
+lseek.o: lseek.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/io.h \
+  unixsupport.h
+mkdir.o: mkdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-lseek.o: lseek.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+mkfifo.o: mkfifo.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-mkdir.o: mkdir.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+nice.o: nice.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-mkfifo.o: mkfifo.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-nice.o: nice.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+open.o: open.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \
+  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h
+opendir.o: opendir.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h
+pipe.o: pipe.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h
+putenv.o: putenv.c ../../byterun/memory.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/misc.h \
+  ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h unixsupport.h
+read.o: read.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \
+  ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h
+readdir.o: readdir.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/fail.h \
+  ../../byterun/alloc.h unixsupport.h
+readlink.o: readlink.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h
+rename.o: rename.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-open.o: open.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h
-opendir.o: opendir.c ../../byterun/config.h ../../config/m.h \
+rewinddir.o: rewinddir.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
   ../../config/s.h ../../byterun/misc.h unixsupport.h
-pipe.o: pipe.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+rmdir.o: rmdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-putenv.o: putenv.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/gc.h ../../byterun/mlvalues.h \
-  ../../byterun/misc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h unixsupport.h
-read.o: read.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h
-readdir.o: readdir.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-readlink.o: readlink.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-rename.o: rename.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-rewinddir.o: rewinddir.c ../../byterun/config.h ../../config/m.h \
+select.o: select.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \
+  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h
+sendrecv.o: sendrecv.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
+  ../../byterun/freelist.h ../../byterun/minor_gc.h \
+  ../../byterun/signals.h unixsupport.h socketaddr.h
+setgid.o: setgid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+setsid.o: setsid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+setuid.o: setuid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h unixsupport.h
+shutdown.o: shutdown.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
   ../../config/s.h ../../byterun/misc.h unixsupport.h
-rmdir.o: rmdir.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+signals.o: signals.c ../../byterun/alloc.h ../../byterun/compatibility.h \
+  ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/mlvalues.h ../../byterun/memory.h \
+  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h
+sleep.o: sleep.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/signals.h unixsupport.h
+socket.o: socket.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-select.o: select.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \
-  ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h unixsupport.h
-sendrecv.o: sendrecv.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \
+socketaddr.o: socketaddr.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
+  ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h \
+  socketaddr.h
+socketpair.o: socketpair.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h
+sockopt.o: sockopt.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h socketaddr.h
+stat.o: stat.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \
   ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h unixsupport.h socketaddr.h
-setgid.o: setgid.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-setsid.o: setsid.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-setuid.o: setuid.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-shutdown.o: shutdown.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-signals.o: signals.c ../../byterun/misc.h ../../byterun/config.h \
-  ../../config/m.h ../../config/s.h ../../byterun/mlvalues.h \
+  ../../byterun/minor_gc.h ../../byterun/alloc.h unixsupport.h \
+  cst2constr.h ../../byterun/io.h
+strofaddr.o: strofaddr.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h socketaddr.h
+symlink.o: symlink.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h unixsupport.h
+termios.o: termios.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  unixsupport.h
+time.o: time.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h
+times.o: times.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \
   ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h unixsupport.h
-sleep.o: sleep.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+truncate.o: truncate.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/io.h unixsupport.h
+umask.o: umask.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-socketaddr.o: socketaddr.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \
+unixsupport.o: unixsupport.c ../../byterun/mlvalues.h \
+  ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \
+  ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
+  ../../byterun/callback.h ../../byterun/memory.h ../../byterun/gc.h \
   ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h unixsupport.h socketaddr.h
-socket.o: socket.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-socketpair.o: socketpair.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-sockopt.o: sockopt.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h socketaddr.h
-stat.o: stat.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h \
+  ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h \
   cst2constr.h
-strofaddr.o: strofaddr.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h socketaddr.h
-symlink.o: symlink.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-termios.o: termios.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-time.o: time.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+unlink.o: unlink.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-times.o: times.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h
-truncate.o: truncate.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-umask.o: umask.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
+utimes.o: utimes.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
   ../../byterun/misc.h unixsupport.h
-unixsupport.o: unixsupport.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \
+wait.o: wait.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \
+  ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
+  ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h
+write.o: write.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
+  ../../byterun/config.h ../../config/m.h ../../config/s.h \
+  ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \
   ../../byterun/major_gc.h ../../byterun/freelist.h \
-  ../../byterun/minor_gc.h unixsupport.h cst2constr.h
-unlink.o: unlink.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-utimes.o: utimes.c ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/misc.h unixsupport.h
-wait.o: wait.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h
-write.o: write.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h
+  ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h
 unixLabels.cmi: unix.cmi 
-unixLabels.cmo: unix.cmi unixLabels.cmi 
-unixLabels.cmx: unix.cmx unixLabels.cmi 
 unix.cmo: unix.cmi 
 unix.cmx: unix.cmi 
+unixLabels.cmo: unix.cmi unixLabels.cmi 
+unixLabels.cmx: unix.cmx unixLabels.cmi 
diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml
index e7f0b38b6..1ffb7eeff 100644
--- a/otherlibs/unix/unix.ml
+++ b/otherlibs/unix/unix.ml
@@ -161,6 +161,7 @@ external openfile : string -> open_flag list -> file_perm -> file_descr
 external close : file_descr -> unit = "unix_close"
 external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read"
 external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write"
+external unsafe_single_write : file_descr -> string -> int -> int -> int = "unix_single_write"
 
 let read fd buf ofs len =
   if ofs < 0 || len < 0 || ofs > String.length buf - len
@@ -170,6 +171,13 @@ let write fd buf ofs len =
   if ofs < 0 || len < 0 || ofs > String.length buf - len
   then invalid_arg "Unix.write"
   else unsafe_write fd buf ofs len
+(* write misbehaves because it attempts to write all data by making repeated
+   calls to the Unix write function (see comment in write.c and unix.mli).
+   partial_write fixes this by never calling write twice. *)
+let single_write fd buf ofs len =
+  if ofs < 0 || len < 0 || ofs > String.length buf - len
+  then invalid_arg "Unix.single_write"
+  else unsafe_single_write fd buf ofs len
 
 external in_channel_of_descr : file_descr -> in_channel
                              = "caml_ml_open_descriptor_in"
diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli
index f82cd88bd..ee08a2760 100644
--- a/otherlibs/unix/unix.mli
+++ b/otherlibs/unix/unix.mli
@@ -260,9 +260,13 @@ val write : file_descr -> string -> int -> int -> int
 (** [write fd buff ofs len] writes [len] characters to descriptor
    [fd], taking them from string [buff], starting at position [ofs]
    in string [buff]. Return the number of characters actually
-   written. *)
-
+   written.  [write] repeats the writing operation until all characters
+   have been written or an error occurs.  *)
 
+val single_write : file_descr -> string -> int -> int -> int
+(** Same as [write], but attempts to write only once.
+   Thus, if an error occurs, [single_write] guarantees that no data
+   has been written. *)
 
 (** {6 Interfacing with the standard input/output library} *)
 
diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli
index 3ab7e6289..1f081c81f 100644
--- a/otherlibs/unix/unixLabels.mli
+++ b/otherlibs/unix/unixLabels.mli
@@ -263,7 +263,15 @@ val write : file_descr -> buf:string -> pos:int -> len:int -> int
 (** [write fd buff ofs len] writes [len] characters to descriptor
    [fd], taking them from string [buff], starting at position [ofs]
    in string [buff]. Return the number of characters actually
-   written. *)
+   written.
+
+   When an error is reported some characters might have already been
+   written.  Use [single_write] instead to ensure that this is not the
+   case. *)
+
+val single_write : file_descr -> buf:string -> pos:int -> len:int -> int
+(** Same as [write] but ensures that all errors are reported and
+   that no character has ever been written when an error is reported. *)
 
 
 (** {6 Interfacing with the standard input/output library} *)
diff --git a/otherlibs/unix/write.c b/otherlibs/unix/write.c
index 0e02437b8..633f05fc0 100644
--- a/otherlibs/unix/write.c
+++ b/otherlibs/unix/write.c
@@ -54,3 +54,34 @@ CAMLprim value unix_write(value fd, value buf, value vofs, value vlen)
   End_roots();
   return Val_long(written);
 }
+
+/* When an error occurs after the first loop, unix_write reports the
+   error and discards the number of already written characters.
+   In this case, it would be better to discard the error and return the
+   number of bytes written, since most likely, unix_write will be call again,
+   and the error will be reproduced and this time will be reported.
+   This problem is avoided in unix_single_write, which is faithful to the
+   Unix system call. */
+
+CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen) 
+{
+  long ofs, len;
+  int numbytes, ret;
+  char iobuf[UNIX_BUFFER_SIZE];
+
+  Begin_root (buf);
+    ofs = Long_val(vofs);
+    len = Long_val(vlen);
+    ret = 0;
+    if (len > 0) {
+      numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len;
+      memmove (iobuf, &Byte(buf, ofs), numbytes);
+      enter_blocking_section();
+      ret = write(Int_val(fd), iobuf, numbytes);
+      leave_blocking_section();
+      if (ret == -1) uerror("single_write", Nothing);
+    }
+  End_roots();
+  return Val_int(ret);
+}
+
diff --git a/otherlibs/win32graph/Makefile.nt b/otherlibs/win32graph/Makefile.nt
index 127418261..18c6410cb 100644
--- a/otherlibs/win32graph/Makefile.nt
+++ b/otherlibs/win32graph/Makefile.nt
@@ -22,7 +22,7 @@ CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib
 CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib
 COMPFLAGS=-warn-error A
 
-COBJS=open.$(O) draw.$(O) dib.$(O)
+COBJS=open.$(O) draw.$(O) events.$(O) dib.$(O)
 CAMLOBJS=graphics.cmo
 WIN32LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,gdi32) $(call SYSLIB,user32)
 
diff --git a/otherlibs/win32graph/draw.c b/otherlibs/win32graph/draw.c
index c4f1224b2..1bebe0208 100644
--- a/otherlibs/win32graph/draw.c
+++ b/otherlibs/win32graph/draw.c
@@ -15,9 +15,11 @@
 #include <math.h>
 #include "mlvalues.h"
 #include "alloc.h"
+#include "fail.h"
 #include "libgraph.h"
 #include "custom.h"
 #include "memory.h"
+
 HDC gcMetaFile;
 int grdisplay_mode;
 int grremember_mode;
@@ -84,38 +86,18 @@ CAMLprim value caml_gr_lineto(value vx, value vy)
 
 CAMLprim value caml_gr_draw_rect(value vx, value vy, value vw, value vh)
 {
-#if 0
-        int x = Int_val(vx);
-        int y = Int_val(vy);
-        int w = Int_val(vw);
-        int h = Int_val(vh);
-
-        gr_check_open();
-        if(grdisplay_mode) {
-                Rectangle(grwindow.gc,x, Wcvt(y) , x+w, Wcvt(y+h));
-        }
-        if(grremember_mode) {
-                Rectangle(grwindow.gcBitmap,x, Wcvt(y), x+w, Wcvt(h+y));
-        }
-        return Val_unit;
-#else
         int     x, y, w, h;
         POINT pt[5];
         x=Int_val(vx);
-        y=Int_val(vy);
+        y=Wcvt(Int_val(vy));
         w=Int_val(vw);
         h=Int_val(vh);
 
-        pt[0].x = x;
-        pt[0].y = Wcvt(y-1);
-        pt[1].x = x+w;
-        pt[1].y = pt[0].y;
-        pt[2].x = pt[1].x;
-        pt[2].y = Wcvt(y+h-1);
-        pt[3].x = pt[0].x;
-        pt[3].y = pt[2].y;
-        pt[4].x = pt[0].x;
-        pt[4].y = pt[0].y;
+        pt[0].x = x;         pt[0].y = y - h;
+	pt[1].x = x + w;     pt[1].y = y - h;
+	pt[2].x = x + w;     pt[2].y = y;
+	pt[3].x = x;         pt[3].y = y;
+	pt[4].x = x;         pt[4].y = y - h;
         if (grremember_mode) {
                 Polyline(grwindow.gcBitmap,pt, 5);
         }
@@ -123,7 +105,6 @@ CAMLprim value caml_gr_draw_rect(value vx, value vy, value vw, value vh)
                 Polyline(grwindow.gc,pt, 5);
         }
         return Val_unit;
-#endif
 }
 
 CAMLprim value caml_gr_draw_text(value text,value x)
@@ -405,125 +386,6 @@ CAMLprim value caml_gr_text_size(value str)
         return res;
 }
 
-#if 0
-static unsigned char gr_queue[SIZE_QUEUE];
-static int gr_head = 0;       /* position of next read */
-static int gr_tail = 0;       /* position of next write */
-
-#define QueueIsEmpty (gr_head == gr_tail)
-#define QueueIsFull  (gr_head == gr_tail + 1)
-
-void gr_enqueue_char(unsigned char c)
-{
-        if (QueueIsFull) return;
-        gr_queue[gr_tail] = c;
-        gr_tail++;
-        if (gr_tail >= SIZE_QUEUE) gr_tail = 0;
-}
-#endif
-
-#define Button_down             1
-#define Button_up               2
-#define Key_pressed             4
-#define Mouse_motion    8
-#define Poll                    16
-MSG * InspectMessages = NULL;
-
-CAMLprim value caml_gr_wait_event(value eventlist)
-{
-        value res;
-        int mask;
-        BOOL poll;
-        int mouse_x, mouse_y, button, key;
-        int root_x, root_y, win_x, win_y;
-        int r,i,stop;
-        unsigned int modifiers;
-        POINT pt;
-        MSG msg;
-
-        gr_check_open();
-        mask = 0;
-        poll = FALSE;
-        while (eventlist != Val_int(0)) {
-                switch (Int_val(Field(eventlist,0))) {
-                case 0:                     /* Button_down */
-                        mask |= Button_down;
-                        break;
-                case 1:                     /* Button_up */
-                        mask |= Button_up;
-                        break;
-                case 2:                     /* Key_pressed */
-                        mask |= Key_pressed;
-                        break;
-                case 3:                     /* Mouse_motion */
-                        mask |= Mouse_motion;
-                        break;
-                case 4:                     /* Poll */
-                        poll = TRUE;
-                        break;
-                }
-                eventlist = Field(eventlist,1);
-        }
-        mouse_x = -1;
-        mouse_y = -1;
-        button = 0;
-        key = -1;
-
-        if (poll) {
-                // Poll uses info on last event stored in global variables
-                mouse_x = MouseLastX;
-                mouse_y = MouseLastY;
-                button = MouseLbuttonDown | MouseMbuttonDown | MouseRbuttonDown;
-                key = LastKey;
-        }
-        else { // Not polled. Block for a message
-                InspectMessages = &msg;
-                do {
-                        WaitForSingleObject(EventHandle,INFINITE);
-                        stop = 0;
-                        switch (msg.message) {
-                        case WM_LBUTTONDOWN:
-                        case WM_MBUTTONDOWN:
-                        case WM_RBUTTONDOWN:
-                                button = 1;
-                                if (mask&Button_down) stop = 1;
-                                break;
-                        case WM_LBUTTONUP:
-                        case WM_MBUTTONUP:
-                        case WM_RBUTTONUP:
-                                button = 0;
-                                if (mask&Button_up) stop = 1;
-                                break;
-                        case WM_MOUSEMOVE:
-                                if (mask&Mouse_motion) stop = 1;
-                                break;
-                        case WM_CHAR:
-                                key = msg.wParam & 0xFF;
-                                if (mask&Key_pressed) stop = 1;
-                                break;
-			case WM_CLOSE:
-			        stop = 1;
-				break;
-                        }
-                        if (stop) {
-                                pt = msg.pt;
-                                MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1);
-                                mouse_x = pt.x;
-                                mouse_y = grwindow.height- 1 - pt.y;
-                        }
-			SetEvent(EventProcessedHandle);
-                } while (! stop);
-                InspectMessages = NULL;
-        }
-        res = alloc_small(5, 0);
-        Field(res, 0) = Val_int(mouse_x);
-        Field(res, 1) = Val_int(mouse_y);
-        Field(res, 2) = Val_bool(button);
-        Field(res, 3) = Val_bool(key != -1);
-        Field(res, 4) = Val_int(key & 0xFF);
-        return res;
-}
-
 CAMLprim value caml_gr_fill_poly(value vect)
 {
         int n_points, i;
diff --git a/otherlibs/win32graph/events.c b/otherlibs/win32graph/events.c
new file mode 100755
index 000000000..9e0791c38
--- /dev/null
+++ b/otherlibs/win32graph/events.c
@@ -0,0 +1,200 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 2004 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 "mlvalues.h"
+#include "alloc.h"
+#include "libgraph.h"
+#include <windows.h>
+
+enum {
+  EVENT_BUTTON_DOWN = 1,
+  EVENT_BUTTON_UP = 2,
+  EVENT_KEY_PRESSED = 4,
+  EVENT_MOUSE_MOTION = 8
+};
+
+struct event_data {
+  short mouse_x, mouse_y;
+  unsigned char kind;
+  unsigned char button;
+  unsigned char key;
+};
+
+static struct event_data caml_gr_queue[SIZE_QUEUE];
+static unsigned int caml_gr_head = 0;       /* position of next read */
+static unsigned int caml_gr_tail = 0;       /* position of next write */
+
+static int caml_gr_event_mask = EVENT_KEY_PRESSED;
+static int last_button = 0;
+static LPARAM last_pos = 0;
+
+HANDLE caml_gr_queue_semaphore = NULL;
+CRITICAL_SECTION caml_gr_queue_mutex;
+
+void caml_gr_init_event_queue(void)
+{
+  if (caml_gr_queue_semaphore == NULL) {
+    caml_gr_queue_semaphore = CreateSemaphore(NULL, 0, SIZE_QUEUE, NULL);
+    InitializeCriticalSection(&caml_gr_queue_mutex);
+  }
+}
+
+#define QueueIsEmpty (caml_gr_tail == caml_gr_head)
+
+static void caml_gr_enqueue_event(int kind, LPARAM mouse_xy,
+                                  int button, int key)
+{
+  struct event_data * ev;
+
+  if ((caml_gr_event_mask & kind) == 0) return;
+  EnterCriticalSection(&caml_gr_queue_mutex);
+  ev = &(caml_gr_queue[caml_gr_tail]);
+  ev->kind = kind;
+  ev->mouse_x = GET_X_LPARAM(mouse_xy);
+  ev->mouse_y = GET_Y_LPARAM(mouse_xy);
+  ev->button = (button != 0);
+  ev->key = key;
+  caml_gr_tail = (caml_gr_tail + 1) % SIZE_QUEUE;
+  /* If queue was full, it now appears empty;
+     drop oldest entry from queue. */
+  if (QueueIsEmpty) {
+    caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE;
+  } else {
+    /* One more event in queue */
+    ReleaseSemaphore(caml_gr_queue_semaphore, 1, NULL);
+  }
+  LeaveCriticalSection(&caml_gr_queue_mutex);
+}
+
+void caml_gr_handle_event(UINT msg, WPARAM wParam, LPARAM lParam)
+{
+  switch (msg) {
+  case WM_LBUTTONDOWN:
+  case WM_RBUTTONDOWN:
+  case WM_MBUTTONDOWN:
+    last_button = 1;
+    last_pos = lParam;
+    caml_gr_enqueue_event(EVENT_BUTTON_DOWN, lParam, 1, 0);
+    break;
+
+  case WM_LBUTTONUP:
+  case WM_RBUTTONUP:
+  case WM_MBUTTONUP:
+    last_button = 0;
+    last_pos = lParam;
+    caml_gr_enqueue_event(EVENT_BUTTON_UP, lParam, 0, 0);
+    break;
+
+  case WM_CHAR:
+    caml_gr_enqueue_event(EVENT_KEY_PRESSED, last_pos, last_button, wParam);
+    break;
+
+  case WM_MOUSEMOVE:
+    last_pos = lParam;
+    caml_gr_enqueue_event(EVENT_MOUSE_MOTION, lParam, last_button, 0);
+    break;
+  }
+}
+
+static value caml_gr_wait_allocate_result(int mouse_x, int mouse_y,
+                                          int button,
+                                          int keypressed, int key)
+{
+  value res = alloc_small(5, 0);
+  Field(res, 0) = Val_int(mouse_x);
+  Field(res, 1) = Val_int(grwindow.height - 1 - mouse_y);
+  Field(res, 2) = Val_bool(button);
+  Field(res, 3) = Val_bool(keypressed);
+  Field(res, 4) = Val_int(key & 0xFF);
+  return res;
+}
+
+static value caml_gr_wait_event_poll(void)
+{
+  int key, keypressed, i;
+
+  /* Look inside event queue for pending KeyPress events */
+  EnterCriticalSection(&caml_gr_queue_mutex);
+  key = 0;
+  keypressed = 0;
+  for (i = caml_gr_head; i != caml_gr_tail; i = (i + 1) % SIZE_QUEUE) {
+    if (caml_gr_queue[i].kind == EVENT_KEY_PRESSED) {
+      keypressed = 1;
+      key = caml_gr_queue[i].key;
+      break;
+    }
+  }
+  LeaveCriticalSection(&caml_gr_queue_mutex);
+  /* Use global vars for mouse position and buttons */
+  return caml_gr_wait_allocate_result(GET_X_LPARAM(last_pos),
+                                      GET_Y_LPARAM(last_pos),
+                                      last_button,
+                                      keypressed, key);
+}
+
+static value caml_gr_wait_event_blocking(int mask)
+{
+  struct event_data ev;
+
+  /* Increase the selected events if needed */
+  caml_gr_event_mask |= mask;
+  /* Pop events from queue until one matches */
+  do {
+    /* Wait for event queue to be non-empty */
+    WaitForSingleObject(caml_gr_queue_semaphore, INFINITE);
+    /* Pop oldest event in queue */
+    EnterCriticalSection(&caml_gr_queue_mutex);
+    ev = caml_gr_queue[caml_gr_head];
+    /* Queue should never be empty at this point, but just in case... */
+    if (QueueIsEmpty) {
+      ev.kind = 0;
+    } else {
+      caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE;
+    }
+    LeaveCriticalSection(&caml_gr_queue_mutex);
+    /* Check if it matches */
+  } while ((ev.kind & mask) == 0);
+  return caml_gr_wait_allocate_result(ev.mouse_x, ev.mouse_y, ev.button,
+                                      ev.kind == EVENT_KEY_PRESSED,
+                                      ev.key);
+}
+
+CAMLprim value caml_gr_wait_event(value eventlist) /* ML */
+{
+  int mask, poll;
+
+  gr_check_open();
+  mask = 0;
+  poll = 0;
+  while (eventlist != Val_int(0)) {
+    switch (Int_val(Field(eventlist, 0))) {
+    case 0:                     /* Button_down */
+      mask |= EVENT_BUTTON_DOWN; break;
+    case 1:                     /* Button_up */
+      mask |= EVENT_BUTTON_UP; break;
+    case 2:                     /* Key_pressed */
+      mask |= EVENT_KEY_PRESSED; break;
+    case 3:                     /* Mouse_motion */
+      mask |= EVENT_MOUSE_MOTION; break;
+    case 4:                     /* Poll */
+      poll = 1; break;
+    }
+    eventlist = Field(eventlist, 1);
+  }
+  if (poll)
+    return caml_gr_wait_event_poll();
+  else
+    return caml_gr_wait_event_blocking(mask);
+}
diff --git a/otherlibs/win32graph/libgraph.h b/otherlibs/win32graph/libgraph.h
index acbe29cc1..6c32f15df 100644
--- a/otherlibs/win32graph/libgraph.h
+++ b/otherlibs/win32graph/libgraph.h
@@ -45,9 +45,6 @@ extern int bits_per_pixel;
 #define BORDER_WIDTH 2
 #define WINDOW_NAME "Caml graphics"
 #define ICON_NAME "Caml graphics"
-#define DEFAULT_EVENT_MASK \
-          (ExposureMask | KeyPressMask | StructureNotifyMask)
-#define DEFAULT_FONT "fixed"
 #define SIZE_QUEUE 256
 
 void gr_fail(char *fmt, char *arg);
@@ -77,10 +74,5 @@ typedef struct tagWindow {
 
 extern GR_WINDOW grwindow;
 HFONT CreationFont(char *name);
-extern int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown;
-extern HANDLE EventHandle, EventProcessedHandle;
-extern MSG * InspectMessages;
-extern int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown;
-extern int MouseLastX, MouseLastY;
-extern int LastKey;
-
+extern void caml_gr_init_event_queue(void);
+extern void caml_gr_handle_event(UINT msg, WPARAM wParam, LPARAM lParam);
diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c
index 654f550bf..6376e5abe 100644
--- a/otherlibs/win32graph/open.c
+++ b/otherlibs/win32graph/open.c
@@ -15,12 +15,11 @@
 #include <fcntl.h>
 #include <signal.h>
 #include "mlvalues.h"
+#include "fail.h"
 #include "libgraph.h"
 #include <windows.h>
+
 static value gr_reset(void);
-int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown;
-int MouseLastX, MouseLastY;
-int LastKey = -1;
 static long tid;
 static HANDLE threadHandle;
 HWND grdisplay = NULL;
@@ -36,11 +35,11 @@ int grcolor;
 extern HFONT * grfont;
 MSG msg;
 
-HANDLE EventHandle, EventProcessedHandle;
 static char *szOcamlWindowClass = "OcamlWindowClass";
 static BOOL gr_initialized = 0;
 CAMLprim value caml_gr_clear_graph(void);
 HANDLE hInst;
+
 HFONT CreationFont(char *name)
 {
    LOGFONT CurrentFont;
@@ -65,8 +64,11 @@ void SetCoordinates(HWND hwnd)
 
 void ResetForClose(HWND hwnd)
 {
+        DeleteDC(grwindow.tempDC);
+        DeleteDC(grwindow.gcBitmap);
         DeleteObject(grwindow.hBitmap);
         memset(&grwindow,0,sizeof(grwindow));
+        gr_initialized = 0;
 }
 
         
@@ -98,44 +100,9 @@ static LRESULT CALLBACK GraphicsWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM
         case WM_DESTROY:
                 ResetForClose(hwnd);
                 break;
-        case WM_LBUTTONDOWN:
-                MouseLbuttonDown = 1;
-                break;
-        case WM_LBUTTONUP:
-                MouseLbuttonDown = 0;
-                break;
-        case WM_RBUTTONDOWN:
-                MouseRbuttonDown = 1;
-                break;
-        case WM_RBUTTONUP:
-                MouseRbuttonDown = 0;
-                break;
-        case WM_MBUTTONDOWN:
-                MouseMbuttonDown = 1;
-                break;
-        case WM_MBUTTONUP:
-                MouseMbuttonDown = 0;
-                break;
-        case WM_CHAR:
-                LastKey = wParam & 0xFF;
-                break;
-        case WM_KEYUP:
-                LastKey = -1;
-                break;
-        case WM_MOUSEMOVE:
-#if 0
-                pt.x = GET_X_LPARAM(lParam);
-                pt.y = GET_Y_LPARAM(lParam);
-                MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1);
-                MouseLastX = pt.x;
-                MouseLastY = grwindow.height - 1 - pt.y;
-#else
-                MouseLastX = GET_X_LPARAM(lParam);
-                MouseLastY = grwindow.height - 1 - GET_Y_LPARAM(lParam);
-#endif
-                break;
         }
-        return DefWindowProc(hwnd,msg,wParam,lParam);
+        caml_gr_handle_event(msg, wParam, lParam);
+        return DefWindowProc(hwnd, msg, wParam, lParam);
 }
 
 int DoRegisterClass(void)
@@ -266,8 +233,7 @@ static DWORD WINAPI gr_open_graph_internal(value arg)
   grwindow.grx = 0;
   grwindow.gry = 0;
   
-  EventHandle = CreateEvent(NULL,0,0,NULL);
-  EventProcessedHandle = CreateEvent(NULL,0,0,NULL);
+  caml_gr_init_event_queue();
 
   /* The global data structures are now correctly initialized.
      Restart the Caml main thread. */
@@ -276,17 +242,10 @@ static DWORD WINAPI gr_open_graph_internal(value arg)
 
   /* Enter the message handling loop */
   while (GetMessage(&msg,NULL,0,0)) {
-    if (InspectMessages != NULL) {
-      *InspectMessages = msg;
-      SetEvent(EventHandle);
-    }
     TranslateMessage(&msg);  // Translates virtual key codes
     DispatchMessage(&msg);   // Dispatches message to window
     if (!IsWindow(grwindow.hwnd))
       break;
-    if (InspectMessages != NULL) {
-      WaitForSingleObject(EventProcessedHandle,INFINITE);
-    }
   }
   return 0;
 }
@@ -310,11 +269,8 @@ CAMLprim value caml_gr_open_graph(value arg)
 CAMLprim value caml_gr_close_graph(void)
 {
         if (gr_initialized) {
-                DeleteDC(grwindow.tempDC);
-                DeleteDC(grwindow.gcBitmap);
-                DestroyWindow(grwindow.hwnd);
-                memset(&grwindow,0,sizeof(grwindow));
-                gr_initialized = 0;
+	        PostMessage(grwindow.hwnd, WM_CLOSE, 0, 0);
+                WaitForSingleObject(threadHandle, INFINITE);
         }
         return Val_unit;
 }
diff --git a/otherlibs/win32unix/rename.c b/otherlibs/win32unix/rename.c
index d84bcd66a..3bfdf4770 100644
--- a/otherlibs/win32unix/rename.c
+++ b/otherlibs/win32unix/rename.c
@@ -19,9 +19,23 @@
 
 CAMLprim value unix_rename(value path1, value path2)
 {
-  if (MoveFileEx(String_val(path1), String_val(path2),
-                 MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH |
-                 MOVEFILE_COPY_ALLOWED) == 0) {
+  static int supports_MoveFileEx = -1; /* don't know yet */
+  BOOL ok;
+
+  if (supports_MoveFileEx < 0) {
+    OSVERSIONINFO VersionInfo;
+    VersionInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
+    supports_MoveFileEx =
+      (GetVersionEx(&VersionInfo) != 0)
+      && (VersionInfo.dwPlatformId == VER_PLATFORM_WIN32_NT);
+  }
+  if (supports_MoveFileEx > 0)
+    ok = MoveFileEx(String_val(path1), String_val(path2),
+		    MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH |
+		    MOVEFILE_COPY_ALLOWED);
+  else
+    ok = MoveFile(String_val(path1), String_val(path2));
+  if (! ok) {
     win32_maperr(GetLastError());
     uerror("rename", path1);
   }     
diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml
index 0f100ed7e..240857943 100644
--- a/otherlibs/win32unix/unix.ml
+++ b/otherlibs/win32unix/unix.ml
@@ -180,6 +180,8 @@ external unsafe_read : file_descr -> string -> int -> int -> int
                      = "unix_read"
 external unsafe_write : file_descr -> string -> int -> int -> int
                       = "unix_write"
+external unsafe_single_write : file_descr -> string -> int -> int -> int
+                      = "unix_single_write"
 
 let read fd buf ofs len =
   if ofs < 0 || len < 0 || ofs > String.length buf - len
@@ -189,6 +191,10 @@ let write fd buf ofs len =
   if ofs < 0 || len < 0 || ofs > String.length buf - len
   then invalid_arg "Unix.write"
   else unsafe_write fd buf ofs len
+let single_write fd buf ofs len =
+  if ofs < 0 || len < 0 || ofs > String.length buf - len
+  then invalid_arg "Unix.single_write"
+  else unsafe_single_write fd buf ofs len
 
 (* Interfacing with the standard input/output library *)
 
diff --git a/otherlibs/win32unix/write.c b/otherlibs/win32unix/write.c
index 8571ff679..862e50791 100644
--- a/otherlibs/win32unix/write.c
+++ b/otherlibs/win32unix/write.c
@@ -62,3 +62,44 @@ CAMLprim value unix_write(value fd, value buf, value vofs, value vlen)
   End_roots();
   return Val_long(written);
 }
+
+CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen)
+{
+  long ofs, len, written;
+  DWORD numbytes, numwritten;
+  char iobuf[UNIX_BUFFER_SIZE];
+
+  Begin_root (buf);
+    ofs = Long_val(vofs);
+    len = Long_val(vlen);
+    written = 0;
+    if (len > 0) {
+      numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len;
+      memmove (iobuf, &Byte(buf, ofs), numbytes);
+      if (Descr_kind_val(fd) == KIND_SOCKET) {
+        int ret;
+        SOCKET s = Socket_val(fd);
+        enter_blocking_section();
+        ret = send(s, iobuf, numbytes, 0);
+        leave_blocking_section();
+        if (ret == SOCKET_ERROR) {
+          win32_maperr(WSAGetLastError());
+          uerror("single_write", Nothing);
+        }
+        numwritten = ret;
+      } else {
+        BOOL ret;
+        HANDLE h = Handle_val(fd);
+        enter_blocking_section();
+        ret = WriteFile(h, iobuf, numbytes, &numwritten, NULL);
+        leave_blocking_section();
+        if (! ret) {
+          win32_maperr(GetLastError());
+          uerror("single_write", Nothing);
+        }
+      }
+      written = numwritten;
+    }
+  End_roots();
+  return Val_long(written);
+}
diff --git a/stdlib/.depend b/stdlib/.depend
index 0d15561d0..82a3ead49 100644
--- a/stdlib/.depend
+++ b/stdlib/.depend
@@ -17,10 +17,10 @@ buffer.cmo: string.cmi sys.cmi buffer.cmi
 buffer.cmx: string.cmx sys.cmx buffer.cmi 
 callback.cmo: obj.cmi callback.cmi 
 callback.cmx: obj.cmx callback.cmi 
-camlinternalOO.cmo: array.cmi hashtbl.cmi list.cmi map.cmi obj.cmi random.cmi \
-    sort.cmi sys.cmi camlinternalOO.cmi 
-camlinternalOO.cmx: array.cmx hashtbl.cmx list.cmx map.cmx obj.cmx random.cmx \
-    sort.cmx sys.cmx camlinternalOO.cmi 
+camlinternalOO.cmo: array.cmi char.cmi list.cmi map.cmi obj.cmi string.cmi \
+    sys.cmi camlinternalOO.cmi 
+camlinternalOO.cmx: array.cmx char.cmx list.cmx map.cmx obj.cmx string.cmx \
+    sys.cmx camlinternalOO.cmi 
 char.cmo: char.cmi 
 char.cmx: char.cmi 
 complex.cmo: complex.cmi 
@@ -67,8 +67,8 @@ parsing.cmo: array.cmi lexing.cmi obj.cmi parsing.cmi
 parsing.cmx: array.cmx lexing.cmx obj.cmx parsing.cmi 
 pervasives.cmo: pervasives.cmi 
 pervasives.cmx: pervasives.cmi 
-printexc.cmo: obj.cmi printf.cmi sys.cmi printexc.cmi 
-printexc.cmx: obj.cmx printf.cmx sys.cmx printexc.cmi 
+printexc.cmo: obj.cmi printf.cmi printexc.cmi 
+printexc.cmx: obj.cmx printf.cmx printexc.cmi 
 printf.cmo: buffer.cmi char.cmi list.cmi obj.cmi string.cmi printf.cmi 
 printf.cmx: buffer.cmx char.cmx list.cmx obj.cmx string.cmx printf.cmi 
 queue.cmo: obj.cmi queue.cmi 
@@ -78,9 +78,9 @@ random.cmo: array.cmi char.cmi digest.cmi int32.cmi int64.cmi nativeint.cmi \
 random.cmx: array.cmx char.cmx digest.cmx int32.cmx int64.cmx nativeint.cmx \
     pervasives.cmx string.cmx random.cmi 
 scanf.cmo: buffer.cmi hashtbl.cmi list.cmi obj.cmi printf.cmi string.cmi \
-    sys.cmi scanf.cmi 
+    scanf.cmi 
 scanf.cmx: buffer.cmx hashtbl.cmx list.cmx obj.cmx printf.cmx string.cmx \
-    sys.cmx scanf.cmi 
+    scanf.cmi 
 set.cmo: set.cmi 
 set.cmx: set.cmi 
 sort.cmo: array.cmi sort.cmi 
diff --git a/stdlib/Compflags b/stdlib/Compflags
index e263fbcf2..697f38dca 100755
--- a/stdlib/Compflags
+++ b/stdlib/Compflags
@@ -15,12 +15,12 @@
 # $Id$
 
 case $1 in
-  pervasives.cm[iox]|pervasives.p.cmx) echo '-nopervasives';;
-  camlinternalOO.cmi) echo '-nopervasives';;
-  camlinternalOO.cmx|camlinternalOO.p.cmx) echo '-inline 0';;
-  arrayLabels.cm[ox]|arrayLabels.p.cmx) echo '-nolabels';;
-  listLabels.cm[ox]|listLabels.p.cmx) echo '-nolabels';;
-  stringLabels.cm[ox]|stringLabels.p.cmx) echo '-nolabels';;
-  moreLabels.cm[ox]|moreLabels.p.cmx) echo '-nolabels';;
-  *) echo '';;
+  pervasives.cm[iox]|pervasives.p.cmx) echo ' -nopervasives';;
+  camlinternalOO.cmi) echo ' -nopervasives';;
+  camlinternalOO.cmx|camlinternalOO.p.cmx) echo ' -inline 0';;
+  arrayLabels.cm[ox]|arrayLabels.p.cmx) echo ' -nolabels';;
+  listLabels.cm[ox]|listLabels.p.cmx) echo ' -nolabels';;
+  stringLabels.cm[ox]|stringLabels.p.cmx) echo ' -nolabels';;
+  moreLabels.cm[ox]|moreLabels.p.cmx) echo ' -nolabels';;
+  *) echo ' ';;
 esac
diff --git a/stdlib/arg.ml b/stdlib/arg.ml
index 9514b9557..dd6c51753 100644
--- a/stdlib/arg.ml
+++ b/stdlib/arg.ml
@@ -133,7 +133,7 @@ let parse_argv ?(current=current) argv speclist anonfun errmsg =
       begin try
         let rec treat_action = function
         | Unit f -> f ();
-        | Bool f ->
+        | Bool f when !current + 1 < l ->
             let arg = argv.(!current + 1) in
             begin try f (bool_of_string arg)
             with Invalid_argument "bool_of_string" ->
diff --git a/stdlib/format.ml b/stdlib/format.ml
index dcee1a491..0c345137d 100644
--- a/stdlib/format.ml
+++ b/stdlib/format.ml
@@ -184,10 +184,25 @@ 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; now that max_int is defined, could also be max_int - 1. *)
-let pp_infinity = 1000000000;;
+(* Pp_infinity: large value for default tokens size.
+
+   Pp_infinity is documented as being greater than 1e10; to avoid
+   confusion about the word ``greater'' we shoose pp_infinity greater
+   than 1e10 + 1; for correct handling of tests in the algorithm
+   pp_infinity must be even one more than that; let's stand on the
+   safe side by choosing 1.e10+10.
+
+   Pp_infinity could probably be 1073741823 that is 2^30 - 1, that is
+   the minimal upper bound of integers; now that max_int is defined,
+   could also be defined as max_int - 1.
+
+   We must carefully double-check all the integer arithmetic
+   operations that involve pp_infinity before setting pp_infinity to
+   something around max_int: otherwise any overflow would wreck havoc
+   the pretty-printing algorithm's invariants.
+   Is it worth the burden ? *)
+
+let pp_infinity = 1000000010;;
 
 (* Output functions for the formatter. *)
 let pp_output_string state s = state.pp_output_function s 0 (String.length s)
@@ -632,11 +647,15 @@ 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-printer. *)
+let pp_limit n =
+  if n < pp_infinity then n else pred pp_infinity;;
+
 let pp_set_min_space_left state n =
-  if n >= 1 && n < pp_infinity then begin
+  if n >= 1 then
+    let n = pp_limit n in
     state.pp_min_space_left <- n;
     state.pp_max_indent <- state.pp_margin - state.pp_min_space_left;
-    pp_rinit state end;;
+    pp_rinit state;;
 
 (* Initially, we have :
   pp_max_indent = pp_margin - pp_min_space_left, and
@@ -646,7 +665,8 @@ let pp_set_max_indent state 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
+  if n >= 1 then
+    let n = pp_limit n in
     state.pp_margin <- n;
     let new_max_indent =
         (* Try to maintain max_indent to its actual value. *)
@@ -658,7 +678,7 @@ let pp_set_margin state n =
          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;;
+    pp_set_max_indent state new_max_indent;;
 
 let pp_get_margin state () = state.pp_margin;;
 
diff --git a/stdlib/format.mli b/stdlib/format.mli
index 3526e2365..09f9badf1 100644
--- a/stdlib/format.mli
+++ b/stdlib/format.mli
@@ -162,8 +162,9 @@ val set_margin : int -> unit;;
 (** [set_margin d] sets the value of the right margin
    to [d] (in characters): this value is used to detect line
    overflows that leads to split lines.
-   Nothing happens if [d] is smaller than 2 or
-   bigger than 999999999. *)
+   Nothing happens if [d] is smaller than 2.
+   If [d] is too large, the right margin is set to the maximum
+   admissible value (which is greater than [10^10]). *)
 
 val get_margin : unit -> int;;
 (** Returns the position of the right margin. *)
@@ -176,13 +177,13 @@ val set_max_indent : int -> unit;;
    indentation limit to [d] (in characters):
    once this limit is reached, boxes are rejected to the left,
    if they do not fit on the current line.
-   Nothing happens if [d] is smaller than 2 or
-   bigger than 999999999. *)
+   Nothing happens if [d] is smaller than 2.
+   If [d] is too large, the limit is set to the maximum
+   admissible value (which is greater than [10^10]). *)
 
 val get_max_indent : unit -> int;;
 (** Return the value of the maximum indentation limit (in characters). *)
 
-
 (** {6 Formatting depth: maximum number of boxes allowed before ellipsis} *)
 
 val set_max_boxes : int -> unit;;
@@ -191,7 +192,7 @@ val set_max_boxes : int -> unit;;
    Material inside boxes nested deeper is printed as an
    ellipsis (more precisely as the text returned by
    [get_ellipsis_text ()]).
-   Nothing happens if [max] is not greater than 1. *)
+   Nothing happens if [max] is smaller than 2. *)
 
 val get_max_boxes : unit -> int;;
 (** Returns the maximum number of boxes allowed before ellipsis. *)
diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml
index 514adeee7..7cdfe9325 100644
--- a/stdlib/pervasives.ml
+++ b/stdlib/pervasives.ml
@@ -401,12 +401,20 @@ external decr: int ref -> unit = "%decr"
 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
 external format_of_string :
  ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 = "%identity"
-external string_of_format : ('a, 'b, 'c, 'd) format4 -> string = "%identity"
-
+external string_of_format_sys :
+ ('a, 'b, 'c, 'd) format4 -> string = "%identity"
 external string_to_format : string -> ('a, 'b, 'c, 'd) format4 = "%identity"
+
 let (( ^^ ) : ('a, 'b, 'c, 'd) format4 -> ('d, 'b, 'c, 'e) format4 ->
               ('a, 'b, 'c, 'e) format4) = fun fmt1 fmt2 ->
-  string_to_format (string_of_format fmt1 ^ string_of_format fmt2);;
+  string_to_format (string_of_format_sys fmt1 ^ string_of_format_sys fmt2);;
+
+let string_of_format f =
+  let s = string_of_format_sys f in
+  let l = string_length s in
+  let r = string_create l in
+  string_blit s 0 r 0 l;
+  r
 
 (* Miscellaneous *)
 
diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli
index 0b678ca28..430d1d7ab 100644
--- a/stdlib/pervasives.mli
+++ b/stdlib/pervasives.mli
@@ -630,9 +630,9 @@ val pos_out : out_channel -> int
     unspecified results). *)
 
 val out_channel_length : out_channel -> int
-(** Return the total length (number of characters) of the
-   given channel.  This works only for regular files. On files of
-   other kinds, the result is meaningless. *)
+(** Return the size (number of characters) of the regular file
+   on which the given channel is opened.  If the channel is opened
+    on a file that is not a regular file, the result is meaningless. *)
 
 val close_out : out_channel -> unit
 (** Close the given channel, flushing all buffered write operations.
@@ -738,9 +738,12 @@ val pos_in : in_channel -> int
 (** Return the current reading position for the given channel. *)
 
 val in_channel_length : in_channel -> int
-(** Return the total length (number of characters) of the
-   given channel. This works only for regular files. On files of
-   other kinds, the result is meaningless. *)
+(** Return the size (number of characters) of the regular file
+    on which the given channel is opened.  If the channel is opened
+    on a file that is not a regular file, the result is meaningless.
+    The returned size does not take into account the end-of-line
+    translations that can be performed when reading from a channel
+    opened in text mode. *)
 
 val close_in : in_channel -> unit
 (** Close the given channel.  Input functions raise a [Sys_error]
@@ -819,9 +822,9 @@ type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
     and ['b] is the type of the first argument given to
     [%a] and [%t] printing functions. *)
 
-external string_of_format :
-  ('a, 'b, 'c, 'd) format4 -> string = "%identity"
+val string_of_format : ('a, 'b, 'c, 'd) format4 -> string
 (** Converts a format string into a string. *)
+
 external format_of_string :
   ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 = "%identity"
 (** [format_of_string s] returns a format string read from the string
diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml
index 78adcc706..cb0291b20 100644
--- a/stdlib/scanf.ml
+++ b/stdlib/scanf.ml
@@ -256,6 +256,7 @@ let bad_float () = bad_input "no dot or exponent part found in float token";;
 
 (* Checking that the current char is indeed one of range, then skip it. *)
 let check_char_in range ib =
+  if range <> [] && not (Scanning.end_of_input ib) then
   let ci = Scanning.checked_peek_char ib in
   if List.memq ci range then Scanning.next_char ib else
   let sr = String.concat "" (List.map (String.make 1) range) in
@@ -486,7 +487,7 @@ let scan_Float max ib =
    characters has been read.*)
 let scan_string stp max ib =
   let rec loop max =
-    if max = 0 || Scanning.eof ib then max else
+    if max = 0 || Scanning.end_of_input ib then max else
     let c = Scanning.checked_peek_char ib in
     if stp == [] then
       match c with
@@ -495,7 +496,7 @@ let scan_string stp max ib =
     if List.mem c stp then max else
     loop (Scanning.store_char ib c max) in
   let max = loop max in
-  if stp != [] then check_char_in stp ib;
+  check_char_in stp ib;
   max;;
 
 (* Scan a char: peek strictly one character in the input, whatsoever. *)
@@ -795,7 +796,7 @@ let scan_chars_in_char_set stp char_set max ib =
         | 2 -> loop_neg2 set.[0] set.[1] max
         | 3 when set.[1] != '-' -> loop_neg3 set.[0] set.[1] set.[2] max
         | n -> loop (find_setp stp char_set) max end in
-  if stp != [] then check_char_in stp ib;
+  check_char_in stp ib;
   max;;
 
 let get_count t ib =
diff --git a/stdlib/stdLabels.mli b/stdlib/stdLabels.mli
index fbda4b7a4..73f72dc68 100644
--- a/stdlib/stdLabels.mli
+++ b/stdlib/stdLabels.mli
@@ -99,6 +99,7 @@ module List :
     val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
     val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
     val fast_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
+    val merge : cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
   end
 
 module String :
@@ -128,6 +129,8 @@ module String :
     val lowercase : string -> string
     val capitalize : string -> string
     val uncapitalize : string -> string
+    type t = string
+    val compare: t -> t -> int
     external unsafe_get : string -> int -> char = "%string_unsafe_get"
     external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set"
     external unsafe_blit :
diff --git a/stdlib/stringLabels.mli b/stdlib/stringLabels.mli
index b1f957751..7ea72bafe 100644
--- a/stdlib/stringLabels.mli
+++ b/stdlib/stringLabels.mli
@@ -142,6 +142,14 @@ val capitalize : string -> string
 val uncapitalize : string -> string
 (** Return a copy of the argument, with the first letter set to lowercase. *)
 
+type t = string
+(** An alias for the type of strings. *)
+
+val compare: t -> t -> int
+(** The comparison function for strings, with the same specification as
+    {!Pervasives.compare}.  Along with the type [t], this function [compare]
+    allows the module [String] to be passed as argument to the functors
+    {!Set.Make} and {!Map.Make}. *)
 
 (**/**)
 
diff --git a/stdlib/sys.ml b/stdlib/sys.ml
index f11f2929e..9554a82a1 100644
--- a/stdlib/sys.ml
+++ b/stdlib/sys.ml
@@ -78,4 +78,4 @@ let catch_break on =
 
 (* OCaml version string, must be in the format described in sys.mli. *)
 
-let ocaml_version = "3.09+dev0 (2004-06-22)";;
+let ocaml_version = "3.09+dev0 (2004-07-13)";;
diff --git a/test/Moretest/tscanf.ml b/test/Moretest/tscanf.ml
index 0cb7658f7..70b35bfc8 100644
--- a/test/Moretest/tscanf.ml
+++ b/test/Moretest/tscanf.ml
@@ -267,10 +267,24 @@ let test11 () =
      prenom = "Daniel" && nom = "de Rauglaudre" && poids = 66)
 ;;
 
+(* Empty string (end of input) testing. *)
 let test110 () =
  sscanf "" " " (fun x -> x) "" = "" &&
- sscanf "" "%[^\n]" (fun x -> x) = "" &&
- sscanf "" "%[^\n] " (fun x -> x) = "";;
+ sscanf "" "%s" (fun x -> x = "") &&
+ sscanf "" "%s%s" (fun x y -> x = "" && y = "") &&
+ sscanf "" "%s " (fun x -> x = "") &&
+ sscanf "" " %s" (fun x -> x = "") &&
+ sscanf "" " %s " (fun x -> x = "") &&
+ sscanf "" "%[^\n]" (fun x -> x = "") &&
+ sscanf "" "%[^\n] " (fun x -> x = "") &&
+ sscanf " " "%s" (fun x -> x = "") &&
+ sscanf " " "%s%s" (fun x y -> x = "" && y = "") &&
+ sscanf " " " %s " (fun x -> x = "") &&
+ sscanf " " " %s %s" (fun x y -> x = "" && x = y) &&
+ sscanf " " " %s@ %s" (fun x y -> x = "" && x = y) &&
+ sscanf " poi !" " %s@ %s@." (fun x y -> x = "" && y = "poi!") &&
+ sscanf " poi !" " %s@ %s@." (fun x y -> x = "poi" && y = "!") &&
+ sscanf " poi !" "%s@ %s@." (fun x y -> x = "" && y = "poi !");;
 
 let test111 () =
  try (sscanf "" "%[^\n]@\n") (fun x -> false) with
diff --git a/tools/.depend b/tools/.depend
index d04026c44..035fd88b9 100644
--- a/tools/.depend
+++ b/tools/.depend
@@ -19,14 +19,10 @@ dumpobj.cmx: ../parsing/asttypes.cmi ../bytecomp/bytesections.cmx \
     ../utils/config.cmx ../bytecomp/emitcode.cmx ../typing/ident.cmx \
     ../bytecomp/instruct.cmx ../bytecomp/lambda.cmx ../bytecomp/opcodes.cmx \
     opnames.cmx ../utils/tbl.cmx 
-lexer299.cmo: ../parsing/location.cmi ../utils/misc.cmi ../utils/warnings.cmi 
-lexer299.cmx: ../parsing/location.cmx ../utils/misc.cmx ../utils/warnings.cmx 
 lexer301.cmo: ../parsing/location.cmi ../utils/misc.cmi ../utils/warnings.cmi 
 lexer301.cmx: ../parsing/location.cmx ../utils/misc.cmx ../utils/warnings.cmx 
 objinfo.cmo: ../utils/config.cmi ../bytecomp/emitcode.cmi 
 objinfo.cmx: ../utils/config.cmx ../bytecomp/emitcode.cmx 
-ocaml299to3.cmo: lexer299.cmo 
-ocaml299to3.cmx: lexer299.cmx 
 ocamlcp.cmo: ../driver/main_args.cmi 
 ocamlcp.cmx: ../driver/main_args.cmx 
 ocamldep.cmo: ../utils/clflags.cmo ../utils/config.cmi depend.cmi \
diff --git a/tools/ocamlmklib.mlp b/tools/ocamlmklib.mlp
index a97ba47a5..352f1da3e 100644
--- a/tools/ocamlmklib.mlp
+++ b/tools/ocamlmklib.mlp
@@ -143,7 +143,7 @@ Options are:
   -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
+  -oc <name>     Generated C library is named dll<name>.so or lib<name>.a
   -rpath <dir>   Same as -dllpath <dir>
   -R<dir>        Same as -rpath
   -verbose       Print commands before executing them
diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
index 2c951cc7f..eac3581f0 100644
--- a/toplevel/topdirs.ml
+++ b/toplevel/topdirs.ml
@@ -102,12 +102,16 @@ let load_file ppf name =
         let toc_pos = input_binary_int ic in  (* Go to table of contents *)
         seek_in ic toc_pos;
         let lib = (input_value ic : library) in
-        begin try
-          Dll.open_dlls (List.map Dll.extract_dll_name lib.lib_dllibs)
-        with Failure reason ->
-          fprintf ppf "Cannot load required shared library: %s.@." reason;
-          raise Load_failed
-        end;
+        List.iter
+          (fun dllib ->
+            let name = Dll.extract_dll_name dllib in
+            try Dll.open_dlls [name]
+            with Failure reason ->
+              fprintf ppf
+                "Cannot load required shared library %s.@.Reason: %s.@."
+                name reason;
+              raise Load_failed)
+          lib.lib_dllibs;
         List.iter (load_compunit ic filename ppf) lib.lib_units;
         true
       end else begin
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 415a7d9f9..4918b50ff 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -224,6 +224,7 @@ let rec opened_object ty =
     Tobject (t, _)     -> opened_object t
   | Tfield(_, _, _, t) -> opened_object t
   | Tvar               -> true
+  | Tunivar            -> true
   | _                  -> false
 
 (**** Close an object ****)
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index eef9ea778..c40b707fc 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -24,16 +24,6 @@ open Types
 open Btype
 open Outcometree
 
-(* Redefine it here since goal differs *)
-
-let rec opened_object ty =
-  match (repr ty).desc with
-    Tobject (t, _)     -> opened_object t
-  | Tfield(_, _, _, t) -> opened_object t
-  | Tvar               -> true
-  | Tunivar            -> true
-  | _                  -> false
-
 (* Print a long identifier *)
 
 let rec longident ppf = function
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 0c3ccc87b..b3017a193 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -720,7 +720,7 @@ let type_format loc fmt =
           | _ ->
              if c = 'l' || c = 'n'
              then conversion (j - 1) Predef.type_int
-             else invalid i (j - i)
+             else invalid i (j - 1)
           end
       | c -> invalid i j in
     scan_width i j in
diff --git a/utils/misc.ml b/utils/misc.ml
index 989c313bb..3c66443f5 100644
--- a/utils/misc.ml
+++ b/utils/misc.ml
@@ -61,6 +61,12 @@ let rec split_last = function
       let (lst, last) = split_last tl in
       (hd :: lst, last)
 
+let rec samelist pred l1 l2 =
+  match (l1, l2) with
+  | ([], []) -> true
+  | (hd1 :: tl1, hd2 :: tl2) -> pred hd1 hd2 && samelist pred tl1 tl2
+  | (_, _) -> false
+
 (* Options *)
 
 let may f = function
diff --git a/utils/misc.mli b/utils/misc.mli
index 4f92077e7..faaa109a8 100644
--- a/utils/misc.mli
+++ b/utils/misc.mli
@@ -35,6 +35,9 @@ val list_remove: 'a -> 'a list -> 'a list
            element equal to [x] removed. *)
 val split_last: 'a list -> 'a list * 'a
         (* Return the last element and the other elements of the given list. *)
+val samelist: ('a -> 'a -> bool) -> 'a list -> 'a list -> bool
+        (* Like [List.for_all2] but returns [false] if the two
+           lists have different length. *)
 
 val may: ('a -> unit) -> 'a option -> unit
 val may_map: ('a -> 'b) -> 'a option -> 'b option
diff --git a/win32caml/editbuffer.c b/win32caml/editbuffer.c
new file mode 100644
index 000000000..480d22d86
--- /dev/null
+++ b/win32caml/editbuffer.c
@@ -0,0 +1,514 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*  Developed by Jacob Navia.                                          */
+/*  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.     */
+/*                                                                     */
+/***********************************************************************/
+
+/***********************************************************************/
+/* Changes made by Chris Watford to enhance the source editor          */
+/* Began 14 Sept 2003 - watford@uiuc.edu                               */
+/***********************************************************************/
+
+#include <string.h>
+#include <stdlib.h>
+#include "inriares.h"
+#include "inria.h"
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_addline ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Adds a line to the current edit buffer
+ Input:			Line of text to append to the end
+ Output:
+ Errors:
+--------------------------------------------------------------------------
+ Edit History:
+	18 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Corrected doubly linked list issue
+------------------------------------------------------------------------*/
+BOOL editbuffer_addline(EditBuffer* edBuf, char* line)
+{
+	LineList *tail = NULL; //head of the edit buffer line list
+	LineList *newline = NULL;
+
+	// sanity check
+	if(edBuf == NULL)
+	{
+		return FALSE;
+	}
+
+	// perform edit buffer sanity checks
+	if((edBuf->LineCount < 0) || (edBuf->Lines == NULL))
+	{
+		edBuf->LineCount = 0;
+	}
+
+	// move to the end of the line list in the edit buffer
+	if((tail = edBuf->Lines) != NULL)
+		for( ; tail->Next != NULL; tail = tail->Next);
+
+	// create the new line entry
+	newline = (LineList*)SafeMalloc(sizeof(LineList));
+	newline->Next = NULL;
+	newline->Prev = tail;
+	newline->Text = (char*)SafeMalloc(strlen(line)+1);
+	strncpy(newline->Text, line, strlen(line)+1);
+	newline->Text[strlen(line)] = '\0';
+
+	// add it to the list as the head or the tail
+	if(tail != NULL)
+	{
+		tail->Next = newline;
+	} else {
+		edBuf->Lines = newline;
+	}
+
+	// update the number of lines in the buffer
+	edBuf->LineCount++;
+
+	return TRUE;
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_updateline ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Updates the edit buffer's internal contents for a line
+ Input:			idx - Line index
+				line - String to add
+ Output:		if the line was updated or not
+ Errors:
+------------------------------------------------------------------------*/
+BOOL editbuffer_updateline(EditBuffer* edBuf, int idx, char* line)
+{
+	LineList *update = edBuf->Lines; //head of the edit buffer line list
+	LineList *newline = NULL;
+	int i;
+
+	// sanity checks
+	if(edBuf == NULL)
+	{
+		return FALSE;
+	} else if(	(edBuf->LineCount == 0) ||
+				(edBuf->Lines == NULL) ||
+				(idx >= edBuf->LineCount) ||
+				(idx < 0) ) {
+		return FALSE;
+	}
+
+	// move to the index in the line list
+	// i left in update != NULL as a sanity check
+	for(i = 0; ((update != NULL) && (i != idx)); update = update->Next, i++);
+
+	// did things mess up?
+	if( (update == NULL) || (i != idx) )
+	{
+		return FALSE;
+	}
+
+	// get rid of the old line
+	free(update->Text);
+
+	// get the new line updated
+	update->Text = (char*)SafeMalloc(strlen(line)+1);
+	strncpy(update->Text, line, strlen(line)+1);
+	update->Text[strlen(line)] = '\0';
+
+	return TRUE;
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_updateoraddline ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Updates the edit buffer's internal contents for a line
+ Input:			idx - Line index
+				line - String to add
+ Output:		if the line was updated or not
+ Errors:
+------------------------------------------------------------------------*/
+BOOL editbuffer_updateoraddline(EditBuffer* edBuf, int idx, char* line)
+{
+	LineList *update;
+
+	// sanity checks
+	if(edBuf == NULL)
+	{
+		return FALSE;
+	} else if((idx > edBuf->LineCount) || (idx < 0)) {
+		return FALSE;
+	}
+
+	update = edBuf->Lines; //head of the edit buffer line list
+
+	// do we update or add?
+	if((idx < edBuf->LineCount) && (edBuf->Lines != NULL))
+	{	//interior line, update
+		return editbuffer_updateline(edBuf, idx, line);
+	} else {
+		//fence line, add
+		return editbuffer_addline(edBuf, line);
+	}
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_removeline ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Removes a line from the edit buffer
+ Input:			idx - Line index to remove
+ Output:		if the line was removed or not
+ Errors:
+--------------------------------------------------------------------------
+ Edit History:
+	18 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Added to allow backspace and delete support
+		- Corrected doubly linked list issue
+------------------------------------------------------------------------*/
+BOOL editbuffer_removeline(EditBuffer* edBuf, int idx)
+{
+	LineList *update = NULL;
+	int i = 0;
+
+	// sanity checks
+	if(edBuf == NULL)
+	{
+		return FALSE;
+	} else if(	(edBuf->LineCount == 0) ||
+				(edBuf->Lines == NULL) ||
+				(idx >= edBuf->LineCount) ||
+				(idx < 0) ) {
+		return FALSE;
+	}
+	
+	// move to the index in the line list
+	// i left in update != NULL as a sanity check
+	for(i = 0, update = edBuf->Lines; ((update != NULL) && (i != idx)); update = update->Next, i++);
+
+	// remove this line
+	if(update != NULL)
+	{
+		// break links, removing our line
+		if(update->Prev != NULL)
+		{
+			// we're not the first so just break the link
+			update->Prev->Next = update->Next;
+			
+			// fix the prev check
+			if(update->Next != NULL)
+				update->Next->Prev = update->Prev;
+		} else {
+			// we're the first, attach the next guy to lines
+			edBuf->Lines = update->Next;
+		}
+
+		// one less line to worry about
+		edBuf->LineCount--;
+
+		// get rid of the text
+		if(update->Text != NULL)
+			free(update->Text);
+
+		// get rid of us
+		free(update);
+
+		return TRUE;
+	}
+
+	return FALSE;
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_getasline ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Returns the edit buffer as one big line, \n's and \t's
+				become spaces.
+ Input:
+ Output:
+ Errors:
+------------------------------------------------------------------------*/
+char* editbuffer_getasline(EditBuffer* edBuf)
+{
+	LineList *line = NULL; //head of the edit buffer line list
+	char* retline = (char*)realloc(NULL, 1);
+	unsigned int i = 0;
+
+	// fix retline bug
+	retline[0] = '\0';
+
+	// sanity checks
+	if(edBuf == NULL)
+	{
+		return NULL;
+	} else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
+		// fix any possible errors that may come from this
+		edBuf->LineCount = 0;
+		edBuf->Lines = NULL;
+		return NULL;
+	}
+
+	// get the big line
+	for(line = edBuf->Lines; line != NULL; line = line->Next)
+	{
+		if(line->Text != NULL)
+		{
+			retline = (char*)realloc(retline, (strlen(retline) + strlen(line->Text) + (strlen(retline) > 0 ? 2 : 1)));
+
+			if(strlen(retline) > 0)
+				retline = strcat(retline, " ");
+
+			retline = strcat(retline, line->Text);
+
+			//concat in the hoouuusssseee!
+		}
+	}
+
+	// now we have the big line, so lets ditch all \n's \t's and \r's
+	for(i = 0; i < strlen(retline); i++)
+	{
+		switch(retline[i])
+		{
+			case '\n':
+			case '\t':
+			case '\r':
+				retline[i] = ' ';
+		}
+	}
+
+	return retline;
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_getasbuffer ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Returns the edit buffer as one big line, \n's and \t's
+				become spaces.
+ Input:
+ Output:
+ Errors:
+------------------------------------------------------------------------*/
+char* editbuffer_getasbuffer(EditBuffer* edBuf)
+{
+	LineList *line = NULL; //head of the edit buffer line list
+	char* retbuf = (char*)realloc(NULL, 1);
+	unsigned int i = 0;
+
+	// fix retline bug
+	retbuf[0] = '\0';
+
+	// sanity checks
+	if(edBuf == NULL)
+	{
+		return NULL;
+	} else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
+		// fix any possible errors that may come from this
+		edBuf->LineCount = 0;
+		edBuf->Lines = NULL;
+		return NULL;
+	}
+
+	// get the big line
+	for(line = edBuf->Lines; line != NULL; line = line->Next)
+	{
+		if(line->Text != NULL)
+		{
+			int len = strlen(retbuf);
+			len += strlen(line->Text) + (len > 0 ? 3 : 1);
+
+			retbuf = (char*)realloc(retbuf, len);
+
+			if(strlen(retbuf) > 0)
+				retbuf = strcat(retbuf, "\r\n");
+
+			retbuf = strcat(retbuf, line->Text);
+
+			retbuf[len-1] = '\0';
+
+			//concat in the hoouuusssseee!
+		}
+	}
+
+	return retbuf;
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_lastline ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Returns the last line in the edit buffer
+ Input:
+ Output:
+ Errors:
+------------------------------------------------------------------------*/
+char* editbuffer_lastline(EditBuffer* edBuf)
+{
+	LineList *line = NULL; //head of the edit buffer line list
+
+	// sanity checks
+	if(edBuf == NULL)
+	{
+		return NULL;
+	} else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
+		// fix any possible errors that may come from this
+		edBuf->LineCount = 0;
+		edBuf->Lines = NULL;
+		return NULL;
+	}
+
+	// go to the last line
+	for(line = edBuf->Lines; line->Next != NULL; line = line->Next);
+
+	return line->Text;
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_copy ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Makes an exact copy of an edit buffer
+ Input:
+ Output:
+ Errors:
+--------------------------------------------------------------------------
+ Edit History:
+	16 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Added to make copies of history entries
+	18 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Corrected doubly linked list issue
+	06 Oct  2003 - Chris Watford watford@uiuc.edu
+		- Added isCorrect flag
+------------------------------------------------------------------------*/
+EditBuffer* editbuffer_copy(EditBuffer* edBuf)
+{
+	// sanity checks
+	if(edBuf == NULL)
+	{
+		return NULL;
+	} else {
+		EditBuffer* copy = (EditBuffer*)SafeMalloc(sizeof(EditBuffer));
+		LineList* lines = edBuf->Lines;
+		LineList* lastLine = NULL;
+
+		// clear its initial values
+		copy->LineCount = 0;
+		copy->Lines = NULL;
+		copy->isCorrect = FALSE;
+
+		// well we don't have to copy much
+		if((lines == NULL) || (edBuf->LineCount <= 0))
+		{
+			return copy;
+		}
+
+		// get if its correct
+		copy->isCorrect = edBuf->isCorrect;
+
+		// go through each line, malloc it and add it
+		for( ; lines != NULL; lines = lines->Next)
+		{
+			LineList* curline = (LineList*)SafeMalloc(sizeof(LineList));
+			curline->Next = NULL;
+			curline->Prev = NULL;
+
+			// if there was a last line, link them to us
+			if(lastLine != NULL)
+			{
+				lastLine->Next = curline;
+				curline->Prev = lastLine;
+			}
+
+			// are we the first line? add us to the edit buffer as the first
+			if(copy->Lines == NULL)
+			{
+				copy->Lines = curline;
+			}
+
+			// check if there is text on the line
+			if(lines->Text == NULL)
+			{	// no text, make it blankz0r
+				curline->Text = (char*)SafeMalloc(sizeof(char));
+				curline->Text[0] = '\0';
+			} else {
+				// there is text, copy it and null-terminate
+				curline->Text = (char*)SafeMalloc(strlen(lines->Text) + 1);
+				strncpy(curline->Text, lines->Text, strlen(lines->Text));
+				curline->Text[strlen(lines->Text)] = '\0';
+			}
+
+			// up the line count and make us the last line
+			copy->LineCount++;
+			lastLine = curline;
+		}
+
+		// return our new copy
+		return copy;
+	}
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_destroy ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Destroys an edit buffer
+ Input:
+ Output:
+ Errors:
+------------------------------------------------------------------------*/
+void editbuffer_destroy(EditBuffer* edBuf)
+{
+	// sanity checks
+	if(edBuf == NULL)
+	{	// nothing to do
+		return;
+	} else if(edBuf->Lines != NULL) {
+		LineList* lastline = NULL;
+
+		// loop through each line free'ing its text
+		for( ; edBuf->Lines != NULL; edBuf->Lines = edBuf->Lines->Next)
+		{
+			if(edBuf->Lines->Text != NULL)
+				free(edBuf->Lines->Text);
+
+			// if there was a line before us, free it
+			if(lastline != NULL)
+			{
+				free(lastline);
+				lastline = NULL;
+			}
+
+			lastline = edBuf->Lines;
+		}
+
+		// free the last line
+		free(lastline);
+	}
+
+	// free ourself
+	free(edBuf);
+}
+
+/*------------------------------------------------------------------------
+ Procedure:     editbuffer_new ID:1
+ Author:		Chris Watford watford@uiuc.edu
+ Purpose:       Creates an edit buffer
+ Input:
+ Output:
+ Errors:
+--------------------------------------------------------------------------
+ Edit History:
+	06 Oct  2003 - Chris Watford watford@uiuc.edu
+		- Added isCorrect flag
+------------------------------------------------------------------------*/
+EditBuffer* editbuffer_new(void)
+{
+	// create a new one
+	EditBuffer *edBuf = (EditBuffer*)SafeMalloc(sizeof(EditBuffer));
+	
+	// default vals
+	edBuf->LineCount = 0;
+	edBuf->Lines = NULL;
+	edBuf->isCorrect = FALSE;
+	
+	// return it
+	return edBuf;
+}
diff --git a/win32caml/editbuffer.h b/win32caml/editbuffer.h
new file mode 100644
index 000000000..91e2999c3
--- /dev/null
+++ b/win32caml/editbuffer.h
@@ -0,0 +1,47 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Jacob Navia, after Xavier Leroy                          */
+/*                                                                     */
+/*  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.     */
+/*                                                                     */
+/***********************************************************************/
+
+/***********************************************************************/
+/* Changes made by Chris Watford to enhance the source editor          */
+/* Began 14 Sept 2003 - watford@uiuc.edu                               */
+/***********************************************************************/
+
+#ifndef _EDITBUFFER_H_
+#define _EDITBUFFER_H_
+
+// All the below was added by Chris Watford watford@uiuc.edu
+
+typedef struct tagLineList {
+        struct tagLineList	*Next;
+		struct tagLineList	*Prev;
+        char				*Text;
+} LineList;
+
+typedef struct tagEditBuffer {
+	int					LineCount;
+	struct tagLineList	*Lines;
+	BOOL				isCorrect;
+} EditBuffer;
+
+BOOL		editbuffer_addline			(EditBuffer* edBuf, char* line);
+BOOL		editbuffer_updateline		(EditBuffer* edBuf, int idx, char* line);
+BOOL		editbuffer_updateoraddline	(EditBuffer* edBuf, int idx, char* line);
+BOOL		editbuffer_removeline		(EditBuffer* edBuf, int idx);
+char*		editbuffer_getasline		(EditBuffer* edBuf);
+char*		editbuffer_getasbuffer		(EditBuffer* edBuf);
+char*		editbuffer_lastline			(EditBuffer* edBuf);
+EditBuffer*	editbuffer_copy				(EditBuffer* edBuf);
+void		editbuffer_destroy			(EditBuffer* edBuf);
+EditBuffer*	editbuffer_new				(void);
+
+#endif
diff --git a/win32caml/history.c b/win32caml/history.c
new file mode 100644
index 000000000..11397ac66
--- /dev/null
+++ b/win32caml/history.c
@@ -0,0 +1,98 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Jacob Navia, after Xavier Leroy                          */
+/*                                                                     */
+/*  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.     */
+/*                                                                     */
+/***********************************************************************/
+
+/***********************************************************************/
+/* Changes made by Chris Watford to enhance the source editor          */
+/* Began 14 Sept 2003 - watford@uiuc.edu                               */
+/***********************************************************************/
+
+#include "inria.h"
+#include "history.h"
+
+/*------------------------------------------------------------------------
+Procedure:     AddToHistory ID:2
+Author:		   Chris Watford watford@uiuc.edu
+Purpose:       Adds an edit buffer to the history control
+Input:		   Pointer to the edit buffer to add
+Output:
+Errors:
+--------------------------------------------------------------------------
+Edit History:
+	15 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Complete rewrite
+		- Got it to add the edit buffer to the history
+	17 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Added doubly link list support
+------------------------------------------------------------------------*/
+void AddToHistory(EditBuffer *edBuf)
+{
+	StatementHistory *newLine;
+
+	// sanity checks
+	if(edBuf == NULL)
+	{
+		return;
+	} else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
+		// fix any possible errors that may come from this
+		edBuf->LineCount = 0;
+		edBuf->Lines = NULL;
+		return;
+	}
+
+	// setup newline and add as the front of the linked list
+	newLine = SafeMalloc(sizeof(StatementHistory));
+	newLine->Next = History;
+	newLine->Prev = NULL;
+	newLine->Statement = edBuf;
+
+	// setup back linking
+	if(History != NULL)
+		History->Prev = newLine;
+
+	// set the history up
+	History = newLine;
+
+	// search for the new history tail
+	for(HistoryTail = (HistoryTail != NULL ? HistoryTail : History); HistoryTail->Next != NULL; HistoryTail = HistoryTail->Next);
+}
+
+/*------------------------------------------------------------------------
+Procedure:     GetHistoryLine ID:2
+Author:		   Chris Watford watford@uiuc.edu
+Purpose:       Returns an entry from the history table
+Input:		   Index of the history entry to return
+Output:		   The history entry as a single line
+Errors:
+--------------------------------------------------------------------------
+Edit History:
+	15 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Complete rewrite
+	17 Sept 2003 - Chris Watford watford@uiuc.edu
+		- Added doubly link list support
+------------------------------------------------------------------------*/
+char *GetHistoryLine(int n)
+{
+	StatementHistory *histentry = History;
+	int i;
+
+	// traverse linked list looking for member n
+	for (i = 0; ((i < n) && (histentry != NULL)); i++, histentry = histentry->Next);
+
+	// figure out what to return
+	if (histentry != NULL)
+	{
+		return editbuffer_getasline(histentry->Statement);
+	} else {
+		return "";
+	}
+}
diff --git a/win32caml/history.h b/win32caml/history.h
new file mode 100644
index 000000000..a9ba85841
--- /dev/null
+++ b/win32caml/history.h
@@ -0,0 +1,35 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Jacob Navia, after Xavier Leroy                          */
+/*                                                                     */
+/*  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.     */
+/*                                                                     */
+/***********************************************************************/
+
+/***********************************************************************/
+/* Changes made by Chris Watford to enhance the source editor          */
+/* Began 14 Sept 2003 - watford@uiuc.edu                               */
+/***********************************************************************/
+
+#ifndef _HISTORY_H_
+#define _HISTORY_H_
+
+#include "editbuffer.h"
+
+// Simple linked list for holding the history lines
+typedef struct tagStatementHistory {
+        struct tagStatementHistory	*Next;
+		struct tagStatementHistory	*Prev;
+        EditBuffer					*Statement;
+} StatementHistory;
+
+void	AddToHistory	(EditBuffer *edBuf);
+char	*GetHistoryLine	(int n);
+static BOOL CALLBACK HistoryDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM lParam);
+
+#endif
diff --git a/win32caml/resource.h b/win32caml/resource.h
new file mode 100644
index 000000000..67625979c
--- /dev/null
+++ b/win32caml/resource.h
@@ -0,0 +1,16 @@
+//{{NO_DEPENDENCIES}}
+// Microsoft Visual C++ generated include file.
+// Used by ocaml.rc
+//
+
+// Next default values for new objects
+// 
+#ifdef APSTUDIO_INVOKED
+#ifndef APSTUDIO_READONLY_SYMBOLS
+#define _APS_NO_MFC                     1
+#define _APS_NEXT_RESOURCE_VALUE        101
+#define _APS_NEXT_COMMAND_VALUE         40001
+#define _APS_NEXT_CONTROL_VALUE         1000
+#define _APS_NEXT_SYMED_VALUE           101
+#endif
+#endif
diff --git a/win32caml/startocaml.c b/win32caml/startocaml.c
index 578d407cb..491fab8ca 100644
--- a/win32caml/startocaml.c
+++ b/win32caml/startocaml.c
@@ -22,7 +22,7 @@
 #include <io.h>
 #include <direct.h>
 #include "inria.h"
-extern int _get_osfhandle(int);
+
 PROCESS_INFORMATION pi;
 #define BUFSIZE 4096
 STARTUPINFO startInfo;
@@ -222,8 +222,9 @@ Output:        None visible
 Errors:        If any system call for whatever reason fails, the
 thread will exit. No error message is shown.
 ------------------------------------------------------------------------*/
-int _stdcall DoStartOcaml(HWND hwndParent)
+DWORD WINAPI DoStartOcaml(LPVOID param)
 {
+        HWND hwndParent = (HWND) param;
 	char *cmdline;
 	int processStarted;
 	LPSECURITY_ATTRIBUTES lpsa=NULL;
@@ -364,7 +365,7 @@ void InterruptOcaml(void)
 {
 	if (!GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pi.dwProcessId)) {
 		char message[1024];
-		sprintf(message, "GenerateConsole failed: %d\n", GetLastError());
+		sprintf(message, "GenerateConsole failed: %lu\n", GetLastError());
 		MessageBox(NULL, message, "Ocaml", MB_OK);
 	}
 	WriteToPipe(" ");