diff options
Diffstat (limited to 'camlp4/boot/Camlp4.ml')
| -rw-r--r-- | camlp4/boot/Camlp4.ml | 452 |
1 files changed, 274 insertions, 178 deletions
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) -> |