
(* Fichier principal du compilateur arithc *)

open Format
open Lexing

(* Option de compilation, pour s'arrêter à l'issue du parser *)
let parse_only = ref false

(* Option de compilation, pour s'arrêter à l'issue du typage *)
let type_only = ref false

(* Noms des fichiers source et cible *)
let ifile = ref ""
let ofile = ref ""

let set_file f s = f := s 

(* Les options du compilateur que l'on affiche en tapant arithc --help *)
let options = 
  ["-parse-only", Arg.Set parse_only, 
   "  Pour ne faire que la phase d'analyse syntaxique";
   "-type-only", Arg.Set type_only,
   "  Pour ne faire que l'analyse syntaxique et le typage";
   "-app-partielle", Arg.Set Option.app_partielle,
   "  Pour autoriser l'application partielle des foncteurs";
   "-o", Arg.String (set_file ofile), 
   "<file>  Pour indiquer le mom du fichier de sortie"]

let usage = "usage: mimo [option] file.ml"

(* localise une erreur en indiquant la ligne et la colonne *)
let localisation pos =
  let l = pos.pos_lnum in
  let c = pos.pos_cnum - pos.pos_bol + 1 in
  eprintf "File \"%s\", line %d, characters %d-%d:\n" !ifile l (c-1) c

(* Meme chose en indiquant le debut et la fin de l'erreur *)
let localisation2 sp ep =
  let l = sp.pos_lnum in
  let c1 = sp.pos_cnum - sp.pos_bol + 1 in
  let c2 = ep.pos_cnum - sp.pos_bol + 1 in
  eprintf "File \"%s\", line %d, characters %d-%d:\n" !ifile l c1 c2

let () = 
  (* Parsing de la ligne de commande *)
  Arg.parse options (set_file ifile) usage;

  (* On vérifie que le nom du fichier source a bien été indiqué *)
  if !ifile="" then begin eprintf "Aucun fichier à compiler\n@?"; exit 2 end; 

  (* Ce fichier doit avoir l'extension .ml *)
  if not (Filename.check_suffix !ifile ".ml") then begin
    eprintf "Le fichier d'entrée doit avoir l'extension .ml\n@?";
    Arg.usage options usage;
    exit 2
  end;

  (* Par défaut, le fichier cible a le même nom que le fichier source, 
     seule l'extension change *)
  if !ofile="" then ofile := Filename.chop_suffix !ifile ".ml" ^ ".s";
  
  (* Ouverture du fichier source en lecture *)
  let f = try open_in !ifile with Sys_error s -> eprintf "Erreur à l'ouverture du fichier :\n%s@." s; exit 2 in
    
  (* Création d'un tampon d'analyse lexicale *)
  let buf = Lexing.from_channel f in

  try
    (* Parsing: la fonction  Parser.prog transforme le tampon lexical en un 
       arbre de syntaxe abstraite si aucune erreur (lexicale ou syntaxique) 
       n'est détectée.
       La fonction Lexer.token est utilisée par Parser.prog pour obtenir 
       le prochain token. *)
    let p = Parser.prog Lexer.token buf in
    close_in f;
    
    (* On s'arrête ici si on ne veut faire que le parsing *)
    if !parse_only then exit 0;

    (* On type maintenant *)
    let p = Typing.typing_program p in

    if !type_only then exit 0;

    (* Maintenant on produit le code *)
    let p = Defunc.defunc_prog p in

    (* Et enfin on optimise *)
    let p = Opt.opt_prog p in

    Compile.compile_program p !ofile
  with
    | Lexer.Lexing_error c -> 
	(* Erreur lexicale. On récupère sa position absolue et 
	   on la convertit en numéro de ligne *)
	localisation (Lexing.lexeme_start_p buf);
	eprintf "Erreur dans l'analyse lexicale: %c@." c;
        exit 1;
    | Parser.Error -> 
	(* Erreur syntaxique. On récupère sa position absolue et on la 
	   convertit en numéro de ligne *)
	localisation (Lexing.lexeme_start_p buf);
	eprintf "Erreur dans l'analyse syntaxique@.";
        exit 1;
    | Parser2.ParserTypeError (sp,ep) ->
        localisation2 sp ep;
        eprintf "Erreur dans l'analyse syntaxique : ce n'est pas un type correct@.";
        exit 1
    | Typing.ExprTypeError ((sp,ep),t1,t2) ->
        localisation2 sp ep;
        eprintf "Erreur dans le typage : cette expression est de type \"%s\" alors que le type attendu est \"%s\"@."
        (Typing.type_to_string t1) (Typing.type_to_string t2);
        exit 1
    | Typing.VarUndef (p,(sp,ep)) ->
        localisation2 sp ep;
        eprintf "Erreur dans le typage : la variable \"%s\" n'est pas definie@."
        (Typing.path_to_string p);
        exit 1
    | Typing.MatchSameNameError (n,(sp,ep)) ->
        localisation2 sp ep;
        eprintf "Erreur dans le typage : la variable \"%s\" est utilisée deux fois dans le match@."
        n;
        exit 1
    | Typing.ModuleExpected (p,(sp,ep)) ->
        localisation2 sp ep;
        eprintf "Erreur dans le typage : le chemin \"%s\" n'est pas un module@."
        (Typing.path_to_string p);
        exit 1
    | Typing.VariableExpected (p,(sp,ep)) ->
        localisation2 sp ep;
        eprintf "Erreur dans le typage : le chemin \"%s\" n'est pas une variable@."
        (Typing.path_to_string p);
        exit 1
    | Typing.BadNumberOfArgs (sp,ep) ->
        localisation2 sp ep;
        eprintf "Erreur dans le typage : il n'y a pas le bon nombre d'arguments@.";
        exit 1
    | Typing.NonUniqueName (n,(sp,ep)) ->
        localisation2 sp ep;
        eprintf "Erreur dans le typage : le nom \"%s\" n'est pas unique@." n;
        exit 1
    | Typing.SigNonCompatible (sp,ep) ->
        localisation2 sp ep;
        eprintf "Erreur dans le typage : la signature n'est pas compatible@.";
        exit 1
    | Failure s ->
        eprintf "Failure : %s@." s;
        exit 2
    | _ ->
        eprintf "Erreur interne inconnue@.";
        exit 2
