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