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