(* $Id: main.ml,v 1.3 2001/01/14 22:15:53 gerd Exp $
 *)

let current_line = ref 1;;
let current_column = ref 0;;
let current_file = ref "<stdin>";;

let rec next_token lexbuf =
  let t = Lexer.token lexbuf in
  begin match t with
      Parser.LINEFEED(n,m) -> 
	current_line := !current_line + n; 
	current_column := m
    | Parser.SETFILE(n,name) ->
	if !current_column <> 0 then raise Lexer.Error;
	current_line := n;
	current_column := 0;
	current_file := name
    | _        -> 
	let s = Lexing.lexeme lexbuf in
	current_column := !current_column + (String.length s)
  end;
  match t with
      Parser.LINEFEED(_,_)
    | Parser.IGNORE 
    | Parser.SETFILE(_,_) -> 
	next_token lexbuf
    | Parser.PERCENT ->
	if !current_column = 1 then begin
	  (match Lexer.ignore_line lexbuf with
	       Parser.LINEFEED(n,m) -> 
		 current_line := !current_line + n; 
		 current_column := m
             | _ -> 
		 let s = Lexing.lexeme lexbuf in
		 current_column := !current_column + (String.length s)
	  );
	  next_token lexbuf
	end
	else
	  raise Lexer.Error
    | _ -> 
	t
;;


let read_channel ch =
  let lexbuf = Lexing.from_channel ch in
  current_line := 1;
  current_column := 0;
  try
    Parser.specification next_token lexbuf
  with
      Parsing.Parse_error ->
	Printf.eprintf
	  "In file %s, line %d, column %d: syntax error\n"
	  !current_file
	  !current_line
	  !current_column;
	flush stderr;
	raise Exit
    | Lexer.Error ->
	Printf.eprintf
	  "In file %s, line %d, column %d: lexer error\n"
	  !current_file
	  !current_line
	  !current_column;
	flush stderr;
	raise Exit
;;


let warning f name =
  Format.fprintf f
    ("(************************************************************\n\
   \032* WARNING!\n\
   \032*\n\
   \032* This file is generated by ocamlrpcgen from the source file\n\
   \032* %s\n\
   \032*\n\
   \032************************************************************)@\n")
    name
;;

let cwarning f name =
  Format.fprintf f
    ("/************************************************************\n\
   \032* WARNING!\n\
   \032*\n\
   \032* This file is generated by ocamlrpcgen from the source file\n\
   \032* %s\n\
   \032*\n\
   \032************************************************************/@\n")
    name
;;


let main() =
  let targets = ref [] in
  let want_aux = ref false in
  let want_clnt = ref false in
  let want_srv = ref false in
  let want_csrv = ref false in
  let want_caux = ref false in
  let cpp = ref (Some "cpp") in
  let cpp_options = ref [] in
  Arg.parse
      [ "-aux",    (Arg.Set want_aux),  " Create file_aux.ml";
	"-clnt",   (Arg.Set want_clnt), " Create file_clnt.ml";
	"-srv",    (Arg.Set want_srv),  " Create file_srv.ml";
        "-csrv",   (Arg.Set want_csrv), " Create file_csrv.ml";
        "-caux",   (Arg.Set want_caux), " Create file_caux.ml";
	"-int",
	           (Arg.String 
		      (function 
			   "abstract" -> 
			     Options.default_int_variant   := Syntax.Abstract
			 | "int32" ->
			     Options.default_int_variant   := Syntax.INT32
			 | "unboxed" ->
			     Options.default_int_variant   := Syntax.Unboxed
			 | s ->
			     raise(Arg.Bad "Bad -int"))
		   ),
		   "<v> Set the default variant of the language mapping of int";
	"-hyper",
	           (Arg.String 
		      (function 
			   "abstract" -> 
			     Options.default_hyper_variant := Syntax.Abstract
			 | "int64" ->
			     Options.default_hyper_variant := Syntax.INT64
			 | "unboxed" ->
			     Options.default_hyper_variant := Syntax.Unboxed
			 | s ->
			     raise(Arg.Bad "Bad -hyper"))
		   ),
		   "<v> Set the default variant of the language mapping of hyper";
	"-cpp", (Arg.String
		   (fun s ->
		      cpp := if s = "none" then None else Some s)),
	        "<p> Call the command <p> as preprocessor";
	"-D", (Arg.String (fun s -> cpp_options := !cpp_options @ [ "-D" ^ s ])),
	      "var=value Define the preprocessor variable var";
	"-U", (Arg.String (fun s -> cpp_options := !cpp_options @ [ "-U" ^ s ])),
	      "var Undefine the preprocessor variable var";

      ]
      (fun s -> targets := !targets @ [s])
"usage: ocamlrpcgen [-aux] [-clnt] [-srv]
                   [-int   (abstract | int32 | unboxed) ]
                   [-hyper (abstract | int64 | unboxed) ]  
                   [-cpp   (/path/to/cpp | none) ]
                   [-D var=value]
                   [-U var]
                   file.xdr ...";
  List.iter
    (fun target ->
       current_file := target;
       let remove_list = ref [] in
       try
	 let xdr = 
	   match !cpp with
	       Some cmd -> 
		 let options = 
		   String.concat " " (List.map Filename.quote !cpp_options) in
		 Unix.open_process_in (cmd ^ " " ^ options ^ " " ^ target) 
	     | None     -> open_in target
	 in
	 let xdr_def = read_channel xdr in
	 (match !cpp with
	      Some _ ->
		let status = Unix.close_process_in xdr in
		if status <> Unix.WEXITED 0 then
		  failwith "Preprocessor failed"
	    | None ->
		close_in xdr
	 );
	 Syntax.resolve_constants xdr_def;
	 Syntax.check_type_constraints xdr_def;
	 Syntax.check_program_definitions xdr_def;
	 Rename.simple_name_mapping xdr_def;
	 let base = Filename.chop_extension target in
	 let auxmodule = String.capitalize (Filename.basename base ^ "_aux") in
	 if !want_aux then begin
	   let auxname = base ^ "_aux.ml" in
	   let auxfile = open_out auxname in
	   remove_list := auxname :: !remove_list;
	   let auxfmt = Format.formatter_of_out_channel auxfile in
	   let auxmliname = base ^ "_aux.mli" in
	   let auxmlifile = open_out auxmliname in
	   remove_list := auxmliname :: !remove_list;
	   let auxmlifmt = Format.formatter_of_out_channel auxmlifile in
	   warning auxfmt target;
	   warning auxmlifmt target;
	   Format.fprintf auxmlifmt "@\n(* Type definitions *)@\n@\n";
	   Generate.output_type_declarations auxfmt xdr_def;
	   Generate.output_type_declarations auxmlifmt xdr_def;
	   Format.fprintf auxmlifmt "@\n(* Constant definitions *)@\n@\n";
	   Generate.output_consts auxmlifmt auxfmt xdr_def;
	   Format.fprintf auxmlifmt "@\n(* Conversion functions *)@\n@\n";
	   Generate.output_conversions auxmlifmt auxfmt xdr_def;
	   Format.fprintf auxmlifmt "@\n(* XDR definitions *)@\n@\n";
	   Generate.output_xdr_type auxmlifmt auxfmt xdr_def;
	   Format.fprintf auxmlifmt "@\n(* Program definitions *)@\n@\n";
	   Generate.output_progdefs auxmlifmt auxfmt xdr_def;
	   close_out auxfile;
	   close_out auxmlifile;
	 end;
	 if !want_clnt then begin
	   (* Clients: *)
	   let clntname = base ^ "_clnt.ml" in
	   let clntfile = open_out clntname in
	   remove_list := clntname :: !remove_list;
	   let clntfmt = Format.formatter_of_out_channel clntfile in
	   let clntmliname = base ^ "_clnt.mli" in
	   let clntmlifile = open_out clntmliname in
	   remove_list := clntmliname :: !remove_list;
	   let clntmlifmt = Format.formatter_of_out_channel clntmlifile in
	   warning clntfmt target;
	   warning clntmlifmt target;
	   Generate.output_client clntmlifmt clntfmt xdr_def auxmodule;
	   close_out clntfile;
	   close_out clntmlifile;
	 end;
	 if !want_srv then begin
	   (* Servers: *)
	   let srvname = base ^ "_srv.ml" in
	   let srvfile = open_out srvname in
	   remove_list := srvname :: !remove_list;
	   let srvfmt = Format.formatter_of_out_channel srvfile in
	   let srvmliname = base ^ "_srv.mli" in
	   let srvmlifile = open_out srvmliname in
	   remove_list := srvmliname :: !remove_list;
	   let srvmlifmt = Format.formatter_of_out_channel srvmlifile in
	   warning srvfmt target;
	   warning srvmlifmt target;
	   Generate.output_server srvmlifmt srvfmt xdr_def auxmodule;
	   close_out srvfile;
	   close_out srvmlifile;
	 end;
         if !want_csrv then begin
           (* C Servers: *)
           let hname = base ^ ".h" in
	   let csrvname = base ^ "_csrv.c" in
	   let csrvfile = open_out csrvname in
	   remove_list := csrvname :: !remove_list;
	   let csrvfmt = Format.formatter_of_out_channel csrvfile in
	   let csrvhname = base ^ "_csrv.h" in
	   let csrvhfile = open_out csrvhname in
	   remove_list := csrvhname :: !remove_list;
	   let csrvhfmt = Format.formatter_of_out_channel csrvhfile in
	   cwarning csrvfmt target;
	   cwarning csrvhfmt target;
	   Cgen.output_c_conversions csrvhfmt csrvfmt xdr_def csrvhname base;
	   close_out csrvfile;
	   close_out csrvhfile;

           let cname = base ^ "_server.c" in
           let cfile = open_out cname in
           remove_list := cname :: !remove_list;
           let cfmt = Format.formatter_of_out_channel cfile in
	   cwarning cfmt target;
           Cgen.output_c_server cfmt xdr_def csrvhname base;
           close_out cfile;
	 end;
	 if !want_caux then begin
	   let cauxname = base ^ "_caux.ml" in
	   let cauxfile = open_out cauxname in
	   remove_list := cauxname :: !remove_list;
	   let cauxfmt = Format.formatter_of_out_channel cauxfile in
	   let cauxmliname = base ^ "_caux.mli" in
	   let cauxmlifile = open_out cauxmliname in
	   remove_list := cauxmliname :: !remove_list;
	   let cauxmlifmt = Format.formatter_of_out_channel cauxmlifile in
	   warning cauxfmt target;
	   warning cauxmlifmt target;
	   Format.fprintf cauxmlifmt "@\n(* Type definitions *)@\n@\n";
	   Generate.output_type_declarations cauxfmt xdr_def;
	   Generate.output_type_declarations cauxmlifmt xdr_def;
	   Format.fprintf cauxmlifmt "@\n(* Constant definitions *)@\n@\n";
	   Generate.output_consts cauxmlifmt cauxfmt xdr_def;
	   close_out cauxfile;
	   close_out cauxmlifile;
	 end
       with
	   any ->
	     List.iter 
	       (fun n -> try Sys.remove n with _ -> ()) 
	       !remove_list;
	     raise any
    )
    !targets
;;

main();;
  

(* ======================================================================
 * 
 * $Log: main.ml,v $
 * Revision 1.3  2001/01/14 22:15:53  gerd
 * 	Now generating MLI files as well.
 *
 * Revision 1.2  2001/01/10 00:30:43  gerd
 * 	Continued: int mapping, C preprocessor, % lines
 *
 * Revision 1.1  2001/01/08 01:47:58  gerd
 * 	Initial revision.
 *
 *)
