1 /* Scheme interface to blocks.
3 Copyright (C) 2008-2014 Free Software Foundation, Inc.
5 This file is part of GDB.
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.
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.
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/>. */
20 /* See README file in this directory for implementation notes, coding
21 conventions, et.al. */
25 #include "dictionary.h"
29 #include "guile-internal.h"
31 /* A smob describing a gdb block. */
33 typedef struct _block_smob
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. */
40 /* The GDB block structure that represents a frame's code block. */
41 const struct block
*block
;
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
;
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.
54 Remember: While iterating over block symbols, you must continually check
55 whether the block is still valid. */
59 /* This always appears first. */
62 /* The iterator for that block. */
63 struct block_iterator iter
;
65 /* Has the iterator been initialized flag. */
67 } block_syms_progress_smob
;
69 static const char block_smob_name
[] = "gdb:block";
70 static const char block_syms_progress_smob_name
[] = "gdb:block-symbols-iterator";
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
;
76 /* The "next!" block syms iterator method. */
77 static SCM bkscm_next_symbol_x_proc
;
79 static const struct objfile_data
*bkscm_objfile_data_key
;
81 /* Administrivia for block smobs. */
83 /* Helper function to hash a block_smob. */
86 bkscm_hash_block_smob (const void *p
)
88 const block_smob
*b_smob
= p
;
90 return htab_hash_pointer (b_smob
->block
);
93 /* Helper function to compute equality of block_smobs. */
96 bkscm_eq_block_smob (const void *ap
, const void *bp
)
98 const block_smob
*a
= ap
;
99 const block_smob
*b
= bp
;
101 return (a
->block
== b
->block
102 && a
->block
!= NULL
);
105 /* Return the struct block pointer -> SCM mapping table.
106 It is created if necessary. */
109 bkscm_objfile_block_map (struct objfile
*objfile
)
111 htab_t htab
= objfile_data (objfile
, bkscm_objfile_data_key
);
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
);
123 /* The smob "mark" function for <gdb:block>. */
126 bkscm_mark_block_smob (SCM self
)
128 block_smob
*b_smob
= (block_smob
*) SCM_SMOB_DATA (self
);
131 return gdbscm_mark_eqable_gsmob (&b_smob
->base
);
134 /* The smob "free" function for <gdb:block>. */
137 bkscm_free_block_smob (SCM self
)
139 block_smob
*b_smob
= (block_smob
*) SCM_SMOB_DATA (self
);
141 if (b_smob
->block
!= NULL
)
143 htab_t htab
= bkscm_objfile_block_map (b_smob
->objfile
);
145 gdbscm_clear_eqable_gsmob_ptr_slot (htab
, &b_smob
->base
);
148 /* Not necessary, done to catch bugs. */
149 b_smob
->block
= NULL
;
150 b_smob
->objfile
= NULL
;
155 /* The smob "print" function for <gdb:block>. */
158 bkscm_print_block_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
160 block_smob
*b_smob
= (block_smob
*) SCM_SMOB_DATA (self
);
161 const struct block
*b
= b_smob
->block
;
163 gdbscm_printf (port
, "#<%s", block_smob_name
);
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");
170 if (BLOCK_FUNCTION (b
) != NULL
)
171 gdbscm_printf (port
, " %s", SYMBOL_PRINT_NAME (BLOCK_FUNCTION (b
)));
173 gdbscm_printf (port
, " %s-%s",
174 hex_string (BLOCK_START (b
)), hex_string (BLOCK_END (b
)));
176 scm_puts (">", port
);
178 scm_remember_upto_here_1 (self
);
180 /* Non-zero means success. */
184 /* Low level routine to create a <gdb:block> object. */
187 bkscm_make_block_smob (void)
189 block_smob
*b_smob
= (block_smob
*)
190 scm_gc_malloc (sizeof (block_smob
), block_smob_name
);
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
);
201 /* Returns non-zero if SCM is a <gdb:block> object. */
204 bkscm_is_block (SCM scm
)
206 return SCM_SMOB_PREDICATE (block_smob_tag
, scm
);
209 /* (block? scm) -> boolean */
212 gdbscm_block_p (SCM scm
)
214 return scm_from_bool (bkscm_is_block (scm
));
217 /* Return the existing object that encapsulates BLOCK, or create a new
218 <gdb:block> object. */
221 bkscm_scm_from_block (const struct block
*block
, struct objfile
*objfile
)
224 eqable_gdb_smob
**slot
;
225 block_smob
*b_smob
, b_smob_for_lookup
;
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
);
234 return (*slot
)->containing_scm
;
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
);
245 /* Returns the <gdb:block> object in SELF.
246 Throws an exception if SELF is not a <gdb:block> object. */
249 bkscm_get_block_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
251 SCM_ASSERT_TYPE (bkscm_is_block (self
), self
, arg_pos
, func_name
,
257 /* Returns a pointer to the block smob of SELF.
258 Throws an exception if SELF is not a <gdb:block> object. */
261 bkscm_get_block_smob_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
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
);
269 /* Returns non-zero if block B_SMOB is valid. */
272 bkscm_is_valid (block_smob
*b_smob
)
274 return b_smob
->block
!= NULL
;
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. */
281 bkscm_get_valid_block_smob_arg_unsafe (SCM self
, int arg_pos
,
282 const char *func_name
)
285 = bkscm_get_block_smob_arg_unsafe (self
, arg_pos
, func_name
);
287 if (!bkscm_is_valid (b_smob
))
289 gdbscm_invalid_object_error (func_name
, arg_pos
, self
,
296 /* Returns the block smob contained in SCM or NULL if SCM is not a
298 If there is an error a <gdb:exception> object is stored in *EXCP. */
301 bkscm_get_valid_block (SCM scm
, int arg_pos
, const char *func_name
, SCM
*excp
)
305 if (!bkscm_is_block (scm
))
307 *excp
= gdbscm_make_type_error (func_name
, arg_pos
, scm
,
312 b_smob
= (block_smob
*) SCM_SMOB_DATA (scm
);
313 if (!bkscm_is_valid (b_smob
))
315 *excp
= gdbscm_make_invalid_object_error (func_name
, arg_pos
, scm
,
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. */
328 bkscm_scm_to_block (SCM block_scm
, int arg_pos
, const char *func_name
,
333 b_smob
= bkscm_get_valid_block (block_scm
, arg_pos
, func_name
, excp
);
336 return b_smob
->block
;
340 /* Helper function for bkscm_del_objfile_blocks to mark the block
344 bkscm_mark_block_invalid (void **slot
, void *info
)
346 block_smob
*b_smob
= (block_smob
*) *slot
;
348 b_smob
->block
= NULL
;
349 b_smob
->objfile
= NULL
;
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. */
359 bkscm_del_objfile_blocks (struct objfile
*objfile
, void *datum
)
365 htab_traverse_noresize (htab
, bkscm_mark_block_invalid
, NULL
);
372 /* (block-valid? <gdb:block>) -> boolean
373 Returns #t if SELF still exists in GDB. */
376 gdbscm_block_valid_p (SCM self
)
379 = bkscm_get_block_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
381 return scm_from_bool (bkscm_is_valid (b_smob
));
384 /* (block-start <gdb:block>) -> address */
387 gdbscm_block_start (SCM self
)
390 = bkscm_get_valid_block_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
391 const struct block
*block
= b_smob
->block
;
393 return gdbscm_scm_from_ulongest (BLOCK_START (block
));
396 /* (block-end <gdb:block>) -> address */
399 gdbscm_block_end (SCM self
)
402 = bkscm_get_valid_block_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
403 const struct block
*block
= b_smob
->block
;
405 return gdbscm_scm_from_ulongest (BLOCK_END (block
));
408 /* (block-function <gdb:block>) -> <gdb:symbol> */
411 gdbscm_block_function (SCM self
)
414 = bkscm_get_valid_block_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
415 const struct block
*block
= b_smob
->block
;
418 sym
= BLOCK_FUNCTION (block
);
421 return syscm_scm_from_symbol (sym
);
425 /* (block-superblock <gdb:block>) -> <gdb:block> */
428 gdbscm_block_superblock (SCM self
)
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
;
435 super_block
= BLOCK_SUPERBLOCK (block
);
438 return bkscm_scm_from_block (super_block
, b_smob
->objfile
);
442 /* (block-global-block <gdb:block>) -> <gdb:block>
443 Returns the global block associated to this block. */
446 gdbscm_block_global_block (SCM self
)
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
;
453 global_block
= block_global_block (block
);
455 return bkscm_scm_from_block (global_block
, b_smob
->objfile
);
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). */
463 gdbscm_block_static_block (SCM self
)
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
;
470 if (BLOCK_SUPERBLOCK (block
) == NULL
)
473 static_block
= block_static_block (block
);
475 return bkscm_scm_from_block (static_block
, b_smob
->objfile
);
478 /* (block-global? <gdb:block>) -> boolean
479 Returns #t if this block object is a global block. */
482 gdbscm_block_global_p (SCM self
)
485 = bkscm_get_valid_block_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
486 const struct block
*block
= b_smob
->block
;
488 return scm_from_bool (BLOCK_SUPERBLOCK (block
) == NULL
);
491 /* (block-static? <gdb:block>) -> boolean
492 Returns #t if this block object is a static block. */
495 gdbscm_block_static_p (SCM self
)
498 = bkscm_get_valid_block_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
499 const struct block
*block
= b_smob
->block
;
501 if (BLOCK_SUPERBLOCK (block
) != NULL
502 && BLOCK_SUPERBLOCK (BLOCK_SUPERBLOCK (block
)) == NULL
)
507 /* (block-symbols <gdb:block>) -> list of <gdb:symbol objects
508 Returns a list of symbols of the block. */
511 gdbscm_block_symbols (SCM self
)
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
;
522 sym
= block_iterator_first (block
, &iter
);
526 SCM s_scm
= syscm_scm_from_symbol (sym
);
528 result
= scm_cons (s_scm
, result
);
529 sym
= block_iterator_next (&iter
);
532 return scm_reverse_x (result
, SCM_EOL
);
535 /* The <gdb:block-symbols-iterator> object,
536 for iterating over all symbols in a block. */
538 /* The smob "mark" function for <gdb:block-symbols-iterator>. */
541 bkscm_mark_block_syms_progress_smob (SCM self
)
543 block_syms_progress_smob
*i_smob
544 = (block_syms_progress_smob
*) SCM_SMOB_DATA (self
);
547 return gdbscm_mark_gsmob (&i_smob
->base
);
550 /* The smob "print" function for <gdb:block-symbols-iterator>. */
553 bkscm_print_block_syms_progress_smob (SCM self
, SCM port
,
554 scm_print_state
*pstate
)
556 block_syms_progress_smob
*i_smob
557 = (block_syms_progress_smob
*) SCM_SMOB_DATA (self
);
559 gdbscm_printf (port
, "#<%s", block_syms_progress_smob_name
);
561 if (i_smob
->initialized_p
)
563 switch (i_smob
->iter
.which
)
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
));
581 case FIRST_LOCAL_BLOCK
:
582 gdbscm_printf (port
, " single block");
587 gdbscm_printf (port
, " !initialized");
589 scm_puts (">", port
);
591 scm_remember_upto_here_1 (self
);
593 /* Non-zero means success. */
597 /* Low level routine to create a <gdb:block-symbols-progress> object. */
600 bkscm_make_block_syms_progress_smob (void)
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
);
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
);
615 /* Returns non-zero if SCM is a <gdb:block-symbols-progress> object. */
618 bkscm_is_block_syms_progress (SCM scm
)
620 return SCM_SMOB_PREDICATE (block_syms_progress_smob_tag
, scm
);
623 /* (block-symbols-progress? scm) -> boolean */
626 bkscm_block_syms_progress_p (SCM scm
)
628 return scm_from_bool (bkscm_is_block_syms_progress (scm
));
631 /* (make-block-symbols-iterator <gdb:block>) -> <gdb:iterator>
632 Return a <gdb:iterator> object for iterating over the symbols of SELF. */
635 gdbscm_make_block_syms_iter (SCM self
)
638 = bkscm_get_valid_block_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
639 const struct block
*block
= b_smob
->block
;
642 progress
= bkscm_make_block_syms_progress_smob ();
644 iter
= gdbscm_make_iterator (self
, progress
, bkscm_next_symbol_x_proc
);
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. */
654 gdbscm_block_next_symbol_x (SCM self
)
656 SCM progress
, iter_scm
, block_scm
;
657 iterator_smob
*iter_smob
;
659 const struct block
*block
;
660 block_syms_progress_smob
*p_smob
;
663 iter_scm
= itscm_get_iterator_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
664 iter_smob
= (iterator_smob
*) SCM_SMOB_DATA (iter_scm
);
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
;
671 progress
= itscm_iterator_smob_progress (iter_smob
);
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
);
678 if (!p_smob
->initialized_p
)
680 sym
= block_iterator_first (block
, &p_smob
->iter
);
681 p_smob
->initialized_p
= 1;
684 sym
= block_iterator_next (&p_smob
->iter
);
687 return gdbscm_end_of_iteration ();
689 return syscm_scm_from_symbol (sym
);
692 /* (lookup-block address) -> <gdb:block>
693 Returns the innermost lexical block containing the specified pc value,
694 or #f if there is none. */
697 gdbscm_lookup_block (SCM pc_scm
)
700 struct block
*block
= NULL
;
701 struct obj_section
*section
= NULL
;
702 struct symtab
*symtab
= NULL
;
703 volatile struct gdb_exception except
;
705 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, NULL
, "U", pc_scm
, &pc
);
707 TRY_CATCH (except
, RETURN_MASK_ALL
)
709 section
= find_pc_mapped_section (pc
);
710 symtab
= find_pc_sect_symtab (pc
, section
);
712 if (symtab
!= NULL
&& symtab
->objfile
!= NULL
)
713 block
= block_for_pc (pc
);
715 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
717 if (symtab
== NULL
|| symtab
->objfile
== NULL
)
719 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, pc_scm
,
720 _("cannot locate object file for block"));
724 return bkscm_scm_from_block (block
, symtab
->objfile
);
728 /* Initialize the Scheme block support. */
730 static const scheme_function block_functions
[] =
732 { "block?", 1, 0, 0, gdbscm_block_p
,
734 Return #t if the object is a <gdb:block> object." },
736 { "block-valid?", 1, 0, 0, gdbscm_block_valid_p
,
738 Return #t if the block is valid.\n\
739 A block becomes invalid when its objfile is freed." },
741 { "block-start", 1, 0, 0, gdbscm_block_start
,
743 Return the start address of the block." },
745 { "block-end", 1, 0, 0, gdbscm_block_end
,
747 Return the end address of the block." },
749 { "block-function", 1, 0, 0, gdbscm_block_function
,
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." },
754 { "block-superblock", 1, 0, 0, gdbscm_block_superblock
,
756 Return the superblock (parent block) of the block." },
758 { "block-global-block", 1, 0, 0, gdbscm_block_global_block
,
760 Return the global block of the block." },
762 { "block-static-block", 1, 0, 0, gdbscm_block_static_block
,
764 Return the static block of the block." },
766 { "block-global?", 1, 0, 0, gdbscm_block_global_p
,
768 Return #t if block is a global block." },
770 { "block-static?", 1, 0, 0, gdbscm_block_static_p
,
772 Return #t if block is a static block." },
774 { "block-symbols", 1, 0, 0, gdbscm_block_symbols
,
776 Return a list of all symbols (as <gdb:symbol> objects) in the block." },
778 { "make-block-symbols-iterator", 1, 0, 0, gdbscm_make_block_syms_iter
,
780 Return a <gdb:iterator> object for iterating over all symbols in the block." },
782 { "block-symbols-progress?", 1, 0, 0, bkscm_block_syms_progress_p
,
784 Return #t if the object is a <gdb:block-symbols-progress> object." },
786 { "lookup-block", 1, 0, 0, gdbscm_lookup_block
,
788 Return the innermost GDB block containing the address or #f if none found.\n\
791 address: the address to lookup" },
797 gdbscm_initialize_blocks (void)
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
);
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
);
813 gdbscm_define_functions (block_functions
, 1);
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."));
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
);