+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(******************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
-(* 24/01/2000 *)
-(* *)
-(* This module implements a trival cache system (an hash-table) for cic *)
-(* objects. Uses the getter (getter.ml) and the parser (cicParser.ml) *)
-(* *)
-(******************************************************************************)
-
-type type_checked_obj =
- CheckedObj of Cic.obj (* cooked obj *)
- | UncheckedObj of Cic.obj (* uncooked obj to proof-check *)
-;;
-
-exception NoFunctionProvided;;
-
-let cook_obj = ref (fun obj uri -> raise NoFunctionProvided);;
-
-let set_cooking_function foo =
- cook_obj := foo
-;;
-
-exception AlreadyCooked of string;;
-exception CircularDependency of string;;
-exception CouldNotFreeze of string;;
-exception CouldNotUnfreeze of string;;
-
-(* Cache that uses == instead of = for testing equality *)
-(* Invariant: an object is always in at most one of the *)
-(* following states: unchecked, frozen and cooked. *)
-module Cache :
- sig
- val find_or_add_unchecked :
- UriManager.uri -> get_object_to_add:(unit -> Cic.obj) -> Cic.obj
- val unchecked_to_frozen : UriManager.uri -> unit
- val frozen_to_cooked :
- uri:UriManager.uri ->
- cooking_procedure:
- (object_to_cook:Cic.obj ->
- add_cooked:(UriManager.uri * int-> Cic.obj -> unit)
- -> unit
- )
- -> unit
- val find_cooked : key:(UriManager.uri * int) -> Cic.obj
- end
-=
- struct
- module CacheOfCookedObjects :
- sig
- val mem : UriManager.uri -> int -> bool
- val find : UriManager.uri -> int -> Cic.obj
- val add : UriManager.uri -> int -> Cic.obj -> unit
- end
- =
- struct
- module HashedType =
- struct
- type t = UriManager.uri
- let equal = UriManager.eq
- let hash = Hashtbl.hash
- end
- ;;
- module HT = Hashtbl.Make(HashedType);;
- let hashtable = HT.create 1009;;
- let mem uri cookingsno =
- try
- let cooked_list =
- HT.find hashtable uri
- in
- List.mem_assq cookingsno !cooked_list
- with
- Not_found -> false
- ;;
- let find uri cookingsno =
- List.assq cookingsno !(HT.find hashtable uri)
- ;;
- let add uri cookingsno obj =
- let cooked_list =
- try
- HT.find hashtable uri
- with
- Not_found ->
- let newl = ref [] in
- HT.add hashtable uri newl ;
- newl
- in
- cooked_list := (cookingsno,obj)::!cooked_list
- ;;
- end
- ;;
- let frozen_list = ref [];;
- let unchecked_list = ref [];;
-
- let find_or_add_unchecked uri ~get_object_to_add =
- try
- List.assq uri !unchecked_list
- with
- Not_found ->
- if List.mem_assq uri !frozen_list then
- raise (CircularDependency (UriManager.string_of_uri uri))
- else
- if CacheOfCookedObjects.mem uri 0 then
- raise (AlreadyCooked (UriManager.string_of_uri uri))
- else
- (* OK, it is not already frozen nor cooked *)
- let obj = get_object_to_add () in
- unchecked_list := (uri,obj)::!unchecked_list ;
- obj
- ;;
- let unchecked_to_frozen uri =
- try
- let obj = List.assq uri !unchecked_list in
- unchecked_list := List.remove_assq uri !unchecked_list ;
- frozen_list := (uri,obj)::!frozen_list
- with
- Not_found -> raise (CouldNotFreeze (UriManager.string_of_uri uri))
- ;;
- let frozen_to_cooked ~uri ~cooking_procedure =
- try
- let obj = List.assq uri !frozen_list in
- frozen_list := List.remove_assq uri !frozen_list ;
- cooking_procedure
- ~object_to_cook:obj
- ~add_cooked:(fun (uri,cookno) -> CacheOfCookedObjects.add uri cookno)
- with
- Not_found -> raise (CouldNotUnfreeze (UriManager.string_of_uri uri))
- ;;
- let find_cooked ~key:(uri,cookingsno)= CacheOfCookedObjects.find uri cookingsno;;
- end
-;;
-
-(* get_cooked_obj uri *)
-(* returns the cooked cic object whose uri is uri. The term must be present *)
-(* and cooked in cache *)
-let get_cooked_obj uri cookingsno =
- Cache.find_cooked (uri,cookingsno)
-;;
-
-let find_or_add_unchecked_to_cache uri =
- Cache.find_or_add_unchecked uri
- ~get_object_to_add:
- (function () ->
- let filename = Getter.getxml uri in
- let obj = CicParser.obj_of_xml filename uri in
- obj
- )
-;;
-
-(* get_obj uri *)
-(* returns the cic object whose uri is uri. If the term is not just in cache, *)
-(* then it is parsed via CicParser.term_of_xml from the file whose name is *)
-(* the result of Getter.getxml uri *)
-let get_obj uri =
- try
- get_cooked_obj uri 0
- with
- Not_found ->
- find_or_add_unchecked_to_cache uri
-;;
-
-(* is_type_checked uri *)
-(* CSC: commento falso ed obsoleto *)
-(* returns a CheckedObj if the term has been type-checked *)
-(* otherwise it freezes the term for type-checking and returns
- it *)
-(* set_type_checking_info must be called to unfreeze the term *)
-let is_type_checked uri cookingsno =
- try
- CheckedObj (Cache.find_cooked (uri,cookingsno))
- with
- Not_found ->
- let obj = find_or_add_unchecked_to_cache uri in
- Cache.unchecked_to_frozen uri ;
- UncheckedObj obj
-;;
-
-(* set_type_checking_info uri *)
-(* must be called once the type-checking of uri is finished *)
-(* The object whose uri is uri is unfreezed *)
-let set_type_checking_info uri =
- Cache.frozen_to_cooked uri
- (fun ~object_to_cook:obj ~add_cooked ->
- (* let's cook the object at every level *)
- let obj' = CicSubstitution.undebrujin_inductive_def uri obj in
- add_cooked (uri,0) obj' ;
- let cooked_objs = !cook_obj obj' uri in
- let last_cooked_level = ref 0 in
- let last_cooked_obj = ref obj' in
- List.iter
- (fun (n,cobj) ->
- for i = !last_cooked_level + 1 to n do
- add_cooked (uri,i) !last_cooked_obj
- done ;
- add_cooked (uri,n + 1) cobj ;
- last_cooked_level := n + 1 ;
- last_cooked_obj := cobj
- ) cooked_objs ;
- for i = !last_cooked_level + 1 to UriManager.depth_of_uri uri + 1 do
- add_cooked (uri,i) !last_cooked_obj
- done
- )
-;;
projects / helm.git / blobdiff