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 open Misc
18 open Path
19 open Instruct
20 open Types
21 open Parser_aux
22 open Events
23
24 type error =
25 Unbound_identifier of Ident.t
26 | Not_initialized_yet of Path.t
27 | Unbound_long_identifier of Longident.t
28 | Unknown_name of int
29 | Tuple_index of type_expr * int * int
30 | Array_index of int * int
31 | List_index of int * int
32 | String_index of string * int * int
33 | Wrong_item_type of type_expr * int
34 | Wrong_label of type_expr * string
35 | Not_a_record of type_expr
36 | No_result
37
38 exception Error of error
39
40 let abstract_type =
41 Btype.newgenty (Tconstr (Pident (Ident.create_local "<abstr>"), [], ref Mnil))
42
43 let rec address path event = function
44 | Env.Aident id ->
45 if Ident.global id then
46 try
47 Debugcom.Remote_value.global (Symtable.get_global_position id)
48 with Symtable.Error _ -> raise(Error(Unbound_identifier id))
49 else
50 begin match event with
51 Some {ev_ev = ev} ->
52 begin try
53 let pos = Ident.find_same id ev.ev_compenv.ce_stack in
54 Debugcom.Remote_value.local (ev.ev_stacksize - pos)
55 with Not_found ->
56 try
57 let pos = Ident.find_same id ev.ev_compenv.ce_heap in
58 Debugcom.Remote_value.from_environment pos
59 with Not_found ->
60 raise(Error(Unbound_identifier id))
61 end
62 | None ->
63 raise(Error(Unbound_identifier id))
64 end
65 | Env.Adot(root, pos) ->
66 let v = address path event root in
67 if not (Debugcom.Remote_value.is_block v) then
68 raise(Error(Not_initialized_yet path));
69 Debugcom.Remote_value.field v pos
70
71 let value_path event env path =
72 match Env.find_value_address path env with
73 | addr -> address path event addr
74 | exception Not_found ->
75 fatal_error ("Cannot find address for: " ^ (Path.name path))
76
77 let rec expression event env = function
78 | E_ident lid -> begin
79 match Env.find_value_by_name lid env with
80 | (p, valdesc) ->
81 let v =
82 match valdesc.val_kind with
83 | Val_ivar (_, cl_num) ->
84 let (p0, _) =
85 Env.find_value_by_name
86 (Longident.Lident ("self-" ^ cl_num)) env
87 in
88 let v = value_path event env p0 in
89 let i = value_path event env p in
90 Debugcom.Remote_value.field v (Debugcom.Remote_value.obj i)
91 | _ ->
92 value_path event env p
93 in
94 let typ = Ctype.correct_levels valdesc.val_type in
95 v, typ
96 | exception Not_found ->
97 raise(Error(Unbound_long_identifier lid))
98 end
99 | E_result ->
100 begin match event with
101 Some {ev_ev = {ev_kind = Event_after ty; ev_typsubst = subst}}
102 when !Frames.current_frame = 0 ->
103 (Debugcom.Remote_value.accu(), Subst.type_expr subst ty)
104 | _ ->
105 raise(Error(No_result))
106 end
107 | E_name n ->
108 begin try
109 Printval.find_named_value n
110 with Not_found ->
111 raise(Error(Unknown_name n))
112 end
113 | E_item(arg, n) ->
114 let (v, ty) = expression event env arg in
115 begin match (Ctype.repr(Ctype.expand_head_opt env ty)).desc with
116 Ttuple ty_list ->
117 if n < 1 || n > List.length ty_list
118 then raise(Error(Tuple_index(ty, List.length ty_list, n)))
119 else (Debugcom.Remote_value.field v (n-1), List.nth ty_list (n-1))
120 | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_array ->
121 let size = Debugcom.Remote_value.size v in
122 if n >= size
123 then raise(Error(Array_index(size, n)))
124 else (Debugcom.Remote_value.field v n, ty_arg)
125 | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list ->
126 let rec nth pos v =
127 if not (Debugcom.Remote_value.is_block v) then
128 raise(Error(List_index(pos, n)))
129 else if pos = n then
130 (Debugcom.Remote_value.field v 0, ty_arg)
131 else
132 nth (pos + 1) (Debugcom.Remote_value.field v 1)
133 in nth 0 v
134 | Tconstr(path, [], _) when Path.same path Predef.path_string ->
135 let s = (Debugcom.Remote_value.obj v : string) in
136 if n >= String.length s
137 then raise(Error(String_index(s, String.length s, n)))
138 else (Debugcom.Remote_value.of_int(Char.code s.[n]),
139 Predef.type_char)
140 | _ ->
141 raise(Error(Wrong_item_type(ty, n)))
142 end
143 | E_field(arg, lbl) ->
144 let (v, ty) = expression event env arg in
145 begin match (Ctype.repr(Ctype.expand_head_opt env ty)).desc with
146 Tconstr(path, _, _) ->
147 let tydesc = Env.find_type path env in
148 begin match tydesc.type_kind with
149 Type_record(lbl_list, _repr) ->
150 let (pos, ty_res) =
151 find_label lbl env ty path tydesc 0 lbl_list in
152 (Debugcom.Remote_value.field v pos, ty_res)
153 | _ -> raise(Error(Not_a_record ty))
154 end
155 | _ -> raise(Error(Not_a_record ty))
156 end
157
158 and find_label lbl env ty path tydesc pos = function
159 [] ->
160 raise(Error(Wrong_label(ty, lbl)))
161 | {ld_id; ld_type} :: rem ->
162 if Ident.name ld_id = lbl then begin
163 let ty_res =
164 Btype.newgenty(Tconstr(path, tydesc.type_params, ref Mnil))
165 in
166 (pos,
167 try Ctype.apply env [ty_res] ld_type [ty] with Ctype.Cannot_apply ->
168 abstract_type)
169 end else
170 find_label lbl env ty path tydesc (pos + 1) rem
171
172 (* Error report *)
173
174 open Format
175
176 let report_error ppf = function
177 | Unbound_identifier id ->
178 fprintf ppf "@[Unbound identifier %s@]@." (Ident.name id)
179 | Not_initialized_yet path ->
180 fprintf ppf
181 "@[The module path %a is not yet initialized.@ \
182 Please run program forward@ \
183 until its initialization code is executed.@]@."
184 Printtyp.path path
185 | Unbound_long_identifier lid ->
186 fprintf ppf "@[Unbound identifier %a@]@." Printtyp.longident lid
187 | Unknown_name n ->
188 fprintf ppf "@[Unknown value name $%i@]@." n
189 | Tuple_index(ty, len, pos) ->
190 fprintf ppf
191 "@[Cannot extract field number %i from a %i-tuple of type@ %a@]@."
192 pos len Printtyp.type_expr ty
193 | Array_index(len, pos) ->
194 fprintf ppf
195 "@[Cannot extract element number %i from an array of length %i@]@."
196 pos len
197 | List_index(len, pos) ->
198 fprintf ppf
199 "@[Cannot extract element number %i from a list of length %i@]@."
200 pos len
201 | String_index(s, len, pos) ->
202 fprintf ppf
203 "@[Cannot extract character number %i@ \
204 from the following string of length %i:@ %S@]@."
205 pos len s
206 | Wrong_item_type(ty, pos) ->
207 fprintf ppf
208 "@[Cannot extract item number %i from a value of type@ %a@]@."
209 pos Printtyp.type_expr ty
210 | Wrong_label(ty, lbl) ->
211 fprintf ppf
212 "@[The record type@ %a@ has no label named %s@]@."
213 Printtyp.type_expr ty lbl
214 | Not_a_record ty ->
215 fprintf ppf
216 "@[The type@ %a@ is not a record type@]@." Printtyp.type_expr ty
217 | No_result ->
218 fprintf ppf "@[No result available at current program event@]@."
219