location change. Heptc works with menhir.
Léonard Gérard
14 years ago
committed by
Léonard Gérard
parent
91aa437264
commit
5e737d0094
@ -1,154 +1,128 @@
|
||||
(* Printing a location in the source program *)
|
||||
(* taken from the source of the Caml Light 0.73 compiler *)
|
||||
(* inspired from the source of the Caml Light 0.73 compiler *)
|
||||
|
||||
open Lexing
|
||||
open Parsing
|
||||
|
||||
(* two important global variables: [input_name] and [input_chan] *)
|
||||
type location =
|
||||
Loc of int (* Position of the first character *)
|
||||
* int (* Position of the next character following the last one *)
|
||||
Loc of position (* Position of the first character *)
|
||||
* position (* Position of the next character following the last one *)
|
||||
|
||||
|
||||
let input_name = ref "" (* Input file name. *)
|
||||
|
||||
let input_chan = ref stdin (* The channel opened on the input. *)
|
||||
let input_chan = ref stdin (* The channel opened on the input. *)
|
||||
|
||||
let initialize iname ic =
|
||||
input_name := iname;
|
||||
input_chan := ic
|
||||
|
||||
|
||||
let no_location = Loc(0,0)
|
||||
|
||||
let no_location = Loc (dummy_pos, dummy_pos)
|
||||
|
||||
let error_prompt = ">"
|
||||
|
||||
let current_loc () =
|
||||
Loc(symbol_start(), symbol_end())
|
||||
|
||||
(** Prints [n] times char [c] on [oc]. *)
|
||||
let prints_n_chars oc n c = for i = 1 to n do output_char oc c done
|
||||
|
||||
let output_lines oc char1 char2 charline1 line1 line2 =
|
||||
let n1 = char1 - charline1
|
||||
and n2 = char2 - charline1 in
|
||||
if line2 > line1 then
|
||||
Printf.fprintf oc
|
||||
", line %d-%d, characters %d-%d:\n" line1 line2 n1 n2
|
||||
else
|
||||
Printf.fprintf oc ", line %d, characters %d-%d:\n" line1 n1 n2;
|
||||
()
|
||||
|
||||
|
||||
let output_loc oc input seek line_flag (Loc(pos1, pos2)) =
|
||||
let pr_chars n c =
|
||||
for i = 1 to n do output_char oc c done in
|
||||
let skip_line () =
|
||||
try
|
||||
while input() != '\n' do () done
|
||||
with End_of_file -> () in
|
||||
let copy_line () =
|
||||
let c = ref ' ' in
|
||||
begin try
|
||||
while c := input(); !c != '\n' do output_char oc !c done
|
||||
with End_of_file ->
|
||||
output_string oc "<EOF>"
|
||||
end;
|
||||
output_char oc '\n' in
|
||||
let pr_line first len ch =
|
||||
let c = ref ' '
|
||||
and f = ref first
|
||||
and l = ref len in
|
||||
try
|
||||
while c := input (); !c != '\n' do
|
||||
if !f > 0 then begin
|
||||
f := !f - 1;
|
||||
output_char oc (if !c == '\t' then !c else ' ')
|
||||
end
|
||||
else if !l > 0 then begin
|
||||
l := !l - 1;
|
||||
output_char oc (if !c == '\t' then !c else ch)
|
||||
end
|
||||
else ()
|
||||
done
|
||||
with End_of_file ->
|
||||
if !f = 0 && !l > 0 then pr_chars 5 ch in
|
||||
let pos = ref 0
|
||||
and line1 = ref 1
|
||||
and line1_pos = ref 0
|
||||
and line2 = ref 1
|
||||
and line2_pos = ref 0 in
|
||||
seek 0;
|
||||
begin try
|
||||
while !pos < pos1 do
|
||||
incr pos;
|
||||
if input() == '\n' then begin incr line1; line1_pos := !pos; () end
|
||||
(** Prints out to [oc] a line designed to be printed under [line] from file [ic]
|
||||
underlining from char [first] to char [last] with char [ch].
|
||||
[line] is the index of the first char of line. *)
|
||||
let underline_line ic oc ch line first last =
|
||||
let c = ref ' '
|
||||
and f = ref first
|
||||
and l = ref (last-first) in
|
||||
( try
|
||||
seek_in ic line;
|
||||
output_string oc error_prompt;
|
||||
while c := input_char ic; !c != '\n' do
|
||||
if !f > 0 then begin
|
||||
f := !f - 1;
|
||||
output_char oc (if !c == '\t' then !c else ' ')
|
||||
end
|
||||
else if !l > 0 then begin
|
||||
l := !l - 1;
|
||||
output_char oc (if !c == '\t' then !c else ch)
|
||||
end
|
||||
else ()
|
||||
done
|
||||
with End_of_file -> ()
|
||||
end;
|
||||
line2 := !line1;
|
||||
line2_pos := !line1_pos;
|
||||
begin try
|
||||
while !pos < pos2 do
|
||||
incr pos;
|
||||
if input() == '\n' then
|
||||
begin incr line2; line2_pos := !pos; () end
|
||||
with End_of_file ->
|
||||
if !f = 0 && !l > 0 then prints_n_chars oc 5 ch )
|
||||
|
||||
|
||||
let copy_lines nl ic oc prompt =
|
||||
for i = 1 to nl do
|
||||
output_string oc prompt;
|
||||
(try output_string oc (input_line ic)
|
||||
with End_of_file -> output_string oc "<EOF>");
|
||||
output_char oc '\n'
|
||||
done
|
||||
|
||||
let copy_chunk p1 p2 ic oc =
|
||||
try for i = p1 to p2 - 1 do output_char oc (input_char ic) done
|
||||
with End_of_file -> output_string oc "<EOF>"
|
||||
|
||||
|
||||
|
||||
let skip_lines n ic =
|
||||
try for i = 1 to n do
|
||||
let _ = input_line ic in ()
|
||||
done
|
||||
with End_of_file -> ()
|
||||
end;
|
||||
if line_flag then output_lines oc pos1 pos2 !line1_pos !line1 !line2;
|
||||
if !line1 == !line2 then begin
|
||||
seek !line1_pos;
|
||||
output_string oc error_prompt;
|
||||
copy_line ();
|
||||
seek !line1_pos;
|
||||
output_string oc error_prompt;
|
||||
pr_line (pos1 - !line1_pos) (pos2 - pos1) '^';
|
||||
output_char oc '\n'
|
||||
end else begin
|
||||
seek !line1_pos;
|
||||
output_string oc error_prompt;
|
||||
pr_line 0 (pos1 - !line1_pos) '.';
|
||||
seek pos1;
|
||||
copy_line();
|
||||
if !line2 - !line1 <= 8 then
|
||||
for i = !line1 + 1 to !line2 - 1 do
|
||||
output_string oc error_prompt;
|
||||
copy_line()
|
||||
done
|
||||
else
|
||||
begin
|
||||
for i = !line1 + 1 to !line1 + 3 do
|
||||
output_string oc error_prompt;
|
||||
copy_line()
|
||||
done;
|
||||
output_string oc error_prompt; output_string oc "..........\n";
|
||||
for i = !line1 + 4 to !line2 - 4 do skip_line() done;
|
||||
for i = !line2 - 3 to !line2 - 1 do
|
||||
output_string oc error_prompt;
|
||||
copy_line()
|
||||
done
|
||||
end;
|
||||
begin try
|
||||
output_string oc error_prompt;
|
||||
for i = !line2_pos to pos2 - 1 do
|
||||
output_char oc (input())
|
||||
done;
|
||||
pr_line 0 100 '.'
|
||||
with End_of_file -> output_string oc "<EOF>"
|
||||
end;
|
||||
output_char oc '\n'
|
||||
end
|
||||
|
||||
|
||||
let output_location oc loc =
|
||||
let p = pos_in !input_chan in
|
||||
Printf.fprintf oc "File \"%s\"" !input_name;
|
||||
output_loc
|
||||
oc (fun () -> input_char !input_chan) (seek_in !input_chan) true
|
||||
loc;
|
||||
seek_in !input_chan p
|
||||
|
||||
let output_location oc (Loc(p1,p2)) =
|
||||
let n1 = p1.pos_cnum - p1.pos_bol in (* character number *)
|
||||
let n2 = p2.pos_cnum - p2.pos_bol in
|
||||
let np1 = p1.pos_cnum in (* character position *)
|
||||
let np2 = p2.pos_cnum in
|
||||
let l1 = p1.pos_lnum in (* line number *)
|
||||
let l2 = p2.pos_lnum in
|
||||
let lp1 = p1.pos_bol in (* line position *)
|
||||
let lp2 = p2.pos_bol in
|
||||
let f1 = p1.pos_fname in (* file name *)
|
||||
let f2 = p2.pos_fname in
|
||||
|
||||
if f1 != f2 then (* Strange case *)
|
||||
Printf.fprintf oc
|
||||
"File \"%s\" line %d, character %d, to file \"%s\" line %d, character %d\n"
|
||||
f1 l1 n1 f2 l2 n2
|
||||
|
||||
let output_input_name oc =
|
||||
Printf.fprintf oc "File \"%s\", line 1:\n" !input_name
|
||||
else begin
|
||||
if l2 > l1 then
|
||||
Printf.fprintf oc
|
||||
"File \"%s\", line %d-%d, characters %d-%d:\n" f1 l1 l2 n1 n2
|
||||
else
|
||||
Printf.fprintf oc "File \"%s\", line %d, characters %d-%d:\n" f1 l1 n1 n2;
|
||||
(* Output source code *)
|
||||
let ic = open_in f1 in
|
||||
|
||||
if l1 == l2 then (
|
||||
(* Only one line : copy full line and underline *)
|
||||
seek_in ic lp1;
|
||||
copy_lines 1 ic oc ">";
|
||||
underline_line ic oc '^' lp1 n1 n2 )
|
||||
else (
|
||||
underline_line ic oc '.' lp1 0 n1; (* dots until n1 *)
|
||||
seek_in ic np1;
|
||||
(* copy the end of the line l1 after the dots *)
|
||||
copy_lines 1 ic oc "";
|
||||
if l2 - l1 <= 8 then
|
||||
(* copy the 6 or less middle lines *)
|
||||
copy_lines (l2-l1-1) ic oc ">"
|
||||
else (
|
||||
(* sum up the middle lines to 6 *)
|
||||
copy_lines 3 ic oc ">";
|
||||
output_string oc "..........\n";
|
||||
skip_lines (l2-l1-7) ic; (* skip middle lines *)
|
||||
copy_lines 3 ic oc ">"
|
||||
);
|
||||
output_string oc ">";
|
||||
copy_chunk lp2 np2 ic oc; (* copy interesting begining of l2 *)
|
||||
);
|
||||
output_char oc '\n'
|
||||
end;
|
||||
|
||||
|
||||
Loading…
Reference in New Issue