Commit | Line | Data |
---|---|---|
ed3ef339 DE |
1 | /* Scheme interface to blocks. |
2 | ||
618f726f | 3 | Copyright (C) 2008-2016 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 | ||
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 | { | |
9a3c8263 | 88 | const block_smob *b_smob = (const block_smob *) p; |
ed3ef339 DE |
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 | { | |
9a3c8263 SM |
98 | const block_smob *a = (const block_smob *) ap; |
99 | const block_smob *b = (const block_smob *) bp; | |
ed3ef339 DE |
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 | { | |
9a3c8263 | 111 | htab_t htab = (htab_t) objfile_data (objfile, bkscm_objfile_data_key); |
ed3ef339 DE |
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 | { | |
9a3c8263 | 350 | htab_t htab = (htab_t) datum; |
ed3ef339 DE |
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 | { | |
43f3e411 | 545 | struct compunit_symtab *cust; |
ed3ef339 DE |
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); | |
43f3e411 DE |
552 | cust = (i_smob->iter.idx == -1 |
553 | ? i_smob->iter.d.compunit_symtab | |
554 | : i_smob->iter.d.compunit_symtab->includes[i_smob->iter.idx]); | |
555 | gdbscm_printf (port, " %s", | |
556 | symtab_to_filename_for_display | |
557 | (compunit_primary_filetab (cust))); | |
ed3ef339 DE |
558 | break; |
559 | } | |
560 | case FIRST_LOCAL_BLOCK: | |
561 | gdbscm_printf (port, " single block"); | |
562 | break; | |
563 | } | |
564 | } | |
565 | else | |
566 | gdbscm_printf (port, " !initialized"); | |
567 | ||
568 | scm_puts (">", port); | |
569 | ||
570 | scm_remember_upto_here_1 (self); | |
571 | ||
572 | /* Non-zero means success. */ | |
573 | return 1; | |
574 | } | |
575 | ||
576 | /* Low level routine to create a <gdb:block-symbols-progress> object. */ | |
577 | ||
578 | static SCM | |
579 | bkscm_make_block_syms_progress_smob (void) | |
580 | { | |
581 | block_syms_progress_smob *i_smob = (block_syms_progress_smob *) | |
582 | scm_gc_malloc (sizeof (block_syms_progress_smob), | |
583 | block_syms_progress_smob_name); | |
584 | SCM smob; | |
585 | ||
586 | memset (&i_smob->iter, 0, sizeof (i_smob->iter)); | |
587 | i_smob->initialized_p = 0; | |
588 | smob = scm_new_smob (block_syms_progress_smob_tag, (scm_t_bits) i_smob); | |
589 | gdbscm_init_gsmob (&i_smob->base); | |
590 | ||
591 | return smob; | |
592 | } | |
593 | ||
594 | /* Returns non-zero if SCM is a <gdb:block-symbols-progress> object. */ | |
595 | ||
596 | static int | |
597 | bkscm_is_block_syms_progress (SCM scm) | |
598 | { | |
599 | return SCM_SMOB_PREDICATE (block_syms_progress_smob_tag, scm); | |
600 | } | |
601 | ||
602 | /* (block-symbols-progress? scm) -> boolean */ | |
603 | ||
604 | static SCM | |
605 | bkscm_block_syms_progress_p (SCM scm) | |
606 | { | |
607 | return scm_from_bool (bkscm_is_block_syms_progress (scm)); | |
608 | } | |
609 | ||
610 | /* (make-block-symbols-iterator <gdb:block>) -> <gdb:iterator> | |
611 | Return a <gdb:iterator> object for iterating over the symbols of SELF. */ | |
612 | ||
613 | static SCM | |
614 | gdbscm_make_block_syms_iter (SCM self) | |
615 | { | |
616 | block_smob *b_smob | |
617 | = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); | |
618 | const struct block *block = b_smob->block; | |
619 | SCM progress, iter; | |
620 | ||
621 | progress = bkscm_make_block_syms_progress_smob (); | |
622 | ||
623 | iter = gdbscm_make_iterator (self, progress, bkscm_next_symbol_x_proc); | |
624 | ||
625 | return iter; | |
626 | } | |
627 | ||
628 | /* Returns the next symbol in the iteration through the block's dictionary, | |
629 | or (end-of-iteration). | |
630 | This is the iterator_smob.next_x method. */ | |
631 | ||
632 | static SCM | |
633 | gdbscm_block_next_symbol_x (SCM self) | |
634 | { | |
635 | SCM progress, iter_scm, block_scm; | |
636 | iterator_smob *iter_smob; | |
637 | block_smob *b_smob; | |
638 | const struct block *block; | |
639 | block_syms_progress_smob *p_smob; | |
640 | struct symbol *sym; | |
641 | ||
642 | iter_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME); | |
643 | iter_smob = (iterator_smob *) SCM_SMOB_DATA (iter_scm); | |
644 | ||
645 | block_scm = itscm_iterator_smob_object (iter_smob); | |
646 | b_smob = bkscm_get_valid_block_smob_arg_unsafe (block_scm, | |
647 | SCM_ARG1, FUNC_NAME); | |
648 | block = b_smob->block; | |
649 | ||
650 | progress = itscm_iterator_smob_progress (iter_smob); | |
651 | ||
652 | SCM_ASSERT_TYPE (bkscm_is_block_syms_progress (progress), | |
653 | progress, SCM_ARG1, FUNC_NAME, | |
654 | block_syms_progress_smob_name); | |
655 | p_smob = (block_syms_progress_smob *) SCM_SMOB_DATA (progress); | |
656 | ||
657 | if (!p_smob->initialized_p) | |
658 | { | |
659 | sym = block_iterator_first (block, &p_smob->iter); | |
660 | p_smob->initialized_p = 1; | |
661 | } | |
662 | else | |
663 | sym = block_iterator_next (&p_smob->iter); | |
664 | ||
665 | if (sym == NULL) | |
666 | return gdbscm_end_of_iteration (); | |
667 | ||
668 | return syscm_scm_from_symbol (sym); | |
669 | } | |
670 | \f | |
671 | /* (lookup-block address) -> <gdb:block> | |
672 | Returns the innermost lexical block containing the specified pc value, | |
673 | or #f if there is none. */ | |
674 | ||
675 | static SCM | |
676 | gdbscm_lookup_block (SCM pc_scm) | |
677 | { | |
678 | CORE_ADDR pc; | |
3977b71f | 679 | const struct block *block = NULL; |
43f3e411 | 680 | struct compunit_symtab *cust = NULL; |
ed3ef339 DE |
681 | |
682 | gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "U", pc_scm, &pc); | |
683 | ||
492d29ea | 684 | TRY |
ed3ef339 | 685 | { |
43f3e411 | 686 | cust = find_pc_compunit_symtab (pc); |
ed3ef339 | 687 | |
43f3e411 | 688 | if (cust != NULL && COMPUNIT_OBJFILE (cust) != NULL) |
ed3ef339 DE |
689 | block = block_for_pc (pc); |
690 | } | |
492d29ea PA |
691 | CATCH (except, RETURN_MASK_ALL) |
692 | { | |
693 | GDBSCM_HANDLE_GDB_EXCEPTION (except); | |
694 | } | |
695 | END_CATCH | |
ed3ef339 | 696 | |
43f3e411 | 697 | if (cust == NULL || COMPUNIT_OBJFILE (cust) == NULL) |
ed3ef339 DE |
698 | { |
699 | gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, pc_scm, | |
700 | _("cannot locate object file for block")); | |
701 | } | |
702 | ||
703 | if (block != NULL) | |
43f3e411 | 704 | return bkscm_scm_from_block (block, COMPUNIT_OBJFILE (cust)); |
ed3ef339 DE |
705 | return SCM_BOOL_F; |
706 | } | |
707 | \f | |
708 | /* Initialize the Scheme block support. */ | |
709 | ||
710 | static const scheme_function block_functions[] = | |
711 | { | |
72e02483 | 712 | { "block?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_p), |
ed3ef339 DE |
713 | "\ |
714 | Return #t if the object is a <gdb:block> object." }, | |
715 | ||
72e02483 | 716 | { "block-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_valid_p), |
ed3ef339 DE |
717 | "\ |
718 | Return #t if the block is valid.\n\ | |
719 | A block becomes invalid when its objfile is freed." }, | |
720 | ||
72e02483 | 721 | { "block-start", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_start), |
ed3ef339 DE |
722 | "\ |
723 | Return the start address of the block." }, | |
724 | ||
72e02483 | 725 | { "block-end", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_end), |
ed3ef339 DE |
726 | "\ |
727 | Return the end address of the block." }, | |
728 | ||
72e02483 | 729 | { "block-function", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_function), |
ed3ef339 DE |
730 | "\ |
731 | Return the gdb:symbol object of the function containing the block\n\ | |
732 | or #f if the block does not live in any function." }, | |
733 | ||
72e02483 | 734 | { "block-superblock", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_superblock), |
ed3ef339 DE |
735 | "\ |
736 | Return the superblock (parent block) of the block." }, | |
737 | ||
72e02483 | 738 | { "block-global-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_global_block), |
ed3ef339 DE |
739 | "\ |
740 | Return the global block of the block." }, | |
741 | ||
72e02483 | 742 | { "block-static-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_static_block), |
ed3ef339 DE |
743 | "\ |
744 | Return the static block of the block." }, | |
745 | ||
72e02483 | 746 | { "block-global?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_global_p), |
ed3ef339 DE |
747 | "\ |
748 | Return #t if block is a global block." }, | |
749 | ||
72e02483 | 750 | { "block-static?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_static_p), |
ed3ef339 DE |
751 | "\ |
752 | Return #t if block is a static block." }, | |
753 | ||
72e02483 | 754 | { "block-symbols", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_symbols), |
ed3ef339 DE |
755 | "\ |
756 | Return a list of all symbols (as <gdb:symbol> objects) in the block." }, | |
757 | ||
72e02483 PA |
758 | { "make-block-symbols-iterator", 1, 0, 0, |
759 | as_a_scm_t_subr (gdbscm_make_block_syms_iter), | |
ed3ef339 DE |
760 | "\ |
761 | Return a <gdb:iterator> object for iterating over all symbols in the block." }, | |
762 | ||
72e02483 PA |
763 | { "block-symbols-progress?", 1, 0, 0, |
764 | as_a_scm_t_subr (bkscm_block_syms_progress_p), | |
ed3ef339 DE |
765 | "\ |
766 | Return #t if the object is a <gdb:block-symbols-progress> object." }, | |
767 | ||
72e02483 | 768 | { "lookup-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_lookup_block), |
ed3ef339 DE |
769 | "\ |
770 | Return the innermost GDB block containing the address or #f if none found.\n\ | |
771 | \n\ | |
772 | Arguments:\n\ | |
773 | address: the address to lookup" }, | |
774 | ||
775 | END_FUNCTIONS | |
776 | }; | |
777 | ||
778 | void | |
779 | gdbscm_initialize_blocks (void) | |
780 | { | |
781 | block_smob_tag | |
782 | = gdbscm_make_smob_type (block_smob_name, sizeof (block_smob)); | |
ed3ef339 DE |
783 | scm_set_smob_free (block_smob_tag, bkscm_free_block_smob); |
784 | scm_set_smob_print (block_smob_tag, bkscm_print_block_smob); | |
785 | ||
786 | block_syms_progress_smob_tag | |
787 | = gdbscm_make_smob_type (block_syms_progress_smob_name, | |
788 | sizeof (block_syms_progress_smob)); | |
ed3ef339 DE |
789 | scm_set_smob_print (block_syms_progress_smob_tag, |
790 | bkscm_print_block_syms_progress_smob); | |
791 | ||
792 | gdbscm_define_functions (block_functions, 1); | |
793 | ||
794 | /* This function is "private". */ | |
795 | bkscm_next_symbol_x_proc | |
796 | = scm_c_define_gsubr ("%block-next-symbol!", 1, 0, 0, | |
72e02483 | 797 | as_a_scm_t_subr (gdbscm_block_next_symbol_x)); |
ed3ef339 DE |
798 | scm_set_procedure_property_x (bkscm_next_symbol_x_proc, |
799 | gdbscm_documentation_symbol, | |
800 | gdbscm_scm_from_c_string ("\ | |
801 | Internal function to assist the block symbols iterator.")); | |
802 | ||
803 | /* Register an objfile "free" callback so we can properly | |
804 | invalidate blocks when an object file is about to be deleted. */ | |
805 | bkscm_objfile_data_key | |
806 | = register_objfile_data_with_cleanup (NULL, bkscm_del_objfile_blocks); | |
807 | } |