/* Scheme interface to blocks.

Copyright (C) 2008-2016 Free Software Foundation, Inc.

This file is part of GDB.

This program is free software; you can redistribute it and/or modify

it under the terms of the GNU General Public License as published by

the Free Software Foundation; either version 3 of the License, or

(at your option) any later version.

This program is distributed in the hope that it will be useful,

but WITHOUT ANY WARRANTY; without even the implied warranty of

MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

GNU General Public License for more details.

You should have received a copy of the GNU General Public License

along with this program. If not, see <http://www.gnu.org/licenses/>. */

/* See README file in this directory for implementation notes, coding

conventions, et.al. */

#include "defs.h"

#include "block.h"

#include "dictionary.h"

#include "objfiles.h"

#include "source.h"

#include "symtab.h"

#include "guile-internal.h"

/* A smob describing a gdb block. */

typedef struct _block_smob

} block_smob;

/* To iterate over block symbols from Scheme we need to store

struct block_iterator somewhere. This is stored in the "progress" field

of <gdb:iterator>. We store the block object in iterator_smob.object,

so we don't store it here.

Remember: While iterating over block symbols, you must continually check

whether the block is still valid. */

typedef struct

{

/* This always appears first. */

gdb_smob base;

/* The iterator for that block. */

struct block_iterator iter;

/* Has the iterator been initialized flag. */

int initialized_p;

} block_syms_progress_smob;

static const char block_smob_name[] = "gdb:block";

static const char block_syms_progress_smob_name[] = "gdb:block-symbols-iterator";

/* The tag Guile knows the block smobs by. */

static scm_t_bits block_smob_tag;

static scm_t_bits block_syms_progress_smob_tag;

/* The "next!" block syms iterator method. */

static SCM bkscm_next_symbol_x_proc;

static const struct objfile_data *bkscm_objfile_data_key;



/* Administrivia for block smobs. */

/* Helper function to hash a block_smob. */

static hashval_t

bkscm_hash_block_smob (const void *p)

{

const block_smob *b_smob = (const block_smob *) p;

return htab_hash_pointer (b_smob->block);

}

/* Helper function to compute equality of block_smobs. */

static int

bkscm_eq_block_smob (const void *ap, const void *bp)

{

const block_smob *a = (const block_smob *) ap;

const block_smob *b = (const block_smob *) bp;

return (a->block == b->block

&& a->block != NULL);

}

/* Return the struct block pointer -> SCM mapping table.

It is created if necessary. */

static htab_t

bkscm_objfile_block_map (struct objfile *objfile)

{

htab_t htab = (htab_t) objfile_data (objfile, bkscm_objfile_data_key);

if (htab == NULL)

{

htab = gdbscm_create_eqable_gsmob_ptr_map (bkscm_hash_block_smob,

bkscm_eq_block_smob);

set_objfile_data (objfile, bkscm_objfile_data_key, htab);

}

return htab;

}

/* The smob "free" function for <gdb:block>. */

static size_t

bkscm_free_block_smob (SCM self)

{

block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (self);

if (b_smob->block != NULL)

{

htab_t htab = bkscm_objfile_block_map (b_smob->objfile);

gdbscm_clear_eqable_gsmob_ptr_slot (htab, &b_smob->base);

}

/* Not necessary, done to catch bugs. */

b_smob->block = NULL;

b_smob->objfile = NULL;

return 0;

}

/* The smob "print" function for <gdb:block>. */

static int

bkscm_print_block_smob (SCM self, SCM port, scm_print_state *pstate)

{

block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (self);

const struct block *b = b_smob->block;

gdbscm_printf (port, "#<%s", block_smob_name);

if (BLOCK_SUPERBLOCK (b) == NULL)

gdbscm_printf (port, " global");

else if (BLOCK_SUPERBLOCK (BLOCK_SUPERBLOCK (b)) == NULL)

gdbscm_printf (port, " static");

if (BLOCK_FUNCTION (b) != NULL)

gdbscm_printf (port, " %s", SYMBOL_PRINT_NAME (BLOCK_FUNCTION (b)));

gdbscm_printf (port, " %s-%s",

hex_string (BLOCK_START (b)), hex_string (BLOCK_END (b)));

scm_puts (">", port);

scm_remember_upto_here_1 (self);

/* Non-zero means success. */

return 1;

}

/* Low level routine to create a <gdb:block> object. */

static SCM

bkscm_make_block_smob (void)

{

block_smob *b_smob = (block_smob *)

scm_gc_malloc (sizeof (block_smob), block_smob_name);

SCM b_scm;

b_smob->block = NULL;

b_smob->objfile = NULL;

b_scm = scm_new_smob (block_smob_tag, (scm_t_bits) b_smob);

gdbscm_init_eqable_gsmob (&b_smob->base, b_scm);

return b_scm;

}

/* Returns non-zero if SCM is a <gdb:block> object. */

static int

bkscm_is_block (SCM scm)

{

return SCM_SMOB_PREDICATE (block_smob_tag, scm);

}

/* (block? scm) -> boolean */

static SCM

gdbscm_block_p (SCM scm)

{

return scm_from_bool (bkscm_is_block (scm));

}

/* Return the existing object that encapsulates BLOCK, or create a new

<gdb:block> object. */

SCM

bkscm_scm_from_block (const struct block *block, struct objfile *objfile)

{

htab_t htab;

eqable_gdb_smob **slot;

block_smob *b_smob, b_smob_for_lookup;

SCM b_scm;

/* If we've already created a gsmob for this block, return it.

This makes blocks eq?-able. */

htab = bkscm_objfile_block_map (objfile);

b_smob_for_lookup.block = block;

slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &b_smob_for_lookup.base);

if (*slot != NULL)

return (*slot)->containing_scm;

b_scm = bkscm_make_block_smob ();

b_smob = (block_smob *) SCM_SMOB_DATA (b_scm);

b_smob->block = block;

b_smob->objfile = objfile;

gdbscm_fill_eqable_gsmob_ptr_slot (slot, &b_smob->base);

return b_scm;

}

/* Returns the <gdb:block> object in SELF.

Throws an exception if SELF is not a <gdb:block> object. */

static SCM

bkscm_get_block_arg_unsafe (SCM self, int arg_pos, const char *func_name)

{

SCM_ASSERT_TYPE (bkscm_is_block (self), self, arg_pos, func_name,

block_smob_name);

return self;

}

/* Returns a pointer to the block smob of SELF.

Throws an exception if SELF is not a <gdb:block> object. */

static block_smob *

bkscm_get_block_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)

{

SCM b_scm = bkscm_get_block_arg_unsafe (self, arg_pos, func_name);

block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (b_scm);

return b_smob;

}

/* Returns non-zero if block B_SMOB is valid. */

static int

bkscm_is_valid (block_smob *b_smob)

{

return b_smob->block != NULL;

}

/* Returns the block smob in SELF, verifying it's valid.

Throws an exception if SELF is not a <gdb:block> object or is invalid. */

static block_smob *

bkscm_get_valid_block_smob_arg_unsafe (SCM self, int arg_pos,

const char *func_name)

{

block_smob *b_smob

= bkscm_get_block_smob_arg_unsafe (self, arg_pos, func_name);

if (!bkscm_is_valid (b_smob))

{

gdbscm_invalid_object_error (func_name, arg_pos, self,

_("<gdb:block>"));

}

return b_smob;

}

/* Returns the block smob contained in SCM or NULL if SCM is not a

<gdb:block> object.

If there is an error a <gdb:exception> object is stored in *EXCP. */

static block_smob *

bkscm_get_valid_block (SCM scm, int arg_pos, const char *func_name, SCM *excp)

{

block_smob *b_smob;

if (!bkscm_is_block (scm))

{

*excp = gdbscm_make_type_error (func_name, arg_pos, scm,

block_smob_name);

return NULL;

}

b_smob = (block_smob *) SCM_SMOB_DATA (scm);

if (!bkscm_is_valid (b_smob))

{

*excp = gdbscm_make_invalid_object_error (func_name, arg_pos, scm,

_("<gdb:block>"));

return NULL;

}

return b_smob;

}

/* Returns the struct block that is wrapped by BLOCK_SCM.

If BLOCK_SCM is not a block, or is an invalid block, then NULL is returned

and a <gdb:exception> object is stored in *EXCP. */

const struct block *

bkscm_scm_to_block (SCM block_scm, int arg_pos, const char *func_name,

SCM *excp)

{

block_smob *b_smob;

b_smob = bkscm_get_valid_block (block_scm, arg_pos, func_name, excp);

if (b_smob != NULL)

return b_smob->block;

return NULL;

}

/* Helper function for bkscm_del_objfile_blocks to mark the block

as invalid. */

static int

bkscm_mark_block_invalid (void **slot, void *info)

{

block_smob *b_smob = (block_smob *) *slot;

b_smob->block = NULL;

b_smob->objfile = NULL;

return 1;

}

/* This function is called when an objfile is about to be freed.

Invalidate the block as further actions on the block would result

in bad data. All access to b_smob->block should be gated by

checks to ensure the block is (still) valid. */

static void

bkscm_del_objfile_blocks (struct objfile *objfile, void *datum)

{

htab_t htab = (htab_t) datum;

if (htab != NULL)

{

htab_traverse_noresize (htab, bkscm_mark_block_invalid, NULL);

htab_delete (htab);

}

}



/* Block methods. */

/* (block-valid? <gdb:block>) -> boolean

Returns #t if SELF still exists in GDB. */

static SCM

gdbscm_block_valid_p (SCM self)

{

block_smob *b_smob

= bkscm_get_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);

return scm_from_bool (bkscm_is_valid (b_smob));

}

/* (block-start <gdb:block>) -> address */

static SCM

gdbscm_block_start (SCM self)

{

block_smob *b_smob

= bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);

const struct block *block = b_smob->block;

return gdbscm_scm_from_ulongest (BLOCK_START (block));

}

/* (block-end <gdb:block>) -> address */

static SCM

gdbscm_block_end (SCM self)

{

block_smob *b_smob

= bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);

const struct block *block = b_smob->block;

return gdbscm_scm_from_ulongest (BLOCK_END (block));

}

/* (block-function <gdb:block>) -> <gdb:symbol> */

static SCM

gdbscm_block_function (SCM self)

{

block_smob *b_smob

= bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);

const struct block *block = b_smob->block;

struct symbol *sym;

sym = BLOCK_FUNCTION (block);

if (sym != NULL)

return syscm_scm_from_symbol (sym);

return SCM_BOOL_F;

}

/* (block-superblock <gdb:block>) -> <gdb:block> */

static SCM

gdbscm_block_superblock (SCM self)

{

block_smob *b_smob

= bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);

const struct block *block = b_smob->block;

const struct block *super_block;

super_block = BLOCK_SUPERBLOCK (block);

if (super_block)

return bkscm_scm_from_block (super_block, b_smob->objfile);

return SCM_BOOL_F;

}

/* (block-global-block <gdb:block>) -> <gdb:block>

Returns the global block associated to this block. */

static SCM

gdbscm_block_global_block (SCM self)

{

block_smob *b_smob

= bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);

const struct block *block = b_smob->block;

const struct block *global_block;

global_block = block_global_block (block);

return bkscm_scm_from_block (global_block, b_smob->objfile);

}

/* (block-static-block <gdb:block>) -> <gdb:block>

Returns the static block associated to this block.

Returns #f if we cannot get the static block (this is the global block). */

static SCM

gdbscm_block_static_block (SCM self)

{

block_smob *b_smob

= bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);

const struct block *block = b_smob->block;

const struct block *static_block;

if (BLOCK_SUPERBLOCK (block) == NULL)

return SCM_BOOL_F;

static_block = block_static_block (block);

return bkscm_scm_from_block (static_block, b_smob->objfile);

}

/* (block-global? <gdb:block>) -> boolean

Returns #t if this block object is a global block. */

static SCM

gdbscm_block_global_p (SCM self)

{

block_smob *b_smob

= bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);

const struct block *block = b_smob->block;

return scm_from_bool (BLOCK_SUPERBLOCK (block) == NULL);

}

/* (block-static? <gdb:block>) -> boolean

Returns #t if this block object is a static block. */

static SCM

gdbscm_block_static_p (SCM self)

{

block_smob *b_smob

= bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);

const struct block *block = b_smob->block;

if (BLOCK_SUPERBLOCK (block) != NULL

&& BLOCK_SUPERBLOCK (BLOCK_SUPERBLOCK (block)) == NULL)

return SCM_BOOL_T;

return SCM_BOOL_F;

}

/* (block-symbols <gdb:block>) -> list of <gdb:symbol objects

Returns a list of symbols of the block. */

static SCM

gdbscm_block_symbols (SCM self)

{

block_smob *b_smob

= bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);

const struct block *block = b_smob->block;

struct block_iterator iter;

struct symbol *sym;

SCM result;

result = SCM_EOL;

sym = block_iterator_first (block, &iter);

while (sym != NULL)

{

SCM s_scm = syscm_scm_from_symbol (sym);

result = scm_cons (s_scm, result);

sym = block_iterator_next (&iter);

}

return scm_reverse_x (result, SCM_EOL);

}



/* The <gdb:block-symbols-iterator> object,

for iterating over all symbols in a block. */

/* The smob "print" function for <gdb:block-symbols-iterator>. */

static int

bkscm_print_block_syms_progress_smob (SCM self, SCM port,

scm_print_state *pstate)

{

block_syms_progress_smob *i_smob

= (block_syms_progress_smob *) SCM_SMOB_DATA (self);

gdbscm_printf (port, "#<%s", block_syms_progress_smob_name);

if (i_smob->initialized_p)

{

switch (i_smob->iter.which)

{

case GLOBAL_BLOCK:

case STATIC_BLOCK:

{

struct compunit_symtab *cust;

gdbscm_printf (port, " %s",

i_smob->iter.which == GLOBAL_BLOCK

? "global" : "static");

if (i_smob->iter.idx != -1)

gdbscm_printf (port, " @%d", i_smob->iter.idx);

cust = (i_smob->iter.idx == -1

? i_smob->iter.d.compunit_symtab

: i_smob->iter.d.compunit_symtab->includes[i_smob->iter.idx]);

gdbscm_printf (port, " %s",

symtab_to_filename_for_display

(compunit_primary_filetab (cust)));

break;

}

case FIRST_LOCAL_BLOCK:

gdbscm_printf (port, " single block");

break;

}

}

else

gdbscm_printf (port, " !initialized");

scm_puts (">", port);

scm_remember_upto_here_1 (self);

/* Non-zero means success. */

return 1;

}

/* Low level routine to create a <gdb:block-symbols-progress> object. */

static SCM

bkscm_make_block_syms_progress_smob (void)

{

block_syms_progress_smob *i_smob = (block_syms_progress_smob *)

scm_gc_malloc (sizeof (block_syms_progress_smob),

block_syms_progress_smob_name);

SCM smob;

memset (&i_smob->iter, 0, sizeof (i_smob->iter));

i_smob->initialized_p = 0;

smob = scm_new_smob (block_syms_progress_smob_tag, (scm_t_bits) i_smob);

gdbscm_init_gsmob (&i_smob->base);

return smob;

}

/* Returns non-zero if SCM is a <gdb:block-symbols-progress> object. */

static int

bkscm_is_block_syms_progress (SCM scm)

{

return SCM_SMOB_PREDICATE (block_syms_progress_smob_tag, scm);

}

/* (block-symbols-progress? scm) -> boolean */

static SCM

bkscm_block_syms_progress_p (SCM scm)

{

return scm_from_bool (bkscm_is_block_syms_progress (scm));

}

/* (make-block-symbols-iterator <gdb:block>) -> <gdb:iterator>

Return a <gdb:iterator> object for iterating over the symbols of SELF. */

static SCM

gdbscm_make_block_syms_iter (SCM self)

{

block_smob *b_smob

= bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);

const struct block *block = b_smob->block;

SCM progress, iter;

progress = bkscm_make_block_syms_progress_smob ();

iter = gdbscm_make_iterator (self, progress, bkscm_next_symbol_x_proc);

return iter;

}

/* Returns the next symbol in the iteration through the block's dictionary,

or (end-of-iteration).

This is the iterator_smob.next_x method. */

static SCM

gdbscm_block_next_symbol_x (SCM self)

{

SCM progress, iter_scm, block_scm;

iterator_smob *iter_smob;

block_smob *b_smob;

const struct block *block;

block_syms_progress_smob *p_smob;

struct symbol *sym;

iter_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);

iter_smob = (iterator_smob *) SCM_SMOB_DATA (iter_scm);

block_scm = itscm_iterator_smob_object (iter_smob);

b_smob = bkscm_get_valid_block_smob_arg_unsafe (block_scm,

SCM_ARG1, FUNC_NAME);

block = b_smob->block;

progress = itscm_iterator_smob_progress (iter_smob);

SCM_ASSERT_TYPE (bkscm_is_block_syms_progress (progress),

progress, SCM_ARG1, FUNC_NAME,

block_syms_progress_smob_name);

p_smob = (block_syms_progress_smob *) SCM_SMOB_DATA (progress);

if (!p_smob->initialized_p)

{

sym = block_iterator_first (block, &p_smob->iter);

p_smob->initialized_p = 1;

}

else

sym = block_iterator_next (&p_smob->iter);

if (sym == NULL)

return gdbscm_end_of_iteration ();

return syscm_scm_from_symbol (sym);

}



/* (lookup-block address) -> <gdb:block>

Returns the innermost lexical block containing the specified pc value,

or #f if there is none. */

static SCM

gdbscm_lookup_block (SCM pc_scm)

{

CORE_ADDR pc;

const struct block *block = NULL;

struct compunit_symtab *cust = NULL;

gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "U", pc_scm, &pc);

TRY

{

cust = find_pc_compunit_symtab (pc);

if (cust != NULL && COMPUNIT_OBJFILE (cust) != NULL)

block = block_for_pc (pc);

}

CATCH (except, RETURN_MASK_ALL)

{

GDBSCM_HANDLE_GDB_EXCEPTION (except);

}

END_CATCH

if (cust == NULL || COMPUNIT_OBJFILE (cust) == NULL)

{

gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, pc_scm,

_("cannot locate object file for block"));

}

if (block != NULL)

return bkscm_scm_from_block (block, COMPUNIT_OBJFILE (cust));

return SCM_BOOL_F;

}



/* Initialize the Scheme block support. */

static const scheme_function block_functions[] =

{

{ "block?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_p),

"\

Return #t if the object is a <gdb:block> object." },

{ "block-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_valid_p),

"\

Return #t if the block is valid.\n\

A block becomes invalid when its objfile is freed." },

{ "block-start", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_start),

"\

Return the start address of the block." },

{ "block-end", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_end),

"\

Return the end address of the block." },

{ "block-function", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_function),

"\

Return the gdb:symbol object of the function containing the block\n\

or #f if the block does not live in any function." },

{ "block-superblock", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_superblock),

"\

Return the superblock (parent block) of the block." },

{ "block-global-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_global_block),

"\

Return the global block of the block." },

{ "block-static-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_static_block),

"\

Return the static block of the block." },

{ "block-global?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_global_p),

"\

Return #t if block is a global block." },

{ "block-static?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_static_p),

"\

Return #t if block is a static block." },

{ "block-symbols", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_symbols),

"\

Return a list of all symbols (as <gdb:symbol> objects) in the block." },

{ "make-block-symbols-iterator", 1, 0, 0,

as_a_scm_t_subr (gdbscm_make_block_syms_iter),

"\

Return a <gdb:iterator> object for iterating over all symbols in the block." },

{ "block-symbols-progress?", 1, 0, 0,

as_a_scm_t_subr (bkscm_block_syms_progress_p),

"\

Return #t if the object is a <gdb:block-symbols-progress> object." },

{ "lookup-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_lookup_block),

"\

Return the innermost GDB block containing the address or #f if none found.\n\

\n\

Arguments:\n\

address: the address to lookup" },

END_FUNCTIONS

};

void

gdbscm_initialize_blocks (void)

{

block_smob_tag

= gdbscm_make_smob_type (block_smob_name, sizeof (block_smob));

scm_set_smob_free (block_smob_tag, bkscm_free_block_smob);

scm_set_smob_print (block_smob_tag, bkscm_print_block_smob);

block_syms_progress_smob_tag

= gdbscm_make_smob_type (block_syms_progress_smob_name,

sizeof (block_syms_progress_smob));

scm_set_smob_print (block_syms_progress_smob_tag,

bkscm_print_block_syms_progress_smob);

gdbscm_define_functions (block_functions, 1);

/* This function is "private". */

bkscm_next_symbol_x_proc

= scm_c_define_gsubr ("%block-next-symbol!", 1, 0, 0,

as_a_scm_t_subr (gdbscm_block_next_symbol_x));

scm_set_procedure_property_x (bkscm_next_symbol_x_proc,

gdbscm_documentation_symbol,

gdbscm_scm_from_c_string ("\

Internal function to assist the block symbols iterator."));

/* Register an objfile "free" callback so we can properly

invalidate blocks when an object file is about to be deleted. */

bkscm_objfile_data_key

= register_objfile_data_with_cleanup (NULL, bkscm_del_objfile_blocks);

}