Imported Upstream snapshot 8.3~beta0+13298

1 files changed, 52 insertions, 61 deletions

diff --git a/library/libobject.ml b/library/libobject.ml
index b455e2b3..ecdcacf1 100644
--- a/library/libobject.ml
+++ b/library/libobject.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: libobject.ml 11739 2009-01-02 19:33:19Z herbelin $ *)
+(* $Id$ *)
 
 open Util
 open Names
@@ -25,7 +25,7 @@ let relax_flag = ref false;;
 
 let relax b = relax_flag := b;;
 
-type 'a substitutivity = 
+type 'a substitutivity =
     Dispose | Substitute of 'a | Keep of 'a | Anticipate of 'a
 
 type 'a object_declaration = {
@@ -33,11 +33,10 @@ type 'a object_declaration = {
   cache_function : object_name * 'a -> unit;
   load_function : int -> object_name * 'a -> unit;
   open_function : int -> object_name * 'a -> unit;
-  classify_function : object_name * 'a -> 'a substitutivity;
-  subst_function : object_name * substitution * 'a -> 'a;
+  classify_function : 'a -> 'a substitutivity;
+  subst_function :  substitution * 'a -> 'a;
   discharge_function : object_name * 'a -> 'a option;
-  rebuild_function : 'a -> 'a;
-  export_function : 'a -> 'a option }
+  rebuild_function : 'a -> 'a }
 
 let yell s = anomaly s
 
@@ -46,12 +45,11 @@ let default_object s = {
   cache_function = (fun _ -> ());
   load_function = (fun _ _ -> ());
   open_function = (fun _ _ -> ());
-  subst_function = (fun _ -> 
+  subst_function = (fun _ ->
     yell ("The object "^s^" does not know how to substitute!"));
-  classify_function = (fun (_,obj) -> Keep obj);
+  classify_function = (fun obj -> Keep obj);
   discharge_function = (fun _ -> None);
-  rebuild_function = (fun x -> x);
-  export_function = (fun _ -> None)} 
+  rebuild_function = (fun x -> x)}
 
 
 (* The suggested object declaration is the following:
@@ -59,13 +57,13 @@ let default_object s = {
    declare_object { (default_object "MY OBJECT") with
        cache_function = fun (sp,a) -> Mytbl.add sp a}
 
-   and the listed functions are only those which definitions accually 
+   and the listed functions are only those which definitions accually
    differ from the default.
 
    This helps introducing new functions in objects.
 *)
 
-let ident_subst_function (_,_,a) = a
+let ident_subst_function (_,a) = a
 
 type obj = Dyn.t (* persistent dynamic objects *)
 
@@ -73,15 +71,14 @@ type dynamic_object_declaration = {
   dyn_cache_function : object_name * obj -> unit;
   dyn_load_function : int -> object_name * obj -> unit;
   dyn_open_function : int -> object_name * obj -> unit;
-  dyn_subst_function : object_name * substitution * obj -> obj;
-  dyn_classify_function : object_name * obj -> obj substitutivity;
+  dyn_subst_function : substitution * obj -> obj;
+  dyn_classify_function : obj -> obj substitutivity;
   dyn_discharge_function : object_name * obj -> obj option;
-  dyn_rebuild_function : obj -> obj;
-  dyn_export_function : obj -> obj option }
+  dyn_rebuild_function : obj -> obj }
 
 let object_tag lobj = Dyn.tag lobj
 
-let cache_tab = 
+let cache_tab =
   (Hashtbl.create 17 : (string,dynamic_object_declaration) Hashtbl.t)
 
 let declare_object odecl =
@@ -96,85 +93,79 @@ let declare_object odecl =
   and opener i (oname,lobj) =
     if Dyn.tag lobj = na then odecl.open_function i (oname,outfun lobj)
     else anomaly "somehow we got the wrong dynamic object in the openfun"
-  and substituter (oname,sub,lobj) = 
+  and substituter (sub,lobj) = 
     if Dyn.tag lobj = na then 
-      infun (odecl.subst_function (oname,sub,outfun lobj))
+      infun (odecl.subst_function (sub,outfun lobj))
     else anomaly "somehow we got the wrong dynamic object in the substfun"
-  and classifier (spopt,lobj) = 
-    if Dyn.tag lobj = na then 
-      match odecl.classify_function (spopt,outfun lobj) with
+  and classifier lobj =
+    if Dyn.tag lobj = na then
+      match odecl.classify_function (outfun lobj) with
 	| Dispose -> Dispose
 	| Substitute obj -> Substitute (infun obj)
 	| Keep obj -> Keep (infun obj)
 	| Anticipate (obj) -> Anticipate (infun obj)
-    else 
+    else
       anomaly "somehow we got the wrong dynamic object in the classifyfun"
-  and discharge (oname,lobj) = 
-    if Dyn.tag lobj = na then 
+  and discharge (oname,lobj) =
+    if Dyn.tag lobj = na then
       Option.map infun (odecl.discharge_function (oname,outfun lobj))
-    else 
+    else
       anomaly "somehow we got the wrong dynamic object in the dischargefun"
-  and rebuild lobj = 
+  and rebuild lobj =
     if Dyn.tag lobj = na then infun (odecl.rebuild_function (outfun lobj))
     else anomaly "somehow we got the wrong dynamic object in the rebuildfun"
-  and exporter lobj = 
-    if Dyn.tag lobj = na then 
-      Option.map infun (odecl.export_function (outfun lobj))
-    else 
-      anomaly "somehow we got the wrong dynamic object in the exportfun"
-
-  in 
+  in
   Hashtbl.add cache_tab na { dyn_cache_function = cacher;
 			     dyn_load_function = loader;
                              dyn_open_function = opener;
 			     dyn_subst_function = substituter;
 			     dyn_classify_function = classifier;
 			     dyn_discharge_function = discharge;
-			     dyn_rebuild_function = rebuild;
-                             dyn_export_function = exporter };
+			     dyn_rebuild_function = rebuild };
   (infun,outfun)
 
+let missing_tab = (Hashtbl.create 17 : (string, unit) Hashtbl.t)
+
 (* this function describes how the cache, load, open, and export functions
    are triggered.  In relaxed mode, this function just return a meaningless
    value instead of raising an exception when they fail. *)
 
 let apply_dyn_fun deflt f lobj =
   let tag = object_tag lobj in
-    try
-      let dodecl =
-    	try
-	  Hashtbl.find cache_tab tag
-    	with Not_found -> 
-	  if !relax_flag then
-	    failwith "local to_apply_dyn_fun"
-	  else
-	    error
-	      ("Cannot find library functions for an object with tag "^tag^
-	       " (maybe a plugin is missing)") in 
-	f dodecl
-    with
-	Failure "local to_apply_dyn_fun" -> deflt;;
+  try
+    let dodecl =
+      try
+        Hashtbl.find cache_tab tag
+      with Not_found ->
+        failwith "local to_apply_dyn_fun" in
+    f dodecl
+  with
+    Failure "local to_apply_dyn_fun" ->
+      if not (!relax_flag || Hashtbl.mem missing_tab tag) then
+        begin
+          Pp.warning ("Cannot find library functions for an object with tag "
+                      ^ tag ^ " (a plugin may be missing)");
+          Hashtbl.add missing_tab tag ()
+        end;
+      deflt
 
 let cache_object ((_,lobj) as node) =
   apply_dyn_fun () (fun d -> d.dyn_cache_function node) lobj
 
-let load_object i ((_,lobj) as node) = 
+let load_object i ((_,lobj) as node) =
   apply_dyn_fun () (fun d -> d.dyn_load_function i node) lobj
 
-let open_object i ((_,lobj) as node) = 
+let open_object i ((_,lobj) as node) =
   apply_dyn_fun () (fun d -> d.dyn_open_function i node) lobj
 
-let subst_object ((_,_,lobj) as node) = 
+let subst_object ((_,lobj) as node) = 
   apply_dyn_fun lobj (fun d -> d.dyn_subst_function node) lobj
 
-let classify_object ((_,lobj) as node) = 
-  apply_dyn_fun Dispose (fun d -> d.dyn_classify_function node) lobj
+let classify_object lobj =
+  apply_dyn_fun Dispose (fun d -> d.dyn_classify_function lobj) lobj
 
-let discharge_object ((_,lobj) as node) = 
+let discharge_object ((_,lobj) as node) =
   apply_dyn_fun None (fun d -> d.dyn_discharge_function node) lobj
 
-let rebuild_object (lobj as node) =
-  apply_dyn_fun lobj (fun d -> d.dyn_rebuild_function node) lobj
-
-let export_object lobj =
-  apply_dyn_fun None (fun d -> d.dyn_export_function lobj) lobj
+let rebuild_object lobj =
+  apply_dyn_fun lobj (fun d -> d.dyn_rebuild_function lobj) lobj