Commit f321a3ca authored by POTTIER Francois's avatar POTTIER Francois

Changed the calling convention of [protect].

parent cab95daa
......@@ -80,6 +80,8 @@ let sum_build_warning (decl : type_declaration) : unit =
Instead, @build should be attached to each data constructor."
plugin
(* -------------------------------------------------------------------------- *)
(* A quick-and-dirty mechanism for registering the current type declaration
(the one that is being processed). We use it to obtain a location for
certain warnings. *)
......@@ -99,6 +101,18 @@ let current () =
(* -------------------------------------------------------------------------- *)
(* Shared code for detecting and warning against name clashes. *)
let protect_attrs_longident (f : attributes * Longident.t -> methode) format =
VisitorsString.protect f (fun (_, x1) (_, x2) m ->
if x1 <> x2 then
let x1 = VisitorsString.print_longident x1
and x2 = VisitorsString.print_longident x2 in
warning (current()) format plugin x1 x2 m
)
(* -------------------------------------------------------------------------- *)
(* We support parameterized type declarations. We require them to be regular.
That is, for instance, if a type ['a term] is being defined, then every
use of [_ term] in the definition should be ['a term]; it cannot be, say,
......@@ -180,20 +194,11 @@ let tycon_visitor_method : attributes * Longident.t -> methode =
(* Step 2 -- protect against name clashes. *)
let tycon_visitor_method : attributes * Longident.t -> methode =
VisitorsString.protect
(fun (_, x1) (_, x2) -> x1 = x2)
tycon_visitor_method
(fun (_, x1) (_, x2) m ->
let loc = current() in
warning loc
"%s: name clash: the types %s and %s\n\
both have a visitor method named %s.\n\
Please consider using [@@name] at type declaration sites\n\
or [@name] at type reference sites."
plugin
(VisitorsString.print_longident x1)
(VisitorsString.print_longident x2)
m)
protect_attrs_longident tycon_visitor_method
"%s: name clash: the types %s and %s\n\
both have a visitor method named %s.\n\
Please consider using [@@name] at type declaration sites\n\
or [@name] at type reference sites."
(* Step 3 -- define auxiliary functions that are easier to use. *)
......
......@@ -32,22 +32,20 @@ let print_longident (x : Longident.t) : string =
String.concat "." (Longident.flatten x)
(* Suppose the function [f] is a lossy (non-injective) mapping of ['a] to
[string]. Then, the function [protect equal f warn] is also a function of
['a] to [string], which behaves like [f], except it warns when [f] is
applied to two values of type ['a] that have the same image of type
[string]. *)
[string]. Then, the function [protect f check] is also a function of ['a]
to [string], which behaves like [f], except it checks if [f] is applied to
two values of type ['a] that have the same image of type [string]. *)
(* [equal] should implement equality at type ['a]. *)
(* [warn x1 x2 y] is invoked when [f] is applied at two values [x1] and [x2]
that have the same image [y] through [f]. *)
(* [check x1 x2 y] is invoked when [f] is applied at two values [x1] and [x2]
that have the same image [y] through [f]. It is up to this function to
compare [x1] and [x2] and to take appropriate action if they are
distinct. *)
module H = Hashtbl
let protect
(equal : 'a -> 'a -> bool)
(f : 'a -> string)
(warn : 'a -> 'a -> string -> unit)
(check : 'a -> 'a -> string -> unit)
: 'a -> string =
(* A hash table memoizes the inverse of [f]. *)
let table : (string, 'a) H.t = H.create 127 in
......@@ -55,8 +53,7 @@ let protect
let y = f x in
begin try
let x' = H.find table y in
if not (equal x x') then
warn x' x y
check x' x y
with Not_found ->
H.add table y x
end;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment