diff options
Diffstat (limited to 'library/libobject.ml')
| -rw-r--r-- | library/libobject.ml | 113 |
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 |