]>
Commit | Line | Data |
---|---|---|
ed3ef339 DE |
1 | /* Scheme interface to blocks. |
2 | ||
1d506c26 | 3 | Copyright (C) 2008-2024 Free Software Foundation, Inc. |
ed3ef339 DE |
4 | |
5 | This file is part of GDB. | |
6 | ||
7 | This program is free software; you can redistribute it and/or modify | |
8 | it under the terms of the GNU General Public License as published by | |
9 | the Free Software Foundation; either version 3 of the License, or | |
10 | (at your option) any later version. | |
11 | ||
12 | This program is distributed in the hope that it will be useful, | |
13 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | GNU General Public License for more details. | |
16 | ||
17 | You should have received a copy of the GNU General Public License | |
18 | along with this program. If not, see <http://www.gnu.org/licenses/>. */ | |
19 | ||
20 | /* See README file in this directory for implementation notes, coding | |
21 | conventions, et.al. */ | |
22 | ||
23 | #include "defs.h" | |
24 | #include "block.h" | |
25 | #include "dictionary.h" | |
26 | #include "objfiles.h" | |
27 | #include "source.h" | |
28 | #include "symtab.h" | |
29 | #include "guile-internal.h" | |
30 | ||
31 | /* A smob describing a gdb block. */ | |
32 | ||
f99b5177 | 33 | struct block_smob |
ed3ef339 DE |
34 | { |
35 | /* This always appears first. | |
36 | We want blocks to be eq?-able. And we need to be able to invalidate | |
37 | blocks when the associated objfile is deleted. */ | |
38 | eqable_gdb_smob base; | |
39 | ||
40 | /* The GDB block structure that represents a frame's code block. */ | |
41 | const struct block *block; | |
42 | ||
43 | /* The backing object file. There is no direct relationship in GDB | |
44 | between a block and an object file. When a block is created also | |
45 | store a pointer to the object file for later use. */ | |
46 | struct objfile *objfile; | |
f99b5177 | 47 | }; |
ed3ef339 DE |
48 | |
49 | /* To iterate over block symbols from Scheme we need to store | |
50 | struct block_iterator somewhere. This is stored in the "progress" field | |
51 | of <gdb:iterator>. We store the block object in iterator_smob.object, | |
52 | so we don't store it here. | |
53 | ||
54 | Remember: While iterating over block symbols, you must continually check | |
55 | whether the block is still valid. */ | |
56 | ||
f99b5177 | 57 | struct block_syms_progress_smob |
ed3ef339 DE |
58 | { |
59 | /* This always appears first. */ | |
60 | gdb_smob base; | |
61 | ||
62 | /* The iterator for that block. */ | |
63 | struct block_iterator iter; | |
64 | ||
65 | /* Has the iterator been initialized flag. */ | |
66 | int initialized_p; | |
f99b5177 | 67 | }; |
ed3ef339 DE |
68 | |
69 | static const char block_smob_name[] = "gdb:block"; | |
70 | static const char block_syms_progress_smob_name[] = "gdb:block-symbols-iterator"; | |
71 | ||
72 | /* The tag Guile knows the block smobs by. */ | |
73 | static scm_t_bits block_smob_tag; | |
74 | static scm_t_bits block_syms_progress_smob_tag; | |
75 | ||
76 | /* The "next!" block syms iterator method. */ | |
77 | static SCM bkscm_next_symbol_x_proc; | |
78 | ||
08b8a139 TT |
79 | /* This is called when an objfile is about to be freed. |
80 | Invalidate the block as further actions on the block would result | |
81 | in bad data. All access to b_smob->block should be gated by | |
82 | checks to ensure the block is (still) valid. */ | |
83 | struct bkscm_deleter | |
84 | { | |
85 | /* Helper function for bkscm_del_objfile_blocks to mark the block | |
86 | as invalid. */ | |
87 | ||
88 | static int | |
89 | bkscm_mark_block_invalid (void **slot, void *info) | |
90 | { | |
91 | block_smob *b_smob = (block_smob *) *slot; | |
92 | ||
93 | b_smob->block = NULL; | |
94 | b_smob->objfile = NULL; | |
95 | return 1; | |
96 | } | |
97 | ||
98 | void operator() (htab_t htab) | |
99 | { | |
43cffa64 TT |
100 | gdb_assert (htab != nullptr); |
101 | htab_traverse_noresize (htab, bkscm_mark_block_invalid, NULL); | |
102 | htab_delete (htab); | |
08b8a139 TT |
103 | } |
104 | }; | |
105 | ||
106 | static const registry<objfile>::key<htab, bkscm_deleter> | |
107 | bkscm_objfile_data_key; | |
ed3ef339 DE |
108 | \f |
109 | /* Administrivia for block smobs. */ | |
110 | ||
111 | /* Helper function to hash a block_smob. */ | |
112 | ||
113 | static hashval_t | |
114 | bkscm_hash_block_smob (const void *p) | |
115 | { | |
9a3c8263 | 116 | const block_smob *b_smob = (const block_smob *) p; |
ed3ef339 DE |
117 | |
118 | return htab_hash_pointer (b_smob->block); | |
119 | } | |
120 | ||
121 | /* Helper function to compute equality of block_smobs. */ | |
122 | ||
123 | static int | |
124 | bkscm_eq_block_smob (const void *ap, const void *bp) | |
125 | { | |
9a3c8263 SM |
126 | const block_smob *a = (const block_smob *) ap; |
127 | const block_smob *b = (const block_smob *) bp; | |
ed3ef339 DE |
128 | |
129 | return (a->block == b->block | |
130 | && a->block != NULL); | |
131 | } | |
132 | ||
133 | /* Return the struct block pointer -> SCM mapping table. | |
134 | It is created if necessary. */ | |
135 | ||
136 | static htab_t | |
137 | bkscm_objfile_block_map (struct objfile *objfile) | |
138 | { | |
08b8a139 | 139 | htab_t htab = bkscm_objfile_data_key.get (objfile); |
ed3ef339 DE |
140 | |
141 | if (htab == NULL) | |
142 | { | |
143 | htab = gdbscm_create_eqable_gsmob_ptr_map (bkscm_hash_block_smob, | |
144 | bkscm_eq_block_smob); | |
08b8a139 | 145 | bkscm_objfile_data_key.set (objfile, htab); |
ed3ef339 DE |
146 | } |
147 | ||
148 | return htab; | |
149 | } | |
150 | ||
ed3ef339 DE |
151 | /* The smob "free" function for <gdb:block>. */ |
152 | ||
153 | static size_t | |
154 | bkscm_free_block_smob (SCM self) | |
155 | { | |
156 | block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (self); | |
157 | ||
158 | if (b_smob->block != NULL) | |
159 | { | |
160 | htab_t htab = bkscm_objfile_block_map (b_smob->objfile); | |
161 | ||
162 | gdbscm_clear_eqable_gsmob_ptr_slot (htab, &b_smob->base); | |
163 | } | |
164 | ||
165 | /* Not necessary, done to catch bugs. */ | |
166 | b_smob->block = NULL; | |
167 | b_smob->objfile = NULL; | |
168 | ||
169 | return 0; | |
170 | } | |
171 | ||
172 | /* The smob "print" function for <gdb:block>. */ | |
173 | ||
174 | static int | |
175 | bkscm_print_block_smob (SCM self, SCM port, scm_print_state *pstate) | |
176 | { | |
177 | block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (self); | |
178 | const struct block *b = b_smob->block; | |
179 | ||
180 | gdbscm_printf (port, "#<%s", block_smob_name); | |
181 | ||
f135fe72 | 182 | if (b->superblock () == NULL) |
ed3ef339 | 183 | gdbscm_printf (port, " global"); |
f135fe72 | 184 | else if (b->superblock ()->superblock () == NULL) |
ed3ef339 DE |
185 | gdbscm_printf (port, " static"); |
186 | ||
6c00f721 SM |
187 | if (b->function () != NULL) |
188 | gdbscm_printf (port, " %s", b->function ()->print_name ()); | |
ed3ef339 DE |
189 | |
190 | gdbscm_printf (port, " %s-%s", | |
4b8791e1 | 191 | hex_string (b->start ()), hex_string (b->end ())); |
ed3ef339 DE |
192 | |
193 | scm_puts (">", port); | |
194 | ||
195 | scm_remember_upto_here_1 (self); | |
196 | ||
197 | /* Non-zero means success. */ | |
198 | return 1; | |
199 | } | |
200 | ||
201 | /* Low level routine to create a <gdb:block> object. */ | |
202 | ||
203 | static SCM | |
204 | bkscm_make_block_smob (void) | |
205 | { | |
206 | block_smob *b_smob = (block_smob *) | |
207 | scm_gc_malloc (sizeof (block_smob), block_smob_name); | |
208 | SCM b_scm; | |
209 | ||
210 | b_smob->block = NULL; | |
211 | b_smob->objfile = NULL; | |
212 | b_scm = scm_new_smob (block_smob_tag, (scm_t_bits) b_smob); | |
1254eefc | 213 | gdbscm_init_eqable_gsmob (&b_smob->base, b_scm); |
ed3ef339 DE |
214 | |
215 | return b_scm; | |
216 | } | |
217 | ||
218 | /* Returns non-zero if SCM is a <gdb:block> object. */ | |
219 | ||
220 | static int | |
221 | bkscm_is_block (SCM scm) | |
222 | { | |
223 | return SCM_SMOB_PREDICATE (block_smob_tag, scm); | |
224 | } | |
225 | ||
226 | /* (block? scm) -> boolean */ | |
227 | ||
228 | static SCM | |
229 | gdbscm_block_p (SCM scm) | |
230 | { | |
231 | return scm_from_bool (bkscm_is_block (scm)); | |
232 | } | |
233 | ||
234 | /* Return the existing object that encapsulates BLOCK, or create a new | |
235 | <gdb:block> object. */ | |
236 | ||
237 | SCM | |
238 | bkscm_scm_from_block (const struct block *block, struct objfile *objfile) | |
239 | { | |
240 | htab_t htab; | |
241 | eqable_gdb_smob **slot; | |
242 | block_smob *b_smob, b_smob_for_lookup; | |
243 | SCM b_scm; | |
244 | ||
245 | /* If we've already created a gsmob for this block, return it. | |
246 | This makes blocks eq?-able. */ | |
247 | htab = bkscm_objfile_block_map (objfile); | |
248 | b_smob_for_lookup.block = block; | |
249 | slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &b_smob_for_lookup.base); | |
250 | if (*slot != NULL) | |
251 | return (*slot)->containing_scm; | |
252 | ||
253 | b_scm = bkscm_make_block_smob (); | |
254 | b_smob = (block_smob *) SCM_SMOB_DATA (b_scm); | |
255 | b_smob->block = block; | |
256 | b_smob->objfile = objfile; | |
1254eefc | 257 | gdbscm_fill_eqable_gsmob_ptr_slot (slot, &b_smob->base); |
ed3ef339 DE |
258 | |
259 | return b_scm; | |
260 | } | |
261 | ||
262 | /* Returns the <gdb:block> object in SELF. | |
263 | Throws an exception if SELF is not a <gdb:block> object. */ | |
264 | ||
265 | static SCM | |
266 | bkscm_get_block_arg_unsafe (SCM self, int arg_pos, const char *func_name) | |
267 | { | |
268 | SCM_ASSERT_TYPE (bkscm_is_block (self), self, arg_pos, func_name, | |
269 | block_smob_name); | |
270 | ||
271 | return self; | |
272 | } | |
273 | ||
274 | /* Returns a pointer to the block smob of SELF. | |
275 | Throws an exception if SELF is not a <gdb:block> object. */ | |
276 | ||
277 | static block_smob * | |
278 | bkscm_get_block_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name) | |
279 | { | |
280 | SCM b_scm = bkscm_get_block_arg_unsafe (self, arg_pos, func_name); | |
281 | block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (b_scm); | |
282 | ||
283 | return b_smob; | |
284 | } | |
285 | ||
286 | /* Returns non-zero if block B_SMOB is valid. */ | |
287 | ||
288 | static int | |
289 | bkscm_is_valid (block_smob *b_smob) | |
290 | { | |
291 | return b_smob->block != NULL; | |
292 | } | |
293 | ||
294 | /* Returns the block smob in SELF, verifying it's valid. | |
295 | Throws an exception if SELF is not a <gdb:block> object or is invalid. */ | |
296 | ||
297 | static block_smob * | |
298 | bkscm_get_valid_block_smob_arg_unsafe (SCM self, int arg_pos, | |
299 | const char *func_name) | |
300 | { | |
301 | block_smob *b_smob | |
302 | = bkscm_get_block_smob_arg_unsafe (self, arg_pos, func_name); | |
303 | ||
304 | if (!bkscm_is_valid (b_smob)) | |
305 | { | |
306 | gdbscm_invalid_object_error (func_name, arg_pos, self, | |
307 | _("<gdb:block>")); | |
308 | } | |
309 | ||
310 | return b_smob; | |
311 | } | |
312 | ||
313 | /* Returns the block smob contained in SCM or NULL if SCM is not a | |
314 | <gdb:block> object. | |
315 | If there is an error a <gdb:exception> object is stored in *EXCP. */ | |
316 | ||
317 | static block_smob * | |
318 | bkscm_get_valid_block (SCM scm, int arg_pos, const char *func_name, SCM *excp) | |
319 | { | |
320 | block_smob *b_smob; | |
321 | ||
322 | if (!bkscm_is_block (scm)) | |
323 | { | |
324 | *excp = gdbscm_make_type_error (func_name, arg_pos, scm, | |
325 | block_smob_name); | |
326 | return NULL; | |
327 | } | |
328 | ||
329 | b_smob = (block_smob *) SCM_SMOB_DATA (scm); | |
330 | if (!bkscm_is_valid (b_smob)) | |
331 | { | |
332 | *excp = gdbscm_make_invalid_object_error (func_name, arg_pos, scm, | |
333 | _("<gdb:block>")); | |
334 | return NULL; | |
335 | } | |
336 | ||
337 | return b_smob; | |
338 | } | |
339 | ||
340 | /* Returns the struct block that is wrapped by BLOCK_SCM. | |
341 | If BLOCK_SCM is not a block, or is an invalid block, then NULL is returned | |
342 | and a <gdb:exception> object is stored in *EXCP. */ | |
343 | ||
344 | const struct block * | |
345 | bkscm_scm_to_block (SCM block_scm, int arg_pos, const char *func_name, | |
346 | SCM *excp) | |
347 | { | |
348 | block_smob *b_smob; | |
349 | ||
350 | b_smob = bkscm_get_valid_block (block_scm, arg_pos, func_name, excp); | |
351 | ||
352 | if (b_smob != NULL) | |
353 | return b_smob->block; | |
354 | return NULL; | |
355 | } | |
356 | ||
ed3ef339 DE |
357 | \f |
358 | /* Block methods. */ | |
359 | ||
360 | /* (block-valid? <gdb:block>) -> boolean | |
361 | Returns #t if SELF still exists in GDB. */ | |
362 | ||
363 | static SCM | |
364 | gdbscm_block_valid_p (SCM self) | |
365 | { | |
366 | block_smob *b_smob | |
367 | = bkscm_get_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); | |
368 | ||
369 | return scm_from_bool (bkscm_is_valid (b_smob)); | |
370 | } | |
371 | ||
372 | /* (block-start <gdb:block>) -> address */ | |
373 | ||
374 | static SCM | |
375 | gdbscm_block_start (SCM self) | |
376 | { | |
377 | block_smob *b_smob | |
378 | = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); | |
379 | const struct block *block = b_smob->block; | |
380 | ||
4b8791e1 | 381 | return gdbscm_scm_from_ulongest (block->start ()); |
ed3ef339 DE |
382 | } |
383 | ||
384 | /* (block-end <gdb:block>) -> address */ | |
385 | ||
386 | static SCM | |
387 | gdbscm_block_end (SCM self) | |
388 | { | |
389 | block_smob *b_smob | |
390 | = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); | |
391 | const struct block *block = b_smob->block; | |
392 | ||
4b8791e1 | 393 | return gdbscm_scm_from_ulongest (block->end ()); |
ed3ef339 DE |
394 | } |
395 | ||
396 | /* (block-function <gdb:block>) -> <gdb:symbol> */ | |
397 | ||
398 | static SCM | |
399 | gdbscm_block_function (SCM self) | |
400 | { | |
401 | block_smob *b_smob | |
402 | = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); | |
403 | const struct block *block = b_smob->block; | |
404 | struct symbol *sym; | |
405 | ||
6c00f721 | 406 | sym = block->function (); |
ed3ef339 DE |
407 | |
408 | if (sym != NULL) | |
409 | return syscm_scm_from_symbol (sym); | |
410 | return SCM_BOOL_F; | |
411 | } | |
412 | ||
413 | /* (block-superblock <gdb:block>) -> <gdb:block> */ | |
414 | ||
415 | static SCM | |
416 | gdbscm_block_superblock (SCM self) | |
417 | { | |
418 | block_smob *b_smob | |
419 | = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); | |
420 | const struct block *block = b_smob->block; | |
421 | const struct block *super_block; | |
422 | ||
f135fe72 | 423 | super_block = block->superblock (); |
ed3ef339 DE |
424 | |
425 | if (super_block) | |
426 | return bkscm_scm_from_block (super_block, b_smob->objfile); | |
427 | return SCM_BOOL_F; | |
428 | } | |
429 | ||
430 | /* (block-global-block <gdb:block>) -> <gdb:block> | |
431 | Returns the global block associated to this block. */ | |
432 | ||
433 | static SCM | |
434 | gdbscm_block_global_block (SCM self) | |
435 | { | |
436 | block_smob *b_smob | |
437 | = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); | |
438 | const struct block *block = b_smob->block; | |
439 | const struct block *global_block; | |
440 | ||
d24e14a0 | 441 | global_block = block->global_block (); |
ed3ef339 DE |
442 | |
443 | return bkscm_scm_from_block (global_block, b_smob->objfile); | |
444 | } | |
445 | ||
446 | /* (block-static-block <gdb:block>) -> <gdb:block> | |
447 | Returns the static block associated to this block. | |
448 | Returns #f if we cannot get the static block (this is the global block). */ | |
449 | ||
450 | static SCM | |
451 | gdbscm_block_static_block (SCM self) | |
452 | { | |
453 | block_smob *b_smob | |
454 | = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); | |
455 | const struct block *block = b_smob->block; | |
456 | const struct block *static_block; | |
457 | ||
f135fe72 | 458 | if (block->superblock () == NULL) |
ed3ef339 DE |
459 | return SCM_BOOL_F; |
460 | ||
d24e14a0 | 461 | static_block = block->static_block (); |
ed3ef339 DE |
462 | |
463 | return bkscm_scm_from_block (static_block, b_smob->objfile); | |
464 | } | |
465 | ||
466 | /* (block-global? <gdb:block>) -> boolean | |
467 | Returns #t if this block object is a global block. */ | |
468 | ||
469 | static SCM | |
470 | gdbscm_block_global_p (SCM self) | |
471 | { | |
472 | block_smob *b_smob | |
473 | = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); | |
474 | const struct block *block = b_smob->block; | |
475 | ||
f135fe72 | 476 | return scm_from_bool (block->superblock () == NULL); |
ed3ef339 DE |
477 | } |
478 | ||
479 | /* (block-static? <gdb:block>) -> boolean | |
480 | Returns #t if this block object is a static block. */ | |
481 | ||
482 | static SCM | |
483 | gdbscm_block_static_p (SCM self) | |
484 | { | |
485 | block_smob *b_smob | |
486 | = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); | |
487 | const struct block *block = b_smob->block; | |
488 | ||
f135fe72 SM |
489 | if (block->superblock () != NULL |
490 | && block->superblock ()->superblock () == NULL) | |
ed3ef339 DE |
491 | return SCM_BOOL_T; |
492 | return SCM_BOOL_F; | |
493 | } | |
494 | ||
495 | /* (block-symbols <gdb:block>) -> list of <gdb:symbol objects | |
496 | Returns a list of symbols of the block. */ | |
497 | ||
498 | static SCM | |
499 | gdbscm_block_symbols (SCM self) | |
500 | { | |
501 | block_smob *b_smob | |
502 | = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); | |
503 | const struct block *block = b_smob->block; | |
ed3ef339 DE |
504 | SCM result; |
505 | ||
506 | result = SCM_EOL; | |
507 | ||
1c49bb45 | 508 | for (struct symbol *sym : block_iterator_range (block)) |
ed3ef339 DE |
509 | { |
510 | SCM s_scm = syscm_scm_from_symbol (sym); | |
511 | ||
512 | result = scm_cons (s_scm, result); | |
ed3ef339 DE |
513 | } |
514 | ||
515 | return scm_reverse_x (result, SCM_EOL); | |
516 | } | |
517 | \f | |
518 | /* The <gdb:block-symbols-iterator> object, | |
519 | for iterating over all symbols in a block. */ | |
520 | ||
ed3ef339 DE |
521 | /* The smob "print" function for <gdb:block-symbols-iterator>. */ |
522 | ||
523 | static int | |
524 | bkscm_print_block_syms_progress_smob (SCM self, SCM port, | |
525 | scm_print_state *pstate) | |
526 | { | |
527 | block_syms_progress_smob *i_smob | |
528 | = (block_syms_progress_smob *) SCM_SMOB_DATA (self); | |
529 | ||
530 | gdbscm_printf (port, "#<%s", block_syms_progress_smob_name); | |
531 | ||
532 | if (i_smob->initialized_p) | |
533 | { | |
534 | switch (i_smob->iter.which) | |
535 | { | |
536 | case GLOBAL_BLOCK: | |
537 | case STATIC_BLOCK: | |
538 | { | |
43f3e411 | 539 | struct compunit_symtab *cust; |
ed3ef339 DE |
540 | |
541 | gdbscm_printf (port, " %s", | |
542 | i_smob->iter.which == GLOBAL_BLOCK | |
543 | ? "global" : "static"); | |
544 | if (i_smob->iter.idx != -1) | |
545 | gdbscm_printf (port, " @%d", i_smob->iter.idx); | |
43f3e411 DE |
546 | cust = (i_smob->iter.idx == -1 |
547 | ? i_smob->iter.d.compunit_symtab | |
548 | : i_smob->iter.d.compunit_symtab->includes[i_smob->iter.idx]); | |
549 | gdbscm_printf (port, " %s", | |
550 | symtab_to_filename_for_display | |
0b17a4f7 | 551 | (cust->primary_filetab ())); |
ed3ef339 DE |
552 | break; |
553 | } | |
554 | case FIRST_LOCAL_BLOCK: | |
555 | gdbscm_printf (port, " single block"); | |
556 | break; | |
557 | } | |
558 | } | |
559 | else | |
560 | gdbscm_printf (port, " !initialized"); | |
561 | ||
562 | scm_puts (">", port); | |
563 | ||
564 | scm_remember_upto_here_1 (self); | |
565 | ||
566 | /* Non-zero means success. */ | |
567 | return 1; | |
568 | } | |
569 | ||
570 | /* Low level routine to create a <gdb:block-symbols-progress> object. */ | |
571 | ||
572 | static SCM | |
573 | bkscm_make_block_syms_progress_smob (void) | |
574 | { | |
575 | block_syms_progress_smob *i_smob = (block_syms_progress_smob *) | |
576 | scm_gc_malloc (sizeof (block_syms_progress_smob), | |
577 | block_syms_progress_smob_name); | |
578 | SCM smob; | |
579 | ||
580 | memset (&i_smob->iter, 0, sizeof (i_smob->iter)); | |
581 | i_smob->initialized_p = 0; | |
582 | smob = scm_new_smob (block_syms_progress_smob_tag, (scm_t_bits) i_smob); | |
583 | gdbscm_init_gsmob (&i_smob->base); | |
584 | ||
585 | return smob; | |
586 | } | |
587 | ||
588 | /* Returns non-zero if SCM is a <gdb:block-symbols-progress> object. */ | |
589 | ||
590 | static int | |
591 | bkscm_is_block_syms_progress (SCM scm) | |
592 | { | |
593 | return SCM_SMOB_PREDICATE (block_syms_progress_smob_tag, scm); | |
594 | } | |
595 | ||
596 | /* (block-symbols-progress? scm) -> boolean */ | |
597 | ||
598 | static SCM | |
599 | bkscm_block_syms_progress_p (SCM scm) | |
600 | { | |
601 | return scm_from_bool (bkscm_is_block_syms_progress (scm)); | |
602 | } | |
603 | ||
604 | /* (make-block-symbols-iterator <gdb:block>) -> <gdb:iterator> | |
605 | Return a <gdb:iterator> object for iterating over the symbols of SELF. */ | |
606 | ||
607 | static SCM | |
608 | gdbscm_make_block_syms_iter (SCM self) | |
609 | { | |
d5e9a511 TT |
610 | /* Call for side effects. */ |
611 | bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); | |
ed3ef339 DE |
612 | SCM progress, iter; |
613 | ||
614 | progress = bkscm_make_block_syms_progress_smob (); | |
615 | ||
616 | iter = gdbscm_make_iterator (self, progress, bkscm_next_symbol_x_proc); | |
617 | ||
618 | return iter; | |
619 | } | |
620 | ||
621 | /* Returns the next symbol in the iteration through the block's dictionary, | |
622 | or (end-of-iteration). | |
623 | This is the iterator_smob.next_x method. */ | |
624 | ||
625 | static SCM | |
626 | gdbscm_block_next_symbol_x (SCM self) | |
627 | { | |
628 | SCM progress, iter_scm, block_scm; | |
629 | iterator_smob *iter_smob; | |
630 | block_smob *b_smob; | |
631 | const struct block *block; | |
632 | block_syms_progress_smob *p_smob; | |
633 | struct symbol *sym; | |
634 | ||
635 | iter_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME); | |
636 | iter_smob = (iterator_smob *) SCM_SMOB_DATA (iter_scm); | |
637 | ||
638 | block_scm = itscm_iterator_smob_object (iter_smob); | |
639 | b_smob = bkscm_get_valid_block_smob_arg_unsafe (block_scm, | |
640 | SCM_ARG1, FUNC_NAME); | |
641 | block = b_smob->block; | |
642 | ||
643 | progress = itscm_iterator_smob_progress (iter_smob); | |
644 | ||
645 | SCM_ASSERT_TYPE (bkscm_is_block_syms_progress (progress), | |
646 | progress, SCM_ARG1, FUNC_NAME, | |
647 | block_syms_progress_smob_name); | |
648 | p_smob = (block_syms_progress_smob *) SCM_SMOB_DATA (progress); | |
649 | ||
650 | if (!p_smob->initialized_p) | |
651 | { | |
652 | sym = block_iterator_first (block, &p_smob->iter); | |
653 | p_smob->initialized_p = 1; | |
654 | } | |
655 | else | |
656 | sym = block_iterator_next (&p_smob->iter); | |
657 | ||
658 | if (sym == NULL) | |
659 | return gdbscm_end_of_iteration (); | |
660 | ||
661 | return syscm_scm_from_symbol (sym); | |
662 | } | |
663 | \f | |
664 | /* (lookup-block address) -> <gdb:block> | |
665 | Returns the innermost lexical block containing the specified pc value, | |
666 | or #f if there is none. */ | |
667 | ||
668 | static SCM | |
669 | gdbscm_lookup_block (SCM pc_scm) | |
670 | { | |
671 | CORE_ADDR pc; | |
3977b71f | 672 | const struct block *block = NULL; |
43f3e411 | 673 | struct compunit_symtab *cust = NULL; |
ed3ef339 DE |
674 | |
675 | gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "U", pc_scm, &pc); | |
676 | ||
680d7fd5 | 677 | gdbscm_gdb_exception exc {}; |
a70b8144 | 678 | try |
ed3ef339 | 679 | { |
43f3e411 | 680 | cust = find_pc_compunit_symtab (pc); |
ed3ef339 | 681 | |
9821f3fa | 682 | if (cust != NULL && cust->objfile () != NULL) |
ed3ef339 DE |
683 | block = block_for_pc (pc); |
684 | } | |
230d2906 | 685 | catch (const gdb_exception &except) |
492d29ea | 686 | { |
680d7fd5 | 687 | exc = unpack (except); |
492d29ea | 688 | } |
ed3ef339 | 689 | |
680d7fd5 | 690 | GDBSCM_HANDLE_GDB_EXCEPTION (exc); |
9821f3fa | 691 | if (cust == NULL || cust->objfile () == NULL) |
ed3ef339 DE |
692 | { |
693 | gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, pc_scm, | |
694 | _("cannot locate object file for block")); | |
695 | } | |
696 | ||
697 | if (block != NULL) | |
9821f3fa | 698 | return bkscm_scm_from_block (block, cust->objfile ()); |
ed3ef339 DE |
699 | return SCM_BOOL_F; |
700 | } | |
701 | \f | |
702 | /* Initialize the Scheme block support. */ | |
703 | ||
704 | static const scheme_function block_functions[] = | |
705 | { | |
72e02483 | 706 | { "block?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_p), |
ed3ef339 DE |
707 | "\ |
708 | Return #t if the object is a <gdb:block> object." }, | |
709 | ||
72e02483 | 710 | { "block-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_valid_p), |
ed3ef339 DE |
711 | "\ |
712 | Return #t if the block is valid.\n\ | |
713 | A block becomes invalid when its objfile is freed." }, | |
714 | ||
72e02483 | 715 | { "block-start", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_start), |
ed3ef339 DE |
716 | "\ |
717 | Return the start address of the block." }, | |
718 | ||
72e02483 | 719 | { "block-end", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_end), |
ed3ef339 DE |
720 | "\ |
721 | Return the end address of the block." }, | |
722 | ||
72e02483 | 723 | { "block-function", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_function), |
ed3ef339 DE |
724 | "\ |
725 | Return the gdb:symbol object of the function containing the block\n\ | |
726 | or #f if the block does not live in any function." }, | |
727 | ||
72e02483 | 728 | { "block-superblock", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_superblock), |
ed3ef339 DE |
729 | "\ |
730 | Return the superblock (parent block) of the block." }, | |
731 | ||
72e02483 | 732 | { "block-global-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_global_block), |
ed3ef339 DE |
733 | "\ |
734 | Return the global block of the block." }, | |
735 | ||
72e02483 | 736 | { "block-static-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_static_block), |
ed3ef339 DE |
737 | "\ |
738 | Return the static block of the block." }, | |
739 | ||
72e02483 | 740 | { "block-global?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_global_p), |
ed3ef339 DE |
741 | "\ |
742 | Return #t if block is a global block." }, | |
743 | ||
72e02483 | 744 | { "block-static?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_static_p), |
ed3ef339 DE |
745 | "\ |
746 | Return #t if block is a static block." }, | |
747 | ||
72e02483 | 748 | { "block-symbols", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_symbols), |
ed3ef339 DE |
749 | "\ |
750 | Return a list of all symbols (as <gdb:symbol> objects) in the block." }, | |
751 | ||
72e02483 PA |
752 | { "make-block-symbols-iterator", 1, 0, 0, |
753 | as_a_scm_t_subr (gdbscm_make_block_syms_iter), | |
ed3ef339 DE |
754 | "\ |
755 | Return a <gdb:iterator> object for iterating over all symbols in the block." }, | |
756 | ||
72e02483 PA |
757 | { "block-symbols-progress?", 1, 0, 0, |
758 | as_a_scm_t_subr (bkscm_block_syms_progress_p), | |
ed3ef339 DE |
759 | "\ |
760 | Return #t if the object is a <gdb:block-symbols-progress> object." }, | |
761 | ||
72e02483 | 762 | { "lookup-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_lookup_block), |
ed3ef339 DE |
763 | "\ |
764 | Return the innermost GDB block containing the address or #f if none found.\n\ | |
765 | \n\ | |
766 | Arguments:\n\ | |
767 | address: the address to lookup" }, | |
768 | ||
769 | END_FUNCTIONS | |
770 | }; | |
771 | ||
772 | void | |
773 | gdbscm_initialize_blocks (void) | |
774 | { | |
775 | block_smob_tag | |
776 | = gdbscm_make_smob_type (block_smob_name, sizeof (block_smob)); | |
ed3ef339 DE |
777 | scm_set_smob_free (block_smob_tag, bkscm_free_block_smob); |
778 | scm_set_smob_print (block_smob_tag, bkscm_print_block_smob); | |
779 | ||
780 | block_syms_progress_smob_tag | |
781 | = gdbscm_make_smob_type (block_syms_progress_smob_name, | |
782 | sizeof (block_syms_progress_smob)); | |
ed3ef339 DE |
783 | scm_set_smob_print (block_syms_progress_smob_tag, |
784 | bkscm_print_block_syms_progress_smob); | |
785 | ||
786 | gdbscm_define_functions (block_functions, 1); | |
787 | ||
788 | /* This function is "private". */ | |
789 | bkscm_next_symbol_x_proc | |
790 | = scm_c_define_gsubr ("%block-next-symbol!", 1, 0, 0, | |
72e02483 | 791 | as_a_scm_t_subr (gdbscm_block_next_symbol_x)); |
ed3ef339 DE |
792 | scm_set_procedure_property_x (bkscm_next_symbol_x_proc, |
793 | gdbscm_documentation_symbol, | |
794 | gdbscm_scm_from_c_string ("\ | |
795 | Internal function to assist the block symbols iterator.")); | |
880ae75a | 796 | } |