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 !Config.load_path in 44 let fname = pos.Lexing.pos_fname in 45 if fname = "" then 46 let innermost_module = 47 try 48 let dot_index = String.rindex mdle '.' in 49 String.sub mdle (succ dot_index) (pred (String.length mdle - dot_index)) 50 with Not_found -> mdle in 51 let rec loop = 52 function 53 | [] -> raise Not_found 54 | ext :: exts -> 55 try find_in_path_uncap path (innermost_module ^ ext) 56 with Not_found -> loop exts 57 in loop source_extensions 58 else if Filename.is_relative fname then 59 find_in_path_rel path fname 60 else if Sys.file_exists fname then fname 61 else raise Not_found 62 63(*** Buffer cache ***) 64 65(* Buffer and cache (to associate lines and positions in the buffer). *) 66type buffer = string * (int * int) list ref 67 68let buffer_max_count = ref 10 69 70let buffer_list = 71 ref ([] : (string * buffer) list) 72 73let flush_buffer_list () = 74 buffer_list := [] 75 76let get_buffer pos mdle = 77 try List.assoc mdle !buffer_list with 78 Not_found -> 79 let inchan = open_in_bin (source_of_module pos mdle) in 80 let content = really_input_string inchan (in_channel_length inchan) in 81 let buffer = (content, ref []) in 82 buffer_list := 83 (list_truncate !buffer_max_count ((mdle, buffer)::!buffer_list)); 84 buffer 85 86let buffer_content = 87 (fst : buffer -> string) 88 89let buffer_length x = 90 String.length (buffer_content x) 91 92(*** Position conversions. ***) 93 94type position = int * int 95 96(* Insert a new pair (position, line) in the cache of the given buffer. *) 97let insert_pos buffer ((position, line) as pair) = 98 let rec new_list = 99 function 100 [] -> 101 [(position, line)] 102 | ((_pos, lin) as a::l) as l' -> 103 if lin < line then 104 pair::l' 105 else if lin = line then 106 l' 107 else 108 a::(new_list l) 109 in 110 let buffer_cache = snd buffer in 111 buffer_cache := new_list !buffer_cache 112 113(* Position of the next linefeed after `pos'. *) 114(* Position just after the buffer end if no linefeed found. *) 115(* Raise `Out_of_range' if already there. *) 116let next_linefeed (buffer, _) pos = 117 let len = String.length buffer in 118 if pos >= len then 119 raise Out_of_range 120 else 121 let rec search p = 122 if p = len || String.get buffer p = '\n' then 123 p 124 else 125 search (succ p) 126 in 127 search pos 128 129(* Go to next line. *) 130let next_line buffer (pos, line) = 131 (next_linefeed buffer pos + 1, line + 1) 132 133(* Convert a position in the buffer to a line number. *) 134let line_of_pos buffer position = 135 let rec find = 136 function 137 | [] -> 138 if position < 0 then 139 raise Out_of_range 140 else 141 (0, 1) 142 | ((pos, _line) as pair)::l -> 143 if pos > position then 144 find l 145 else 146 pair 147 and find_line previous = 148 let (pos, _line) as next = next_line buffer previous in 149 if pos <= position then 150 find_line next 151 else 152 previous 153 in 154 let result = find_line (find !(snd buffer)) in 155 insert_pos buffer result; 156 result 157 158(* Convert a line number to a position. *) 159let pos_of_line buffer line = 160 let rec find = 161 function 162 [] -> 163 if line <= 0 then 164 raise Out_of_range 165 else 166 (0, 1) 167 | ((_pos, lin) as pair)::l -> 168 if lin > line then 169 find l 170 else 171 pair 172 and find_pos previous = 173 let (_, lin) as next = next_line buffer previous in 174 if lin <= line then 175 find_pos next 176 else 177 previous 178 in 179 let result = find_pos (find !(snd buffer)) in 180 insert_pos buffer result; 181 result 182 183(* Convert a coordinate (line / column) into a position. *) 184(* --- The first line and column are line 1 and column 1. *) 185let point_of_coord buffer line column = 186 fst (pos_of_line buffer line) + (pred column) 187 188let start_and_cnum buffer pos = 189 let line_number = pos.Lexing.pos_lnum in 190 let start = point_of_coord buffer line_number 1 in 191 start, start + (pos.Lexing.pos_cnum - pos.Lexing.pos_bol) 192