X-Git-Url: http://matita.cs.unibo.it/gitweb/?p=helm.git;a=blobdiff_plain;f=helm%2Focaml%2Fcic_proof_checking%2FcicEnvironment.ml;fp=helm%2Focaml%2Fcic_proof_checking%2FcicEnvironment.ml;h=0000000000000000000000000000000000000000;hp=9d93c443e44479248c793cac425ed9427801c332;hb=869549224eef6278a48c16ae27dd786376082b38;hpb=89262281b6e83bd2321150f81f1a0583645eb0c8 diff --git a/helm/ocaml/cic_proof_checking/cicEnvironment.ml b/helm/ocaml/cic_proof_checking/cicEnvironment.ml deleted file mode 100644 index 9d93c443e..000000000 --- a/helm/ocaml/cic_proof_checking/cicEnvironment.ml +++ /dev/null @@ -1,230 +0,0 @@ -(* 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 *) -(* 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 - ) -;;