+++ /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) *)
-(* *)
-(******************************************************************************)
-
-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
-;;
projects / helm.git / blobdiff