(* $Id: main.ml 1791 2012-07-19 23:01:25Z gerd $
 *)

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 main() =
  let targets = ref [] in
  let want_aux = ref false in
  let want_clnt = ref false in
  let want_srv = ref None in
  let cpp = ref (Some Config.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.Unit (fun () -> want_srv := Some `Create)),  
	" Create file_srv.ml";
	"-srv2",   (Arg.Unit (fun () -> want_srv := Some `Create2)),  
	" Create file_srv.ml (new style)";

	"-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";

	"-I", (Arg.String (fun s -> cpp_options := !cpp_options @ [ "-I" ^ s ])),
	      "path Include this path into the cpp search path";

	"-direct", Arg.Set Options.enable_direct,
	      "  Enable direct mapping";
      ]
      (fun s -> targets := !targets @ [s])
"usage: ocamlrpcgen [-aux] [-clnt] [-srv | -srv2]
                   [-int   (abstract | int32 | unboxed) ]
                   [-hyper (abstract | int64 | unboxed) ]
                   [-cpp   (/path/to/cpp | none) ]
                   [-D var=value]
                   [-U var]
                   [-direct]
                   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;
	 Direct.mark_decls_suited_for_direct_mapping 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;
	 ( match !want_srv with
	     | None -> ()
	     | Some style ->
		 (* 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 
		   style srvmlifmt srvfmt xdr_def auxmodule;
		 close_out srvfile;
		 close_out srvmlifile;
	 )
       with
	   any ->
	     List.iter
	       (fun n -> try Sys.remove n with _ -> ())
	       !remove_list;
	     raise any
    )
    !targets
;;

main();;