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=8014a19404d99da98716962b039b203ef559e97d;hb=1696761e4b8576e8ed81caa905fd108717019226;hpb=5325734bc2e4927ed7ec146e35a6f0f2b49f50c1 diff --git a/helm/ocaml/cic_proof_checking/cicEnvironment.ml b/helm/ocaml/cic_proof_checking/cicEnvironment.ml deleted file mode 100644 index 8014a1940..000000000 --- a/helm/ocaml/cic_proof_checking/cicEnvironment.ml +++ /dev/null @@ -1,407 +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) *) -(* *) -(******************************************************************************) - -let cleanup_tmp = true;; - -let trust_obj = function uri -> true;; - -type type_checked_obj = - CheckedObj of Cic.obj (* cooked obj *) - | UncheckedObj of Cic.obj (* uncooked obj to proof-check *) -;; - - -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 -> unit - val find_cooked : key:UriManager.uri -> Cic.obj - val add_cooked : key:UriManager.uri -> Cic.obj -> unit - - val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit - val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit - val empty : unit -> unit - end -= - struct - module CacheOfCookedObjects : - sig - val mem : UriManager.uri -> bool - val find : UriManager.uri -> Cic.obj - val add : UriManager.uri -> Cic.obj -> unit - - (** (de)serialization of type checker cache *) - val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit - val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit - val empty : unit -> 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 = - try - HT.mem hashtable uri - with - Not_found -> false - ;; - let find uri = HT.find hashtable uri - ;; - let add uri obj = - HT.add hashtable uri obj - ;; - - (* used to hash cons uris on restore to grant URI structure unicity *) - let restore_uris = - let module C = Cic in - let recons uri = - UriManager.uri_of_string (UriManager.string_of_uri uri) - in - let rec restore_in_term = - function - (C.Rel _) as t -> t - | C.Var (uri,exp_named_subst) -> - let uri' = recons uri in - let exp_named_subst' = - List.map - (function (uri,t) ->(recons uri,restore_in_term t)) exp_named_subst - in - C.Var (uri',exp_named_subst') - | C.Meta (i,l) -> - let l' = - List.map - (function - None -> None - | Some t -> Some (restore_in_term t) - ) l - in - C.Meta(i,l') - | C.Sort _ as t -> t - | C.Implicit _ as t -> t - | C.Cast (te,ty) -> C.Cast (restore_in_term te, restore_in_term ty) - | C.Prod (n,s,t) -> C.Prod (n, restore_in_term s, restore_in_term t) - | C.Lambda (n,s,t) -> C.Lambda (n, restore_in_term s, restore_in_term t) - | C.LetIn (n,s,t) -> C.LetIn (n, restore_in_term s, restore_in_term t) - | C.Appl l -> C.Appl (List.map restore_in_term l) - | C.Const (uri,exp_named_subst) -> - let uri' = recons uri in - let exp_named_subst' = - List.map - (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst - in - C.Const (uri',exp_named_subst') - | C.MutInd (uri,tyno,exp_named_subst) -> - let uri' = recons uri in - let exp_named_subst' = - List.map - (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst - in - C.MutInd (uri',tyno,exp_named_subst') - | C.MutConstruct (uri,tyno,consno,exp_named_subst) -> - let uri' = recons uri in - let exp_named_subst' = - List.map - (function (uri,t) -> (recons uri,restore_in_term t)) exp_named_subst - in - C.MutConstruct (uri',tyno,consno,exp_named_subst') - | C.MutCase (uri,i,outty,t,pl) -> - C.MutCase (recons uri, i, restore_in_term outty, restore_in_term t, - List.map restore_in_term pl) - | C.Fix (i, fl) -> - let len = List.length fl in - let liftedfl = - List.map - (fun (name, i, ty, bo) -> - (name, i, restore_in_term ty, restore_in_term bo)) - fl - in - C.Fix (i, liftedfl) - | C.CoFix (i, fl) -> - let len = List.length fl in - let liftedfl = - List.map - (fun (name, ty, bo) -> (name, restore_in_term ty, restore_in_term bo)) - fl - in - C.CoFix (i, liftedfl) - in - function - C.Constant (name,bo,ty,params) -> - let bo' = - match bo with - None -> None - | Some bo -> Some (restore_in_term bo) - in - let ty' = restore_in_term ty in - let params' = List.map recons params in - C.Constant (name, bo', ty', params') - | C.CurrentProof (name,conjs,bo,ty,params) -> - let conjs' = - List.map - (function (i,hyps,ty) -> - (i, - List.map (function - None -> None - | Some (name,C.Decl t) -> - Some (name,C.Decl (restore_in_term t)) - | Some (name,C.Def (bo,ty)) -> - let ty' = - match ty with - None -> None - | Some ty'' -> Some (restore_in_term ty'') - in - Some (name,C.Def (restore_in_term bo, ty'))) hyps, - restore_in_term ty)) - conjs - in - let bo' = restore_in_term bo in - let ty' = restore_in_term ty in - let params' = List.map recons params in - C.CurrentProof (name, conjs', bo', ty', params') - | C.Variable (name,bo,ty,params) -> - let bo' = - match bo with - None -> None - | Some bo -> Some (restore_in_term bo) - in - let ty' = restore_in_term ty in - let params' = List.map recons params in - C.Variable (name, bo', ty', params') - | C.InductiveDefinition (tl,params,paramsno) -> - let params' = List.map recons params in - let tl' = - List.map (function (name, inductive, ty, constructors) -> - name, - inductive, - restore_in_term ty, - (List.map - (function (name, ty) -> name, restore_in_term ty) - constructors)) - tl - in - C.InductiveDefinition (tl', params', paramsno) - - let dump_to_channel ?(callback = ignore) oc = - HT.iter (fun uri _ -> callback (UriManager.string_of_uri uri)) hashtable; - Marshal.to_channel oc hashtable [] ;; - let empty () = HT.clear hashtable ;; - let restore_from_channel ?(callback = ignore) ic = - let restored = Marshal.from_channel ic in - empty (); - HT.iter - (fun k v -> - callback (UriManager.string_of_uri k); - HT.add hashtable - (UriManager.uri_of_string (UriManager.string_of_uri k)) - (restore_uris v)) - restored - ;; - - 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 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 = - try - let obj = List.assq uri !frozen_list in - frozen_list := List.remove_assq uri !frozen_list ; - CacheOfCookedObjects.add uri obj - with - Not_found -> raise (CouldNotUnfreeze (UriManager.string_of_uri uri)) - ;; - let find_cooked ~key:uri = CacheOfCookedObjects.find uri;; - let add_cooked ~key:uri obj = CacheOfCookedObjects.add uri obj;; - - let dump_to_channel = CacheOfCookedObjects.dump_to_channel;; - let restore_from_channel = CacheOfCookedObjects.restore_from_channel;; - let empty = CacheOfCookedObjects.empty;; - end -;; - -let dump_to_channel = Cache.dump_to_channel;; -let restore_from_channel = Cache.restore_from_channel;; -let empty = Cache.empty;; - -let find_or_add_unchecked_to_cache uri = - Cache.find_or_add_unchecked uri - ~get_object_to_add: - (function () -> - let filename = Http_getter.getxml' uri in - let bodyfilename = - match UriManager.bodyuri_of_uri uri with - None -> None - | Some bodyuri -> - try - ignore (Http_getter.resolve' bodyuri) ; - (* The body exists ==> it is not an axiom *) - Some (Http_getter.getxml' bodyuri) - with - Http_getter_types.Unresolvable_URI _ -> - (* The body does not exist ==> we consider it an axiom *) - None - in - let obj = CicParser.obj_of_xml filename bodyfilename in - if cleanup_tmp then - begin - Unix.unlink filename ; - match bodyfilename with - Some f -> Unix.unlink f - | None -> () - end ; - 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 -;; - -(* 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 ?(trust=true) uri = - try - CheckedObj (Cache.find_cooked uri) - with - Not_found -> - let obj = find_or_add_unchecked_to_cache uri in - Cache.unchecked_to_frozen uri ; - if trust && trust_obj uri then - begin - CicLogger.log (`Trusting uri) ; - set_type_checking_info uri ; - CheckedObj (Cache.find_cooked uri) - end - else - UncheckedObj obj -;; - -(* get_cooked_obj ~trust uri *) -(* returns the object if it is already type-checked or if it can be *) -(* trusted (if [trust] = true and the trusting function accepts it) *) -(* Otherwise it raises Not_found *) -let get_cooked_obj ?(trust=true) uri = - try - Cache.find_cooked uri - with Not_found -> - if trust && trust_obj uri then - begin - match is_type_checked uri with - CheckedObj obj -> obj - | _ -> assert false - end - else - begin - prerr_endline ("@@@ OOOOOOOPS: get_cooked_obj(" ^ UriManager.string_of_uri uri ^ ") raises Not_found since the object is not type-checked nor trusted.") ; - raise Not_found - end -;; - -(* 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 - with - Not_found -> - find_or_add_unchecked_to_cache uri -;; - -exception OnlyPutOfInductiveDefinitionsIsAllowed - -let put_inductive_definition uri obj = - match obj with - Cic.InductiveDefinition _ -> Cache.add_cooked uri obj - | _ -> raise OnlyPutOfInductiveDefinitionsIsAllowed -;; - -let in_cache uri = - try - ignore (Cache.find_cooked uri);true - with Not_found -> false -;;