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