From 2a0d260c9c80c07844605fcb6844bb9cfdfeb0fd Mon Sep 17 00:00:00 2001
From: Pierre-Marie Pédrot
Date: Sat, 1 Mar 2014 14:17:09 +0100
Subject: Canary testing absence of generic equality for KerNames

---
 kernel/names.ml | 9 ++++++---
 lib/errors.ml   | 1 +
 2 files changed, 7 insertions(+), 3 deletions(-)

diff --git a/kernel/names.ml b/kernel/names.ml
index b0c9335348..21d22baffb 100644
--- a/kernel/names.ml
+++ b/kernel/names.ml
@@ -332,6 +332,7 @@ module MPmap = CMap.Make(ModPath)
 module KerName = struct
 
   type t = {
+    canary : Canary.t;
     modpath : ModPath.t;
     dirpath : DirPath.t;
     knlabel : Label.t;
@@ -339,14 +340,16 @@ module KerName = struct
     (** Lazily computed hash. If unset, it is set to negative values. *)
   }
 
+  let canary = Canary.obj
+
   type kernel_name = t
 
   let make modpath dirpath knlabel =
-    { modpath; dirpath; knlabel; refhash = -1; }
+    { modpath; dirpath; knlabel; refhash = -1; canary; }
   let repr kn = (kn.modpath, kn.dirpath, kn.knlabel)
 
   let make2 modpath knlabel =
-    { modpath; dirpath = DirPath.empty; knlabel; refhash = -1; }
+    { modpath; dirpath = DirPath.empty; knlabel; refhash = -1; canary; }
 
   let modpath kn = kn.modpath
   let label kn = kn.knlabel
@@ -391,7 +394,7 @@ module KerName = struct
         * (string -> string)
     let hashcons (hmod,hdir,hstr) kn =
       let { modpath = mp; dirpath = dp; knlabel = l; refhash; } = kn in
-      { modpath = hmod mp; dirpath = hdir dp; knlabel = hstr l; refhash; }
+      { modpath = hmod mp; dirpath = hdir dp; knlabel = hstr l; refhash; canary; }
     let equal kn1 kn2 =
       kn1.modpath == kn2.modpath && kn1.dirpath == kn2.dirpath &&
         kn1.knlabel == kn2.knlabel
diff --git a/lib/errors.ml b/lib/errors.ml
index 9df276465d..45e0f9fdf2 100644
--- a/lib/errors.ml
+++ b/lib/errors.ml
@@ -114,4 +114,5 @@ let noncritical = function
   | Sys.Break | Out_of_memory | Stack_overflow
   | Assert_failure _ | Match_failure _ | Anomaly _
   | Timeout | Drop | Quit -> false
+  | Invalid_argument "equal: functional value" -> false
   | _ -> true
-- 
cgit v1.2.3