1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
|
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
(* OCaml port by John Malecki and Xavier Leroy *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(************************ Source management ****************************)
open Misc
open Primitives
let source_extensions = [".ml"]
(*** Conversion function. ***)
let source_of_module pos mdle =
let pos_fname = pos.Lexing.pos_fname in
if Sys.file_exists pos_fname then pos_fname else
let is_submodule m m' =
let len' = String.length m' in
try
(String.sub m 0 len') = m' && (String.get m len') = '.'
with
Invalid_argument _ -> false in
let path =
Hashtbl.fold
(fun mdl dirs acc ->
if is_submodule mdle mdl then
dirs
else
acc)
Debugger_config.load_path_for
(Load_path.get_path_list ()) in
let fname = pos.Lexing.pos_fname in
if fname = "" then
let innermost_module =
try
let dot_index = String.rindex mdle '.' in
String.sub mdle (succ dot_index) (pred (String.length mdle - dot_index))
with Not_found -> mdle in
let rec loop =
function
| [] -> raise Not_found
| ext :: exts ->
try find_in_path_normalized path (innermost_module ^ ext)
with Not_found -> loop exts
in loop source_extensions
else if Filename.is_relative fname then
find_in_path_rel path fname
else if Sys.file_exists fname then fname
else raise Not_found
(*** Buffer cache ***)
(* Buffer and cache (to associate lines and positions in the buffer). *)
type buffer = string * (int * int) list ref
let buffer_max_count = ref 10
let buffer_list =
ref ([] : (string * buffer) list)
let flush_buffer_list () =
buffer_list := []
let get_buffer pos mdle =
try List.assoc mdle !buffer_list with
Not_found ->
let inchan = open_in_bin (source_of_module pos mdle) in
let content = really_input_string inchan (in_channel_length inchan) in
let buffer = (content, ref []) in
buffer_list :=
(list_truncate !buffer_max_count ((mdle, buffer)::!buffer_list));
buffer
let buffer_content =
(fst : buffer -> string)
let buffer_length x =
String.length (buffer_content x)
(*** Position conversions. ***)
type position = int * int
(* Insert a new pair (position, line) in the cache of the given buffer. *)
let insert_pos buffer ((position, line) as pair) =
let rec new_list =
function
[] ->
[(position, line)]
| ((_pos, lin) as a::l) as l' ->
if lin < line then
pair::l'
else if lin = line then
l'
else
a::(new_list l)
in
let buffer_cache = snd buffer in
buffer_cache := new_list !buffer_cache
(* Position of the next linefeed after `pos'. *)
(* Position just after the buffer end if no linefeed found. *)
(* Raise `Out_of_range' if already there. *)
let next_linefeed (buffer, _) pos =
let len = String.length buffer in
if pos >= len then
raise Out_of_range
else
let rec search p =
if p = len || String.get buffer p = '\n' then
p
else
search (succ p)
in
search pos
(* Go to next line. *)
let next_line buffer (pos, line) =
(next_linefeed buffer pos + 1, line + 1)
(* Convert a position in the buffer to a line number. *)
let line_of_pos buffer position =
let rec find =
function
| [] ->
if position < 0 then
raise Out_of_range
else
(0, 1)
| ((pos, _line) as pair)::l ->
if pos > position then
find l
else
pair
and find_line previous =
let (pos, _line) as next = next_line buffer previous in
if pos <= position then
find_line next
else
previous
in
let result = find_line (find !(snd buffer)) in
insert_pos buffer result;
result
(* Convert a line number to a position. *)
let pos_of_line buffer line =
let rec find =
function
[] ->
if line <= 0 then
raise Out_of_range
else
(0, 1)
| ((_pos, lin) as pair)::l ->
if lin > line then
find l
else
pair
and find_pos previous =
let (_, lin) as next = next_line buffer previous in
if lin <= line then
find_pos next
else
previous
in
let result = find_pos (find !(snd buffer)) in
insert_pos buffer result;
result
(* Convert a coordinate (line / column) into a position. *)
(* --- The first line and column are line 1 and column 1. *)
let point_of_coord buffer line column =
fst (pos_of_line buffer line) + (pred column)
let start_and_cnum buffer pos =
let line_number = pos.Lexing.pos_lnum in
let start = point_of_coord buffer line_number 1 in
start, start + (pos.Lexing.pos_cnum - pos.Lexing.pos_bol)
|
