aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/aux_file.ml20
-rw-r--r--lib/aux_file.mli8
-rw-r--r--lib/cAst.ml24
-rw-r--r--lib/cAst.mli22
-rw-r--r--lib/cWarnings.ml19
-rw-r--r--lib/cWarnings.mli2
-rw-r--r--lib/clib.mllib1
-rw-r--r--lib/feedback.ml2
-rw-r--r--lib/feedback.mli2
-rw-r--r--lib/loc.ml30
-rw-r--r--lib/loc.mli34
-rw-r--r--lib/stateid.ml2
-rw-r--r--lib/stateid.mli2
13 files changed, 105 insertions, 63 deletions
diff --git a/lib/aux_file.ml b/lib/aux_file.ml
index 1b6651a55f..09a254e9d9 100644
--- a/lib/aux_file.ml
+++ b/lib/aux_file.ml
@@ -46,19 +46,21 @@ let contents x = x
let empty_aux_file = H.empty
-let get aux loc key = M.find key (H.find (Loc.unloc loc) aux)
+let get ?loc aux key = M.find key (H.find (Option.cata Loc.unloc (0,0) loc) aux)
-let record_in_aux_at loc key v =
+let record_in_aux_at ?loc key v =
Option.iter (fun oc ->
- let i, j = Loc.unloc loc in
- Printf.fprintf oc "%d %d %s %S\n" i j key v)
- !oc
+ match loc with
+ | Some loc -> let i, j = Loc.unloc loc in
+ Printf.fprintf oc "%d %d %s %S\n" i j key v
+ | None -> Printf.fprintf oc "--- %s %S\n" key v
+ ) !oc
-let current_loc = ref Loc.ghost
+let current_loc : Loc.t option ref = ref None
-let record_in_aux_set_at loc = current_loc := loc
+let record_in_aux_set_at ?loc () = current_loc := loc
-let record_in_aux key v = record_in_aux_at !current_loc key v
+let record_in_aux key v = record_in_aux_at ?loc:!current_loc key v
let set h loc k v =
let m = try H.find loc h with Not_found -> M.empty in
@@ -91,4 +93,4 @@ let load_aux_file_for vfile =
Flags.if_verbose Feedback.msg_info Pp.(str"Loading file "++str aux_fname++str": "++str s);
empty_aux_file
-let set h loc k v = set h (Loc.unloc loc) k v
+let set ?loc h k v = set h (Option.cata Loc.unloc (0,0) loc) k v
diff --git a/lib/aux_file.mli b/lib/aux_file.mli
index 86e322b71d..a7960fa169 100644
--- a/lib/aux_file.mli
+++ b/lib/aux_file.mli
@@ -9,9 +9,9 @@
type aux_file
val load_aux_file_for : string -> aux_file
-val get : aux_file -> Loc.t -> string -> string
val empty_aux_file : aux_file
-val set : aux_file -> Loc.t -> string -> string -> aux_file
+val get : ?loc:Loc.t -> aux_file -> string -> string
+val set : ?loc:Loc.t -> aux_file -> string -> string -> aux_file
module H : Map.S with type key = int * int
module M : Map.S with type key = string
@@ -22,6 +22,6 @@ val start_aux_file : aux_file:string -> v_file:string -> unit
val stop_aux_file : unit -> unit
val recording : unit -> bool
-val record_in_aux_at : Loc.t -> string -> string -> unit
+val record_in_aux_at : ?loc:Loc.t -> string -> string -> unit
val record_in_aux : string -> string -> unit
-val record_in_aux_set_at : Loc.t -> unit
+val record_in_aux_set_at : ?loc:Loc.t -> unit -> unit
diff --git a/lib/cAst.ml b/lib/cAst.ml
new file mode 100644
index 0000000000..301a6bac8c
--- /dev/null
+++ b/lib/cAst.ml
@@ -0,0 +1,24 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** The ast type contains generic metadata for AST nodes. *)
+type 'a t = {
+ v : 'a;
+ loc : Loc.t option;
+}
+
+let make ?loc v = { v; loc }
+
+let map f n = { n with v = f n.v }
+let map_with_loc f n = { n with v = f ?loc:n.loc n.v }
+let map_from_loc f l =
+ let loc, v = l in
+ { v = f ?loc v ; loc }
+
+let with_val f n = f n.v
+let with_loc_val f n = f ?loc:n.loc n.v
diff --git a/lib/cAst.mli b/lib/cAst.mli
new file mode 100644
index 0000000000..700a06ce84
--- /dev/null
+++ b/lib/cAst.mli
@@ -0,0 +1,22 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** The ast type contains generic metadata for AST nodes *)
+type 'a t = private {
+ v : 'a;
+ loc : Loc.t option;
+}
+
+val make : ?loc:Loc.t -> 'a -> 'a t
+
+val map : ('a -> 'b) -> 'a t -> 'b t
+val map_with_loc : (?loc:Loc.t -> 'a -> 'b) -> 'a t -> 'b t
+val map_from_loc : (?loc:Loc.t -> 'a -> 'b) -> 'a Loc.located -> 'b t
+
+val with_val : ('a -> 'b) -> 'a t -> 'b
+val with_loc_val : (?loc:Loc.t -> 'a -> 'b) -> 'a t -> 'b
diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml
index 71e02b3ba4..2755946abc 100644
--- a/lib/cWarnings.ml
+++ b/lib/cWarnings.ml
@@ -20,10 +20,10 @@ type t = {
let warnings : (string, t) Hashtbl.t = Hashtbl.create 97
let categories : (string, string list) Hashtbl.t = Hashtbl.create 97
-let current_loc = ref Loc.ghost
+let current_loc = ref None
let flags = ref ""
-let set_current_loc = (:=) current_loc
+let set_current_loc loc = current_loc := loc
let get_flags () = !flags
@@ -35,29 +35,22 @@ let add_warning_in_category ~name ~category =
in
Hashtbl.replace categories category (name::ws)
-let refine_loc = function
- | None when not (Loc.is_ghost !current_loc) -> Some !current_loc
- | loc -> loc
-
let create ~name ~category ?(default=Enabled) pp =
Hashtbl.add warnings name { default; category; status = default };
add_warning_in_category ~name ~category;
if default <> Disabled then
add_warning_in_category ~name ~category:"default";
- fun ?loc x -> let w = Hashtbl.find warnings name in
+ fun ?loc x ->
+ let w = Hashtbl.find warnings name in
+ let loc = Option.append loc !current_loc in
match w.status with
| Disabled -> ()
- | AsError ->
- begin match refine_loc loc with
- | Some loc -> CErrors.user_err ~loc (pp x)
- | None -> CErrors.user_err (pp x)
- end
+ | AsError -> CErrors.user_err ?loc (pp x)
| Enabled ->
let msg =
pp x ++ spc () ++ str "[" ++ str name ++ str "," ++
str category ++ str "]"
in
- let loc = refine_loc loc in
Feedback.msg_warning ?loc msg
let warn_unknown_warning =
diff --git a/lib/cWarnings.mli b/lib/cWarnings.mli
index 3f6cee31b7..c1fb5d6042 100644
--- a/lib/cWarnings.mli
+++ b/lib/cWarnings.mli
@@ -8,7 +8,7 @@
type status = Disabled | Enabled | AsError
-val set_current_loc : Loc.t -> unit
+val set_current_loc : Loc.t option -> unit
val create : name:string -> category:string -> ?default:status ->
('a -> Pp.std_ppcmds) -> ?loc:Loc.t -> 'a -> unit
diff --git a/lib/clib.mllib b/lib/clib.mllib
index c73ae9b904..9eb479fcc9 100644
--- a/lib/clib.mllib
+++ b/lib/clib.mllib
@@ -18,6 +18,7 @@ IStream
Flags
Control
Loc
+CAst
CList
CString
Deque
diff --git a/lib/feedback.ml b/lib/feedback.ml
index 0846e419b2..f6abf65120 100644
--- a/lib/feedback.ml
+++ b/lib/feedback.ml
@@ -30,7 +30,7 @@ type feedback_content =
| FileDependency of string option * string
| FileLoaded of string * string
(* Extra metadata *)
- | Custom of Loc.t * string * xml
+ | Custom of Loc.t option * string * xml
(* Generic messages *)
| Message of level * Loc.t option * Pp.std_ppcmds
diff --git a/lib/feedback.mli b/lib/feedback.mli
index bdd236ac78..dc104132a0 100644
--- a/lib/feedback.mli
+++ b/lib/feedback.mli
@@ -38,7 +38,7 @@ type feedback_content =
| FileDependency of string option * string
| FileLoaded of string * string
(* Extra metadata *)
- | Custom of Loc.t * string * xml
+ | Custom of Loc.t option * string * xml
(* Generic messages *)
| Message of level * Loc.t option * Pp.std_ppcmds
diff --git a/lib/loc.ml b/lib/loc.ml
index e373a760cb..ee759bdfc1 100644
--- a/lib/loc.ml
+++ b/lib/loc.ml
@@ -26,12 +26,6 @@ let make_loc (bp, ep) = {
fname = ""; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0;
bp = bp; ep = ep; }
-let ghost = {
- fname = ""; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0;
- bp = 0; ep = 0; }
-
-let is_ghost loc = loc.ep = 0
-
let merge loc1 loc2 =
if loc1.bp < loc2.bp then
if loc1.ep < loc2.ep then {
@@ -51,24 +45,25 @@ let merge loc1 loc2 =
bp = loc2.bp; ep = loc1.ep; }
else loc2
-let unloc loc = (loc.bp, loc.ep)
+let merge_opt l1 l2 = match l1, l2 with
+ | None, None -> None
+ | Some l , None -> Some l
+ | None, Some l -> Some l
+ | Some l1, Some l2 -> Some (merge l1 l2)
-let dummy_loc = ghost
-let join_loc = merge
+let unloc loc = (loc.bp, loc.ep)
(** Located type *)
+type 'a located = t option * 'a
-type 'a located = t * 'a
-let located_fold_left f x (_,a) = f x a
-let located_iter2 f (_,a) (_,b) = f a b
-let down_located f (_,a) = f a
+let tag ?loc x = loc, x
+let map f (l,x) = (l, f x)
(** Exceptions *)
let location : t Exninfo.t = Exninfo.make ()
let add_loc e loc = Exninfo.add e location loc
-
let get_loc e = Exninfo.get e location
let raise ?loc e =
@@ -77,3 +72,10 @@ let raise ?loc e =
| Some loc ->
let info = Exninfo.add Exninfo.null location loc in
Exninfo.iraise (e, info)
+
+(** Deprecated *)
+let located_fold_left f x (_,a) = f x a
+let located_iter2 f (_,a) (_,b) = f a b
+let down_located f (_,a) = f a
+
+
diff --git a/lib/loc.mli b/lib/loc.mli
index bb88f86428..edcf701bf2 100644
--- a/lib/loc.mli
+++ b/lib/loc.mli
@@ -18,9 +18,6 @@ type t = {
ep : int; (** end position *)
}
-type 'a located = t * 'a
-(** Embed a location in a type *)
-
(** {5 Location manipulation} *)
(** This is inherited from CAMPL4/5. *)
@@ -35,13 +32,9 @@ val unloc : t -> int * int
val make_loc : int * int -> t
(** Make a location out of its start and end position *)
-val ghost : t
-(** Dummy location *)
-
-val is_ghost : t -> bool
-(** Test whether the location is meaningful *)
-
val merge : t -> t -> t
+val merge_opt : t option -> t option -> t option
+(** Merge locations, usually generating the largest possible span *)
(** {5 Located exceptions} *)
@@ -54,18 +47,23 @@ val get_loc : Exninfo.info -> t option
val raise : ?loc:t -> exn -> 'a
(** [raise loc e] is the same as [Pervasives.raise (add_loc e loc)]. *)
-(** {5 Location utilities} *)
+(** {5 Objects with location information } *)
+
+type 'a located = t option * 'a
+val tag : ?loc:t -> 'a -> 'a located
+(** Embed a location in a type *)
+
+val map : ('a -> 'b) -> 'a located -> 'b located
+(** Modify an object carrying a location *)
+
+(** Deprecated functions *)
val located_fold_left : ('a -> 'b -> 'a) -> 'a -> 'b located -> 'a
-val located_iter2 : ('a -> 'b -> unit) -> 'a located -> 'b located -> unit
+ [@@ocaml.deprecated "use pattern matching"]
val down_located : ('a -> 'b) -> 'a located -> 'b
-(** Projects out a located object *)
+ [@@ocaml.deprecated "use pattern matching"]
-(** {5 Backward compatibility} *)
-
-val dummy_loc : t
-(** Same as [ghost] *)
+val located_iter2 : ('a -> 'b -> unit) -> 'a located -> 'b located -> unit
+ [@@ocaml.deprecated "use pattern matching"]
-val join_loc : t -> t -> t
-(** Same as [merge] *)
diff --git a/lib/stateid.ml b/lib/stateid.ml
index c153f0e808..29f020071b 100644
--- a/lib/stateid.ml
+++ b/lib/stateid.ml
@@ -40,7 +40,7 @@ type ('a,'b) request = {
exn_info : t * t;
stop : t;
document : 'b;
- loc : Loc.t;
+ loc : Loc.t option;
uuid : 'a;
name : string
}
diff --git a/lib/stateid.mli b/lib/stateid.mli
index 1d87a343b3..d9e75f5840 100644
--- a/lib/stateid.mli
+++ b/lib/stateid.mli
@@ -34,7 +34,7 @@ type ('a,'b) request = {
exn_info : t * t;
stop : t;
document : 'b;
- loc : Loc.t;
+ loc : Loc.t option;
uuid : 'a;
name : string
}
generated by cgit v1.2.3 (git 2.25.1) at 2026-03-02 06:53:46 +0000