(**********************************************************************)
(* (c) Greg Morrisett, Neal Glew,                                     *)
(*     June 1998, all rights reserved.                                *)
(**********************************************************************)

(* Talbe
 * TAL backend functions.
 *
 *)

open Tal;;
open Talctxt;;

let read_x parsefun filename =
  try
    let ic = open_in filename in
    let lb = Lexing.from_channel ic in
    try
      Tallex.reset_lexer ();
      let x = parsefun Tallex.main lb in
      close_in ic;
      x
    with
      Parsing.Parse_error ->
      	Printf.eprintf "%s: line %d(%d): syntax error\n"
 	  filename !Tallex.line (try Lexing.lexeme_start lb with _ -> 0);
      	flush stderr; close_in ic; raise Talfail
    | Failure s ->
      	Printf.eprintf "%s: line %d(%d): parser/scanner failure: %s\n"
 	  filename !Tallex.line (try Lexing.lexeme_start lb with _ -> 0) s;
      	flush stderr; close_in ic; raise Talfail
    | x -> close_in ic; raise x
  with
    Sys_error s ->
      Printf.eprintf "%s: %s\n" filename s; flush stderr; raise Talfail 
;;

let read_int = read_x Talparser.tal_int;;
let read_imp = read_x Talparser.tal_imp;;

let find_interface s =
  if Sys.file_exists s then
    s
  else
    let rec loop dirs =
      match dirs with
	[] ->
	  let s1 = Filename.concat !Talout.runtime s in
	  if Sys.file_exists s1 then s1 else begin
	    Printf.eprintf "%s: no such interface\n" s; flush stderr;
	    raise Talfail
	  end
      |	dir::dirs ->
	  let s1 = Filename.concat dir s in
	  if Sys.file_exists s1 then s1 else loop dirs in
    loop (List.rev !Talout.includes)
;;

let talintcache = Hashtbl.create 13;;

let rec get_tali intref =
  try Hashtbl.find talintcache intref
  with Not_found ->
    let tali = read_tali intref in
    Hashtbl.add talintcache intref tali;
    tali
and read_tali intref =
  let fn = find_interface intref in
  read_int fn
;;

let multiple_errors = ref true;;
let silent_verify = ref false;;
let print_interfaces = ref false;;

let print_verify_error ctxt ve =
  let fmt = Format.err_formatter in
  Talpp.print_Talverify fmt Talpp.std_options (ctxt,ve);
  Format.pp_print_newline fmt ()
;;

let mult_ctxt = error_handler empty_ctxt (fun c e -> print_verify_error c e);;
let sing_ctxt = error_handler empty_ctxt (fun c e -> raise (Talverify (c,e)));;

let verify talfn talimp =
  try
    let imex =
      Talverify.verify_imp
      	get_tali
      	(if !multiple_errors then mult_ctxt else sing_ctxt)
      	talimp in
    if not !silent_verify then
      begin Printf.printf "%s: TAL verified\n" talfn; flush stdout end;
    if !print_interfaces then begin
      let (it,et) = imex in
      Printf.printf "%s: import interface:\n" talfn; flush stdout;
      Talpp.print_tal_int_type Format.std_formatter Talpp.std_options it;
      Format.print_newline ();
      Printf.printf "%s: export interface:\n" talfn; flush stdout;
      Talpp.print_tal_int_type Format.std_formatter Talpp.std_options et;
      Format.print_newline ()
    end;
    imex
  with
    Talverify (c,e) -> print_verify_error c e; raise Talfail
  | Failure s ->
      Printf.eprintf "%s: TAL verify failure: %s\n" talfn s; flush stderr;
      raise Talfail
;;

let silent_asm = ref false;;

let asm talfn talimp imex objname =
  (match !Talout.asm_bintool with
    Talout.MS ->
      (match !Talout.objformat with
	Talout.COFF -> Talout.asm talfn (Some objname)
      |	Talout.ELF ->
	  Printf.eprintf "%s: masm cannot output ELF\n" talfn; flush stderr)
  | Talout.TALC ->
      let objfile = Talasm.assemble talimp imex in
      (match !Talout.objformat with
    	Talout.COFF -> Coff.create_coff talfn objname objfile
      | Talout.ELF -> Elf.create_elf talfn objname objfile));
  if not !silent_asm then
    begin Printf.printf "%s: object file created\n" talfn; flush stdout end
;;

(* EOF: talbe.ml *)
