251 lines
7.9 KiB
OCaml
251 lines
7.9 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* Objective Caml *)
|
|
(* *)
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique. All rights reserved. This file is distributed *)
|
|
(* under the terms of the Q Public License version 1.0. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* $Id$ *)
|
|
|
|
open Lexing
|
|
|
|
type t = { loc_start: position; loc_end: position; loc_ghost: bool };;
|
|
|
|
let none = { loc_start = dummy_pos; loc_end = dummy_pos; loc_ghost = true };;
|
|
|
|
let in_file name =
|
|
let loc = {
|
|
pos_fname = name;
|
|
pos_lnum = 1;
|
|
pos_bol = 0;
|
|
pos_cnum = -1;
|
|
} in
|
|
{ loc_start = loc; loc_end = loc; loc_ghost = true }
|
|
;;
|
|
|
|
let curr lexbuf = {
|
|
loc_start = lexbuf.lex_start_p;
|
|
loc_end = lexbuf.lex_curr_p;
|
|
loc_ghost = false
|
|
};;
|
|
|
|
let init lexbuf fname =
|
|
lexbuf.lex_curr_p <- {
|
|
pos_fname = fname;
|
|
pos_lnum = 1;
|
|
pos_bol = 0;
|
|
pos_cnum = 0;
|
|
}
|
|
;;
|
|
|
|
let symbol_rloc () = {
|
|
loc_start = Parsing.symbol_start_pos ();
|
|
loc_end = Parsing.symbol_end_pos ();
|
|
loc_ghost = false;
|
|
};;
|
|
|
|
let symbol_gloc () = {
|
|
loc_start = Parsing.symbol_start_pos ();
|
|
loc_end = Parsing.symbol_end_pos ();
|
|
loc_ghost = true;
|
|
};;
|
|
|
|
let rhs_loc n = {
|
|
loc_start = Parsing.rhs_start_pos n;
|
|
loc_end = Parsing.rhs_end_pos n;
|
|
loc_ghost = false;
|
|
};;
|
|
|
|
let input_name = ref ""
|
|
let input_lexbuf = ref (None : lexbuf option)
|
|
|
|
(* Terminal info *)
|
|
|
|
let status = ref Terminfo.Uninitialised
|
|
|
|
let num_loc_lines = ref 0 (* number of lines already printed after input *)
|
|
|
|
(* Highlight the location using standout mode. *)
|
|
|
|
let highlight_terminfo ppf num_lines lb loc1 loc2 =
|
|
(* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
|
|
let pos0 = -lb.lex_abs_pos in
|
|
(* Do nothing if the buffer does not contain the whole phrase. *)
|
|
if pos0 < 0 then raise Exit;
|
|
(* Count number of lines in phrase *)
|
|
let lines = ref !num_loc_lines in
|
|
for i = pos0 to lb.lex_buffer_len - 1 do
|
|
if lb.lex_buffer.[i] = '\n' then incr lines
|
|
done;
|
|
(* If too many lines, give up *)
|
|
if !lines >= num_lines - 2 then raise Exit;
|
|
(* Move cursor up that number of lines *)
|
|
flush stdout; Terminfo.backup !lines;
|
|
(* Print the input, switching to standout for the location *)
|
|
let bol = ref false in
|
|
print_string "# ";
|
|
for pos = 0 to lb.lex_buffer_len - pos0 - 1 do
|
|
if !bol then (print_string " "; bol := false);
|
|
if pos = loc1.loc_start.pos_cnum || pos = loc2.loc_start.pos_cnum then
|
|
Terminfo.standout true;
|
|
if pos = loc1.loc_end.pos_cnum || pos = loc2.loc_end.pos_cnum then
|
|
Terminfo.standout false;
|
|
let c = lb.lex_buffer.[pos + pos0] in
|
|
print_char c;
|
|
bol := (c = '\n')
|
|
done;
|
|
(* Make sure standout mode is over *)
|
|
Terminfo.standout false;
|
|
(* Position cursor back to original location *)
|
|
Terminfo.resume !num_loc_lines;
|
|
flush stdout
|
|
|
|
(* Highlight the location by printing it again. *)
|
|
|
|
let highlight_dumb ppf lb loc =
|
|
(* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
|
|
let pos0 = -lb.lex_abs_pos in
|
|
(* Do nothing if the buffer does not contain the whole phrase. *)
|
|
if pos0 < 0 then raise Exit;
|
|
let end_pos = lb.lex_buffer_len - pos0 - 1 in
|
|
(* Determine line numbers for the start and end points *)
|
|
let line_start = ref 0 and line_end = ref 0 in
|
|
for pos = 0 to end_pos do
|
|
if lb.lex_buffer.[pos + pos0] = '\n' then begin
|
|
if loc.loc_start.pos_cnum > pos then incr line_start;
|
|
if loc.loc_end.pos_cnum > pos then incr line_end;
|
|
end
|
|
done;
|
|
(* Print character location (useful for Emacs) *)
|
|
Format.fprintf ppf "Characters %i-%i:@."
|
|
loc.loc_start.pos_cnum loc.loc_end.pos_cnum;
|
|
(* Print the input, underlining the location *)
|
|
print_string " ";
|
|
let line = ref 0 in
|
|
let pos_at_bol = ref 0 in
|
|
for pos = 0 to end_pos do
|
|
let c = lb.lex_buffer.[pos + pos0] in
|
|
if c <> '\n' then begin
|
|
if !line = !line_start && !line = !line_end then
|
|
(* loc is on one line: print whole line *)
|
|
print_char c
|
|
else if !line = !line_start then
|
|
(* first line of multiline loc: print ... before loc_start *)
|
|
if pos < loc.loc_start.pos_cnum
|
|
then print_char '.'
|
|
else print_char c
|
|
else if !line = !line_end then
|
|
(* last line of multiline loc: print ... after loc_end *)
|
|
if pos < loc.loc_end.pos_cnum
|
|
then print_char c
|
|
else print_char '.'
|
|
else if !line > !line_start && !line < !line_end then
|
|
(* intermediate line of multiline loc: print whole line *)
|
|
print_char c
|
|
end else begin
|
|
if !line = !line_start && !line = !line_end then begin
|
|
(* loc is on one line: underline location *)
|
|
print_string "\n ";
|
|
for i = !pos_at_bol to loc.loc_start.pos_cnum - 1 do
|
|
print_char ' '
|
|
done;
|
|
for i = loc.loc_start.pos_cnum to loc.loc_end.pos_cnum - 1 do
|
|
print_char '^'
|
|
done
|
|
end;
|
|
if !line >= !line_start && !line <= !line_end then begin
|
|
print_char '\n';
|
|
if pos < loc.loc_end.pos_cnum then print_string " "
|
|
end;
|
|
incr line;
|
|
pos_at_bol := pos + 1;
|
|
end
|
|
done
|
|
|
|
(* Highlight the location using one of the supported modes. *)
|
|
|
|
let rec highlight_locations ppf loc1 loc2 =
|
|
match !status with
|
|
Terminfo.Uninitialised ->
|
|
status := Terminfo.setup stdout; highlight_locations ppf loc1 loc2
|
|
| Terminfo.Bad_term ->
|
|
begin match !input_lexbuf with
|
|
None -> false
|
|
| Some lb ->
|
|
let norepeat =
|
|
try Sys.getenv "TERM" = "norepeat" with Not_found -> false in
|
|
if norepeat then false else
|
|
try highlight_dumb ppf lb loc1; true
|
|
with Exit -> false
|
|
end
|
|
| Terminfo.Good_term num_lines ->
|
|
begin match !input_lexbuf with
|
|
None -> false
|
|
| Some lb ->
|
|
try highlight_terminfo ppf num_lines lb loc1 loc2; true
|
|
with Exit -> false
|
|
end
|
|
|
|
(* Print the location in some way or another *)
|
|
|
|
open Format
|
|
|
|
let reset () =
|
|
num_loc_lines := 0
|
|
|
|
let (msg_file, msg_line, msg_chars, msg_to, msg_colon, msg_head) =
|
|
("File \"", "\", line ", ", characters ", "-", ":", "")
|
|
|
|
(* return file, line, char from the given position *)
|
|
let get_pos_info pos =
|
|
let (filename, linenum, linebeg) =
|
|
if pos.pos_fname = "" && !input_name = "" then
|
|
("", -1, 0)
|
|
else if pos.pos_fname = "" then
|
|
Linenum.for_position !input_name pos.pos_cnum
|
|
else
|
|
(pos.pos_fname, pos.pos_lnum, pos.pos_bol)
|
|
in
|
|
(filename, linenum, pos.pos_cnum - linebeg)
|
|
;;
|
|
|
|
let print ppf loc =
|
|
let (file, line, startchar) = get_pos_info loc.loc_start in
|
|
let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
|
|
let (startchar, endchar) =
|
|
if startchar < 0 then (0, 1) else (startchar, endchar)
|
|
in
|
|
if file = "" then begin
|
|
if highlight_locations ppf loc none then () else
|
|
fprintf ppf "Characters %i-%i:@."
|
|
loc.loc_start.pos_cnum loc.loc_end.pos_cnum
|
|
end else begin
|
|
fprintf ppf "%s%s%s%i" msg_file file msg_line line;
|
|
fprintf ppf "%s%i" msg_chars startchar;
|
|
fprintf ppf "%s%i%s@.%s" msg_to endchar msg_colon msg_head;
|
|
end
|
|
|
|
let print_warning loc ppf w =
|
|
if Warnings.is_active w then begin
|
|
let printw ppf w =
|
|
let n = Warnings.print ppf w in
|
|
num_loc_lines := !num_loc_lines + n
|
|
in
|
|
fprintf ppf "%a" print loc;
|
|
fprintf ppf "Warning %a@." printw w;
|
|
pp_print_flush ppf ();
|
|
incr num_loc_lines;
|
|
end
|
|
;;
|
|
|
|
let prerr_warning loc w = print_warning loc err_formatter w;;
|
|
|
|
let echo_eof () =
|
|
print_newline ();
|
|
incr num_loc_lines
|