Strengthen the dynamic loading of OCaml objects.

Makefile.distrib

@@ -200,7 +200,7 @@ parser/cduce_loc.cmo  parser/cduce_url.cmo \
  types/patterns.cmo \
  compile/print_auto.cmo \
  \
- compile/lambda.cmo \
+ compile/lambda.cmo  compile/dlink.cmo \
  runtime/run_dispatch.cmo runtime/explain.cmo runtime/eval.cmo \
  \
  parser/ulexer.cmo parser/ast.cmo parser/parser.cmo \

compile/compile.ml

@@ -375,10 +375,6 @@ let rec collect_types accu = function
   | rest -> (accu,rest)
 
 
-let link file =
-    Dynlink.(loadfile (adapt_filename  (file ^ ".cmo")))
-
-
 let rec phrases ~run ~show ~directive =
   let rec loop accu phs =
     match phs with
@@ -407,10 +403,9 @@ let rec phrases ~run ~show ~directive =
 	  directive tenv cenv d;
 	  loop accu rest
       | { descr = Ast.Link f } :: rest ->
-	 link f;
+	 let aname, digest = Dlink.load (f ^ ".cmo") in
 	 let (tenv, cenv, codes) = accu in
-	 link f;
-	 loop (tenv, cenv, (Lambda.Link f) :: codes) rest
+	 loop (tenv, cenv, (Lambda.Link (digest,aname, f)) :: codes) rest
       | [] ->
 	  accu
   in

compile/compile.mli

@@ -24,7 +24,5 @@ val comp_unit:
   Typer.t -> env -> Ast.pmodule_item list -> 
   Typer.t * env * Lambda.code_item list
 
-val link : string -> unit
-
 val from_comp_unit: (Compunit.t -> env) ref
   (* Defined in Librarian *)

compile/dlink.ml

+let obj_table = Hashtbl.create 17
+
+
+
+let resolve_file digest real_name name =
+  let aname = Dynlink.adapt_filename name in
+  match real_name with
+    Some real_name when real_name <> aname ->
+          failwith (Printf.sprintf "Trying to load %s while %s is expected" aname real_name)
+  | _ ->
+     let path = Cduce_loc.resolve_filename aname in
+     if not (Sys.file_exists path) then
+       failwith (Printf.sprintf "Cannot find OCaml object file %s" path);
+     let new_digest = Digest.file path in
+     match digest with
+       Some digest when digest <> new_digest ->
+       failwith (Printf.sprintf "Checksum error while loading %s" path)
+     | _ -> (path, aname, new_digest)
+
+
+let load ?digest ?real_name name =
+  let path, aname, digest = resolve_file digest real_name name in
+  try
+    let saved_digest = Hashtbl.find obj_table path in
+    if saved_digest <> digest then
+      failwith (Printf.sprintf "Inconsistent assumptions over OCaml object file %s" path);
+    (aname, digest)
+  with Not_found ->
+       Hashtbl.add obj_table path digest;
+       Dynlink.loadfile aname;
+       (aname, digest)
+
+

compile/dlink.mli

+val load : ?digest:Digest.t -> ?real_name:string -> string -> (string * Digest.t)

compile/lambda.ml

@@ -10,29 +10,29 @@ type var_loc =
       (* Slot in the table of locals *)
   | Env of int
       (* Slot in the environment *)
-  | Ext of Compunit.t * int 
+  | Ext of Compunit.t * int
       (* Global slot from a given compilation unit *)
       (* If pos < 0, the first arg is the value *)
-  | External of Compunit.t * int 
+  | External of Compunit.t * int
       (* OCaml External *)
       (* If pos < 0, the first arg is the value *)
   | Builtin of string
       (* OCaml external embedded in the runtime *)
-  | Global of int 
+  | Global of int
       (* Only for the toplevel *)
   | Dummy
 
 type iface = (Types.descr * Types.descr) list
 
-type sigma = 
+type sigma =
   | Identity (* this is basically as Types.Tallying.CS.sat *)
   | List of Types.Subst.t list
   | Comp of (sigma * sigma)
-  | Sel of (var_loc * iface * sigma) 
+  | Sel of (var_loc * iface * sigma)
 
 (* only TVar (polymorphic type variable) and Abstraction have
  * a sigma annotation *)
-type expr = 
+type expr =
   | Var of var_loc
   | TVar of (var_loc * sigma)
   | Apply of expr * expr
@@ -55,7 +55,7 @@ type expr =
   | RemoveField of expr * label
   | Dot of expr * label
   | Ref of expr * Types.Node.t
-  | Op of string * expr list  
+  | Op of string * expr list
   | OpResolved of (Value.t list -> Value.t) * expr list
   | NsTable of Ns.table * expr
 
@@ -72,8 +72,8 @@ type code_item =
   | LetDecls of expr * int * Auto_pat.state * int
       (* expression, size of locals, dispatcher, number of globals to set *)
   | LetDecl of expr * int
-  | Link of string
-	      
+  | Link of (Digest.t * string * string)
+
 type code = code_item list
 
 module Print = struct

compile/lambda.mli

@@ -72,7 +72,7 @@ type code_item =
   | LetDecls of expr * int * Auto_pat.state * int
       (* expression, size of locals, dispatcher, number of globals to set *)
   | LetDecl of expr * int
-  | Link of string
+  | Link of (Digest.t * string * string)
 
 
 type code = code_item list

depend

@@ -138,6 +138,8 @@ compile/lambda.cmx : runtime/value.cmx misc/utils.cmx misc/upool.cmx \
     types/types.cmx types/type_tallying.cmx schema/schema_validator.cmx \
     misc/ns.cmx misc/imap.cmx types/ident.cmx misc/encodings.cmx \
     types/compunit.cmx compile/auto_pat.cmx compile/lambda.cmi
+compile/dlink.cmo : parser/cduce_loc.cmi compile/dlink.cmi
+compile/dlink.cmx : parser/cduce_loc.cmx compile/dlink.cmi
 runtime/run_dispatch.cmo : runtime/value.cmi misc/upool.cmi types/types.cmi \
     types/type_tallying.cmi misc/imap.cmi types/ident.cmo misc/encodings.cmi \
     types/chars.cmi compile/auto_pat.cmi types/atoms.cmi \
@@ -155,11 +157,13 @@ runtime/explain.cmx : runtime/value.cmx misc/upool.cmx types/types.cmx \
 runtime/eval.cmo : runtime/value.cmi misc/upool.cmi types/types.cmi \
     schema/schema_validator.cmi schema/schema_common.cmi \
     runtime/run_dispatch.cmi misc/ns.cmi compile/lambda.cmi misc/imap.cmi \
-    types/ident.cmo runtime/explain.cmi compile/auto_pat.cmi runtime/eval.cmi
+    types/ident.cmo runtime/explain.cmi compile/dlink.cmi \
+    compile/auto_pat.cmi runtime/eval.cmi
 runtime/eval.cmx : runtime/value.cmx misc/upool.cmx types/types.cmx \
     schema/schema_validator.cmx schema/schema_common.cmx \
     runtime/run_dispatch.cmx misc/ns.cmx compile/lambda.cmx misc/imap.cmx \
-    types/ident.cmx runtime/explain.cmx compile/auto_pat.cmx runtime/eval.cmi
+    types/ident.cmx runtime/explain.cmx compile/dlink.cmx \
+    compile/auto_pat.cmx runtime/eval.cmi
 parser/ulexer.cmo : parser/cduce_loc.cmi parser/ulexer.cmi
 parser/ulexer.cmx : parser/cduce_loc.cmx parser/ulexer.cmi
 parser/ast.cmo : types/types.cmi types/sequence.cmi misc/ns.cmi \
@@ -207,13 +211,15 @@ typing/typer.cmx : types/var.cmx misc/utils.cmx types/types.cmx \
 compile/compile.cmo : types/var.cmi runtime/value.cmi misc/upool.cmi \
     types/types.cmi typing/typer.cmi typing/typed.cmo types/type_tallying.cmi \
     types/patterns.cmi misc/ns.cmi compile/lambda.cmi misc/imap.cmi \
-    types/ident.cmo runtime/eval.cmi types/compunit.cmi parser/cduce_loc.cmi \
-    compile/auto_pat.cmi parser/ast.cmo compile/compile.cmi
+    types/ident.cmo runtime/eval.cmi compile/dlink.cmi types/compunit.cmi \
+    parser/cduce_loc.cmi compile/auto_pat.cmi parser/ast.cmo \
+    compile/compile.cmi
 compile/compile.cmx : types/var.cmx runtime/value.cmx misc/upool.cmx \
     types/types.cmx typing/typer.cmx typing/typed.cmx types/type_tallying.cmx \
     types/patterns.cmx misc/ns.cmx compile/lambda.cmx misc/imap.cmx \
-    types/ident.cmx runtime/eval.cmx types/compunit.cmx parser/cduce_loc.cmx \
-    compile/auto_pat.cmx parser/ast.cmx compile/compile.cmi
+    types/ident.cmx runtime/eval.cmx compile/dlink.cmx types/compunit.cmx \
+    parser/cduce_loc.cmx compile/auto_pat.cmx parser/ast.cmx \
+    compile/compile.cmi
 schema/schema_parser.cmo : schema/schema_xml.cmi schema/schema_validator.cmi \
     schema/schema_utils.cmi schema/schema_types.cmi schema/schema_common.cmi \
     schema/schema_builtin.cmi misc/ns.cmi misc/encodings.cmi \
@@ -332,14 +338,12 @@ plugins/expat_plugin.cmo : runtime/value.cmi schema/schema_xml.cmi \
 plugins/expat_plugin.cmx : runtime/value.cmx schema/schema_xml.cmx \
     runtime/load_xml.cmx parser/cduce_url.cmx driver/cduce_config.cmx \
     plugins/expat_plugin.cmi
-plugins/jsoo_plugin.cmo : runtime/value.cmi types/types.cmi \
-    compile/operators.cmi misc/ns.cmi runtime/load_xml.cmi \
-    types/intervals.cmi misc/imap.cmi types/ident.cmo misc/encodings.cmi \
-    driver/cduce_config.cmi types/builtin_defs.cmi plugins/jsoo_plugin.cmi
-plugins/jsoo_plugin.cmx : runtime/value.cmx types/types.cmx \
-    compile/operators.cmx misc/ns.cmx runtime/load_xml.cmx \
-    types/intervals.cmx misc/imap.cmx types/ident.cmx misc/encodings.cmx \
-    driver/cduce_config.cmx types/builtin_defs.cmx plugins/jsoo_plugin.cmi
+plugins/dummy_js_plugin.cmo : runtime/value.cmi types/types.cmi \
+    compile/operators.cmi misc/ns.cmi driver/cduce_config.cmi \
+    types/builtin_defs.cmi
+plugins/dummy_js_plugin.cmx : runtime/value.cmx types/types.cmx \
+    compile/operators.cmx misc/ns.cmx driver/cduce_config.cmx \
+    types/builtin_defs.cmx
 driver/run.cmo : runtime/value.cmi parser/ulexer.cmi misc/stats.cmi \
     misc/ns.cmi driver/librarian.cmi types/ident.cmo misc/html.cmi \
     parser/cduce_loc.cmi driver/cduce_config.cmi driver/cduce.cmi \
@@ -458,6 +462,7 @@ compile/print_auto.cmi : compile/auto_pat.cmi
 compile/lambda.cmi : runtime/value.cmi types/types.cmi \
     schema/schema_validator.cmi misc/ns.cmi misc/imap.cmi types/ident.cmo \
     types/compunit.cmi compile/auto_pat.cmi
+compile/dlink.cmi :
 runtime/run_dispatch.cmi : runtime/value.cmi compile/auto_pat.cmi
 runtime/explain.cmi : runtime/value.cmi compile/auto_pat.cmi
 runtime/eval.cmi : runtime/value.cmi misc/ns.cmi compile/lambda.cmi \
@@ -488,7 +493,6 @@ driver/cduce.cmi : runtime/value.cmi types/atoms.cmi
 plugins/pxp_plugin.cmi :
 plugins/pxp_plugin.cmi :
 plugins/expat_plugin.cmi :
-plugins/jsoo_plugin.cmi :
 plugins/expat_plugin.cmi :
 plugins/pxp_plugin.cmi :
 plugins/jsoo_plugin.cmi :

parser/cduce_loc.ml

 (* TODO: handle encodings of the input for pretty printing
    fragments of code *)
 
-type source = [ `None | `File of string | `Stream | `String of string 
+type source = [ `None | `File of string | `Stream | `String of string
 	      | `Buffer of Buffer.t ]
 type loc = source * int * int
 type precise = [ `Full | `Char of int ]
 
 let merge_loc ((s1,i1,j1) as loc1) ((s2,i2,j2) as loc2) =
-  if s1 = s2 then 
-    if i1 = -1 then loc2 else if i2 = -1 then loc1 else 
+  if s1 = s2 then
+    if i1 = -1 then loc2 else if i2 = -1 then loc1 else
       (s1, min i1 i2, max j1 j2)
   else loc1
 
@@ -16,7 +16,7 @@ let source = ref `None
 let get_source () = !source
 let source_stack = ref []
 let push_source s = source_stack := !source :: !source_stack; source := s
-let pop_source () = 
+let pop_source () =
   match !source_stack with
     | [] -> assert false
     | s::rem -> source_stack := rem; source := s
@@ -87,7 +87,7 @@ let print_precise ppf = function
   | `Full -> ()
   | `Char i -> Format.fprintf ppf "Char %i of the string:@\n" i
 
-let print_loc ppf ((src,i,j),w) =  
+let print_loc ppf ((src,i,j),w) =
   match src with
     | `None -> () (*Format.fprintf ppf "somewhere (no source defined !)"*)
     | `Stream | `String _ ->
@@ -135,7 +135,7 @@ let html_hilight ((src,i,j),w) =
   match (src, Html.is_html v) with
     | `String s, true ->
 	if (i < 0) then
-	  Html.markup v "b" 
+	  Html.markup v "b"
 	    (fun ppf -> Format.fprintf ppf "GHOST LOCATION@.")
 	else
 	  let i0 = beg_of_line s i in
@@ -149,7 +149,7 @@ let html_hilight ((src,i,j),w) =
 	       Format.fprintf ppf "%s@." (extr s j j0);
 	    )
     | _ -> ()
-	
+
 
 type 'a located = { loc : loc; descr : 'a }
 
@@ -164,18 +164,20 @@ let is_protected () = !protected
 
 let protect_op op =
   if (!protected) then
-    raise 
+    raise
       (Generic (op ^ ": operation not authorized in the web prototype"))
 
 let obj_path = ref [ "" ; <:symbol<cduce_libdir>> ]
 
 
-let resolve_filename s =
+let resolve_filename ?(test=(fun (_:string) -> true)) s =
   if Filename.is_relative s then
     try
-      let p = 
-	List.find 
-	  (fun p -> Sys.file_exists (Filename.concat p s)) 
+      let p =
+	List.find
+	  (fun p ->
+	   let path = Filename.concat p s in
+	   Sys.file_exists path && test path)
 	  (current_dir () :: !obj_path) in
       Filename.concat p s
     with Not_found -> s

parser/cduce_loc.mli

@@ -55,4 +55,4 @@ val protect_op : string -> unit
 
 
 val obj_path: string list ref
-val resolve_filename: string -> string
+val resolve_filename: ?test:(string -> bool) -> string -> string

runtime/eval.ml

@@ -280,7 +280,6 @@ and eval_remove_field l = function
   | _ -> assert false
 
 let expr e lsize = eval [||] (Array.create lsize Value.Absent) e
-let link s = Dynlink.(loadfile (adapt_filename (s ^ ".cmo")))
 (* Evaluation in the toplevel *)
 
 let eval_toplevel = function
@@ -296,7 +295,8 @@ let eval_toplevel = function
       let v = expr e lsize in
       set globs !nglobs v;
       incr nglobs
-  | Link s -> link s
+  | Link (digest, aname, s) ->
+     ignore (Dlink.load ~digest ~real_name:aname ( s ^ ".cmo"))
 
 let eval_toplevel items =
   let n = !nglobs in
@@ -320,8 +320,9 @@ let eval_unit globs nglobs = function
       let v = expr e lsize in
       globs.(!nglobs) <- v;
       incr nglobs
-  | Link s -> link s
-
+  | Link (digest, aname, s) ->
+     ignore (Dlink.load ~digest ~real_name:aname ( s ^ ".cmo"))
+	    
 let eval_unit globs items =
   let nglobs = ref 0 in
   List.iter (eval_unit globs nglobs) items;