merge with branch bin-annot

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@12516 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
author: Fabrice Le Fessant <Fabrice.Le_fessant@inria.fr> 2012-05-30 14:52:37 +0000
committer: Fabrice Le Fessant <Fabrice.Le_fessant@inria.fr> 2012-05-30 14:52:37 +0000
commit: d39d43e55fab716fbe05cec3c89233f0dd208835 (patch)
tree: bf5c56aa9bb32a0e3d49509b8b2863a9ec407563 /camlp4
parent: e3d82817909dd7bc69dff4f75aa63c5ba606d9c8 (diff)
6 files changed, 572 insertions, 444 deletions
diff --git a/camlp4/Camlp4/Printers/OCaml.ml b/camlp4/Camlp4/Printers/OCaml.ml
index 6cd292aba..c1b5f1d90 100644
--- a/camlp4/Camlp4/Printers/OCaml.ml
+++ b/camlp4/Camlp4/Printers/OCaml.ml
@@ -106,8 +106,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
           "Cannot print %S this identifier does not respect OCaml lexing rules (%s)"
           str (Lexer.Error.to_string exn)) ];
 
-  (* This is to be sure character literals are always escaped. *)
-  value ocaml_char x = Char.escaped (Struct.Token.Eval.char x);
+  value ocaml_char x =
+      match x with [ "'" -> "\\'" | c -> c ];
 
   value rec get_expr_args a al =
     match a with
@@ -557,7 +557,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
     | <:expr< $int64:s$ >> -> o#numeric f s "L"
     | <:expr< $int32:s$ >> -> o#numeric f s "l"
     | <:expr< $flo:s$ >> -> o#numeric f s ""
-    | <:expr< $chr:s$ >> -> pp f "'%s'" (ocaml_char s)
+    | <:expr< $chr:s$ >> -> pp f "'%s'" s
     | <:expr< $id:i$ >> -> o#var_ident f i
     | <:expr< { $b$ } >> ->
         pp f "@[<hv0>@[<hv2>{%a@]@ }@]" o#record_binding b
@@ -667,7 +667,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
     | <:patt< $int32:s$ >> -> o#numeric f s "l"
     | <:patt< $int:s$ >> -> o#numeric f s ""
     | <:patt< $flo:s$ >> -> o#numeric f s ""
-    | <:patt< $chr:s$ >> -> pp f "'%s'" (ocaml_char s)
+    | <:patt< $chr:s$ >> -> pp f "'%s'" s
     | <:patt< ~ $s$ >> -> pp f "~%s" s
     | <:patt< ` $uid:s$ >> -> pp f "`%a" o#var s
     | <:patt< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i
diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
index e73e875ff..2838083fd 100644
--- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
+++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
@@ -57,6 +57,8 @@ module Make (Ast : Sig.Camlp4Ast) = struct
   value mkloc = Loc.to_ocaml_location;
   value mkghloc loc = Loc.to_ocaml_location (Loc.ghostify loc);
 
+  value with_loc txt loc = Camlp4_import.Location.mkloc txt (mkloc loc);
+
   value mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc};
   value mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc};
   value mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc};
@@ -67,7 +69,10 @@ module Make (Ast : Sig.Camlp4Ast) = struct
   value mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc};
   value mkfield loc d = {pfield_desc = d; pfield_loc = mkloc loc};
   value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc};
-  value mkpcl loc d = {pcl_desc = d; pcl_loc = mkloc loc};
+  value mkcl loc d = {pcl_desc = d; pcl_loc = mkloc loc};
+  value mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; };
+  value mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; };
+
   value mkpolytype t =
     match t.ptyp_desc with
     [ Ptyp_poly _ _ -> t
@@ -85,6 +90,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     | _ -> assert False ];
 
   value lident s = Lident s;
+  value lident_with_loc s loc = with_loc (Lident s) loc;
+
+
   value ldot l s = Ldot l s;
   value lapply l s = Lapply l s;
 
@@ -106,17 +114,17 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     }
   ;
 
-  value array_function str name =
+  value array_function_no_loc str name =
     ldot (lident str) (if Camlp4_config.unsafe.val then "unsafe_" ^ name else name)
   ;
-
+  value array_function loc str name = with_loc (array_function_no_loc str name) loc;
   value mkrf =
     fun
     [ <:rec_flag< rec >> -> Recursive
     | <:rec_flag<>> -> Nonrecursive
     | _ -> assert False ];
 
-  value mkli s = loop lident
+  value mkli sloc s list = with_loc (loop lident list) sloc
     where rec loop f =
       fun
       [ [i :: il] -> loop (ldot (f i)) il
@@ -161,18 +169,20 @@ module Make (Ast : Sig.Camlp4Ast) = struct
       | _ -> error (loc_of_ident i) "invalid long identifier" ]
     in self i None;
 
-  value ident ?conv_lid i = fst (ident_tag ?conv_lid i);
+  value ident_noloc ?conv_lid i = fst (ident_tag ?conv_lid i);
+  value ident ?conv_lid  i =
+        with_loc (ident_noloc ?conv_lid i) (loc_of_ident i);
 
-  value long_lident msg i =
-    match ident_tag i with
-    [ (i, `lident) -> i
-    | _ -> error (loc_of_ident i) msg ]
+  value long_lident msg id =
+    match ident_tag id with
+    [ (i, `lident) -> with_loc i (loc_of_ident id)
+    | _ -> error (loc_of_ident id) msg ]
   ;
 
   value long_type_ident = long_lident "invalid long identifier type";
   value long_class_ident = long_lident "invalid class name";
 
-  value long_uident ?(conv_con = fun x -> x) i =
+  value long_uident_noloc ?(conv_con = fun x -> x) i =
     match ident_tag i with
     [ (Ldot i s, `uident) -> ldot i (conv_con s)
     | (Lident s, `uident) -> lident (conv_con s)
@@ -180,9 +190,12 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     | _ -> error (loc_of_ident i) "uppercase identifier expected" ]
   ;
 
+  value long_uident ?conv_con i =
+     with_loc (long_uident_noloc ?conv_con i) (loc_of_ident i);
+
   value rec ctyp_long_id_prefix t =
     match t with
-    [ <:ctyp< $id:i$ >> -> ident i
+    [ <:ctyp< $id:i$ >> -> ident_noloc i
     | <:ctyp< $m1$ $m2$ >> ->
         let li1 = ctyp_long_id_prefix m1 in
         let li2 = ctyp_long_id_prefix m2 in
@@ -318,20 +331,21 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     | _ -> assert False ];
   value mktrecord =
     fun
-    [ <:ctyp@loc< $lid:s$ : mutable $t$ >> ->
-        (s, Mutable, mkpolytype (ctyp t), mkloc loc)
-    | <:ctyp@loc< $lid:s$ : $t$ >> ->
-        (s, Immutable, mkpolytype (ctyp t), mkloc loc)
+    [ <:ctyp@loc< $id:(<:ident@sloc< $lid:s$ >>)$ : mutable $t$ >> ->
+        (with_loc s sloc, Mutable, mkpolytype (ctyp t), mkloc loc)
+    | <:ctyp@loc< $id:(<:ident@sloc< $lid:s$ >>)$ : $t$ >> ->
+        (with_loc s sloc, Immutable, mkpolytype (ctyp t), mkloc loc)
     | _ -> assert False (*FIXME*) ];
   value mkvariant =
     fun
-    [ <:ctyp@loc< $uid:s$ >> -> (conv_con s, [], None, mkloc loc)
-    | <:ctyp@loc< $uid:s$ of $t$ >> ->
-        (conv_con s, List.map ctyp (list_of_ctyp t []), None, mkloc loc)
-    | <:ctyp@loc< $uid:s$ : ($t$ -> $u$) >> ->
-        (conv_con s, List.map ctyp (list_of_ctyp t []), Some (ctyp u), mkloc loc)
-    | <:ctyp@loc< $uid:s$ : $t$ >> ->
-        (conv_con s, [], Some (ctyp t), mkloc loc)
+    [ <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ >> ->
+      (with_loc (conv_con s) sloc, [], None, mkloc loc)
+    | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ of $t$ >> ->
+      (with_loc (conv_con s) sloc, List.map ctyp (list_of_ctyp t []), None, mkloc loc)
+    | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ : ($t$ -> $u$) >> ->
+      (with_loc (conv_con s) sloc, List.map ctyp (list_of_ctyp t []), Some (ctyp u), mkloc loc)
+    | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ : $t$ >> ->
+      (with_loc (conv_con s) sloc, [], Some (ctyp t), mkloc loc)
 
     | _ -> assert False (*FIXME*) ];
   value rec type_decl tl cl loc m pflag =
@@ -359,7 +373,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
 
   value type_decl tl cl t loc = type_decl tl cl loc None False t;
 
-  value mkvalue_desc t p = {pval_type = ctyp t; pval_prim = p};
+  value mkvalue_desc loc t p = {pval_type = ctyp t; pval_prim = p; pval_loc = mkloc loc};
 
   value rec list_of_meta_list =
     fun
@@ -395,20 +409,20 @@ module Make (Ast : Sig.Camlp4Ast) = struct
   value rec optional_type_parameters t acc =
     match t with
     [ <:ctyp< $t1$ $t2$ >> -> optional_type_parameters t1 (optional_type_parameters t2 acc)
-    | <:ctyp< +'$s$ >> -> [(Some s, (True, False)) :: acc]
+    | <:ctyp@loc< +'$s$ >> -> [(Some (with_loc s loc), (True, False)) :: acc]
     | Ast.TyAnP _loc  -> [(None, (True, False)) :: acc]
-    | <:ctyp< -'$s$ >> -> [(Some s, (False, True)) :: acc]
+    | <:ctyp@loc< -'$s$ >> -> [(Some (with_loc s loc), (False, True)) :: acc]
     | Ast.TyAnM _loc -> [(None, (False, True)) :: acc]
-    | <:ctyp< '$s$ >> -> [(Some s, (False, False)) :: acc]
+    | <:ctyp@loc< '$s$ >> -> [(Some (with_loc s loc), (False, False)) :: acc]
     | Ast.TyAny _loc -> [(None, (False, False)) :: acc]
     | _ -> assert False ];
 
   value rec class_parameters t acc =
     match t with
     [ <:ctyp< $t1$, $t2$ >> -> class_parameters t1 (class_parameters t2 acc)
-    | <:ctyp< +'$s$ >> -> [(s, (True, False)) :: acc]
-    | <:ctyp< -'$s$ >> -> [(s, (False, True)) :: acc]
-    | <:ctyp< '$s$ >> -> [(s, (False, False)) :: acc]
+    | <:ctyp@loc< +'$s$ >> -> [(with_loc s loc, (True, False)) :: acc]
+    | <:ctyp@loc< -'$s$ >> -> [(with_loc s loc, (False, True)) :: acc]
+    | <:ctyp@loc< '$s$ >> -> [(with_loc s loc, (False, False)) :: acc]
     | _ -> assert False ];
 
   value rec type_parameters_and_type_name t acc =
@@ -470,7 +484,8 @@ module Make (Ast : Sig.Camlp4Ast) = struct
 
   value rec patt =
     fun
-    [ <:patt@loc< $lid:s$ >> -> mkpat loc (Ppat_var s)
+    [ <:patt@loc< $id:(<:ident@sloc< $lid:s$ >>)$ >> ->
+      mkpat loc (Ppat_var (with_loc s sloc))
     | <:patt@loc< $id:i$ >> ->
         let p = Ppat_construct (long_uident ~conv_con i)
                   None (constructors_arity ())
@@ -478,15 +493,15 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     | PaAli loc p1 p2 ->
         let (p, i) =
           match (p1, p2) with
-          [ (p, <:patt< $lid:s$ >>) -> (p, s)
-          | (<:patt< $lid:s$ >>, p) -> (p, s)
+          [ (p, <:patt< $id:(<:ident@sloc< $lid:s$ >>)$ >>) -> (p, with_loc s sloc)
+          | (<:patt< $id:(<:ident@sloc< $lid:s$ >>)$ >>, p) -> (p, with_loc s sloc)
           | _ -> error loc "invalid alias pattern" ]
         in
         mkpat loc (Ppat_alias (patt p) i)
     | PaAnt loc _ -> error loc "antiquotation not allowed here"
     | PaAny loc -> mkpat loc Ppat_any
-    | <:patt@loc< $uid:s$ ($tup:<:patt@loc_any< _ >>$) >> ->
-        mkpat loc (Ppat_construct (lident (conv_con s))
+    | <:patt@loc< $id:(<:ident@sloc< $uid:s$ >>)$ ($tup:<:patt@loc_any< _ >>$) >> ->
+        mkpat loc (Ppat_construct (lident_with_loc (conv_con s) sloc)
               (Some (mkpat loc_any Ppat_any)) False)
     | PaApp loc _ _ as f ->
         let (f, al) = patt_fa [] f in
@@ -560,7 +575,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     | PaTyp loc i -> mkpat loc (Ppat_type (long_type_ident i))
     | PaVrn loc s -> mkpat loc (Ppat_variant (conv_con s) None)
     | PaLaz loc p -> mkpat loc (Ppat_lazy (patt p))
-    | PaMod loc m -> mkpat loc (Ppat_unpack m)
+    | PaMod loc m -> mkpat loc (Ppat_unpack (with_loc m loc))
     | PaEq _ _ _ | PaSem _ _ _ | PaCom _ _ _ | PaNil _ as p ->
         error (loc_of_patt p) "invalid pattern" ]
   and mklabpat =
@@ -612,9 +627,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     [ <:ctyp<>> -> acc
     | t -> list_of_ctyp t acc ];
 
-value varify_constructors var_names = 
-  let rec loop t = 
-    let desc = 
+value varify_constructors var_names =
+  let rec loop t =
+    let desc =
       match t.ptyp_desc with
 	  [
        Ptyp_any -> Ptyp_any
@@ -622,27 +637,27 @@ value varify_constructors var_names =
       | Ptyp_arrow label core_type core_type' ->
 	  Ptyp_arrow label (loop core_type) (loop core_type')
       | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
-      | Ptyp_constr (Lident s) [] when List.mem s var_names ->
+      | Ptyp_constr ({ txt = Lident s }) [] when List.mem s var_names ->
 	  Ptyp_var ("&" ^ s)
       | Ptyp_constr longident lst ->
-	  Ptyp_constr longident (List.map loop lst) 
+	  Ptyp_constr longident (List.map loop lst)
       | Ptyp_object lst ->
-	  Ptyp_object (List.map loop_core_field lst)		    
+	  Ptyp_object (List.map loop_core_field lst)
       | Ptyp_class longident lst lbl_list ->
-	  Ptyp_class (longident, List.map loop lst, lbl_list) 
+	  Ptyp_class (longident, List.map loop lst, lbl_list)
       | Ptyp_alias core_type string ->
-	  Ptyp_alias(loop core_type, string) 
-      | Ptyp_variant row_field_list flag lbl_lst_option -> 
-	  Ptyp_variant(List.map loop_row_field row_field_list, flag, lbl_lst_option) 
+	  Ptyp_alias(loop core_type, string)
+      | Ptyp_variant row_field_list flag lbl_lst_option ->
+	  Ptyp_variant(List.map loop_row_field row_field_list, flag, lbl_lst_option)
       | Ptyp_poly string_lst core_type ->
-	  Ptyp_poly(string_lst, loop core_type) 
+	  Ptyp_poly(string_lst, loop core_type)
       | Ptyp_package longident lst ->
 	  Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
 ]
     in
     {(t) with ptyp_desc = desc}
-  and loop_core_field t = 
-    let desc = 
+  and loop_core_field t =
+    let desc =
       match t.pfield_desc with
       [ Pfield(n,typ) ->
 	  Pfield(n,loop typ)
@@ -650,10 +665,10 @@ value varify_constructors var_names =
 	  Pfield_var]
     in
     { (t) with pfield_desc=desc}
-  and loop_row_field x  = 
+  and loop_row_field x  =
     match x with
       [ Rtag(label,flag,lst) ->
-	  Rtag(label,flag,List.map loop lst) 
+	  Rtag(label,flag,List.map loop lst)
       | Rinherit t ->
 	  Rinherit (loop t) ]
   in
@@ -665,15 +680,15 @@ value varify_constructors var_names =
     fun
     [ <:expr@loc< $x$.val >> ->
         mkexp loc
-          (Pexp_apply (mkexp loc (Pexp_ident (Lident "!"))) [("", expr x)])
+          (Pexp_apply (mkexp loc (Pexp_ident (lident_with_loc "!" loc))) [("", expr x)])
     | ExAcc loc _ _ | <:expr@loc< $id:<:ident< $_$ . $_$ >>$ >> as e ->
         let (e, l) =
           match sep_expr_acc [] e with
-          [ [(loc, ml, <:expr< $uid:s$ >>) :: l] ->
+          [ [(loc, ml, <:expr@sloc< $uid:s$ >>) :: l] ->
               let ca = constructors_arity () in
-              (mkexp loc (Pexp_construct (mkli (conv_con s) ml) None ca), l)
-          | [(loc, ml, <:expr< $lid:s$ >>) :: l] ->
-              (mkexp loc (Pexp_ident (mkli s ml)), l)
+              (mkexp loc (Pexp_construct (mkli sloc (conv_con s) ml) None ca), l)
+          | [(loc, ml, <:expr@sloc< $lid:s$ >>) :: l] ->
+              (mkexp loc (Pexp_ident (mkli sloc s ml)), l)
           | [(_, [], e) :: l] -> (expr e, l)
           | _ -> error loc "bad ast in expression" ]
         in
@@ -681,9 +696,9 @@ value varify_constructors var_names =
           List.fold_left
             (fun (loc_bp, e1) (loc_ep, ml, e2) ->
               match e2 with
-              [ <:expr< $lid:s$ >> ->
+              [ <:expr@sloc< $lid:s$ >> ->
                   let loc = Loc.merge loc_bp loc_ep
-                  in  (loc, mkexp loc (Pexp_field e1 (mkli (conv_lab s) ml)))
+                  in  (loc, mkexp loc (Pexp_field e1 (mkli sloc (conv_lab s) ml)))
               | _ -> error (loc_of_expr e2) "lowercase identifier expected" ])
             (loc, e) l
         in
@@ -717,7 +732,7 @@ value varify_constructors var_names =
         | _ -> mkexp loc (Pexp_apply (expr f) al) ]
     | ExAre loc e1 e2 ->
         mkexp loc
-          (Pexp_apply (mkexp loc (Pexp_ident (array_function "Array" "get")))
+          (Pexp_apply (mkexp loc (Pexp_ident (array_function loc "Array" "get")))
             [("", expr e1); ("", expr e2)])
     | ExArr loc e -> mkexp loc (Pexp_array (List.map expr (list_of_expr e [])))
     | ExAsf loc -> mkexp loc Pexp_assertfalse
@@ -725,19 +740,19 @@ value varify_constructors var_names =
         let e =
           match e with
           [ <:expr@loc< $x$.val >> ->
-              Pexp_apply (mkexp loc (Pexp_ident (Lident ":=")))
+              Pexp_apply (mkexp loc (Pexp_ident (lident_with_loc ":=" loc)))
                 [("", expr x); ("", expr v)]
           | ExAcc loc _ _ ->
               match (expr e).pexp_desc with
               [ Pexp_field e lab -> Pexp_setfield e lab (expr v)
               | _ -> error loc "bad record access" ]
-          | ExAre _ e1 e2 ->
-              Pexp_apply (mkexp loc (Pexp_ident (array_function "Array" "set")))
+          | ExAre loc e1 e2 ->
+              Pexp_apply (mkexp loc (Pexp_ident (array_function loc "Array" "set")))
                 [("", expr e1); ("", expr e2); ("", expr v)]
-          | <:expr< $lid:lab$ >> -> Pexp_setinstvar lab (expr v)
-          | ExSte _ e1 e2 ->
+          | <:expr< $id:(<:ident@lloc< $lid:lab$ >>)$ >> -> Pexp_setinstvar (with_loc lab lloc) (expr v)
+          | ExSte loc e1 e2 ->
               Pexp_apply
-                (mkexp loc (Pexp_ident (array_function "String" "set")))
+                (mkexp loc (Pexp_ident (array_function loc "String" "set")))
                 [("", expr e1); ("", expr e2); ("", expr v)]
           | _ -> error loc "bad left part of assignment" ]
         in
@@ -754,7 +769,7 @@ value varify_constructors var_names =
     | ExFlo loc s -> mkexp loc (Pexp_constant (Const_float (remove_underscores s)))
     | ExFor loc i e1 e2 df el ->
         let e3 = ExSeq loc el in
-        mkexp loc (Pexp_for i (expr e1) (expr e2) (mkdirection df) (expr e3))
+        mkexp loc (Pexp_for (with_loc i loc) (expr e1) (expr e2) (mkdirection df) (expr e3))
     | <:expr@loc< fun [ $PaLab _ lab po$ when $w$ -> $e$ ] >> ->
         mkexp loc
           (Pexp_function lab None
@@ -790,7 +805,7 @@ value varify_constructors var_names =
     | ExLaz loc e -> mkexp loc (Pexp_lazy (expr e))
     | ExLet loc rf bi e ->
         mkexp loc (Pexp_let (mkrf rf) (binding bi []) (expr e))
-    | ExLmd loc i me e -> mkexp loc (Pexp_letmodule i (module_expr me) (expr e))
+    | ExLmd loc i me e -> mkexp loc (Pexp_letmodule (with_loc i loc) (module_expr me) (expr e))
     | ExMat loc e a -> mkexp loc (Pexp_match (expr e) (match_case a []))
     | ExNew loc id -> mkexp loc (Pexp_new (long_type_ident id))
     | ExObj loc po cfl ->
@@ -800,7 +815,7 @@ value varify_constructors var_names =
           | p -> p ]
         in
         let cil = class_str_item cfl [] in
-        mkexp loc (Pexp_object (patt p, cil))
+        mkexp loc (Pexp_object { pcstr_pat = patt p; pcstr_fields = cil })
     | ExOlb loc _ _ -> error loc "labeled expression not allowed here"
     | ExOvr loc iel -> mkexp loc (Pexp_override (mkideexp iel []))
     | ExRec loc lel eo ->
@@ -825,7 +840,7 @@ value varify_constructors var_names =
     | ExSnd loc e s -> mkexp loc (Pexp_send (expr e) s)
     | ExSte loc e1 e2 ->
         mkexp loc
-          (Pexp_apply (mkexp loc (Pexp_ident (array_function "String" "get")))
+          (Pexp_apply (mkexp loc (Pexp_ident (array_function loc "String" "get")))
             [("", expr e1); ("", expr e2)])
     | ExStr loc s ->
         mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s)))
@@ -835,12 +850,12 @@ value varify_constructors var_names =
     | <:expr@loc< ($tup:_$) >> -> error loc "singleton tuple"
     | ExTyc loc e t -> mkexp loc (Pexp_constraint (expr e) (Some (ctyp t)) None)
     | <:expr@loc< () >> ->
-        mkexp loc (Pexp_construct (lident "()") None True)
+        mkexp loc (Pexp_construct (lident_with_loc "()" loc) None True)
     | <:expr@loc< $lid:s$ >> ->
-        mkexp loc (Pexp_ident (lident s))
+        mkexp loc (Pexp_ident (lident_with_loc s loc))
     | <:expr@loc< $uid:s$ >> ->
         (* let ca = constructors_arity () in *)
-        mkexp loc (Pexp_construct (lident (conv_con s)) None True)
+        mkexp loc (Pexp_construct (lident_with_loc (conv_con s) loc) None True)
     | ExVrn loc s -> mkexp loc (Pexp_variant (conv_con s) None)
     | ExWhi loc e1 el ->
         let e2 = ExSeq loc el in
@@ -875,10 +890,10 @@ value varify_constructors var_names =
     match x with
     [ <:binding< $x$ and $y$ >> ->
          binding x (binding y acc)
-    | <:binding@_loc< $lid:bind_name$ = ($e$ : $TyTypePol _ vs ty$) >> ->
+    | <:binding@_loc< $pat:( <:patt@sloc< $lid:bind_name$ >> )$ = ($e$ : $TyTypePol _ vs ty$) >> ->
       (* this code is not pretty because it is temporary *)
-      let rec id_to_string x = 
-	match x with 
+      let rec id_to_string x =
+	match x with
 	    [ <:ctyp< $lid:x$ >> -> [x]
 	    | <:ctyp< $x$ $y$ >> -> (id_to_string x) @ (id_to_string y)
 	    | _ -> assert False]
@@ -889,15 +904,16 @@ value varify_constructors var_names =
       let mkexp = mkexp _loc in
       let mkpat = mkpat _loc in
       let e = mkexp (Pexp_constraint (expr e) (Some (ctyp ty)) None) in
-      let rec mk_newtypes x = 
+      let rec mk_newtypes x =
 	match x with
 	  [ [newtype :: []] -> mkexp (Pexp_newtype(newtype, e))
 	  | [newtype :: newtypes] ->
 	    mkexp(Pexp_newtype (newtype,mk_newtypes newtypes))
 	  | [] -> assert False]
       in
-      let pat = 
-	mkpat (Ppat_constraint (mkpat (Ppat_var bind_name), mktyp _loc (Ptyp_poly ampersand_vars ty')))
+      let pat =
+	mkpat (Ppat_constraint (mkpat (Ppat_var (with_loc bind_name sloc)),
+                                mktyp _loc (Ptyp_poly ampersand_vars ty')))
       in
       let e = mk_newtypes vars in
       [( pat, e) :: acc]
@@ -928,13 +944,13 @@ value varify_constructors var_names =
     [ <:rec_binding<>> -> acc
     | <:rec_binding< $x$; $y$ >> ->
          mkideexp x (mkideexp y acc)
-    | <:rec_binding< $lid:s$ = $e$ >> -> [(s, expr e) :: acc]
+    | <:rec_binding< $id:( <:ident@sloc< $lid:s$ >>)$ = $e$ >> -> [(with_loc s sloc, expr e) :: acc]
     | _ -> assert False ]
   and mktype_decl x acc =
     match x with
     [ <:ctyp< $x$ and $y$ >> ->
          mktype_decl x (mktype_decl y acc)
-    | Ast.TyDcl loc c tl td cl ->
+    | Ast.TyDcl cloc c tl td cl ->
         let cl =
           List.map
             (fun (t1, t2) ->
@@ -942,14 +958,15 @@ value varify_constructors var_names =
               (ctyp t1, ctyp t2, mkloc loc))
             cl
         in
-        [(c, type_decl (List.fold_right optional_type_parameters tl []) cl td loc) :: acc]
+        [(with_loc c cloc,
+          type_decl (List.fold_right optional_type_parameters tl []) cl td cloc) :: acc]
     | _ -> assert False ]
   and module_type =
     fun
     [ <:module_type@loc<>> -> error loc "abstract/nil module type not allowed here"
     | <:module_type@loc< $id:i$ >> -> mkmty loc (Pmty_ident (long_uident i))
     | <:module_type@loc< functor ($n$ : $nt$) -> $mt$ >> ->
-        mkmty loc (Pmty_functor n (module_type nt) (module_type mt))
+        mkmty loc (Pmty_functor (with_loc n loc) (module_type nt) (module_type mt))
     | <:module_type@loc< '$_$ >> -> error loc "module type variable not allowed here"
     | <:module_type@loc< sig $sl$ end >> ->
         mkmty loc (Pmty_signature (sig_item sl []))
@@ -970,14 +987,14 @@ value varify_constructors var_names =
     | <:sig_item< $sg1$; $sg2$ >> -> sig_item sg1 (sig_item sg2 l)
     | SgDir _ _ _ -> l
     | <:sig_item@loc< exception $uid:s$ >> ->
-        [mksig loc (Psig_exception (conv_con s) []) :: l]
+        [mksig loc (Psig_exception (with_loc (conv_con s) loc) []) :: l]
     | <:sig_item@loc< exception $uid:s$ of $t$ >> ->
-        [mksig loc (Psig_exception (conv_con s)
+        [mksig loc (Psig_exception (with_loc (conv_con s) loc)
                                    (List.map ctyp (list_of_ctyp t []))) :: l]
     | SgExc _ _ -> assert False (*FIXME*)
-    | SgExt loc n t sl -> [mksig loc (Psig_value n (mkvalue_desc t (list_of_meta_list sl))) :: l]
+    | SgExt loc n t sl -> [mksig loc (Psig_value (with_loc n loc) (mkvalue_desc loc t (list_of_meta_list sl))) :: l]
     | SgInc loc mt -> [mksig loc (Psig_include (module_type mt)) :: l]
-    | SgMod loc n mt -> [mksig loc (Psig_module n (module_type mt)) :: l]
+    | SgMod loc n mt -> [mksig loc (Psig_module (with_loc n loc) (module_type mt)) :: l]
     | SgRecMod loc mb ->
         [mksig loc (Psig_recmodule (module_sig_binding mb [])) :: l]
     | SgMty loc n mt ->
@@ -986,25 +1003,25 @@ value varify_constructors var_names =
           [ MtQuo _ _ -> Pmodtype_abstract
           | _ -> Pmodtype_manifest (module_type mt) ]
         in
-        [mksig loc (Psig_modtype n si) :: l]
+        [mksig loc (Psig_modtype (with_loc n loc) si) :: l]
     | SgOpn loc id ->
         [mksig loc (Psig_open (long_uident id)) :: l]
     | SgTyp loc tdl -> [mksig loc (Psig_type (mktype_decl tdl [])) :: l]
-    | SgVal loc n t -> [mksig loc (Psig_value n (mkvalue_desc t [])) :: l]
+    | SgVal loc n t -> [mksig loc (Psig_value (with_loc n loc) (mkvalue_desc loc t [])) :: l]
     | <:sig_item@loc< $anti:_$ >> -> error loc "antiquotation in sig_item" ]
   and module_sig_binding x acc =
     match x with
     [ <:module_binding< $x$ and $y$ >> ->
         module_sig_binding x (module_sig_binding y acc)
-    | <:module_binding< $s$ : $mt$ >> ->
-        [(s, module_type mt) :: acc]
+    | <:module_binding@loc< $s$ : $mt$ >> ->
+        [(with_loc s loc, module_type mt) :: acc]
     | _ -> assert False ]
   and module_str_binding x acc =
     match x with
     [ <:module_binding< $x$ and $y$ >> ->
         module_str_binding x (module_str_binding y acc)
-    | <:module_binding< $s$ : $mt$ = $me$ >> ->
-        [(s, module_type mt, module_expr me) :: acc]
+    | <:module_binding@loc< $s$ : $mt$ = $me$ >> ->
+        [(with_loc s loc, module_type mt, module_expr me) :: acc]
     | _ -> assert False ]
   and module_expr =
     fun
@@ -1013,7 +1030,7 @@ value varify_constructors var_names =
     | <:module_expr@loc< $me1$ $me2$ >> ->
         mkmod loc (Pmod_apply (module_expr me1) (module_expr me2))
     | <:module_expr@loc< functor ($n$ : $mt$) -> $me$ >> ->
-        mkmod loc (Pmod_functor n (module_type mt) (module_expr me))
+        mkmod loc (Pmod_functor (with_loc n loc) (module_type mt) (module_expr me))
     | <:module_expr@loc< struct $sl$ end >> ->
         mkmod loc (Pmod_structure (str_item sl []))
     | <:module_expr@loc< ($me$ : $mt$) >> ->
@@ -1038,22 +1055,22 @@ value varify_constructors var_names =
     | <:str_item< $st1$; $st2$ >> -> str_item st1 (str_item st2 l)
     | StDir _ _ _ -> l
     | <:str_item@loc< exception $uid:s$ >> ->
-        [mkstr loc (Pstr_exception (conv_con s) []) :: l ]
+        [mkstr loc (Pstr_exception (with_loc (conv_con s) loc) []) :: l ]
     | <:str_item@loc< exception $uid:s$ of $t$ >> ->
-        [mkstr loc (Pstr_exception (conv_con s)
+        [mkstr loc (Pstr_exception (with_loc (conv_con s) loc)
                       (List.map ctyp (list_of_ctyp t []))) :: l ]
     | <:str_item@loc< exception $uid:s$ = $i$ >> ->
-        [mkstr loc (Pstr_exn_rebind (conv_con s) (ident i)) :: l ]
+        [mkstr loc (Pstr_exn_rebind (with_loc (conv_con s) loc) (ident i)) :: l ]
     | <:str_item@loc< exception $uid:_$ of $_$ = $_$ >> ->
         error loc "type in exception alias"
     | StExc _ _ _ -> assert False (*FIXME*)
     | StExp loc e -> [mkstr loc (Pstr_eval (expr e)) :: l]
-    | StExt loc n t sl -> [mkstr loc (Pstr_primitive n (mkvalue_desc t (list_of_meta_list sl))) :: l]
+    | StExt loc n t sl -> [mkstr loc (Pstr_primitive (with_loc n loc) (mkvalue_desc loc t (list_of_meta_list sl))) :: l]
     | StInc loc me -> [mkstr loc (Pstr_include (module_expr me)) :: l]
-    | StMod loc n me -> [mkstr loc (Pstr_module n (module_expr me)) :: l]
+    | StMod loc n me -> [mkstr loc (Pstr_module (with_loc n loc) (module_expr me)) :: l]
     | StRecMod loc mb ->
         [mkstr loc (Pstr_recmodule (module_str_binding mb [])) :: l]
-    | StMty loc n mt -> [mkstr loc (Pstr_modtype n (module_type mt)) :: l]
+    | StMty loc n mt -> [mkstr loc (Pstr_modtype (with_loc n loc) (module_type mt)) :: l]
     | StOpn loc id ->
         [mkstr loc (Pstr_open (long_uident id)) :: l]
     | StTyp loc tdl -> [mkstr loc (Pstr_type (mktype_decl tdl [])) :: l]
@@ -1078,7 +1095,11 @@ value varify_constructors var_names =
           | t -> t ]
         in
         let cil = class_sig_item ctfl [] in
-        mkcty loc (Pcty_signature (ctyp t, cil))
+        mkcty loc (Pcty_signature {
+          pcsig_self = ctyp t;
+          pcsig_fields = cil;
+          pcsig_loc = mkloc loc;
+        })
     | CtCon loc _ _ _ ->
         error loc "invalid virtual class inside a class type"
     | CtAnt _ _ | CtEq _ _ _ | CtCol _ _ _ | CtAnd _ _ _ | CtNil _ ->
@@ -1086,7 +1107,7 @@ value varify_constructors var_names =
 
   and class_info_class_expr ci =
     match ci with
-    [ CeEq _ (CeCon loc vir (IdLid _ name) params) ce ->
+    [ CeEq _ (CeCon loc vir (IdLid nloc name) params) ce ->
       let (loc_params, (params, variance)) =
         match params with
         [ <:ctyp<>> -> (loc, ([], []))
@@ -1094,15 +1115,15 @@ value varify_constructors var_names =
       in
       {pci_virt = mkvirtual vir;
        pci_params = (params, mkloc loc_params);
-       pci_name = name;
+       pci_name = with_loc name nloc;
        pci_expr = class_expr ce;
        pci_loc = mkloc loc;
        pci_variance = variance}
     | ce -> error (loc_of_class_expr ce) "bad class definition" ]
   and class_info_class_type ci =
     match ci with
-    [ CtEq _ (CtCon loc vir (IdLid _ name) params) ct |
-      CtCol _ (CtCon loc vir (IdLid _ name) params) ct ->
+    [ CtEq _ (CtCon loc vir (IdLid nloc name) params) ct |
+      CtCol _ (CtCon loc vir (IdLid nloc name) params) ct ->
       let (loc_params, (params, variance)) =
         match params with
         [ <:ctyp<>> -> (loc, ([], []))
@@ -1110,7 +1131,7 @@ value varify_constructors var_names =
       in
       {pci_virt = mkvirtual vir;
        pci_params = (params, mkloc loc_params);
-       pci_name = name;
+       pci_name = with_loc name nloc;
        pci_expr = class_type ct;
        pci_loc = mkloc loc;
        pci_variance = variance}
@@ -1119,39 +1140,39 @@ value varify_constructors var_names =
   and class_sig_item c l =
     match c with
     [ <:class_sig_item<>> -> l
-    | CgCtr loc t1 t2 -> [Pctf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l]
+    | CgCtr loc t1 t2 -> [mkctf loc (Pctf_cstr (ctyp t1, ctyp t2)) :: l]
     | <:class_sig_item< $csg1$; $csg2$ >> ->
         class_sig_item csg1 (class_sig_item csg2 l)
-    | CgInh _ ct -> [Pctf_inher (class_type ct) :: l]
+    | CgInh loc ct -> [mkctf loc (Pctf_inher (class_type ct)) :: l]
     | CgMth loc s pf t ->
-        [Pctf_meth (s, mkprivate pf, mkpolytype (ctyp t), mkloc loc) :: l]
+        [mkctf loc (Pctf_meth (s, mkprivate pf, mkpolytype (ctyp t))) :: l]
     | CgVal loc s b v t ->
-        [Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l]
+        [mkctf loc (Pctf_val (s, mkmutable b, mkvirtual v, ctyp t)) :: l]
     | CgVir loc s b t ->
-        [Pctf_virt (s, mkprivate b, mkpolytype (ctyp t), mkloc loc) :: l]
+        [mkctf loc (Pctf_virt (s, mkprivate b, mkpolytype (ctyp t))) :: l]
     | CgAnt _ _ -> assert False ]
   and class_expr =
     fun
     [ CeApp loc _ _ as c ->
         let (ce, el) = class_expr_fa [] c in
         let el = List.map label_expr el in
-        mkpcl loc (Pcl_apply (class_expr ce) el)
+        mkcl loc (Pcl_apply (class_expr ce) el)
     | CeCon loc ViNil id tl ->
-        mkpcl loc
+        mkcl loc
           (Pcl_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl [])))
     | CeFun loc (PaLab _ lab po) ce ->
-        mkpcl loc
+        mkcl loc
           (Pcl_fun lab None (patt_of_lab loc lab po) (class_expr ce))
     | CeFun loc (PaOlbi _ lab p e) ce ->
         let lab = paolab lab p in
-        mkpcl loc (Pcl_fun ("?" ^ lab) (Some (expr e)) (patt p) (class_expr ce))
+        mkcl loc (Pcl_fun ("?" ^ lab) (Some (expr e)) (patt p) (class_expr ce))
     | CeFun loc (PaOlb _ lab p) ce ->
         let lab = paolab lab p in
-        mkpcl loc
+        mkcl loc
           (Pcl_fun ("?" ^ lab) None (patt_of_lab loc lab p) (class_expr ce))
-    | CeFun loc p ce -> mkpcl loc (Pcl_fun "" None (patt p) (class_expr ce))
+    | CeFun loc p ce -> mkcl loc (Pcl_fun "" None (patt p) (class_expr ce))
     | CeLet loc rf bi ce ->
-        mkpcl loc (Pcl_let (mkrf rf) (binding bi []) (class_expr ce))
+        mkcl loc (Pcl_let (mkrf rf) (binding bi []) (class_expr ce))
     | CeStr loc po cfl ->
         let p =
           match po with
@@ -1159,35 +1180,38 @@ value varify_constructors var_names =
           | p -> p ]
         in
         let cil = class_str_item cfl [] in
-        mkpcl loc (Pcl_structure (patt p, cil))
+        mkcl loc (Pcl_structure {
+          pcstr_pat = patt p;
+          pcstr_fields = cil;
+        })
     | CeTyc loc ce ct ->
-        mkpcl loc (Pcl_constraint (class_expr ce) (class_type ct))
+        mkcl loc (Pcl_constraint (class_expr ce) (class_type ct))
     | CeCon loc _ _ _ ->
         error loc "invalid virtual class inside a class expression"
     | CeAnt _ _ | CeEq _ _ _ | CeAnd _ _ _ | CeNil _ -> assert False ]
   and class_str_item c l =
     match c with
     [ CrNil _ -> l
-    | CrCtr loc t1 t2 -> [Pcf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l]
+    | CrCtr loc t1 t2 -> [mkcf loc (Pcf_constr (ctyp t1, ctyp t2)) :: l]
     | <:class_str_item< $cst1$; $cst2$ >> ->
         class_str_item cst1 (class_str_item cst2 l)
     | CrInh loc ov ce pb ->
         let opb = if pb = "" then None else Some pb in
-        [Pcf_inher (override_flag loc ov) (class_expr ce) opb :: l]
-    | CrIni _ e -> [Pcf_init (expr e) :: l]
+        [mkcf loc (Pcf_inher (override_flag loc ov) (class_expr ce) opb) :: l]
+    | CrIni loc e -> [mkcf loc (Pcf_init (expr e)) :: l]
     | CrMth loc s ov pf e t ->
         let t =
           match t with
           [ <:ctyp<>> -> None
           | t -> Some (mkpolytype (ctyp t)) ] in
         let e = mkexp loc (Pexp_poly (expr e) t) in
-        [Pcf_meth (s, mkprivate pf, override_flag loc ov, e, mkloc loc) :: l]
+        [mkcf loc (Pcf_meth (with_loc s loc, mkprivate pf, override_flag loc ov, e)) :: l]
     | CrVal loc s ov mf e ->
-        [Pcf_val (s, mkmutable mf, override_flag loc ov, expr e, mkloc loc) :: l]
+        [mkcf loc (Pcf_val (with_loc s loc, mkmutable mf, override_flag loc ov, expr e)) :: l]
     | CrVir loc s pf t ->
-        [Pcf_virt (s, mkprivate pf, mkpolytype (ctyp t), mkloc loc) :: l]
+        [mkcf loc (Pcf_virt (with_loc s loc, mkprivate pf, mkpolytype (ctyp t))) :: l]
     | CrVvr loc s mf t ->
-        [Pcf_valvirt (s, mkmutable mf, ctyp t, mkloc loc) :: l]
+        [mkcf loc (Pcf_valvirt (with_loc s loc, mkmutable mf, ctyp t)) :: l]
     | CrAnt _ _ -> assert False ];
 
   value sig_item ast = sig_item ast [];
@@ -1200,7 +1224,7 @@ value varify_constructors var_names =
     | ExInt _ i -> Pdir_int (int_of_string i)
     | <:expr< True >> -> Pdir_bool True
     | <:expr< False >> -> Pdir_bool False
-    | e -> Pdir_ident (ident (ident_of_expr e)) ]
+    | e -> Pdir_ident (ident_noloc (ident_of_expr e)) ]
   ;
 
   value phrase =
diff --git a/camlp4/Camlp4/Struct/Token.ml b/camlp4/Camlp4/Struct/Token.ml
index 262072972..701e990d5 100644
--- a/camlp4/Camlp4/Struct/Token.ml
+++ b/camlp4/Camlp4/Struct/Token.ml
@@ -211,7 +211,7 @@ module Eval = struct
     | [: `'b' :]  -> '\b'
     | [: `'\\' :] -> '\\'
     | [: `'"' :]  -> '"'
-    | [: `''' :]  -> '''
+    | [: `'\'' :]  -> '\''
     | [: `' ' :]  -> ' '
     | [: `('0'..'9' as c1); `('0'..'9' as c2); `('0'..'9' as c3) :] ->
         chr (100 * (valch c1) + 10 * (valch c2) + (valch c3))
diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml
index 3967ba21b..4030702ae 100644
--- a/camlp4/boot/Camlp4.ml
+++ b/camlp4/boot/Camlp4.ml
@@ -81,25 +81,15 @@ module Debug :
       
     let formatter =
       let header = "camlp4-debug: " in
-      let normal s =
-        let rec self from accu =
-          try
-            let i = String.index_from s from '\n'
-            in self (i + 1) ((String.sub s from ((i - from) + 1)) :: accu)
-          with
-          | Not_found ->
-              (String.sub s from ((String.length s) - from)) :: accu
-        in String.concat header (List.rev (self 0 [])) in
-      let after_new_line str = header ^ (normal str) in
-      let f = ref after_new_line in
-      let output str chr =
-        (output_string out_channel (!f str);
-         output_char out_channel chr;
-         f := if chr = '\n' then after_new_line else normal)
+      let at_bol = ref true
       in
         make_formatter
           (fun buf pos len ->
-             let p = pred len in output (String.sub buf pos p) buf.[pos + p])
+             for i = pos to (pos + len) - 1 do
+               if !at_bol then output_string out_channel header else ();
+               let ch = buf.[i]
+               in (output_char out_channel ch; at_bol := ch = '\n')
+             done)
           (fun () -> flush out_channel)
       
     let printf section fmt = fprintf formatter ("%s: " ^^ fmt) section
@@ -424,6 +414,16 @@ module Sig =
     (** A signature for locations. *)
     module type Loc =
       sig
+        (** The type of locations.  Note that, as for OCaml locations,
+      character numbers in locations refer to character numbers in the
+      parsed character stream, while line numbers refer to line
+      numbers in the source file. The source file and the parsed
+      character stream differ, for instance, when the parsed character
+      stream contains a line number directive. The line number
+      directive will only update the file-name field and the
+      line-number field of the position. It makes therefore no sense
+      to use character numbers with the source file if the sources
+      contain line number directives. *)
         type t
         
         (** Return a start location for the given file name.
@@ -457,7 +457,8 @@ module Sig =
         val to_tuple :
           t -> (string * int * int * int * int * int * int * bool)
           
-        (** [merge loc1 loc2] Return a location that starts at [loc1] and end at [loc2]. *)
+        (** [merge loc1 loc2] Return a location that starts at [loc1] and end at
+      [loc2]. *)
         val merge : t -> t -> t
           
         (** The stop pos becomes equal to the start pos. *)
@@ -488,19 +489,19 @@ module Sig =
         (** Return the line number of the ending of this location. *)
         val stop_line : t -> int
           
-        (** Returns the number of characters from the begining of the file
+        (** Returns the number of characters from the begining of the stream
       to the begining of the line of location's begining. *)
         val start_bol : t -> int
           
-        (** Returns the number of characters from the begining of the file
+        (** Returns the number of characters from the begining of the stream
       to the begining of the line of location's ending. *)
         val stop_bol : t -> int
           
-        (** Returns the number of characters from the begining of the file
+        (** Returns the number of characters from the begining of the stream
       of the begining of this location. *)
         val start_off : t -> int
           
-        (** Return the number of characters from the begining of the file
+        (** Return the number of characters from the begining of the stream
       of the ending of this location. *)
         val stop_off : t -> int
           
@@ -801,6 +802,8 @@ module Sig =
         (*  source tree.                                                            *)
         (*                                                                          *)
         (****************************************************************************)
+        (* Note: when you modify these types you must increment
+   ast magic numbers defined in Camlp4_config.ml. *)
         type loc =
           Loc.
           t
@@ -14159,6 +14162,9 @@ module Struct =
               
             let mkghloc loc = Loc.to_ocaml_location (Loc.ghostify loc)
               
+            let with_loc txt loc =
+              Camlp4_import.Location.mkloc txt (mkloc loc)
+              
             let mktyp loc d = { ptyp_desc = d; ptyp_loc = mkloc loc; }
               
             let mkpat loc d = { ppat_desc = d; ppat_loc = mkloc loc; }
@@ -14179,7 +14185,11 @@ module Struct =
               
             let mkcty loc d = { pcty_desc = d; pcty_loc = mkloc loc; }
               
-            let mkpcl loc d = { pcl_desc = d; pcl_loc = mkloc loc; }
+            let mkcl loc d = { pcl_desc = d; pcl_loc = mkloc loc; }
+              
+            let mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; }
+              
+            let mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; }
               
             let mkpolytype t =
               match t.ptyp_desc with
@@ -14200,6 +14210,8 @@ module Struct =
               
             let lident s = Lident s
               
+            let lident_with_loc s loc = with_loc (Lident s) loc
+              
             let ldot l s = Ldot (l, s)
               
             let lapply l s = Lapply (l, s)
@@ -14219,20 +14231,23 @@ module Struct =
                    [ ("val", "contents") ];
                  fun s -> try Hashtbl.find t s with | Not_found -> s)
               
-            let array_function str name =
+            let array_function_no_loc str name =
               ldot (lident str)
                 (if !Camlp4_config.unsafe then "unsafe_" ^ name else name)
               
+            let array_function loc str name =
+              with_loc (array_function_no_loc str name) loc
+              
             let mkrf =
               function
               | Ast.ReRecursive -> Recursive
               | Ast.ReNil -> Nonrecursive
               | _ -> assert false
               
-            let mkli s =
+            let mkli sloc s list =
               let rec loop f =
                 function | i :: il -> loop (ldot (f i)) il | [] -> f s
-              in loop lident
+              in with_loc (loop lident list) sloc
               
             let rec ctyp_fa al =
               function
@@ -14242,6 +14257,9 @@ module Struct =
             let ident_tag ?(conv_lid = fun x -> x) i =
               let rec self i acc =
                 match i with
+                | Ast.IdAcc (_, (Ast.IdLid (_, "*predef*")),
+                    (Ast.IdLid (_, "option"))) ->
+                    ((ldot (lident "*predef*") "option"), `lident)
                 | Ast.IdAcc (_, i1, i2) -> self i2 (Some (self i1 acc))
                 | Ast.IdApp (_, i1, i2) ->
                     let i' =
@@ -14272,27 +14290,33 @@ module Struct =
                 | _ -> error (loc_of_ident i) "invalid long identifier"
               in self i None
               
-            let ident ?conv_lid i = fst (ident_tag ?conv_lid i)
+            let ident_noloc ?conv_lid i = fst (ident_tag ?conv_lid i)
               
-            let long_lident msg i =
-              match ident_tag i with
-              | (i, `lident) -> i
-              | _ -> error (loc_of_ident i) msg
+            let ident ?conv_lid i =
+              with_loc (ident_noloc ?conv_lid i) (loc_of_ident i)
+              
+            let long_lident msg id =
+              match ident_tag id with
+              | (i, `lident) -> with_loc i (loc_of_ident id)
+              | _ -> error (loc_of_ident id) msg
               
             let long_type_ident = long_lident "invalid long identifier type"
               
             let long_class_ident = long_lident "invalid class name"
               
-            let long_uident ?(conv_con = fun x -> x) i =
+            let long_uident_noloc ?(conv_con = fun x -> x) i =
               match ident_tag i with
               | (Ldot (i, s), `uident) -> ldot i (conv_con s)
               | (Lident s, `uident) -> lident (conv_con s)
               | (i, `app) -> i
               | _ -> error (loc_of_ident i) "uppercase identifier expected"
               
+            let long_uident ?conv_con i =
+              with_loc (long_uident_noloc ?conv_con i) (loc_of_ident i)
+              
             let rec ctyp_long_id_prefix t =
               match t with
-              | Ast.TyId (_, i) -> ident i
+              | Ast.TyId (_, i) -> ident_noloc i
               | Ast.TyApp (_, m1, m2) ->
                   let li1 = ctyp_long_id_prefix m1 in
                   let li2 = ctyp_long_id_prefix m2 in Lapply (li1, li2)
@@ -14312,6 +14336,13 @@ module Struct =
               | Ast.TyQuo (_, s) -> [ s ]
               | _ -> assert false
               
+            let predef_option loc =
+              TyId
+                ((loc,
+                  (IdAcc
+                     ((loc, (IdLid ((loc, "*predef*"))),
+                       (IdLid ((loc, "option"))))))))
+              
             let rec ctyp =
               function
               | TyId (loc, i) ->
@@ -14335,9 +14366,7 @@ module Struct =
               | TyArr (loc, (TyLab (_, lab, t1)), t2) ->
                   mktyp loc (Ptyp_arrow (lab, (ctyp t1), (ctyp t2)))
               | TyArr (loc, (TyOlb (loc1, lab, t1)), t2) ->
-                  let t1 =
-                    TyApp (loc1,
-                      (Ast.TyId (loc1, (Ast.IdLid (loc1, "option")))), t1)
+                  let t1 = TyApp (loc1, (predef_option loc1), t1)
                   in
                     mktyp loc
                       (Ptyp_arrow (("?" ^ lab), (ctyp t1), (ctyp t2)))
@@ -14421,8 +14450,8 @@ module Struct =
             and package_type_constraints wc acc =
               match wc with
               | Ast.WcNil _ -> acc
-              | Ast.WcTyp (_, (Ast.TyId (_, (Ast.IdLid (_, id)))), ct) ->
-                  (Lident id, (ctyp ct)) :: acc
+              | Ast.WcTyp (_, (Ast.TyId (_, id)), ct) ->
+                  ((ident id), (ctyp ct)) :: acc
               | Ast.WcAnd (_, wc1, wc2) ->
                   package_type_constraints wc1
                     (package_type_constraints wc2 acc)
@@ -14459,26 +14488,30 @@ module Struct =
               
             let mktrecord =
               function
-              | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (_, s)))),
+              | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (sloc, s)))),
                   (Ast.TyMut (_, t))) ->
-                  (s, Mutable, (mkpolytype (ctyp t)), (mkloc loc))
-              | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (_, s)))), t) ->
-                  (s, Immutable, (mkpolytype (ctyp t)), (mkloc loc))
+                  ((with_loc s sloc), Mutable, (mkpolytype (ctyp t)),
+                   (mkloc loc))
+              | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (sloc, s)))), t) ->
+                  ((with_loc s sloc), Immutable, (mkpolytype (ctyp t)),
+                   (mkloc loc))
               | _ -> assert false
               
             let mkvariant =
               function
-              | Ast.TyId (loc, (Ast.IdUid (_, s))) ->
-                  ((conv_con s), [], None, (mkloc loc))
-              | Ast.TyOf (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), t) ->
-                  ((conv_con s), (List.map ctyp (list_of_ctyp t [])), None,
-                   (mkloc loc))
-              | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))),
+              | Ast.TyId (loc, (Ast.IdUid (sloc, s))) ->
+                  ((with_loc (conv_con s) sloc), [], None, (mkloc loc))
+              | Ast.TyOf (loc, (Ast.TyId (_, (Ast.IdUid (sloc, s)))), t) ->
+                  ((with_loc (conv_con s) sloc),
+                   (List.map ctyp (list_of_ctyp t [])), None, (mkloc loc))
+              | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (sloc, s)))),
                   (Ast.TyArr (_, t, u))) ->
-                  ((conv_con s), (List.map ctyp (list_of_ctyp t [])),
-                   (Some (ctyp u)), (mkloc loc))
-              | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), t) ->
-                  ((conv_con s), [], (Some (ctyp t)), (mkloc loc))
+                  ((with_loc (conv_con s) sloc),
+                   (List.map ctyp (list_of_ctyp t [])), (Some (ctyp u)),
+                   (mkloc loc))
+              | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (sloc, s)))), t) ->
+                  ((with_loc (conv_con s) sloc), [], (Some (ctyp t)),
+                   (mkloc loc))
               | _ -> assert false
               
             let rec type_decl tl cl loc m pflag =
@@ -14505,10 +14538,10 @@ module Struct =
                        | _ -> Some (ctyp t)
                      in mktype loc tl cl Ptype_abstract (mkprivate' pflag) m)
               
-            let type_decl tl cl t =
-              type_decl tl cl (loc_of_ctyp t) None false t
+            let type_decl tl cl t loc = type_decl tl cl loc None false t
               
-            let mkvalue_desc t p = { pval_type = ctyp t; pval_prim = p; }
+            let mkvalue_desc loc t p =
+              { pval_type = ctyp t; pval_prim = p; pval_loc = mkloc loc; }
               
             let rec list_of_meta_list =
               function
@@ -14550,11 +14583,14 @@ module Struct =
               | Ast.TyApp (_, t1, t2) ->
                   optional_type_parameters t1
                     (optional_type_parameters t2 acc)
-              | Ast.TyQuP (_, s) -> ((Some s), (true, false)) :: acc
+              | Ast.TyQuP (loc, s) ->
+                  ((Some (with_loc s loc)), (true, false)) :: acc
               | Ast.TyAnP _loc -> (None, (true, false)) :: acc
-              | Ast.TyQuM (_, s) -> ((Some s), (false, true)) :: acc
+              | Ast.TyQuM (loc, s) ->
+                  ((Some (with_loc s loc)), (false, true)) :: acc
               | Ast.TyAnM _loc -> (None, (false, true)) :: acc
-              | Ast.TyQuo (_, s) -> ((Some s), (false, false)) :: acc
+              | Ast.TyQuo (loc, s) ->
+                  ((Some (with_loc s loc)), (false, false)) :: acc
               | Ast.TyAny _loc -> (None, (false, false)) :: acc
               | _ -> assert false
               
@@ -14562,9 +14598,12 @@ module Struct =
               match t with
               | Ast.TyCom (_, t1, t2) ->
                   class_parameters t1 (class_parameters t2 acc)
-              | Ast.TyQuP (_, s) -> (s, (true, false)) :: acc
-              | Ast.TyQuM (_, s) -> (s, (false, true)) :: acc
-              | Ast.TyQuo (_, s) -> (s, (false, false)) :: acc
+              | Ast.TyQuP (loc, s) ->
+                  ((with_loc s loc), (true, false)) :: acc
+              | Ast.TyQuM (loc, s) ->
+                  ((with_loc s loc), (false, true)) :: acc
+              | Ast.TyQuo (loc, s) ->
+                  ((with_loc s loc), (false, false)) :: acc
               | _ -> assert false
               
             let rec type_parameters_and_type_name t acc =
@@ -14636,7 +14675,8 @@ module Struct =
               
             let rec patt =
               function
-              | Ast.PaId (loc, (Ast.IdLid (_, s))) -> mkpat loc (Ppat_var s)
+              | Ast.PaId (loc, (Ast.IdLid (sloc, s))) ->
+                  mkpat loc (Ppat_var (with_loc s sloc))
               | Ast.PaId (loc, i) ->
                   let p =
                     Ppat_construct ((long_uident ~conv_con i), None,
@@ -14645,16 +14685,18 @@ module Struct =
               | PaAli (loc, p1, p2) ->
                   let (p, i) =
                     (match (p1, p2) with
-                     | (p, Ast.PaId (_, (Ast.IdLid (_, s)))) -> (p, s)
-                     | (Ast.PaId (_, (Ast.IdLid (_, s))), p) -> (p, s)
+                     | (p, Ast.PaId (_, (Ast.IdLid (sloc, s)))) ->
+                         (p, (with_loc s sloc))
+                     | (Ast.PaId (_, (Ast.IdLid (sloc, s))), p) ->
+                         (p, (with_loc s sloc))
                      | _ -> error loc "invalid alias pattern")
                   in mkpat loc (Ppat_alias ((patt p), i))
               | PaAnt (loc, _) -> error loc "antiquotation not allowed here"
               | PaAny loc -> mkpat loc Ppat_any
-              | Ast.PaApp (loc, (Ast.PaId (_, (Ast.IdUid (_, s)))),
+              | Ast.PaApp (loc, (Ast.PaId (_, (Ast.IdUid (sloc, s)))),
                   (Ast.PaTup (_, (Ast.PaAny loc_any)))) ->
                   mkpat loc
-                    (Ppat_construct ((lident (conv_con s)),
+                    (Ppat_construct ((lident_with_loc (conv_con s) sloc),
                        (Some (mkpat loc_any Ppat_any)), false))
               | (PaApp (loc, _, _) as f) ->
                   let (f, al) = patt_fa [] f in
@@ -14762,9 +14804,10 @@ module Struct =
               | PaTyc (loc, p, t) ->
                   mkpat loc (Ppat_constraint ((patt p), (ctyp t)))
               | PaTyp (loc, i) -> mkpat loc (Ppat_type (long_type_ident i))
-              | PaVrn (loc, s) -> mkpat loc (Ppat_variant (s, None))
+              | PaVrn (loc, s) ->
+                  mkpat loc (Ppat_variant ((conv_con s), None))
               | PaLaz (loc, p) -> mkpat loc (Ppat_lazy (patt p))
-              | PaMod (loc, m) -> mkpat loc (Ppat_unpack m)
+              | PaMod (loc, m) -> mkpat loc (Ppat_unpack (with_loc m loc))
               | (PaEq (_, _, _) | PaSem (_, _, _) | PaCom (_, _, _) | PaNil _
                  as p) -> error (loc_of_patt p) "invalid pattern"
             and mklabpat =
@@ -14824,8 +14867,8 @@ module Struct =
                   | Ptyp_arrow (label, core_type, core_type') ->
                       Ptyp_arrow (label, (loop core_type), (loop core_type'))
                   | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
-                  | Ptyp_constr ((Lident s), []) when List.mem s var_names ->
-                      Ptyp_var ("&" ^ s)
+                  | Ptyp_constr ({ txt = Lident s }, []) when
+                      List.mem s var_names -> Ptyp_var ("&" ^ s)
                   | Ptyp_constr (longident, lst) ->
                       Ptyp_constr (longident, (List.map loop lst))
                   | Ptyp_object lst ->
@@ -14862,33 +14905,35 @@ module Struct =
               function
               | Ast.ExAcc (loc, x, (Ast.ExId (_, (Ast.IdLid (_, "val"))))) ->
                   mkexp loc
-                    (Pexp_apply ((mkexp loc (Pexp_ident (Lident "!"))),
+                    (Pexp_apply
+                       ((mkexp loc (Pexp_ident (lident_with_loc "!" loc))),
                        [ ("", (expr x)) ]))
               | (ExAcc (loc, _, _) | Ast.ExId (loc, (Ast.IdAcc (_, _, _))) as
                  e) ->
                   let (e, l) =
                     (match sep_expr_acc [] e with
-                     | (loc, ml, Ast.ExId (_, (Ast.IdUid (_, s)))) :: l ->
+                     | (loc, ml, Ast.ExId (sloc, (Ast.IdUid (_, s)))) :: l ->
                          let ca = constructors_arity ()
                          in
                            ((mkexp loc
-                               (Pexp_construct ((mkli (conv_con s) ml), None,
-                                  ca))),
+                               (Pexp_construct ((mkli sloc (conv_con s) ml),
+                                  None, ca))),
                             l)
-                     | (loc, ml, Ast.ExId (_, (Ast.IdLid (_, s)))) :: l ->
-                         ((mkexp loc (Pexp_ident (mkli s ml))), l)
+                     | (loc, ml, Ast.ExId (sloc, (Ast.IdLid (_, s)))) :: l ->
+                         ((mkexp loc (Pexp_ident (mkli sloc s ml))), l)
                      | (_, [], e) :: l -> ((expr e), l)
                      | _ -> error loc "bad ast in expression") in
                   let (_, e) =
                     List.fold_left
                       (fun (loc_bp, e1) (loc_ep, ml, e2) ->
                          match e2 with
-                         | Ast.ExId (_, (Ast.IdLid (_, s))) ->
+                         | Ast.ExId (sloc, (Ast.IdLid (_, s))) ->
                              let loc = Loc.merge loc_bp loc_ep
                              in
                                (loc,
                                 (mkexp loc
-                                   (Pexp_field (e1, (mkli (conv_lab s) ml)))))
+                                   (Pexp_field (e1,
+                                      (mkli sloc (conv_lab s) ml)))))
                          | _ ->
                              error (loc_of_expr e2)
                                "lowercase identifier expected")
@@ -14931,7 +14976,7 @@ module Struct =
                   mkexp loc
                     (Pexp_apply
                        ((mkexp loc
-                           (Pexp_ident (array_function "Array" "get"))),
+                           (Pexp_ident (array_function loc "Array" "get"))),
                        [ ("", (expr e1)); ("", (expr e2)) ]))
               | ExArr (loc, e) ->
                   mkexp loc (Pexp_array (List.map expr (list_of_expr e [])))
@@ -14941,24 +14986,27 @@ module Struct =
                     (match e with
                      | Ast.ExAcc (loc, x,
                          (Ast.ExId (_, (Ast.IdLid (_, "val"))))) ->
-                         Pexp_apply ((mkexp loc (Pexp_ident (Lident ":="))),
+                         Pexp_apply
+                           ((mkexp loc
+                               (Pexp_ident (lident_with_loc ":=" loc))),
                            [ ("", (expr x)); ("", (expr v)) ])
                      | ExAcc (loc, _, _) ->
                          (match (expr e).pexp_desc with
                           | Pexp_field (e, lab) ->
                               Pexp_setfield (e, lab, (expr v))
                           | _ -> error loc "bad record access")
-                     | ExAre (_, e1, e2) ->
+                     | ExAre (loc, e1, e2) ->
                          Pexp_apply
                            ((mkexp loc
-                               (Pexp_ident (array_function "Array" "set"))),
+                               (Pexp_ident (array_function loc "Array" "set"))),
                            [ ("", (expr e1)); ("", (expr e2)); ("", (expr v)) ])
-                     | Ast.ExId (_, (Ast.IdLid (_, lab))) ->
-                         Pexp_setinstvar (lab, (expr v))
-                     | ExSte (_, e1, e2) ->
+                     | Ast.ExId (_, (Ast.IdLid (lloc, lab))) ->
+                         Pexp_setinstvar ((with_loc lab lloc), (expr v))
+                     | ExSte (loc, e1, e2) ->
                          Pexp_apply
                            ((mkexp loc
-                               (Pexp_ident (array_function "String" "set"))),
+                               (Pexp_ident
+                                  (array_function loc "String" "set"))),
                            [ ("", (expr e1)); ("", (expr e2)); ("", (expr v)) ])
                      | _ -> error loc "bad left part of assignment")
                   in mkexp loc e
@@ -14979,8 +15027,8 @@ module Struct =
                   let e3 = ExSeq (loc, el)
                   in
                     mkexp loc
-                      (Pexp_for (i, (expr e1), (expr e2), (mkdirection df),
-                         (expr e3)))
+                      (Pexp_for ((with_loc i loc), (expr e1), (expr e2),
+                         (mkdirection df), (expr e3)))
               | Ast.ExFun (loc, (Ast.McArr (_, (PaLab (_, lab, po)), w, e)))
                   ->
                   mkexp loc
@@ -15043,7 +15091,9 @@ module Struct =
               | ExLet (loc, rf, bi, e) ->
                   mkexp loc (Pexp_let ((mkrf rf), (binding bi []), (expr e)))
               | ExLmd (loc, i, me, e) ->
-                  mkexp loc (Pexp_letmodule (i, (module_expr me), (expr e)))
+                  mkexp loc
+                    (Pexp_letmodule ((with_loc i loc), (module_expr me),
+                       (expr e)))
               | ExMat (loc, e, a) ->
                   mkexp loc (Pexp_match ((expr e), (match_case a [])))
               | ExNew (loc, id) -> mkexp loc (Pexp_new (long_type_ident id))
@@ -15051,7 +15101,10 @@ module Struct =
                   let p =
                     (match po with | Ast.PaNil _ -> Ast.PaAny loc | p -> p) in
                   let cil = class_str_item cfl []
-                  in mkexp loc (Pexp_object (((patt p), cil)))
+                  in
+                    mkexp loc
+                      (Pexp_object
+                         { pcstr_pat = patt p; pcstr_fields = cil; })
               | ExOlb (loc, _, _) ->
                   error loc "labeled expression not allowed here"
               | ExOvr (loc, iel) ->
@@ -15079,7 +15132,7 @@ module Struct =
                   mkexp loc
                     (Pexp_apply
                        ((mkexp loc
-                           (Pexp_ident (array_function "String" "get"))),
+                           (Pexp_ident (array_function loc "String" "get"))),
                        [ ("", (expr e1)); ("", (expr e2)) ]))
               | ExStr (loc, s) ->
                   mkexp loc
@@ -15096,13 +15149,16 @@ module Struct =
                   mkexp loc
                     (Pexp_constraint ((expr e), (Some (ctyp t)), None))
               | Ast.ExId (loc, (Ast.IdUid (_, "()"))) ->
-                  mkexp loc (Pexp_construct ((lident "()"), None, true))
+                  mkexp loc
+                    (Pexp_construct ((lident_with_loc "()" loc), None, true))
               | Ast.ExId (loc, (Ast.IdLid (_, s))) ->
-                  mkexp loc (Pexp_ident (lident s))
+                  mkexp loc (Pexp_ident (lident_with_loc s loc))
               | Ast.ExId (loc, (Ast.IdUid (_, s))) ->
                   mkexp loc
-                    (Pexp_construct ((lident (conv_con s)), None, true))
-              | ExVrn (loc, s) -> mkexp loc (Pexp_variant (s, None))
+                    (Pexp_construct ((lident_with_loc (conv_con s) loc),
+                       None, true))
+              | ExVrn (loc, s) ->
+                  mkexp loc (Pexp_variant ((conv_con s), None))
               | ExWhi (loc, e1, el) ->
                   let e2 = ExSeq (loc, el)
                   in mkexp loc (Pexp_while ((expr e1), (expr e2)))
@@ -15142,7 +15198,8 @@ module Struct =
             and binding x acc =
               match x with
               | Ast.BiAnd (_, x, y) -> binding x (binding y acc)
-              | Ast.BiEq (_loc, (Ast.PaId (_, (Ast.IdLid (_, bind_name)))),
+              | Ast.BiEq (_loc,
+                  (Ast.PaId (sloc, (Ast.IdLid (_, bind_name)))),
                   (Ast.ExTyc (_, e, (TyTypePol (_, vs, ty))))) ->
                   let rec id_to_string x =
                     (match x with
@@ -15152,11 +15209,6 @@ module Struct =
                      | _ -> assert false) in
                   let vars = id_to_string vs in
                   let ampersand_vars = List.map (fun x -> "&" ^ x) vars in
-                  let rec merge_quoted_vars lst =
-                    (match lst with
-                     | [ x ] -> x
-                     | x :: y -> Ast.TyApp (_loc, x, (merge_quoted_vars y))
-                     | [] -> assert false) in
                   let ty' = varify_constructors vars (ctyp ty) in
                   let mkexp = mkexp _loc in
                   let mkpat = mkpat _loc in
@@ -15173,7 +15225,7 @@ module Struct =
                   let pat =
                     mkpat
                       (Ppat_constraint
-                         (((mkpat (Ppat_var bind_name)),
+                         (((mkpat (Ppat_var (with_loc bind_name sloc))),
                            (mktyp _loc (Ptyp_poly (ampersand_vars, ty')))))) in
                   let e = mk_newtypes vars in (pat, e) :: acc
               | Ast.BiEq (_loc, p,
@@ -15203,12 +15255,13 @@ module Struct =
               match x with
               | Ast.RbNil _ -> acc
               | Ast.RbSem (_, x, y) -> mkideexp x (mkideexp y acc)
-              | Ast.RbEq (_, (Ast.IdLid (_, s)), e) -> (s, (expr e)) :: acc
+              | Ast.RbEq (_, (Ast.IdLid (sloc, s)), e) ->
+                  ((with_loc s sloc), (expr e)) :: acc
               | _ -> assert false
             and mktype_decl x acc =
               match x with
               | Ast.TyAnd (_, x, y) -> mktype_decl x (mktype_decl y acc)
-              | Ast.TyDcl (_, c, tl, td, cl) ->
+              | Ast.TyDcl (cloc, c, tl, td, cl) ->
                   let cl =
                     List.map
                       (fun (t1, t2) ->
@@ -15217,10 +15270,10 @@ module Struct =
                          in ((ctyp t1), (ctyp t2), (mkloc loc)))
                       cl
                   in
-                    (c,
+                    ((with_loc c cloc),
                      (type_decl
                         (List.fold_right optional_type_parameters tl []) cl
-                        td)) ::
+                        td cloc)) ::
                       acc
               | _ -> assert false
             and module_type =
@@ -15230,7 +15283,8 @@ module Struct =
               | Ast.MtId (loc, i) -> mkmty loc (Pmty_ident (long_uident i))
               | Ast.MtFun (loc, n, nt, mt) ->
                   mkmty loc
-                    (Pmty_functor (n, (module_type nt), (module_type mt)))
+                    (Pmty_functor ((with_loc n loc), (module_type nt),
+                       (module_type mt)))
               | Ast.MtQuo (loc, _) ->
                   error loc "module type variable not allowed here"
               | Ast.MtSig (loc, sl) ->
@@ -15258,22 +15312,27 @@ module Struct =
               | Ast.SgSem (_, sg1, sg2) -> sig_item sg1 (sig_item sg2 l)
               | SgDir (_, _, _) -> l
               | Ast.SgExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s))))) ->
-                  (mksig loc (Psig_exception ((conv_con s), []))) :: l
+                  (mksig loc
+                     (Psig_exception ((with_loc (conv_con s) loc), []))) ::
+                    l
               | Ast.SgExc (loc,
                   (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, s)))), t))) ->
                   (mksig loc
-                     (Psig_exception ((conv_con s),
+                     (Psig_exception ((with_loc (conv_con s) loc),
                         (List.map ctyp (list_of_ctyp t []))))) ::
                     l
               | SgExc (_, _) -> assert false
               | SgExt (loc, n, t, sl) ->
                   (mksig loc
-                     (Psig_value (n, (mkvalue_desc t (list_of_meta_list sl))))) ::
+                     (Psig_value ((with_loc n loc),
+                        (mkvalue_desc loc t (list_of_meta_list sl))))) ::
                     l
               | SgInc (loc, mt) ->
                   (mksig loc (Psig_include (module_type mt))) :: l
               | SgMod (loc, n, mt) ->
-                  (mksig loc (Psig_module (n, (module_type mt)))) :: l
+                  (mksig loc
+                     (Psig_module ((with_loc n loc), (module_type mt)))) ::
+                    l
               | SgRecMod (loc, mb) ->
                   (mksig loc (Psig_recmodule (module_sig_binding mb []))) ::
                     l
@@ -15282,26 +15341,30 @@ module Struct =
                     (match mt with
                      | MtQuo (_, _) -> Pmodtype_abstract
                      | _ -> Pmodtype_manifest (module_type mt))
-                  in (mksig loc (Psig_modtype (n, si))) :: l
+                  in (mksig loc (Psig_modtype ((with_loc n loc), si))) :: l
               | SgOpn (loc, id) ->
                   (mksig loc (Psig_open (long_uident id))) :: l
               | SgTyp (loc, tdl) ->
                   (mksig loc (Psig_type (mktype_decl tdl []))) :: l
               | SgVal (loc, n, t) ->
-                  (mksig loc (Psig_value (n, (mkvalue_desc t [])))) :: l
+                  (mksig loc
+                     (Psig_value ((with_loc n loc), (mkvalue_desc loc t [])))) ::
+                    l
               | Ast.SgAnt (loc, _) -> error loc "antiquotation in sig_item"
             and module_sig_binding x acc =
               match x with
               | Ast.MbAnd (_, x, y) ->
                   module_sig_binding x (module_sig_binding y acc)
-              | Ast.MbCol (_, s, mt) -> (s, (module_type mt)) :: acc
+              | Ast.MbCol (loc, s, mt) ->
+                  ((with_loc s loc), (module_type mt)) :: acc
               | _ -> assert false
             and module_str_binding x acc =
               match x with
               | Ast.MbAnd (_, x, y) ->
                   module_str_binding x (module_str_binding y acc)
-              | Ast.MbColEq (_, s, mt, me) ->
-                  (s, (module_type mt), (module_expr me)) :: acc
+              | Ast.MbColEq (loc, s, mt, me) ->
+                  ((with_loc s loc), (module_type mt), (module_expr me)) ::
+                    acc
               | _ -> assert false
             and module_expr =
               function
@@ -15312,7 +15375,8 @@ module Struct =
                     (Pmod_apply ((module_expr me1), (module_expr me2)))
               | Ast.MeFun (loc, n, mt, me) ->
                   mkmod loc
-                    (Pmod_functor (n, (module_type mt), (module_expr me)))
+                    (Pmod_functor ((with_loc n loc), (module_type mt),
+                       (module_expr me)))
               | Ast.MeStr (loc, sl) ->
                   mkmod loc (Pmod_structure (str_item sl []))
               | Ast.MeTyc (loc, me, mt) ->
@@ -15349,17 +15413,21 @@ module Struct =
               | StDir (_, _, _) -> l
               | Ast.StExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), Ast.
                   ONone) ->
-                  (mkstr loc (Pstr_exception ((conv_con s), []))) :: l
+                  (mkstr loc
+                     (Pstr_exception ((with_loc (conv_con s) loc), []))) ::
+                    l
               | Ast.StExc (loc,
                   (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, s)))), t)), Ast.
                   ONone) ->
                   (mkstr loc
-                     (Pstr_exception ((conv_con s),
+                     (Pstr_exception ((with_loc (conv_con s) loc),
                         (List.map ctyp (list_of_ctyp t []))))) ::
                     l
               | Ast.StExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))),
                   (Ast.OSome i)) ->
-                  (mkstr loc (Pstr_exn_rebind ((conv_con s), (ident i)))) ::
+                  (mkstr loc
+                     (Pstr_exn_rebind ((with_loc (conv_con s) loc),
+                        (ident i)))) ::
                     l
               | Ast.StExc (loc,
                   (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, _)))), _)),
@@ -15368,18 +15436,22 @@ module Struct =
               | StExp (loc, e) -> (mkstr loc (Pstr_eval (expr e))) :: l
               | StExt (loc, n, t, sl) ->
                   (mkstr loc
-                     (Pstr_primitive (n,
-                        (mkvalue_desc t (list_of_meta_list sl))))) ::
+                     (Pstr_primitive ((with_loc n loc),
+                        (mkvalue_desc loc t (list_of_meta_list sl))))) ::
                     l
               | StInc (loc, me) ->
                   (mkstr loc (Pstr_include (module_expr me))) :: l
               | StMod (loc, n, me) ->
-                  (mkstr loc (Pstr_module (n, (module_expr me)))) :: l
+                  (mkstr loc
+                     (Pstr_module ((with_loc n loc), (module_expr me)))) ::
+                    l
               | StRecMod (loc, mb) ->
                   (mkstr loc (Pstr_recmodule (module_str_binding mb []))) ::
                     l
               | StMty (loc, n, mt) ->
-                  (mkstr loc (Pstr_modtype (n, (module_type mt)))) :: l
+                  (mkstr loc
+                     (Pstr_modtype ((with_loc n loc), (module_type mt)))) ::
+                    l
               | StOpn (loc, id) ->
                   (mkstr loc (Pstr_open (long_uident id))) :: l
               | StTyp (loc, tdl) ->
@@ -15396,9 +15468,7 @@ module Struct =
               | CtFun (loc, (TyLab (_, lab, t)), ct) ->
                   mkcty loc (Pcty_fun (lab, (ctyp t), (class_type ct)))
               | CtFun (loc, (TyOlb (loc1, lab, t)), ct) ->
-                  let t =
-                    TyApp (loc1,
-                      (Ast.TyId (loc1, (Ast.IdLid (loc1, "option")))), t)
+                  let t = TyApp (loc1, (predef_option loc1), t)
                   in
                     mkcty loc
                       (Pcty_fun (("?" ^ lab), (ctyp t), (class_type ct)))
@@ -15408,15 +15478,22 @@ module Struct =
                   let t =
                     (match t_o with | Ast.TyNil _ -> Ast.TyAny loc | t -> t) in
                   let cil = class_sig_item ctfl []
-                  in mkcty loc (Pcty_signature (((ctyp t), cil)))
+                  in
+                    mkcty loc
+                      (Pcty_signature
+                         {
+                           pcsig_self = ctyp t;
+                           pcsig_fields = cil;
+                           pcsig_loc = mkloc loc;
+                         })
               | CtCon (loc, _, _, _) ->
                   error loc "invalid virtual class inside a class type"
               | CtAnt (_, _) | CtEq (_, _, _) | CtCol (_, _, _) |
                   CtAnd (_, _, _) | CtNil _ -> assert false
             and class_info_class_expr ci =
               match ci with
-              | CeEq (_, (CeCon (loc, vir, (IdLid (_, name)), params)), ce)
-                  ->
+              | CeEq (_, (CeCon (loc, vir, (IdLid (nloc, name)), params)),
+                  ce) ->
                   let (loc_params, (params, variance)) =
                     (match params with
                      | Ast.TyNil _ -> (loc, ([], []))
@@ -15427,7 +15504,7 @@ module Struct =
                     {
                       pci_virt = mkvirtual vir;
                       pci_params = (params, (mkloc loc_params));
-                      pci_name = name;
+                      pci_name = with_loc name nloc;
                       pci_expr = class_expr ce;
                       pci_loc = mkloc loc;
                       pci_variance = variance;
@@ -15435,8 +15512,9 @@ module Struct =
               | ce -> error (loc_of_class_expr ce) "bad class definition"
             and class_info_class_type ci =
               match ci with
-              | CtEq (_, (CtCon (loc, vir, (IdLid (_, name)), params)), ct) |
-                  CtCol (_, (CtCon (loc, vir, (IdLid (_, name)), params)),
+              | CtEq (_, (CtCon (loc, vir, (IdLid (nloc, name)), params)),
+                  ct) |
+                  CtCol (_, (CtCon (loc, vir, (IdLid (nloc, name)), params)),
                     ct)
                   ->
                   let (loc_params, (params, variance)) =
@@ -15449,7 +15527,7 @@ module Struct =
                     {
                       pci_virt = mkvirtual vir;
                       pci_params = (params, (mkloc loc_params));
-                      pci_name = name;
+                      pci_name = with_loc name nloc;
                       pci_expr = class_type ct;
                       pci_loc = mkloc loc;
                       pci_variance = variance;
@@ -15461,22 +15539,22 @@ module Struct =
               match c with
               | Ast.CgNil _ -> l
               | CgCtr (loc, t1, t2) ->
-                  (Pctf_cstr (((ctyp t1), (ctyp t2), (mkloc loc)))) :: l
+                  (mkctf loc (Pctf_cstr (((ctyp t1), (ctyp t2))))) :: l
               | Ast.CgSem (_, csg1, csg2) ->
                   class_sig_item csg1 (class_sig_item csg2 l)
-              | CgInh (_, ct) -> (Pctf_inher (class_type ct)) :: l
+              | CgInh (loc, ct) ->
+                  (mkctf loc (Pctf_inher (class_type ct))) :: l
               | CgMth (loc, s, pf, t) ->
-                  (Pctf_meth
-                     ((s, (mkprivate pf), (mkpolytype (ctyp t)), (mkloc loc)))) ::
+                  (mkctf loc
+                     (Pctf_meth ((s, (mkprivate pf), (mkpolytype (ctyp t)))))) ::
                     l
               | CgVal (loc, s, b, v, t) ->
-                  (Pctf_val
-                     ((s, (mkmutable b), (mkvirtual v), (ctyp t),
-                       (mkloc loc)))) ::
+                  (mkctf loc
+                     (Pctf_val ((s, (mkmutable b), (mkvirtual v), (ctyp t))))) ::
                     l
               | CgVir (loc, s, b, t) ->
-                  (Pctf_virt
-                     ((s, (mkprivate b), (mkpolytype (ctyp t)), (mkloc loc)))) ::
+                  (mkctf loc
+                     (Pctf_virt ((s, (mkprivate b), (mkpolytype (ctyp t)))))) ::
                     l
               | CgAnt (_, _) -> assert false
             and class_expr =
@@ -15484,39 +15562,42 @@ module Struct =
               | (CeApp (loc, _, _) as c) ->
                   let (ce, el) = class_expr_fa [] c in
                   let el = List.map label_expr el
-                  in mkpcl loc (Pcl_apply ((class_expr ce), el))
+                  in mkcl loc (Pcl_apply ((class_expr ce), el))
               | CeCon (loc, ViNil, id, tl) ->
-                  mkpcl loc
+                  mkcl loc
                     (Pcl_constr ((long_class_ident id),
                        (List.map ctyp (list_of_opt_ctyp tl []))))
               | CeFun (loc, (PaLab (_, lab, po)), ce) ->
-                  mkpcl loc
+                  mkcl loc
                     (Pcl_fun (lab, None, (patt_of_lab loc lab po),
                        (class_expr ce)))
               | CeFun (loc, (PaOlbi (_, lab, p, e)), ce) ->
                   let lab = paolab lab p
                   in
-                    mkpcl loc
+                    mkcl loc
                       (Pcl_fun (("?" ^ lab), (Some (expr e)), (patt p),
                          (class_expr ce)))
               | CeFun (loc, (PaOlb (_, lab, p)), ce) ->
                   let lab = paolab lab p
                   in
-                    mkpcl loc
+                    mkcl loc
                       (Pcl_fun (("?" ^ lab), None, (patt_of_lab loc lab p),
                          (class_expr ce)))
               | CeFun (loc, p, ce) ->
-                  mkpcl loc (Pcl_fun ("", None, (patt p), (class_expr ce)))
+                  mkcl loc (Pcl_fun ("", None, (patt p), (class_expr ce)))
               | CeLet (loc, rf, bi, ce) ->
-                  mkpcl loc
+                  mkcl loc
                     (Pcl_let ((mkrf rf), (binding bi []), (class_expr ce)))
               | CeStr (loc, po, cfl) ->
                   let p =
                     (match po with | Ast.PaNil _ -> Ast.PaAny loc | p -> p) in
                   let cil = class_str_item cfl []
-                  in mkpcl loc (Pcl_structure (((patt p), cil)))
+                  in
+                    mkcl loc
+                      (Pcl_structure
+                         { pcstr_pat = patt p; pcstr_fields = cil; })
               | CeTyc (loc, ce, ct) ->
-                  mkpcl loc
+                  mkcl loc
                     (Pcl_constraint ((class_expr ce), (class_type ct)))
               | CeCon (loc, _, _, _) ->
                   error loc "invalid virtual class inside a class expression"
@@ -15526,15 +15607,17 @@ module Struct =
               match c with
               | CrNil _ -> l
               | CrCtr (loc, t1, t2) ->
-                  (Pcf_cstr (((ctyp t1), (ctyp t2), (mkloc loc)))) :: l
+                  (mkcf loc (Pcf_constr (((ctyp t1), (ctyp t2))))) :: l
               | Ast.CrSem (_, cst1, cst2) ->
                   class_str_item cst1 (class_str_item cst2 l)
               | CrInh (loc, ov, ce, pb) ->
                   let opb = if pb = "" then None else Some pb
                   in
-                    (Pcf_inher ((override_flag loc ov), (class_expr ce), opb)) ::
+                    (mkcf loc
+                       (Pcf_inher ((override_flag loc ov), (class_expr ce),
+                          opb))) ::
                       l
-              | CrIni (_, e) -> (Pcf_init (expr e)) :: l
+              | CrIni (loc, e) -> (mkcf loc (Pcf_init (expr e))) :: l
               | CrMth (loc, s, ov, pf, e, t) ->
                   let t =
                     (match t with
@@ -15542,21 +15625,27 @@ module Struct =
                      | t -> Some (mkpolytype (ctyp t))) in
                   let e = mkexp loc (Pexp_poly ((expr e), t))
                   in
-                    (Pcf_meth
-                       ((s, (mkprivate pf), (override_flag loc ov), e,
-                         (mkloc loc)))) ::
+                    (mkcf loc
+                       (Pcf_meth
+                          (((with_loc s loc), (mkprivate pf),
+                            (override_flag loc ov), e)))) ::
                       l
               | CrVal (loc, s, ov, mf, e) ->
-                  (Pcf_val
-                     ((s, (mkmutable mf), (override_flag loc ov), (expr e),
-                       (mkloc loc)))) ::
+                  (mkcf loc
+                     (Pcf_val
+                        (((with_loc s loc), (mkmutable mf),
+                          (override_flag loc ov), (expr e))))) ::
                     l
               | CrVir (loc, s, pf, t) ->
-                  (Pcf_virt
-                     ((s, (mkprivate pf), (mkpolytype (ctyp t)), (mkloc loc)))) ::
+                  (mkcf loc
+                     (Pcf_virt
+                        (((with_loc s loc), (mkprivate pf),
+                          (mkpolytype (ctyp t)))))) ::
                     l
               | CrVvr (loc, s, mf, t) ->
-                  (Pcf_valvirt ((s, (mkmutable mf), (ctyp t), (mkloc loc)))) ::
+                  (mkcf loc
+                     (Pcf_valvirt
+                        (((with_loc s loc), (mkmutable mf), (ctyp t))))) ::
                     l
               | CrAnt (_, _) -> assert false
               
@@ -15571,7 +15660,7 @@ module Struct =
               | ExInt (_, i) -> Pdir_int (int_of_string i)
               | Ast.ExId (_, (Ast.IdUid (_, "True"))) -> Pdir_bool true
               | Ast.ExId (_, (Ast.IdUid (_, "False"))) -> Pdir_bool false
-              | e -> Pdir_ident (ident (ident_of_expr e))
+              | e -> Pdir_ident (ident_noloc (ident_of_expr e))
               
             let phrase =
               function
@@ -16986,9 +17075,14 @@ module Struct =
                 let drop_prev_loc = Tools.drop_prev_loc
                   
                 let add_loc bp parse_fun strm =
+                  let count1 = Stream.count strm in
                   let x = parse_fun strm in
-                  let ep = loc_ep strm in
-                  let loc = Loc.merge bp ep in (x, loc)
+                  let count2 = Stream.count strm in
+                  let loc =
+                    if count1 < count2
+                    then (let ep = loc_ep strm in Loc.merge bp ep)
+                    else Loc.join bp
+                  in (x, loc)
                   
                 let stream_peek_nth strm n =
                   let rec loop i =
@@ -17799,13 +17893,6 @@ module Struct =
                                  in Some t
                              | None -> None)
                     | LocAct (_, _) | DeadEnd -> None
-                  and insert_new =
-                    function
-                    | s :: sl ->
-                        Node
-                          { node = s; son = insert_new sl; brother = DeadEnd;
-                          }
-                    | [] -> LocAct (action, [])
                   in insert gsymbols tree
                   
                 let insert_level entry e1 symbols action slev =
@@ -18868,7 +18955,7 @@ module Printers =
                        "Cannot print %S this identifier does not respect OCaml lexing rules (%s)"
                        str (Lexer.Error.to_string exn))
               
-            let ocaml_char = function | "'" -> "\\'" | c -> c
+            let ocaml_char x = match x with | "'" -> "\\'" | c -> c
               
             let rec get_expr_args a al =
               match a with
@@ -19150,7 +19237,16 @@ module Printers =
                   fun f t ->
                     match Ast.list_of_ctyp t [] with
                     | [] -> ()
-                    | ts -> pp f "@[<hv0>| %a@]" (list o#ctyp "@ | ") ts
+                    | ts ->
+                        pp f "@[<hv0>| %a@]"
+                          (list o#constructor_declaration "@ | ") ts
+                method private constructor_declaration =
+                  fun f t ->
+                    match t with
+                    | Ast.TyCol (_, t1, (Ast.TyArr (_, t2, t3))) ->
+                        pp f "@[<2>%a :@ @[<2>%a@ ->@ %a@]@]" o#ctyp t1
+                          o#constructor_type t2 o#ctyp t3
+                    | t -> o#ctyp f t
                 method string = fun f -> pp f "%s"
                 method quoted_string = fun f -> pp f "%S"
                 method numeric =
@@ -19388,7 +19484,7 @@ module Printers =
                       | Ast.ExInt64 (_, s) -> o#numeric f s "L"
                       | Ast.ExInt32 (_, s) -> o#numeric f s "l"
                       | Ast.ExFlo (_, s) -> o#numeric f s ""
-                      | Ast.ExChr (_, s) -> pp f "'%s'" (ocaml_char s)
+                      | Ast.ExChr (_, s) -> pp f "'%s'" s
                       | Ast.ExId (_, i) -> o#var_ident f i
                       | Ast.ExRec (_, b, (Ast.ExNil _)) ->
                           pp f "@[<hv0>@[<hv2>{%a@]@ }@]" o#record_binding b
@@ -19533,7 +19629,7 @@ module Printers =
                       | Ast.PaInt32 (_, s) -> o#numeric f s "l"
                       | Ast.PaInt (_, s) -> o#numeric f s ""
                       | Ast.PaFlo (_, s) -> o#numeric f s ""
-                      | Ast.PaChr (_, s) -> pp f "'%s'" (ocaml_char s)
+                      | Ast.PaChr (_, s) -> pp f "'%s'" s
                       | Ast.PaLab (_, s, (Ast.PaNil _)) -> pp f "~%s" s
                       | Ast.PaVrn (_, s) -> pp f "`%a" o#var s
                       | Ast.PaTyp (_, i) -> pp f "@[<2>#%a@]" o#ident i
@@ -19889,7 +19985,7 @@ module Printers =
                     in
                       match ce with
                       | Ast.CeApp (_, ce, e) ->
-                          pp f "@[<2>%a@ %a@]" o#class_expr ce o#expr e
+                          pp f "@[<2>%a@ %a@]" o#class_expr ce o#apply_expr e
                       | Ast.CeCon (_, Ast.ViNil, i, (Ast.TyNil _)) ->
                           pp f "@[<2>%a@]" o#ident i
                       | Ast.CeCon (_, Ast.ViNil, i, t) ->
diff --git a/camlp4/boot/Camlp4Ast.ml b/camlp4/boot/Camlp4Ast.ml
index acb8afd3c..fb49d01b5 100644
--- a/camlp4/boot/Camlp4Ast.ml
+++ b/camlp4/boot/Camlp4Ast.ml
@@ -471,11 +471,10 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
             value meta_loc = meta_loc_expr;
             module Expr =
               struct
-                value meta_string _loc s =
-                  Ast.ExStr _loc (safe_string_escaped s);
+                value meta_string _loc s = Ast.ExStr _loc s;
                 value meta_int _loc s = Ast.ExInt _loc s;
                 value meta_float _loc s = Ast.ExFlo _loc s;
-                value meta_char _loc s = Ast.ExChr _loc (String.escaped s);
+                value meta_char _loc s = Ast.ExChr _loc s;
                 value meta_bool _loc =
                   fun
                   [ False -> Ast.ExId _loc (Ast.IdUid _loc "False")
@@ -5048,6 +5047,8 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
             (*  source tree.                                                            *)
             (*                                                                          *)
             (****************************************************************************)
+            (* Note: when you modify these types you must increment
+   ast magic numbers defined in Camlp4_config.ml. *)
             'a 'a_out.
             ('self_type -> 'a -> 'a_out) ->
               meta_option 'a -> meta_option 'a_out =
diff --git a/camlp4/boot/camlp4boot.ml b/camlp4/boot/camlp4boot.ml
index 6cc5466c0..a434eea4f 100644
--- a/camlp4/boot/camlp4boot.ml
+++ b/camlp4/boot/camlp4boot.ml
@@ -588,6 +588,12 @@ New syntax:\
         let stopped_at _loc = Some (Loc.move_line 1 _loc)
           
         (* FIXME be more precise *)
+        let rec generalized_type_of_type =
+          function
+          | Ast.TyArr (_, t1, t2) ->
+              let (tl, rt) = generalized_type_of_type t2 in ((t1 :: tl), rt)
+          | t -> ([], t)
+          
         let symbolchar =
           let list =
             [ '$'; '!'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '=';
@@ -676,8 +682,8 @@ New syntax:\
                  (match Stream.peek __strm with
                   | Some
                       ((KEYWORD
-                          (("mod" | "land" | "lor" | "lxor" | "lsl" | "lsr" |
-                              "asr"
+                          (("or" | "mod" | "land" | "lor" | "lxor" | "lsl" |
+                              "lsr" | "asr"
                             as i)),
                         _loc))
                       ->
@@ -3027,16 +3033,8 @@ New syntax:\
                     [ (None, (Some Camlp4.Sig.Grammar.RightA),
                        [ ([ Gram.Snterm
                               (Gram.Entry.obj
-                                 (cvalue_binding :
-                                   'cvalue_binding Gram.Entry.t)) ],
-                          (Gram.Action.mk
-                             (fun (bi : 'cvalue_binding) (_loc : Gram.Loc.t)
-                                -> (bi : 'fun_binding))));
-                         ([ Gram.Stry
-                              (Gram.Snterm
-                                 (Gram.Entry.obj
-                                    (labeled_ipatt :
-                                      'labeled_ipatt Gram.Entry.t)));
+                                 (labeled_ipatt :
+                                   'labeled_ipatt Gram.Entry.t));
                             Gram.Sself ],
                           (Gram.Action.mk
                              (fun (e : 'fun_binding) (p : 'labeled_ipatt)
@@ -3045,6 +3043,14 @@ New syntax:\
                                    (Ast.McArr (_loc, p, (Ast.ExNil _loc), e))) :
                                   'fun_binding))));
                          ([ Gram.Stry
+                              (Gram.Snterm
+                                 (Gram.Entry.obj
+                                    (cvalue_binding :
+                                      'cvalue_binding Gram.Entry.t))) ],
+                          (Gram.Action.mk
+                             (fun (bi : 'cvalue_binding) (_loc : Gram.Loc.t)
+                                -> (bi : 'fun_binding))));
+                         ([ Gram.Stry
                               (Gram.srules fun_binding
                                  [ ([ Gram.Skeyword "("; Gram.Skeyword "type" ],
                                     (Gram.Action.mk
@@ -4294,6 +4300,25 @@ New syntax:\
                          ([ Gram.Snterm
                               (Gram.Entry.obj
                                  (label_ipatt : 'label_ipatt Gram.Entry.t));
+                            Gram.Skeyword ";"; Gram.Skeyword "_";
+                            Gram.Skeyword ";" ],
+                          (Gram.Action.mk
+                             (fun _ _ _ (p1 : 'label_ipatt)
+                                (_loc : Gram.Loc.t) ->
+                                (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) :
+                                  'label_ipatt_list))));
+                         ([ Gram.Snterm
+                              (Gram.Entry.obj
+                                 (label_ipatt : 'label_ipatt Gram.Entry.t));
+                            Gram.Skeyword ";"; Gram.Skeyword "_" ],
+                          (Gram.Action.mk
+                             (fun _ _ (p1 : 'label_ipatt) (_loc : Gram.Loc.t)
+                                ->
+                                (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) :
+                                  'label_ipatt_list))));
+                         ([ Gram.Snterm
+                              (Gram.Entry.obj
+                                 (label_ipatt : 'label_ipatt Gram.Entry.t));
                             Gram.Skeyword ";"; Gram.Sself ],
                           (Gram.Action.mk
                              (fun (p2 : 'label_ipatt_list) _
@@ -5037,40 +5062,16 @@ New syntax:\
                                  (a_UIDENT : 'a_UIDENT Gram.Entry.t));
                             Gram.Skeyword ":";
                             Gram.Snterm
-                              (Gram.Entry.obj
-                                 (constructor_arg_list :
-                                   'constructor_arg_list Gram.Entry.t)) ],
-                          (Gram.Action.mk
-                             (fun (ret : 'constructor_arg_list) _
-                                (s : 'a_UIDENT) (_loc : Gram.Loc.t) ->
-                                (match Ast.list_of_ctyp ret [] with
-                                 | [ c ] ->
-                                     Ast.TyCol (_loc,
-                                       (Ast.TyId (_loc,
-                                          (Ast.IdUid (_loc, s)))),
-                                       c)
-                                 | _ ->
-                                     raise
-                                       (Stream.Error
-                                          "invalid generalized constructor type") :
-                                  'constructor_declarations))));
-                         ([ Gram.Snterm
-                              (Gram.Entry.obj
-                                 (a_UIDENT : 'a_UIDENT Gram.Entry.t));
-                            Gram.Skeyword ":";
-                            Gram.Snterm
-                              (Gram.Entry.obj
-                                 (constructor_arg_list :
-                                   'constructor_arg_list Gram.Entry.t));
-                            Gram.Skeyword "->";
-                            Gram.Snterm
                               (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
                           (Gram.Action.mk
-                             (fun (ret : 'ctyp) _ (t : 'constructor_arg_list)
-                                _ (s : 'a_UIDENT) (_loc : Gram.Loc.t) ->
-                                (Ast.TyCol (_loc,
-                                   (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))),
-                                   (Ast.TyArr (_loc, t, ret))) :
+                             (fun (t : 'ctyp) _ (s : 'a_UIDENT)
+                                (_loc : Gram.Loc.t) ->
+                                (let (tl, rt) = generalized_type_of_type t
+                                 in
+                                   Ast.TyCol (_loc,
+                                     (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))),
+                                     (Ast.TyArr (_loc,
+                                        (Ast.tyAnd_of_list tl), rt))) :
                                   'constructor_declarations))));
                          ([ Gram.Snterm
                               (Gram.Entry.obj
@@ -8756,7 +8757,10 @@ New syntax:\
                           (Gram.Action.mk
                              (fun (st2 : 'str_item_quot) _ (st1 : 'str_item)
                                 (_loc : Gram.Loc.t) ->
-                                (Ast.StSem (_loc, st1, st2) : 'str_item_quot))));
+                                (match st2 with
+                                 | Ast.StNil _ -> st1
+                                 | _ -> Ast.StSem (_loc, st1, st2) :
+                                  'str_item_quot))));
                          ([ Gram.Skeyword "#";
                             Gram.Snterm
                               (Gram.Entry.obj
@@ -8792,7 +8796,10 @@ New syntax:\
                           (Gram.Action.mk
                              (fun (sg2 : 'sig_item_quot) _ (sg1 : 'sig_item)
                                 (_loc : Gram.Loc.t) ->
-                                (Ast.SgSem (_loc, sg1, sg2) : 'sig_item_quot))));
+                                (match sg2 with
+                                 | Ast.SgNil _ -> sg1
+                                 | _ -> Ast.SgSem (_loc, sg1, sg2) :
+                                  'sig_item_quot))));
                          ([ Gram.Skeyword "#";
                             Gram.Snterm
                               (Gram.Entry.obj
@@ -9232,7 +9239,9 @@ New syntax:\
                           (Gram.Action.mk
                              (fun (x2 : 'class_str_item_quot) _
                                 (x1 : 'class_str_item) (_loc : Gram.Loc.t) ->
-                                (Ast.CrSem (_loc, x1, x2) :
+                                (match x2 with
+                                 | Ast.CrNil _ -> x1
+                                 | _ -> Ast.CrSem (_loc, x1, x2) :
                                   'class_str_item_quot)))) ]) ]))
                   ());
              Gram.extend
@@ -9261,7 +9270,9 @@ New syntax:\
                           (Gram.Action.mk
                              (fun (x2 : 'class_sig_item_quot) _
                                 (x1 : 'class_sig_item) (_loc : Gram.Loc.t) ->
-                                (Ast.CgSem (_loc, x1, x2) :
+                                (match x2 with
+                                 | Ast.CgNil _ -> x1
+                                 | _ -> Ast.CgSem (_loc, x1, x2) :
                                   'class_sig_item_quot)))) ]) ]))
                   ());
              Gram.extend (with_constr_quot : 'with_constr_quot Gram.Entry.t)
@@ -13692,6 +13703,7 @@ Added statements:
      DEFINE <lident> = <expression> IN <expression>
      __FILE__
      __LOCATION__
+     LOCATION_OF <parameter>
 
   In patterns:
 
@@ -13724,6 +13736,10 @@ Added statements:
 
   The expression __FILE__ returns the current compiled file name.
   The expression __LOCATION__ returns the current location of itself.
+  If used inside a macro, it returns the location where the macro is
+  called.
+  The expression (LOCATION_OF parameter) returns the location of the given
+  macro parameter. It cannot be used outside a macro definition.
 
 *)
     open Camlp4
@@ -13794,6 +13810,48 @@ Added statements:
                    Ast.ExId (_, (Ast.IdUid (_, x)))
                  as e) ->
                   (try List.assoc x env with | Not_found -> super#expr e)
+              | (Ast.ExApp (_loc,
+                   (Ast.ExId (_, (Ast.IdUid (_, "LOCATION_OF")))),
+                   (Ast.ExId (_, (Ast.IdLid (_, x))))) |
+                   Ast.ExApp (_loc,
+                     (Ast.ExId (_, (Ast.IdUid (_, "LOCATION_OF")))),
+                     (Ast.ExId (_, (Ast.IdUid (_, x)))))
+                 as e) ->
+                  (try
+                     let loc = Ast.loc_of_expr (List.assoc x env) in
+                     let (a, b, c, d, e, f, g, h) = Loc.to_tuple loc
+                     in
+                       Ast.ExApp (_loc,
+                         (Ast.ExId (_loc,
+                            (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")),
+                               (Ast.IdLid (_loc, "of_tuple")))))),
+                         (Ast.ExTup (_loc,
+                            (Ast.ExCom (_loc,
+                               (Ast.ExStr (_loc, (Ast.safe_string_escaped a))),
+                               (Ast.ExCom (_loc,
+                                  (Ast.ExCom (_loc,
+                                     (Ast.ExCom (_loc,
+                                        (Ast.ExCom (_loc,
+                                           (Ast.ExCom (_loc,
+                                              (Ast.ExCom (_loc,
+                                                 (Ast.ExInt (_loc,
+                                                    (string_of_int b))),
+                                                 (Ast.ExInt (_loc,
+                                                    (string_of_int c))))),
+                                              (Ast.ExInt (_loc,
+                                                 (string_of_int d))))),
+                                           (Ast.ExInt (_loc,
+                                              (string_of_int e))))),
+                                        (Ast.ExInt (_loc, (string_of_int f))))),
+                                     (Ast.ExInt (_loc, (string_of_int g))))),
+                                  (if h
+                                   then
+                                     Ast.ExId (_loc,
+                                       (Ast.IdUid (_loc, "True")))
+                                   else
+                                     Ast.ExId (_loc,
+                                       (Ast.IdUid (_loc, "False")))))))))))
+                   with | Not_found -> super#expr e)
               | e -> super#expr e
             method patt =
               function
@@ -14541,87 +14599,6 @@ Added statements:
                                 (i : 'uident) _ (_loc : Gram.Loc.t) ->
                                 (if is_defined i then e1 else e2 : 'expr)))) ]) ]))
                   ());
-             Gram.extend (expr : 'expr Gram.Entry.t)
-               ((fun () ->
-                   ((Some (Camlp4.Sig.Grammar.Level "simple")),
-                    [ (None, None,
-                       [ ([ Gram.Stoken
-                              (((function
-                                 | LIDENT "__LOCATION__" -> true
-                                 | _ -> false),
-                                "LIDENT \"__LOCATION__\"")) ],
-                          (Gram.Action.mk
-                             (fun (__camlp4_0 : Gram.Token.t)
-                                (_loc : Gram.Loc.t) ->
-                                match __camlp4_0 with
-                                | LIDENT "__LOCATION__" ->
-                                    (let (a, b, c, d, e, f, g, h) =
-                                       Loc.to_tuple _loc
-                                     in
-                                       Ast.ExApp (_loc,
-                                         (Ast.ExId (_loc,
-                                            (Ast.IdAcc (_loc,
-                                               (Ast.IdUid (_loc, "Loc")),
-                                               (Ast.IdLid (_loc, "of_tuple")))))),
-                                         (Ast.ExTup (_loc,
-                                            (Ast.ExCom (_loc,
-                                               (Ast.ExStr (_loc,
-                                                  (Ast.safe_string_escaped a))),
-                                               (Ast.ExCom (_loc,
-                                                  (Ast.ExCom (_loc,
-                                                     (Ast.ExCom (_loc,
-                                                        (Ast.ExCom (_loc,
-                                                           (Ast.ExCom (_loc,
-                                                              (Ast.ExCom
-                                                                 (_loc,
-                                                                 (Ast.ExInt
-                                                                    (_loc,
-                                                                    (
-                                                                    string_of_int
-                                                                    b))),
-                                                                 (Ast.ExInt
-                                                                    (_loc,
-                                                                    (
-                                                                    string_of_int
-                                                                    c))))),
-                                                              (Ast.ExInt
-                                                                 (_loc,
-                                                                 (string_of_int
-                                                                    d))))),
-                                                           (Ast.ExInt (_loc,
-                                                              (string_of_int
-                                                                 e))))),
-                                                        (Ast.ExInt (_loc,
-                                                           (string_of_int f))))),
-                                                     (Ast.ExInt (_loc,
-                                                        (string_of_int g))))),
-                                                  (if h
-                                                   then
-                                                     Ast.ExId (_loc,
-                                                       (Ast.IdUid (_loc,
-                                                          "True")))
-                                                   else
-                                                     Ast.ExId (_loc,
-                                                       (Ast.IdUid (_loc,
-                                                          "False"))))))))))) :
-                                      'expr)
-                                | _ -> assert false)));
-                         ([ Gram.Stoken
-                              (((function
-                                 | LIDENT "__FILE__" -> true
-                                 | _ -> false),
-                                "LIDENT \"__FILE__\"")) ],
-                          (Gram.Action.mk
-                             (fun (__camlp4_0 : Gram.Token.t)
-                                (_loc : Gram.Loc.t) ->
-                                match __camlp4_0 with
-                                | LIDENT "__FILE__" ->
-                                    (Ast.ExStr (_loc,
-                                       (Ast.safe_string_escaped
-                                          (Loc.file_name _loc))) :
-                                      'expr)
-                                | _ -> assert false))) ]) ]))
-                  ());
              Gram.extend (patt : 'patt Gram.Entry.t)
                ((fun () ->
                    (None,
@@ -14790,17 +14767,47 @@ Added statements:
           
         open Ast
           
-        let remove_nothings =
+        (* Remove NOTHING and expanse __FILE__ and __LOCATION__ *)
+        let map_expr =
           function
           | Ast.ExApp (_, e, (Ast.ExId (_, (Ast.IdUid (_, "NOTHING"))))) |
               Ast.ExFun (_,
                 (Ast.McArr (_, (Ast.PaId (_, (Ast.IdUid (_, "NOTHING")))),
                    (Ast.ExNil _), e)))
               -> e
+          | Ast.ExId (_loc, (Ast.IdLid (_, "__FILE__"))) ->
+              Ast.ExStr (_loc,
+                (Ast.safe_string_escaped (Loc.file_name _loc)))
+          | Ast.ExId (_loc, (Ast.IdLid (_, "__LOCATION__"))) ->
+              let (a, b, c, d, e, f, g, h) = Loc.to_tuple _loc
+              in
+                Ast.ExApp (_loc,
+                  (Ast.ExId (_loc,
+                     (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")),
+                        (Ast.IdLid (_loc, "of_tuple")))))),
+                  (Ast.ExTup (_loc,
+                     (Ast.ExCom (_loc,
+                        (Ast.ExStr (_loc, (Ast.safe_string_escaped a))),
+                        (Ast.ExCom (_loc,
+                           (Ast.ExCom (_loc,
+                              (Ast.ExCom (_loc,
+                                 (Ast.ExCom (_loc,
+                                    (Ast.ExCom (_loc,
+                                       (Ast.ExCom (_loc,
+                                          (Ast.ExInt (_loc,
+                                             (string_of_int b))),
+                                          (Ast.ExInt (_loc,
+                                             (string_of_int c))))),
+                                       (Ast.ExInt (_loc, (string_of_int d))))),
+                                    (Ast.ExInt (_loc, (string_of_int e))))),
+                                 (Ast.ExInt (_loc, (string_of_int f))))),
+                              (Ast.ExInt (_loc, (string_of_int g))))),
+                           (if h
+                            then Ast.ExId (_loc, (Ast.IdUid (_loc, "True")))
+                            else Ast.ExId (_loc, (Ast.IdUid (_loc, "False")))))))))))
           | e -> e
           
-        let _ =
-          register_str_item_filter (Ast.map_expr remove_nothings)#str_item
+        let _ = register_str_item_filter (Ast.map_expr map_expr)#str_item
           
       end
author	Fabrice Le Fessant <Fabrice.Le_fessant@inria.fr>	2012-05-30 14:52:37 +0000
committer	Fabrice Le Fessant <Fabrice.Le_fessant@inria.fr>	2012-05-30 14:52:37 +0000
commit	d39d43e55fab716fbe05cec3c89233f0dd208835 (patch)
tree	bf5c56aa9bb32a0e3d49509b8b2863a9ec407563 /camlp4
parent	e3d82817909dd7bc69dff4f75aa63c5ba606d9c8 (diff)