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 trust = ref (fun _ -> true);;
41 let set_trust f = trust := f
42 let trust_obj uri = !trust uri
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;;
54 exception Term_not_found of UriManager.uri;;
56 (* Cache that uses == instead of = for testing equality *)
57 (* Invariant: an object is always in at most one of the *)
58 (* following states: unchecked, frozen and cooked. *)
61 val find_or_add_unchecked :
62 UriManager.uri -> get_object_to_add:(unit -> Cic.obj) -> Cic.obj
63 val unchecked_to_frozen : UriManager.uri -> unit
64 val frozen_to_cooked :
65 uri:UriManager.uri -> unit
66 val find_cooked : key:UriManager.uri -> Cic.obj
67 val add_cooked : key:UriManager.uri -> Cic.obj -> unit
68 val remove: UriManager.uri -> unit
70 val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit
71 val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit
72 val empty : unit -> unit
76 module CacheOfCookedObjects :
78 val mem : UriManager.uri -> bool
79 val find : UriManager.uri -> Cic.obj
80 val add : UriManager.uri -> Cic.obj -> unit
81 val remove : UriManager.uri -> unit
83 (** (de)serialization of type checker cache *)
84 val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit
85 val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit
86 val empty : unit -> unit
92 type t = UriManager.uri
93 let equal = UriManager.eq
94 let hash = Hashtbl.hash
97 module HT = Hashtbl.Make(HashedType);;
98 let hashtable = HT.create 1009;;
105 let find uri = HT.find hashtable uri
108 HT.add hashtable uri obj
112 HT.remove hashtable uri
114 raise (Term_not_found uri);
117 (* used to hash cons uris on restore to grant URI structure unicity *)
119 let module C = Cic in
121 UriManager.uri_of_string (UriManager.string_of_uri uri)
123 let rec restore_in_term =
126 | C.Var (uri,exp_named_subst) ->
127 let uri' = recons uri in
128 let exp_named_subst' =
130 (function (uri,t) ->(recons uri,restore_in_term t)) exp_named_subst
132 C.Var (uri',exp_named_subst')
138 | Some t -> Some (restore_in_term t)
143 | C.Implicit _ as t -> t
144 | C.Cast (te,ty) -> C.Cast (restore_in_term te, restore_in_term ty)
145 | C.Prod (n,s,t) -> C.Prod (n, restore_in_term s, restore_in_term t)
146 | C.Lambda (n,s,t) -> C.Lambda (n, restore_in_term s, restore_in_term t)
147 | C.LetIn (n,s,t) -> C.LetIn (n, restore_in_term s, restore_in_term t)
148 | C.Appl l -> C.Appl (List.map restore_in_term l)
149 | C.Const (uri,exp_named_subst) ->
150 let uri' = recons uri in
151 let exp_named_subst' =
153 (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
155 C.Const (uri',exp_named_subst')
156 | C.MutInd (uri,tyno,exp_named_subst) ->
157 let uri' = recons uri in
158 let exp_named_subst' =
160 (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
162 C.MutInd (uri',tyno,exp_named_subst')
163 | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
164 let uri' = recons uri in
165 let exp_named_subst' =
167 (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst
169 C.MutConstruct (uri',tyno,consno,exp_named_subst')
170 | C.MutCase (uri,i,outty,t,pl) ->
171 C.MutCase (recons uri, i, restore_in_term outty, restore_in_term t,
172 List.map restore_in_term pl)
174 let len = List.length fl in
177 (fun (name, i, ty, bo) ->
178 (name, i, restore_in_term ty, restore_in_term bo))
183 let len = List.length fl in
186 (fun (name, ty, bo) -> (name, restore_in_term ty, restore_in_term bo))
189 C.CoFix (i, liftedfl)
192 C.Constant (name,bo,ty,params) ->
196 | Some bo -> Some (restore_in_term bo)
198 let ty' = restore_in_term ty in
199 let params' = List.map recons params in
200 C.Constant (name, bo', ty', params')
201 | C.CurrentProof (name,conjs,bo,ty,params) ->
204 (function (i,hyps,ty) ->
208 | Some (name,C.Decl t) ->
209 Some (name,C.Decl (restore_in_term t))
210 | Some (name,C.Def (bo,ty)) ->
214 | Some ty'' -> Some (restore_in_term ty'')
216 Some (name,C.Def (restore_in_term bo, ty'))) hyps,
220 let bo' = restore_in_term bo in
221 let ty' = restore_in_term ty in
222 let params' = List.map recons params in
223 C.CurrentProof (name, conjs', bo', ty', params')
224 | C.Variable (name,bo,ty,params) ->
228 | Some bo -> Some (restore_in_term bo)
230 let ty' = restore_in_term ty in
231 let params' = List.map recons params in
232 C.Variable (name, bo', ty', params')
233 | C.InductiveDefinition (tl,params,paramsno) ->
234 let params' = List.map recons params in
236 List.map (function (name, inductive, ty, constructors) ->
241 (function (name, ty) -> name, restore_in_term ty)
245 C.InductiveDefinition (tl', params', paramsno)
247 let dump_to_channel ?(callback = ignore) oc =
248 HT.iter (fun uri _ -> callback (UriManager.string_of_uri uri)) hashtable;
249 Marshal.to_channel oc hashtable [] ;;
250 let empty () = HT.clear hashtable ;;
251 let restore_from_channel ?(callback = ignore) ic =
252 let restored = Marshal.from_channel ic in
256 callback (UriManager.string_of_uri k);
258 (UriManager.uri_of_string (UriManager.string_of_uri k))
265 let frozen_list = ref [];;
266 let unchecked_list = ref [];;
268 let find_or_add_unchecked uri ~get_object_to_add =
270 List.assq uri !unchecked_list
273 if List.mem_assq uri !frozen_list then
274 raise (CircularDependency (UriManager.string_of_uri uri))
276 if CacheOfCookedObjects.mem uri then
277 raise (AlreadyCooked (UriManager.string_of_uri uri))
279 (* OK, it is not already frozen nor cooked *)
280 let obj = get_object_to_add () in
281 unchecked_list := (uri,obj)::!unchecked_list ;
284 let unchecked_to_frozen uri =
286 let obj = List.assq uri !unchecked_list in
287 unchecked_list := List.remove_assq uri !unchecked_list ;
288 frozen_list := (uri,obj)::!frozen_list
290 Not_found -> raise (CouldNotFreeze (UriManager.string_of_uri uri))
292 let frozen_to_cooked ~uri =
294 let obj = List.assq uri !frozen_list in
295 frozen_list := List.remove_assq uri !frozen_list ;
296 CacheOfCookedObjects.add uri obj
298 Not_found -> raise (CouldNotUnfreeze (UriManager.string_of_uri uri))
300 let find_cooked ~key:uri = CacheOfCookedObjects.find uri;;
301 let add_cooked ~key:uri obj = CacheOfCookedObjects.add uri obj;;
303 if (!unchecked_list <> []) || (!frozen_list <> []) then
304 failwith "CicEnvironment.remove while type checking"
306 CacheOfCookedObjects.remove uri
308 let dump_to_channel = CacheOfCookedObjects.dump_to_channel;;
309 let restore_from_channel = CacheOfCookedObjects.restore_from_channel;;
310 let empty = CacheOfCookedObjects.empty;;
314 let dump_to_channel = Cache.dump_to_channel;;
315 let restore_from_channel = Cache.restore_from_channel;;
316 let empty = Cache.empty;;
318 let find_or_add_unchecked_to_cache uri =
319 Cache.find_or_add_unchecked uri
322 let filename = Http_getter.getxml' uri in
324 match UriManager.bodyuri_of_uri uri with
328 ignore (Http_getter.resolve' bodyuri) ;
329 (* The body exists ==> it is not an axiom *)
330 Some (Http_getter.getxml' bodyuri)
332 Http_getter_types.Key_not_found _ ->
333 (* The body does not exist ==> we consider it an axiom *)
339 if Sys.file_exists filename then Unix.unlink filename ;
340 match bodyfilename with
341 Some f -> if Sys.file_exists f then Unix.unlink f
345 CicUniv.directly_to_env_begin ();
348 CicParser.obj_of_xml filename bodyfilename
353 CicUniv.directly_to_env_end ();
359 (* set_type_checking_info uri *)
360 (* must be called once the type-checking of uri is finished *)
361 (* The object whose uri is uri is unfreezed *)
362 let set_type_checking_info uri =
363 Cache.frozen_to_cooked uri
366 (* is_type_checked uri *)
367 (* CSC: commento falso ed obsoleto *)
368 (* returns a CheckedObj if the term has been type-checked *)
369 (* otherwise it freezes the term for type-checking and returns
371 (* set_type_checking_info must be called to unfreeze the term *)
372 let is_type_checked ?(trust=true) uri =
374 CheckedObj (Cache.find_cooked uri)
377 let obj = find_or_add_unchecked_to_cache uri in
378 Cache.unchecked_to_frozen uri ;
379 if trust && trust_obj uri then
381 CicLogger.log (`Trusting uri) ;
382 set_type_checking_info uri ;
383 CheckedObj (Cache.find_cooked uri)
389 (* get_cooked_obj ~trust uri *)
390 (* returns the object if it is already type-checked or if it can be *)
391 (* trusted (if [trust] = true and the trusting function accepts it) *)
392 (* Otherwise it raises Not_found *)
393 let get_cooked_obj ?(trust=true) uri =
395 Cache.find_cooked uri
397 if trust && trust_obj uri then
399 match is_type_checked uri with
400 CheckedObj obj -> obj
405 prerr_endline ("@@@ OOOOOOOPS: get_cooked_obj(" ^ UriManager.string_of_uri uri ^ ") raises Not_found since the object is not type-checked nor trusted.") ;
411 (* returns the cic object whose uri is uri. If the term is not just in cache, *)
412 (* then it is parsed via CicParser.term_of_xml from the file whose name is *)
413 (* the result of Getter.getxml uri *)
419 find_or_add_unchecked_to_cache uri
422 exception OnlyPutOfInductiveDefinitionsIsAllowed
424 let put_inductive_definition uri obj =
426 Cic.InductiveDefinition _ -> Cache.add_cooked uri obj
427 | _ -> raise OnlyPutOfInductiveDefinitionsIsAllowed
432 ignore (Cache.find_cooked uri);true
433 with Not_found -> false
436 let add_type_checked_term uri obj =
438 Cic.Constant (s,(Some bo),ty,ul) ->
439 Cache.add_cooked ~key:uri obj
444 let remove_term = Cache.remove