Fixing printing bug due to using equality ill-checking hash key of kernel name.

Thanks to Georges Gonthier for noticing it.

Expanding a few Pervasives.compare at this occasion.

5 files changed, 44 insertions, 5 deletions

diff --git a/interp/constrextern.ml b/interp/constrextern.ml
index 0d0b6158d9..444ac5ab6d 100644
--- a/interp/constrextern.ml
+++ b/interp/constrextern.ml
@@ -67,10 +67,7 @@ let print_no_symbol = ref false
 
 (**********************************************************************)
 (* Turning notations and scopes on and off for printing *)
-module IRuleSet = Set.Make(struct
-    type t = interp_rule
-    let compare x y = Pervasives.compare x y
-  end)
+module IRuleSet = InterpRuleSet
 
 let inactive_notations_table =
   Summary.ref ~name:"inactive_notations_table" (IRuleSet.empty)
diff --git a/interp/notation.ml b/interp/notation.ml
index b0854de4a3..ca27d439fb 100644
--- a/interp/notation.ml
+++ b/interp/notation.ml
@@ -50,15 +50,25 @@ let notation_entry_level_eq s1 s2 = match (s1,s2) with
 | InCustomEntryLevel (s1,n1), InCustomEntryLevel (s2,n2) -> String.equal s1 s2 && n1 = n2
 | (InConstrEntrySomeLevel | InCustomEntryLevel _), _ -> false
 
+let notation_entry_level_compare s1 s2 = match (s1,s2) with
+| InConstrEntrySomeLevel, InConstrEntrySomeLevel -> 0
+| InCustomEntryLevel (s1,n1), InCustomEntryLevel (s2,n2) ->
+   pair_compare String.compare Int.compare (s1,n1) (s2,n2)
+| InConstrEntrySomeLevel, _ -> -1
+| InCustomEntryLevel _, _ -> 1
+
 let notation_eq (from1,ntn1) (from2,ntn2) =
   notation_entry_level_eq from1 from2 && String.equal ntn1 ntn2
 
 let pr_notation (from,ntn) = qstring ntn ++ match from with InConstrEntrySomeLevel -> mt () | InCustomEntryLevel (s,n) -> str " in custom " ++ str s
 
+let notation_compare =
+  pair_compare notation_entry_level_compare String.compare
+
 module NotationOrd =
   struct
     type t = notation
-    let compare = Pervasives.compare
+    let compare = notation_compare
   end
 
 module NotationSet = Set.Make(NotationOrd)
@@ -178,6 +188,17 @@ type scoped_notation_rule_core = scope_name * notation * interpretation * int op
 type notation_rule_core = interp_rule * interpretation * int option
 type notation_rule = notation_rule_core * delimiters option * bool
 
+let interp_rule_compare r1 r2 = match r1, r2 with
+  | NotationRule (sc1,ntn1), NotationRule (sc2,ntn2) ->
+      pair_compare (Option.compare String.compare) notation_compare (sc1,ntn1) (sc2,ntn2)
+  | SynDefRule kn1, SynDefRule kn2 -> KerName.compare kn1 kn2
+  | (NotationRule _ | SynDefRule _), _ -> -1
+
+module InterpRuleSet = Set.Make(struct
+    type t = interp_rule
+    let compare = interp_rule_compare
+  end)
+
 (* Scopes for uninterpretation: includes abbreviations (i.e. syntactic definitions) and  *)
 
 type uninterp_scope_elem =
diff --git a/interp/notation.mli b/interp/notation.mli
index 75034cad70..a482e00e81 100644
--- a/interp/notation.mli
+++ b/interp/notation.mli
@@ -210,6 +210,8 @@ type interp_rule =
   | NotationRule of scope_name option * notation
   | SynDefRule of KerName.t
 
+module InterpRuleSet : Set.S with type elt = interp_rule
+
 val declare_notation_interpretation : notation -> scope_name option ->
       interpretation -> notation_location -> onlyprint:bool -> unit
 
diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out
index d58e4bf2d6..94016e170b 100644
--- a/test-suite/output/Notations4.out
+++ b/test-suite/output/Notations4.out
@@ -45,3 +45,5 @@ fun x : nat => (x.-1)%pred
      : Prop
 ##
      : Prop
+Notation Cn := Foo.FooCn
+Expands to: Notation Top.J.Mfoo.Foo.Bar.Cn
diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v
index 61206b6dd0..309115848f 100644
--- a/test-suite/output/Notations4.v
+++ b/test-suite/output/Notations4.v
@@ -164,3 +164,20 @@ Open Scope my_scope.
 Check ##.
 
 End H.
+
+(* Fixing a bug reported by G. Gonthier in #9207 *)
+
+Module J.
+
+Module Import Mfoo.
+Module Foo.
+Definition FooCn := 2.
+Module Bar.
+Notation Cn := FooCn.
+End Bar.
+End Foo.
+Export Foo.Bar.
+End Mfoo.
+About Cn.
+
+End J.