1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Xavier Leroy, projet Gallium, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 2006 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 open! Int_replace_polymorphic_compare
17 open Lexing
18 open Location
19
20 type item = {
21 dinfo_file: string;
22 dinfo_line: int;
23 dinfo_char_start: int;
24 dinfo_char_end: int;
25 dinfo_start_bol: int;
26 dinfo_end_bol: int;
27 dinfo_end_line: int;
28 }
29
30 type t = item list
31
32 let none = []
33
34 let is_none = function
35 | [] -> true
36 | _ :: _ -> false
37
38 let to_string dbg =
39 match dbg with
40 | [] -> ""
41 | ds ->
42 let items =
43 List.map
44 (fun d ->
45 Printf.sprintf "%s:%d,%d-%d"
46 d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end)
47 ds
48 in
49 "{" ^ String.concat ";" items ^ "}"
50
51 let item_from_location loc =
52 let valid_endpos =
53 String.equal loc.loc_end.pos_fname loc.loc_start.pos_fname in
54 { dinfo_file = loc.loc_start.pos_fname;
55 dinfo_line = loc.loc_start.pos_lnum;
56 dinfo_char_start = loc.loc_start.pos_cnum - loc.loc_start.pos_bol;
57 dinfo_char_end =
58 if valid_endpos
59 then loc.loc_end.pos_cnum - loc.loc_start.pos_bol
60 else loc.loc_start.pos_cnum - loc.loc_start.pos_bol;
61 dinfo_start_bol = loc.loc_start.pos_bol;
62 dinfo_end_bol =
63 if valid_endpos then loc.loc_end.pos_bol
64 else loc.loc_start.pos_bol;
65 dinfo_end_line =
66 if valid_endpos then loc.loc_end.pos_lnum
67 else loc.loc_start.pos_lnum;
68 }
69
70 let from_location loc =
71 if loc == Location.none then [] else [item_from_location loc]
72
73 let to_location = function
74 | [] -> Location.none
75 | d :: _ ->
76 let loc_start =
77 { pos_fname = d.dinfo_file;
78 pos_lnum = d.dinfo_line;
79 pos_bol = d.dinfo_start_bol;
80 pos_cnum = d.dinfo_start_bol + d.dinfo_char_start;
81 } in
82 let loc_end =
83 { pos_fname = d.dinfo_file;
84 pos_lnum = d.dinfo_end_line;
85 pos_bol = d.dinfo_end_bol;
86 pos_cnum = d.dinfo_start_bol + d.dinfo_char_end;
87 } in
88 { loc_ghost = false; loc_start; loc_end; }
89
90 let inline loc t =
91 if loc == Location.none then t
92 else (item_from_location loc) :: t
93
94 let concat dbg1 dbg2 =
95 dbg1 @ dbg2
96
97 (* CR-someday afrisch: FWIW, the current compare function does not seem very
98 good, since it reverses the two lists. I don't know how long the lists are,
99 nor if the specific currently implemented ordering is useful in other
100 contexts, but if one wants to use Map, a more efficient comparison should
101 be considered. *)
102 let compare dbg1 dbg2 =
103 let rec loop ds1 ds2 =
104 match ds1, ds2 with
105 | [], [] -> 0
106 | _ :: _, [] -> 1
107 | [], _ :: _ -> -1
108 | d1 :: ds1, d2 :: ds2 ->
109 let c = String.compare d1.dinfo_file d2.dinfo_file in
110 if c <> 0 then c else
111 let c = compare d1.dinfo_line d2.dinfo_line in
112 if c <> 0 then c else
113 let c = compare d1.dinfo_char_end d2.dinfo_char_end in
114 if c <> 0 then c else
115 let c = compare d1.dinfo_char_start d2.dinfo_char_start in
116 if c <> 0 then c else
117 let c = compare d1.dinfo_start_bol d2.dinfo_start_bol in
118 if c <> 0 then c else
119 let c = compare d1.dinfo_end_bol d2.dinfo_end_bol in
120 if c <> 0 then c else
121 let c = compare d1.dinfo_end_line d2.dinfo_end_line in
122 if c <> 0 then c else
123 loop ds1 ds2
124 in
125 loop (List.rev dbg1) (List.rev dbg2)
126
127 let hash t =
128 List.fold_left (fun hash item -> Hashtbl.hash (hash, item)) 0 t
129
130 let rec print_compact ppf t =
131 let print_item item =
132 Format.fprintf ppf "%a:%i"
133 Location.print_filename item.dinfo_file
134 item.dinfo_line;
135 if item.dinfo_char_start >= 0 then begin
136 Format.fprintf ppf ",%i--%i" item.dinfo_char_start item.dinfo_char_end
137 end
138 in
139 match t with
140 | [] -> ()
141 | [item] -> print_item item
142 | item::t ->
143 print_item item;
144 Format.fprintf ppf ";";
145 print_compact ppf t
146