1 (* Copyright (C) 2000, HELM Team.
3 * This file is part of HELM, an Hypertextual, Electronic
4 * Library of Mathematics, developed at the Computer Science
5 * Department, University of Bologna, Italy.
7 * HELM is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU General Public License
9 * as published by the Free Software Foundation; either version 2
10 * of the License, or (at your option) any later version.
12 * HELM is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with HELM; if not, write to the Free Software
19 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
22 * For details, see the HELM World-Wide-Web page,
23 * http://cs.unibo.it/helm/.
26 (******************************************************************************)
30 (* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
33 (* This module implements a trival cache system (an hash-table) for cic *)
34 (* objects. Uses the getter (getter.ml) and the parser (cicParser.ml) *)
36 (******************************************************************************)
38 let cleanup_tmp = true;;
40 let never_trust = function uri -> false;;
41 let always_trust = function uri -> true;;
42 let trust_obj = ref never_trust;;
44 type type_checked_obj =
45 CheckedObj of Cic.obj (* cooked obj *)
46 | UncheckedObj of Cic.obj (* uncooked obj to proof-check *)
50 exception AlreadyCooked of string;;
51 exception CircularDependency of string;;
52 exception CouldNotFreeze of string;;
53 exception CouldNotUnfreeze of string;;
55 (* Cache that uses == instead of = for testing equality *)
56 (* Invariant: an object is always in at most one of the *)
57 (* following states: unchecked, frozen and cooked. *)
60 val find_or_add_unchecked :
61 UriManager.uri -> get_object_to_add:(unit -> Cic.obj) -> Cic.obj
62 val unchecked_to_frozen : UriManager.uri -> unit
63 val frozen_to_cooked :
64 uri:UriManager.uri -> unit
65 val find_cooked : key:UriManager.uri -> Cic.obj
69 module CacheOfCookedObjects :
71 val mem : UriManager.uri -> bool
72 val find : UriManager.uri -> Cic.obj
73 val add : UriManager.uri -> Cic.obj -> unit
79 type t = UriManager.uri
80 let equal = UriManager.eq
81 let hash = Hashtbl.hash
84 module HT = Hashtbl.Make(HashedType);;
85 let hashtable = HT.create 1009;;
92 let find uri = HT.find hashtable uri
95 HT.add hashtable uri obj
99 let frozen_list = ref [];;
100 let unchecked_list = ref [];;
102 let find_or_add_unchecked uri ~get_object_to_add =
104 List.assq uri !unchecked_list
107 if List.mem_assq uri !frozen_list then
108 raise (CircularDependency (UriManager.string_of_uri uri))
110 if CacheOfCookedObjects.mem uri then
111 raise (AlreadyCooked (UriManager.string_of_uri uri))
113 (* OK, it is not already frozen nor cooked *)
114 let obj = get_object_to_add () in
115 unchecked_list := (uri,obj)::!unchecked_list ;
118 let unchecked_to_frozen uri =
120 let obj = List.assq uri !unchecked_list in
121 unchecked_list := List.remove_assq uri !unchecked_list ;
122 frozen_list := (uri,obj)::!frozen_list
124 Not_found -> raise (CouldNotFreeze (UriManager.string_of_uri uri))
126 let frozen_to_cooked ~uri =
128 let obj = List.assq uri !frozen_list in
129 frozen_list := List.remove_assq uri !frozen_list ;
130 CacheOfCookedObjects.add uri obj
132 Not_found -> raise (CouldNotUnfreeze (UriManager.string_of_uri uri))
134 let find_cooked ~key:uri = CacheOfCookedObjects.find uri;;
138 let find_or_add_unchecked_to_cache uri =
139 Cache.find_or_add_unchecked uri
142 let filename = Getter.getxml uri in
144 match UriManager.bodyuri_of_uri uri with
148 ignore (Getter.resolve bodyuri) ;
149 (* The body exists ==> it is not an axiom *)
150 Some (Getter.getxml bodyuri)
153 (* The body does not exist ==> we consider it an axiom *)
156 let obj = CicParser.obj_of_xml filename bodyfilename uri in
159 Unix.unlink filename ;
160 match bodyfilename with
161 Some f -> Unix.unlink f
168 (* set_type_checking_info uri *)
169 (* must be called once the type-checking of uri is finished *)
170 (* The object whose uri is uri is unfreezed *)
171 let set_type_checking_info uri =
172 trust_obj := never_trust ;
173 Cache.frozen_to_cooked uri
176 (* is_type_checked uri *)
177 (* CSC: commento falso ed obsoleto *)
178 (* returns a CheckedObj if the term has been type-checked *)
179 (* otherwise it freezes the term for type-checking and returns
181 (* set_type_checking_info must be called to unfreeze the term *)
182 let is_type_checked uri =
184 CheckedObj (Cache.find_cooked uri)
187 let obj = find_or_add_unchecked_to_cache uri in
188 Cache.unchecked_to_frozen uri ;
189 if !trust_obj uri then
191 Logger.log (`Trusting uri) ;
192 set_type_checking_info uri ;
193 trust_obj := always_trust ;
194 CheckedObj (Cache.find_cooked uri)
198 trust_obj := always_trust ;
203 (* get_cooked_obj uri *)
204 (* returns the cooked cic object whose uri is uri. The term must be present *)
205 (* and cooked in cache *)
206 let get_cooked_obj uri =
208 Cache.find_cooked uri
210 if not (!trust_obj uri) then
211 prerr_endline ("@@@ OOOOOOOPS: WE TRUST " ^ UriManager.string_of_uri uri ^ " EVEN IF WE SHOULD NOT DO THAT! THAT MEANS LOOKING FOR TROUBLES ;-(") ;
212 match is_type_checked uri with
213 CheckedObj obj -> obj
218 (* returns the cic object whose uri is uri. If the term is not just in cache, *)
219 (* then it is parsed via CicParser.term_of_xml from the file whose name is *)
220 (* the result of Getter.getxml uri *)
226 find_or_add_unchecked_to_cache uri