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
|
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
(* Objective Caml 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 Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* $Id$ *)
open Debugger_config
open Misc
open Path
open Instruct
open Types
open Parser_aux
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 "<abstr>"), [], ref Mnil))
let rec path event = function
Pident id ->
if Ident.global id then
Debugcom.Remote_value.global (Symtable.get_global_position id)
else
begin match event with
Some 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
| Pdot(root, fieldname, pos) ->
let v = path event root in
if not (Debugcom.Remote_value.is_block v) then
raise(Error(Not_initialized_yet root));
Debugcom.Remote_value.field v pos
| Papply(p1, p2) ->
fatal_error "Eval.path: Papply"
let rec expression event env = function
E_ident lid ->
begin try
let (p, valdesc) = Env.lookup_value lid env in
(begin match valdesc.val_kind with
Val_ivar (_, cl_num) ->
let (p0, _) =
Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
in
let v = path event p0 in
let i = path event p in
Debugcom.Remote_value.field v (Debugcom.Remote_value.obj i)
| _ ->
path event p
end,
Ctype.correct_levels valdesc.val_type)
with Not_found ->
raise(Error(Unbound_long_identifier lid))
end
| E_result ->
begin match event with
Some {ev_kind = Event_after ty} when !Frames.current_frame = 0 ->
(Debugcom.Remote_value.accu(), 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 (Ctype.repr(Ctype.expand_head env ty)).desc 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 (Ctype.repr(Ctype.expand_head env ty)).desc with
Tconstr(path, args, _) ->
let tydesc = Env.find_type path env in
begin match tydesc.type_kind with
Type_record lbl_list ->
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)))
| (name, mut, ty_arg) :: rem ->
if name = lbl then begin
let ty_res =
Btype.newgenty(Tconstr(path, tydesc.type_params, ref Mnil))
in
(pos,
try Ctype.apply env [ty_res] ty_arg [ty] with Ctype.Cannot_apply ->
abstract_type)
end else
find_label lbl env ty path tydesc (pos + 1) rem
(* Error report *)
open Formatmsg
let report_error error =
open_box 0;
begin match error with
Unbound_identifier id ->
print_string "Unbound identifier "; print_string (Ident.name id)
| Not_initialized_yet path ->
print_string "The module path "; Printtyp.path path;
print_string " is not yet initialized."; print_space();
print_string "Please run program forward until its initialization code is executed."
| Unbound_long_identifier lid ->
print_string "Unbound identifier "; Printtyp.longident lid
| Unknown_name n ->
print_string "Unknown value name $"; print_int n
| Tuple_index(ty, len, pos) ->
print_string "Cannot extract field number "; print_int pos;
print_string " from a "; print_int len;
print_string "-components tuple of type ";
Printtyp.reset (); Printtyp.mark_loops ty;
print_space(); Printtyp.type_expr ty
| Array_index(len, pos) ->
print_string "Cannot extract element number "; print_int pos;
print_string " from array of length "; print_int len
| List_index(len, pos) ->
print_string "Cannot extract element number "; print_int pos;
print_string " from list of length "; print_int len
| String_index(s, len, pos) ->
print_string "Cannot extract character number "; print_int pos;
print_string " from the following string of length "; print_int len;
print_string ":"; print_space();
print_char '"'; print_string(String.escaped s); print_char '"'
| Wrong_item_type(ty, pos) ->
print_string "Cannot extract item number "; print_int pos;
print_string " from a value of type"; print_space();
Printtyp.type_expr ty
| Wrong_label(ty, lbl) ->
print_string "The record type"; print_space(); Printtyp.type_expr ty;
print_space(); print_string " has no label named "; print_string lbl
| Not_a_record ty ->
print_string "The type"; print_space(); Printtyp.type_expr ty;
print_space(); print_string " is not a record type"
| No_result ->
print_string "No result available at current program event"
end;
close_box(); print_newline()
|
