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
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
|
(**************************************************************************)
(* *)
(* 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. *)
(* *)
(**************************************************************************)
open Misc
open Path
open Instruct
open Types
open Parser_aux
open Events
type error =
Unbound_identifier of Ident.t
| Not_initialized_yet of Path.t
| Unbound_long_identifier of Longident.t
| Unknown_name of int
| Tuple_index of type_expr * int * int
| Array_index of int * int
| List_index of int * int
| String_index of string * int * int
| Wrong_item_type of type_expr * int
| Wrong_label of type_expr * string
| Not_a_record of type_expr
| No_result
exception Error of error
let abstract_type =
Btype.newgenty (Tconstr (Pident (Ident.create_local "<abstr>"), [], ref Mnil))
let rec address path event = function
| Env.Aident id ->
if Ident.global id then
try
Debugcom.Remote_value.global (Symtable.get_global_position id)
with Symtable.Error _ -> raise(Error(Unbound_identifier id))
else
begin match event with
Some {ev_ev = ev} ->
begin try
let pos = Ident.find_same id ev.ev_compenv.ce_stack in
Debugcom.Remote_value.local (ev.ev_stacksize - pos)
with Not_found ->
try
let pos = Ident.find_same id ev.ev_compenv.ce_heap in
Debugcom.Remote_value.from_environment pos
with Not_found ->
raise(Error(Unbound_identifier id))
end
| None ->
raise(Error(Unbound_identifier id))
end
| Env.Adot(root, pos) ->
let v = address path event root in
if not (Debugcom.Remote_value.is_block v) then
raise(Error(Not_initialized_yet path));
Debugcom.Remote_value.field v pos
let value_path event env path =
match Env.find_value_address path env with
| addr -> address path event addr
| exception Not_found ->
fatal_error ("Cannot find address for: " ^ (Path.name path))
let rec expression event env = function
| E_ident lid -> begin
match Env.find_value_by_name lid env with
| (p, valdesc) ->
let v =
match valdesc.val_kind with
| Val_ivar (_, cl_num) ->
let (p0, _) =
Env.find_value_by_name
(Longident.Lident ("self-" ^ cl_num)) env
in
let v = value_path event env p0 in
let i = value_path event env p in
Debugcom.Remote_value.field v (Debugcom.Remote_value.obj i)
| _ ->
value_path event env p
in
let typ = Ctype.correct_levels valdesc.val_type in
v, typ
| exception Not_found ->
raise(Error(Unbound_long_identifier lid))
end
| E_result ->
begin match event with
Some {ev_ev = {ev_kind = Event_after ty; ev_typsubst = subst}}
when !Frames.current_frame = 0 ->
(Debugcom.Remote_value.accu(), Subst.type_expr subst ty)
| _ ->
raise(Error(No_result))
end
| E_name n ->
begin try
Printval.find_named_value n
with Not_found ->
raise(Error(Unknown_name n))
end
| E_item(arg, n) ->
let (v, ty) = expression event env arg in
begin match get_desc (Ctype.expand_head_opt env ty) with
Ttuple ty_list ->
if n < 1 || n > List.length ty_list
then raise(Error(Tuple_index(ty, List.length ty_list, n)))
else (Debugcom.Remote_value.field v (n-1), List.nth ty_list (n-1))
| Tconstr(path, [ty_arg], _) when Path.same path Predef.path_array ->
let size = Debugcom.Remote_value.size v in
if n >= size
then raise(Error(Array_index(size, n)))
else (Debugcom.Remote_value.field v n, ty_arg)
| Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list ->
let rec nth pos v =
if not (Debugcom.Remote_value.is_block v) then
raise(Error(List_index(pos, n)))
else if pos = n then
(Debugcom.Remote_value.field v 0, ty_arg)
else
nth (pos + 1) (Debugcom.Remote_value.field v 1)
in nth 0 v
| Tconstr(path, [], _) when Path.same path Predef.path_string ->
let s = (Debugcom.Remote_value.obj v : string) in
if n >= String.length s
then raise(Error(String_index(s, String.length s, n)))
else (Debugcom.Remote_value.of_int(Char.code s.[n]),
Predef.type_char)
| _ ->
raise(Error(Wrong_item_type(ty, n)))
end
| E_field(arg, lbl) ->
let (v, ty) = expression event env arg in
begin match get_desc (Ctype.expand_head_opt env ty) with
Tconstr(path, _, _) ->
let tydesc = Env.find_type path env in
begin match tydesc.type_kind with
Type_record(lbl_list, _repr) ->
let (pos, ty_res) =
find_label lbl env ty path tydesc 0 lbl_list in
(Debugcom.Remote_value.field v pos, ty_res)
| _ -> raise(Error(Not_a_record ty))
end
| _ -> raise(Error(Not_a_record ty))
end
and find_label lbl env ty path tydesc pos = function
[] ->
raise(Error(Wrong_label(ty, lbl)))
| {ld_id; ld_type} :: rem ->
if Ident.name ld_id = lbl then begin
let ty_res =
Btype.newgenty(Tconstr(path, tydesc.type_params, ref Mnil))
in
(pos,
try Ctype.apply env [ty_res] ld_type [ty] with Ctype.Cannot_apply ->
abstract_type)
end else
find_label lbl env ty path tydesc (pos + 1) rem
(* Error report *)
open Format
let report_error ppf = function
| Unbound_identifier id ->
fprintf ppf "@[Unbound identifier %s@]@." (Ident.name id)
| Not_initialized_yet path ->
fprintf ppf
"@[The module path %a is not yet initialized.@ \
Please run program forward@ \
until its initialization code is executed.@]@."
Printtyp.path path
| Unbound_long_identifier lid ->
fprintf ppf "@[Unbound identifier %a@]@." Printtyp.longident lid
| Unknown_name n ->
fprintf ppf "@[Unknown value name $%i@]@." n
| Tuple_index(ty, len, pos) ->
fprintf ppf
"@[Cannot extract field number %i from a %i-tuple of type@ %a@]@."
pos len Printtyp.type_expr ty
| Array_index(len, pos) ->
fprintf ppf
"@[Cannot extract element number %i from an array of length %i@]@."
pos len
| List_index(len, pos) ->
fprintf ppf
"@[Cannot extract element number %i from a list of length %i@]@."
pos len
| String_index(s, len, pos) ->
fprintf ppf
"@[Cannot extract character number %i@ \
from the following string of length %i:@ %S@]@."
pos len s
| Wrong_item_type(ty, pos) ->
fprintf ppf
"@[Cannot extract item number %i from a value of type@ %a@]@."
pos Printtyp.type_expr ty
| Wrong_label(ty, lbl) ->
fprintf ppf
"@[The record type@ %a@ has no label named %s@]@."
Printtyp.type_expr ty lbl
| Not_a_record ty ->
fprintf ppf
"@[The type@ %a@ is not a record type@]@." Printtyp.type_expr ty
| No_result ->
fprintf ppf "@[No result available at current program event@]@."
|
