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