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