modules System, Lib et States

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@71 85f007b7-540e-0410-9357-904b9bb8a0f7

2 files changed, 87 insertions, 0 deletions

diff --git a/lib/system.ml b/lib/system.ml
index fe0efa0737..016a6f97e0 100644
--- a/lib/system.ml
+++ b/lib/system.ml
@@ -1,6 +1,86 @@
 
 (* $Id$ *)
 
+open Pp
+open Util
+
+(* Files and load path. *)
+
+let load_path = ref ([] : string list)
+
+let add_path dir = load_path := dir :: !load_path
+
+let del_path dir =
+  if List.mem dir !load_path then
+    load_path := List.filter (fun s -> s <> dir) !load_path
+
+(* TODO: rétablir glob (expansion ~user et $VAR) si on le juge nécessaire *)
+let glob s = s
+
+let search_in_path path filename =
+  let rec search = function
+    | dir :: rem ->
+	let f = glob (Filename.concat dir filename) in
+	if Sys.file_exists f then f else search rem
+    | [] ->
+	raise Not_found
+  in
+  search path
+
+let find_file_in_path name =
+  let globname = glob name in
+  if not (Filename.is_relative globname) then
+    globname
+  else 
+    try 
+      search_in_path !load_path name
+    with Not_found ->
+      errorlabstrm "System.find_file_in_path"
+	(hOV 0 [< 'sTR"Can't find file" ; 'sPC ; 'sTR name ; 'sPC ; 
+		  'sTR"on loadpath" >])
+
+let make_suffix name suffix =
+  if Filename.check_suffix name suffix then name else (name ^ suffix)
+
+let open_trapping_failure open_fun name suffix =
+  let rname = make_suffix name suffix in
+  try open_fun rname with _ -> error ("Can't open " ^ rname)
+
+let (extern_intern :
+      int -> string -> ((string -> 'a -> unit) * (string -> 'a)))
+  = fun magic suffix ->
+
+  let extern_state name val_0 = 
+    try
+      let (expname,channel) =
+        open_trapping_failure (fun n -> n,open_out_bin n) name suffix in
+      try
+        output_binary_int channel magic;
+        output_value channel val_0;
+        close_out channel
+      with e -> begin
+        (try Sys.remove expname
+         with _ -> mSGNL [< 'sTR"Warning: " ; 'sTR"Could not remove file " ;
+                            'sTR expname ; 'sTR" which is corrupted !!" >]);
+        raise e
+      end
+    with Sys_error s -> error ("System error: " ^ s)
+
+  and intern_state name = 
+    try
+      let fname = find_file_in_path (make_suffix name suffix) in
+      let channel = open_in_bin fname in
+      if input_binary_int channel <> magic then
+        error (fname^" not compiled with the current version of Coq");
+      let v = input_value(channel) in
+      close_in channel; 
+      v
+    with Sys_error s -> error("System error: " ^ s)
+
+  in 
+  (extern_state,intern_state)
+
+
 (* Time stamps. *)
 
 type time_stamp = float
diff --git a/lib/system.mli b/lib/system.mli
index 13265d1d83..b887f5eb51 100644
--- a/lib/system.mli
+++ b/lib/system.mli
@@ -1,6 +1,13 @@
 
 (* $Id$ *)
 
+(*s Files and load path. *)
+
+val add_path : string -> unit
+val del_path : string -> unit
+
+val extern_intern : int -> string -> (string -> 'a -> unit) * (string -> 'a)
+
 (*s Time stamps. *)
 
 type time_stamp