2012-06-27 18:09:30 +02:00
|
|
|
(***********************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* Heptagon *)
|
|
|
|
(* *)
|
|
|
|
(* Gwenael Delaval, LIG/INRIA, UJF *)
|
|
|
|
(* Leonard Gerard, Parkas, ENS *)
|
|
|
|
(* Adrien Guatto, Parkas, ENS *)
|
|
|
|
(* Cedric Pasteur, Parkas, ENS *)
|
2012-06-29 01:43:15 +02:00
|
|
|
(* Marc Pouzet, Parkas, ENS *)
|
2012-06-27 18:09:30 +02:00
|
|
|
(* *)
|
|
|
|
(* Copyright 2012 ENS, INRIA, UJF *)
|
|
|
|
(* *)
|
|
|
|
(* This file is part of the Heptagon compiler. *)
|
|
|
|
(* *)
|
|
|
|
(* Heptagon is free software: you can redistribute it and/or modify it *)
|
|
|
|
(* under the terms of the GNU General Public License as published by *)
|
|
|
|
(* the Free Software Foundation, either version 3 of the License, or *)
|
|
|
|
(* (at your option) any later version. *)
|
|
|
|
(* *)
|
|
|
|
(* Heptagon is distributed in the hope that it will be useful, *)
|
|
|
|
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
|
|
|
|
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
|
|
|
|
(* GNU General Public License for more details. *)
|
|
|
|
(* *)
|
|
|
|
(* You should have received a copy of the GNU General Public License *)
|
|
|
|
(* along with Heptagon. If not, see <http://www.gnu.org/licenses/> *)
|
|
|
|
(* *)
|
|
|
|
(***********************************************************************)
|
2010-06-17 16:26:52 +02:00
|
|
|
open Location
|
2010-09-15 09:38:52 +02:00
|
|
|
open Format
|
|
|
|
open Unix
|
|
|
|
open Compiler_options
|
2010-06-17 16:26:52 +02:00
|
|
|
|
2010-09-14 09:39:02 +02:00
|
|
|
type lexical_error =
|
|
|
|
| Illegal_character
|
|
|
|
| Unterminated_comment
|
|
|
|
| Bad_char_constant
|
|
|
|
| Unterminated_string
|
|
|
|
|
2010-06-17 16:26:52 +02:00
|
|
|
let lexical_error err loc =
|
2010-09-14 09:39:02 +02:00
|
|
|
Format.eprintf (match err with
|
|
|
|
| Illegal_character -> Pervasives.format_of_string "%aIllegal character.@."
|
|
|
|
| Unterminated_comment -> "%aUnterminated comment.@."
|
|
|
|
| Bad_char_constant -> "%aBad char constant.@."
|
|
|
|
| Unterminated_string -> "%aUnterminated string.@."
|
|
|
|
) print_location loc;
|
2010-09-15 09:38:52 +02:00
|
|
|
raise Errors.Error
|
2010-06-17 16:26:52 +02:00
|
|
|
|
|
|
|
let syntax_error loc =
|
2010-09-01 13:31:28 +02:00
|
|
|
Format.eprintf "%aSyntax error.@." print_location loc;
|
2010-09-15 09:38:52 +02:00
|
|
|
raise Errors.Error
|
2010-06-17 16:26:52 +02:00
|
|
|
|
|
|
|
let language_error lang =
|
2010-09-01 13:31:28 +02:00
|
|
|
Format.eprintf "Unknown language: '%s'.@." lang
|
2010-06-17 16:26:52 +02:00
|
|
|
|
2010-09-09 00:35:06 +02:00
|
|
|
let separateur = "\n*********************************************\
|
|
|
|
*********************************\n*** "
|
2010-06-26 16:53:25 +02:00
|
|
|
|
2010-09-09 00:35:06 +02:00
|
|
|
let comment ?(sep=separateur) s =
|
|
|
|
if !verbose then Format.printf "%s%s@." sep s
|
2010-06-17 16:26:52 +02:00
|
|
|
|
2015-09-18 13:26:48 +02:00
|
|
|
let info: ('a, formatter, unit, unit) format4 -> 'a = fun f ->
|
2014-10-22 17:42:57 +02:00
|
|
|
if !verbose then
|
2015-09-18 13:26:48 +02:00
|
|
|
kfprintf (kfprintf (fun fmt -> fprintf fmt "@]@.")) err_formatter
|
|
|
|
"Info: @[" f
|
|
|
|
else ifprintf err_formatter f
|
2014-10-22 17:42:57 +02:00
|
|
|
|
2015-09-18 13:26:48 +02:00
|
|
|
let warn ?(cond = true): ('a, formatter, unit, unit) format4 -> 'a = fun f ->
|
|
|
|
if cond then
|
|
|
|
kfprintf (kfprintf (fun fmt -> fprintf fmt "@]@.")) err_formatter
|
|
|
|
"Warning: @[" f
|
|
|
|
else ifprintf err_formatter f
|
2014-10-22 17:42:57 +02:00
|
|
|
|
2015-09-18 13:26:48 +02:00
|
|
|
let error: ('a, formatter, unit, unit) format4 -> 'a = fun f ->
|
|
|
|
kfprintf (kfprintf (fun fmt -> fprintf fmt "@]@.")) err_formatter
|
|
|
|
"Error: @[" f
|
2014-10-21 15:24:48 +02:00
|
|
|
|
2010-09-09 00:35:06 +02:00
|
|
|
let do_pass d f p pp =
|
2012-03-07 17:44:57 +01:00
|
|
|
comment (d ^ " ...\n");
|
2013-11-08 18:51:06 +01:00
|
|
|
let _start = Unix.gettimeofday () in
|
2012-03-07 17:44:57 +01:00
|
|
|
let r = Compiler_timings.time_pass d f p in
|
2013-11-08 18:51:06 +01:00
|
|
|
let _stop = Unix.gettimeofday () in
|
2010-09-09 00:35:06 +02:00
|
|
|
pp r;
|
2012-03-07 17:44:57 +01:00
|
|
|
comment ~sep:"*** " (d ^ " done.");
|
2010-09-09 00:35:06 +02:00
|
|
|
r
|
|
|
|
|
2010-09-14 09:39:02 +02:00
|
|
|
let do_silent_pass d f p = do_pass d f p (fun _ -> ())
|
2010-09-09 00:35:06 +02:00
|
|
|
|
|
|
|
let pass d enabled f p pp =
|
2010-06-17 16:26:52 +02:00
|
|
|
if enabled
|
2010-09-09 00:35:06 +02:00
|
|
|
then do_pass d f p pp
|
2010-06-17 16:26:52 +02:00
|
|
|
else p
|
|
|
|
|
2010-09-09 00:35:06 +02:00
|
|
|
let silent_pass d enabled f p =
|
2010-06-17 16:26:52 +02:00
|
|
|
if enabled
|
2010-09-09 00:35:06 +02:00
|
|
|
then do_silent_pass d f p
|
2010-06-17 16:26:52 +02:00
|
|
|
else p
|
2010-06-18 14:00:58 +02:00
|
|
|
|
2011-03-08 09:22:02 +01:00
|
|
|
let filename_of_name n =
|
2017-03-14 12:24:29 +01:00
|
|
|
String.uncapitalize_ascii n
|
2011-02-07 14:24:17 +01:00
|
|
|
|
2010-06-18 14:00:58 +02:00
|
|
|
let build_path suf =
|
|
|
|
match !target_path with
|
|
|
|
| None -> suf
|
|
|
|
| Some path -> Filename.concat path suf
|
|
|
|
|
|
|
|
let clean_dir dir =
|
|
|
|
if Sys.file_exists dir && Sys.is_directory dir
|
|
|
|
then begin
|
|
|
|
let rm_file_in_dir fn = Sys.remove (Filename.concat dir fn) in
|
|
|
|
Array.iter rm_file_in_dir (Sys.readdir dir);
|
|
|
|
end else Unix.mkdir dir 0o740;
|
|
|
|
dir
|
|
|
|
|
2011-02-07 14:24:17 +01:00
|
|
|
let ensure_dir dir =
|
|
|
|
if not (Sys.file_exists dir && Sys.is_directory dir)
|
|
|
|
then Unix.mkdir dir 0o740
|
|
|
|
|
|
|
|
|
|
|
|
|
2010-09-15 09:38:52 +02:00
|
|
|
exception Cannot_find_file of string
|
|
|
|
|
|
|
|
let findfile filename =
|
|
|
|
if Sys.file_exists filename then
|
|
|
|
filename
|
|
|
|
else if not(Filename.is_implicit filename) then
|
|
|
|
raise(Cannot_find_file filename)
|
|
|
|
else
|
|
|
|
let rec find = function
|
|
|
|
| [] -> raise(Cannot_find_file filename)
|
|
|
|
| a::rest ->
|
|
|
|
let b = Filename.concat a filename in
|
|
|
|
if Sys.file_exists b then b else find rest in
|
|
|
|
find !load_path
|
2010-06-18 14:00:58 +02:00
|
|
|
|
2010-07-16 17:33:14 +02:00
|
|
|
let lexbuf_from_file file_name =
|
|
|
|
let ic = open_in file_name in
|
|
|
|
let lexbuf = Lexing.from_channel ic in
|
|
|
|
lexbuf.Lexing.lex_curr_p <-
|
|
|
|
{ lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = file_name };
|
|
|
|
ic, lexbuf
|
|
|
|
|
2010-09-15 09:38:52 +02:00
|
|
|
let print_header_info ff cbeg cend =
|
|
|
|
let tm = Unix.localtime (Unix.time ()) in
|
|
|
|
fprintf ff "%s --- Generated the %d/%d/%d at %d:%d --- %s@\n"
|
|
|
|
cbeg tm.tm_mday (tm.tm_mon+1) (tm.tm_year + 1900) tm.tm_hour tm.tm_min cend;
|
|
|
|
fprintf ff "%s --- heptagon compiler, version %s (compiled %s) --- %s@\n"
|
|
|
|
cbeg version date cend;
|
|
|
|
fprintf ff "%s --- Command line: %a--- %s@\n@\n"
|
|
|
|
cbeg
|
|
|
|
(fun ff a ->
|
|
|
|
Array.iter (fun arg -> fprintf ff "%s " arg) a)
|
|
|
|
Sys.argv
|
|
|
|
cend
|
2010-07-16 17:33:14 +02:00
|
|
|
|
2010-06-18 14:00:58 +02:00
|
|
|
let errmsg = "Options are:"
|