Skip to content

GitLab

Commit 7088b4f3 authored by Pietro Abate's avatar Pietro Abate
Browse files

[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
parent 1a1ea967
Hide whitespace changes
Inline Side-by-side
Makefile.distrib
View file @ 7088b4f3
......@@ -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
View file @ 7088b4f3
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
View file @ 7088b4f3
......@@ -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
View file @ 7088b4f3
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
View file @ 7088b4f3
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
View file @ 7088b4f3
......@@ -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
View file @ 7088b4f3
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment