[r2003-10-13 20:03:05 by cvscast] Remove -o; add -I --obj-dir; error messages

Original author: cvscast
Date: 2003-10-13 20:03:06+00:00

Makefile.distrib

@@ -173,13 +173,13 @@ driver/examples.ml: cduce web/examples/build.cd web/examples/examples.xml
 	(cd web/examples; ../../cduce --quiet build.cd --arg examples.xml)
 
 webpages: cduce web/site.cdo
-	(cd web; ../cduce --run site  --arg site.xml)
+	(cd web; ../cduce --run site.cdo --arg site.xml)
 
 web/site.cdo: cduce web/xhtml.cdo web/site.cd
-	(cd web; ../cduce --compile site)
+	./cduce -I web/ --compile web/site.cd
 
 web/xhtml.cdo: cduce web/xhtml.cd
-	(cd web; ../cduce --compile xhtml)
+	./cduce -I web/ --compile web/xhtml.cd
 
 website: webpages webiface
 

driver/cduce.ml

 open Location
 open Ident
 
+exception InvalidInputFilename of string
+exception InvalidObjectFilename of string
+
 (* retuns a filename without the suffix suff if any *) 
 let prefix filename suff =
   if Filename.check_suffix filename suff then
@@ -122,6 +125,31 @@ let rec print_exn ppf = function
       Format.fprintf ppf "%a%s" Location.html_hilight loc s
   | Parser.Error s | Stream.Error s -> 
       Format.fprintf ppf "Parsing error: %a@." print_protect s
+  | Librarian.InconsistentCrc id ->
+      Format.fprintf ppf "Link error:@.";
+      let name = Encodings.Utf8.to_string (Types.CompUnit.value id) in
+      Format.fprintf ppf "Inconsistent checksum (compilation unit: %s)@."
+	name
+  | Librarian.NoImplementation id ->
+      Format.fprintf ppf "Link error:@.";
+      let name = Encodings.Utf8.to_string (Types.CompUnit.value id) in
+      Format.fprintf ppf "No implementation found for compilation unit: %s@."
+	name
+  | Librarian.Loop id ->
+      Format.fprintf ppf "Compilation error:@.";
+      let name = Encodings.Utf8.to_string (Types.CompUnit.value id) in
+      Format.fprintf ppf "Loop between compilation unit (compilation unit: %s)@."
+	name
+  | InvalidInputFilename f ->
+      Format.fprintf ppf "Compilation error:@.";
+      Format.fprintf ppf "Source filename must have extension .cd@.";
+  | InvalidObjectFilename f ->
+      Format.fprintf ppf "Compilation error:@.";
+      Format.fprintf ppf "Object filename must have extension .cdo@.";
+  | Librarian.InvalidObject f ->
+      Format.fprintf ppf "Invalid object file %s@." f
+  | Librarian.CannotOpen f ->
+      Format.fprintf ppf "Cannot open file %s@." f
   | Location.Generic s ->
       Format.fprintf ppf "%a@." print_protect s
   | exn ->
@@ -304,24 +332,38 @@ let run rule ppf ppf_err input =
 let script = run Parser.prog
 let topinput = run Parser.top_phrases
 
-let compile src out=
+let compile src out_dir =
   try
-    let id = Types.CompUnit.mk (U.mk_latin1 src) in
-      Librarian.compile id;
-      Librarian.save id out;
+    if not (Filename.check_suffix src ".cd")
+    then raise (InvalidInputFilename src);
+    let cu = Filename.chop_suffix (Filename.basename src) ".cd" in
+    let out_dir = 
+      match out_dir with
+	| None -> Filename.dirname src
+	| Some x -> x in
+    let out = Filename.concat out_dir (cu ^ ".cdo") in
+    let id = Types.CompUnit.mk (U.mk_latin1 cu) in
+    Librarian.compile id src;
+    Librarian.save id out;
     exit 0
   with exn -> catch_exn Format.err_formatter exn; exit 1
   
 let compile_run src argv =
   try
-    let id = Types.CompUnit.mk (U.mk_latin1 src) in
-    Librarian.compile id;
+    if not (Filename.check_suffix src ".cd")
+    then raise (InvalidInputFilename src);
+    let cu = Filename.chop_suffix (Filename.basename src) ".cd" in
+    let id = Types.CompUnit.mk (U.mk_latin1 cu) in
+    Librarian.compile id src;
     Librarian.run argv id
   with exn -> catch_exn Format.err_formatter exn; exit 1
 
 let run obj argv =  
   try
-    let id = Types.CompUnit.mk (U.mk_latin1 obj) in
+    if not (Filename.check_suffix obj ".cdo")
+    then raise (InvalidObjectFilename obj);
+    let cu = Filename.chop_suffix (Filename.basename obj) ".cdo" in
+    let id = Types.CompUnit.mk (U.mk_latin1 cu) in
     Librarian.import id;
     Librarian.run argv id
   with exn -> catch_exn Format.err_formatter exn; exit 1

driver/cduce.mli

@@ -8,6 +8,6 @@ val topinput : Format.formatter -> Format.formatter -> char Stream.t -> bool
 
 val dump_env : Format.formatter -> unit
 
-val compile: string -> string -> unit
+val compile: string -> string option -> unit
 val compile_run: string -> Value.t -> unit
 val run: string -> Value.t -> unit

driver/librarian.ml

 open Location
 open Ident
 
-
 module C = Types.CompUnit
 
+exception InconsistentCrc of C.t
+exception Loop of C.t
+exception InvalidObject of string
+exception CannotOpen of string
+exception NoImplementation of C.t
+
 type t = {
   typing: Typer.t;
   compile: Compile.env;
@@ -24,6 +29,8 @@ let mk (typing,compile,code) =
 
 let magic = "CDUCE:compunit:00001"
 
+let obj_path = ref [ "" ]
+
 let tbl = C.Tbl.create ()
 
 let find id =
@@ -52,21 +59,14 @@ let deserialize_dep =
     (Serialize.Get.pair Encodings.Utf8.deserialize Serialize.Get.string)
 
 
-let source_filename id = 
-    let filename = Encodings.Utf8.to_string (C.value id) 
-     in if (Filename.check_suffix filename "cd") then filename else filename^ ".cd"
-
-let object_filename id  obj = 
-    match obj with
-      | "" ->  let filename = Encodings.Utf8.to_string (C.value id) in 
-               (if (Filename.check_suffix filename ".cd") 
-                then Filename.chop_suffix filename ".cd" else filename) ^ ".cdo"
-     | _ -> obj 
-
-
-
+let find_obj id = 
+  let base = Encodings.Utf8.to_string (C.value id) ^ ".cdo" in
+  let p = 
+    List.find (fun p -> Sys.file_exists (Filename.concat p base)) !obj_path in
+  Filename.concat p base
 
-let save id out=
+let save id out =
+  protect_op "Save compilation unit";
   let cu = find id in
   C.enter id;
   let raw = Serialize.Put.run serialize cu in
@@ -89,15 +89,16 @@ let save id out=
 
   let depend = Serialize.Put.run serialize_dep depend in
   let digest = Digest.string raw in
-  let oc = open_out (object_filename id out) in
-  output_value oc (digest,depend,raw);
+  let oc = open_out out in
+  Marshal.to_channel oc (digest,depend,raw) [];
   close_out oc
   
   
-let check_digest exp digest =
+let check_digest id exp digest =
   match digest with
     | Some x ->
-	if exp <> x then failwith "Inconsistent checksum"
+	if exp <> x then 
+	  raise (InconsistentCrc id)
     | None -> 
 	assert false
 
@@ -105,17 +106,19 @@ let loop = C.Tbl.create ()
 let check_loop id = 
   try 
     C.Tbl.find loop id;
-    failwith "Loop between compilation units"
+    raise (Loop id)
   with Not_found -> 
     C.Tbl.add loop id ()
 
 let depends = ref []
 let during_compile = ref false
 
-let rec compile id =
+let rec compile id src =
   check_loop id;
-  let src = source_filename id in
-  let ic = open_in src in
+  protect_op "Compile external file";
+  let ic = 
+    try open_in src
+    with Sys_error _ -> raise (CannotOpen src) in
   Location.push_source (`File src);
   let input = Stream.of_channel ic in
   let p = 
@@ -143,22 +146,28 @@ let rec compile id =
   depends := []
 
 let rec load id =
+  protect_op "Load compiled compilation unit";
   try 
     C.Tbl.find tbl id
   with Not_found ->
-    check_loop id;
-    if !during_compile then depends := id :: !depends;
 (*    Printf.eprintf "load %s: start\n" (object_filename id);
     flush stderr; *)
-    let filename =  Encodings.Utf8.to_string (C.value id) in
+
+    let obj = 
+      try find_obj id
+      with Not_found -> raise (NoImplementation id) in
     let ic = 
-      if Filename.check_suffix filename ".cdo" then open_in filename
-      else try  
-             open_in (object_filename id "") 
-           with  Sys_error _ -> open_in (filename) in 
-    let (dig, depend, raw) = input_value ic in
+      try open_in obj
+      with Sys_error _ -> raise (CannotOpen obj) in
+
+    let (dig, depend, raw) = 
+      try Marshal.from_channel ic
+      with Failure _ | End_of_file -> raise (InvalidObject obj) in
+
     close_in ic;
     let depend = Serialize.Get.run deserialize_dep depend in
+    check_loop id;
+    if !during_compile then depends := id :: !depends;
     List.iter (fun (id,dig) -> load_check (C.mk id) dig) depend;
     C.enter id;
     let cu = Serialize.Get.run deserialize raw in
@@ -170,7 +179,7 @@ let rec load id =
 
 and load_check id exp =
   let cu = load id in
-  check_digest exp cu.digest
+  check_digest id exp cu.digest
 
 let rec run argv id =
   let cu = find id in

driver/librarian.mli

-val compile: Types.CompUnit.t -> unit
+exception InconsistentCrc of Types.CompUnit.t
+exception Loop of Types.CompUnit.t
+exception InvalidObject of string
+exception CannotOpen of string
+exception NoImplementation of Types.CompUnit.t
+
+val obj_path: string list ref
+
+val compile: Types.CompUnit.t -> string -> unit
 val run:  Value.t -> Types.CompUnit.t -> unit
 val import: Types.CompUnit.t -> unit
 val save: Types.CompUnit.t -> string -> unit

driver/run.ml

@@ -5,7 +5,7 @@ let () = State.close ();;
 let load_dump = ref None
 let save_dump = ref None
 
-let out_file  = ref [] (* stores the name of the output file *)
+let out_dir  = ref [] (* directory of the output file *)
 let src  = ref []
 let args = ref []
 
@@ -37,11 +37,13 @@ let specs =
     "--quiet", Arg.Set Cduce.quiet, 
            "  suppress normal output (typing, results)";
     "--compile", Arg.Set compile,
-           "compile the given CDuce file";
-    "-o",  Arg.String (fun s -> out_file := s :: !out_file),
-      "       output file for compilation";           
+             "compile the given CDuce file";
+    "--obj-dir",  Arg.String (fun s -> out_dir := s :: !out_dir),
+             "directory for the compiled .cdo file";
+    "-I", Arg.String (fun s -> Librarian.obj_path := s::!Librarian.obj_path),
+      "       add one directory to the lookup path for .cdo files";
     "--run", Arg.Set run,
-           "    execute the given CDuce object file";
+           "    execute the given .cdo file";
     "--stdin", Arg.Unit (fun () -> src := "" :: !src),
            "  read CDuce script on standard input";
     "--verbose", Arg.Unit (fun () -> Stats.set_verbosity Stats.Summary),
@@ -85,21 +87,21 @@ let err s =
 let mode =
   Arg.parse specs (fun s -> src := s :: !src) 
     "Usage:\ncduce [OPTIONS ...] [FILE ...] [--arg argument ...]\n\nOptions:";
-  match (!compile,!out_file,!run,!src,!args) with
-    | false, [_], _,  _, _   -> 
-	err "-o option can be used only with the --compile one"
-    | false, _, false, [],  args   -> `Toplevel args
-    | false, _, false, [x], args   -> `Script (x,args)
-    | false, _, false, _, _        ->
+  match (!compile,!out_dir,!run,!src,!args) with
+    | false, _::_, _,  _, _   -> 
+	err "--obj-dir option can be used only with --compile"
+    | false, [], false, [],  args   -> `Toplevel args
+    | false, [], false, [x], args   -> `Script (x,args)
+    | false, [], false, _, _        ->
 	err "Only one CDuce program can be executed at a time"
-    | true,  [o], false, [x], []     -> `Compile (x,o) 
-    | true,  [], false, [x], []     -> `Compile (x,"") 
+    | true,  [o], false, [x], []     -> `Compile (x,Some o) 
+    | true,  [], false, [x], []     -> `Compile (x,None) 
     | true,  [], false, [], []      ->
-	err "Please specifiy the CDuce program to be compiled"
+	err "Please specify the CDuce program to be compiled"
     | true,  [], false, _, []       ->
 	err "Only one CDuce program can be compiled at a time"
     | true,  _, false, _, []        ->
-	err "Please specify just one output file"
+	err "Please specify only one output directory"
     | true,  _, false, _, _        ->
 	err "No argument can be passed to programs at compile time"
     | false, _, true,  [x], args   -> `Run (x,args)

typing/typer.ml

@@ -59,6 +59,16 @@ let empty_env = {
 
 let from_comp_unit = ref (fun cu -> assert false)
 
+let enter_cu x cu env =
+  { env with cu = Env.add (ident x) cu env.cu }
+
+let find_cu loc x env =
+  try Env.find x env.cu
+  with Not_found -> 
+    raise_loc_generic loc 
+      ("Unbound compunit prefix " ^ (Ident.to_string x))
+
+
 let enter_type id t env =
   { env with ids = Env.add id (Type t) env.ids }
 let enter_types l env =
@@ -69,8 +79,8 @@ let find_type id env =
     | Type t -> t
     | Val _ -> raise Not_found
 
-let find_type_global cu id env =
-  let cu = Env.find cu env.cu in
+let find_type_global loc cu id env =
+  let cu = find_cu loc cu env in
   let env = !from_comp_unit cu in
   find_type id env
 
@@ -99,12 +109,6 @@ let iter_values env f =
 		| _ -> ()) env.ids
 
 
-let enter_cu x cu env =
-  { env with cu = Env.add (ident x) cu env.cu }
-
-let find_cu x env =
-  try Env.find x env.cu
-  with Not_found -> failwith ("Unbound compunit prefix " ^ (Ident.to_string x))
 
 (* Namespaces *)
 
@@ -445,9 +449,10 @@ let rec derecurs env p = match p.descr with
 	 | cu, v -> 
 	     try 
 	       let cu = ident (U.mk cu) in
-	       PType (find_type_global cu (ident v) env.penv_tenv)
+	       PType (find_type_global p.loc cu (ident v) env.penv_tenv)
 	     with Not_found ->
-	       failwith ("Unbound external type " ^ cu ^ ":" ^ (U.to_string v)))
+	       raise_loc_generic p.loc 
+	       ("Unbound external type " ^ cu ^ ":" ^ (U.to_string v)))
   | SchemaVar (kind, schema, item) ->
       PType (derecurs_schema env kind schema item)
   | Recurs (p,b) -> derecurs (derecurs_def env b) p
@@ -796,7 +801,7 @@ let rec expr env loc = function
 	| "", id -> let id = ident id in
 	  exp loc (Fv.singleton id) (Typed.Var id)
 	| cu, id -> 
-	    let cu = find_cu (ident (U.mk cu)) env in
+	    let cu = find_cu loc (ident (U.mk cu)) env in
 	    exp loc Fv.empty (Typed.ExtVar (cu, ident id)))
   | Apply (e1,e2) -> 
       let (fv1,e1) = expr env loc e1 and (fv2,e2) = expr env loc e2 in