This is the mail archive of the
archer@sourceware.org
mailing list for the Archer project.
[jankratochvil-misc] Implement Fortran common blocks, `infocommon', remove old #if 0-ed code
- From: Jan Kratochvil <jan dot kratochvil at redhat dot com>
- To: archer at sourceware dot org
- Date: Mon, 24 Nov 2008 00:37:14 +0100
- Subject: [jankratochvil-misc] Implement Fortran common blocks, `infocommon', remove old #if 0-ed code
Implement Fortran common blocks, `info common', remove old #if 0-ed code
Red Hat private: https://bugzilla.redhat.com/show_bug.cgi?id=459762
(gdb) info common
Contents of F77 COMMON block 'fo_o':
ix = 11
iy2 = 22
iz = 33
Contents of F77 COMMON block 'foo':
ix_x = 1
iy_y = 2
iz_z2 = 3
(gdb)
New testcase: gdb.fortran/common-block.exp
---
gdb/dwarf2read.c | 69 +++++-
gdb/f-lang.c | 406 ----------------------------
gdb/f-lang.h | 33 ---
gdb/f-valprint.c | 210 +++++----------
gdb/stack.c | 2 +
gdb/symtab.h | 5 +-
gdb/testsuite/gdb.fortran/common-block.exp | 101 +++++++
gdb/testsuite/gdb.fortran/common-block.f90 | 67 +++++
8 files changed, 306 insertions(+), 587 deletions(-)
create mode 100644 gdb/testsuite/gdb.fortran/common-block.exp
create mode 100644 gdb/testsuite/gdb.fortran/common-block.f90
diff --git a/gdb/dwarf2read.c b/gdb/dwarf2read.c
index 3bed85f..44925e6 100644
--- a/gdb/dwarf2read.c
+++ b/gdb/dwarf2read.c
@@ -46,6 +46,7 @@
#include "command.h"
#include "gdbcmd.h"
#include "addrmap.h"
+#include "f-lang.h"
#include <fcntl.h>
#include "gdb_string.h"
@@ -4685,12 +4686,14 @@ read_set_type (struct die_info *die, struct dwarf2_cu *cu)
return set_die_type (die, set_type, cu);
}
-/* First cut: install each common block member as a global variable. */
+/* Create appropriate locally-scoped variables for all the DW_TAG_common_block
+ entries. Create also TYPE_CODE_STRUCT listing all such variables to be
+ available for `info common'. COMMON_BLOCK_DOMAIN is used to sepate the
+ common blocks name namespace from regular variable names. */
static void
read_common_block (struct die_info *die, struct dwarf2_cu *cu)
{
- struct die_info *child_die;
struct attribute *attr;
struct symbol *sym;
CORE_ADDR base = (CORE_ADDR) 0;
@@ -4715,10 +4718,40 @@ read_common_block (struct die_info *die, struct dwarf2_cu *cu)
}
if (die->child != NULL)
{
+ struct objfile *objfile = cu->objfile;
+ struct die_info *child_die;
+ struct type *type;
+ struct field *field;
+ char *name;
+ struct symbol *sym;
+
+ type = alloc_type (objfile);
+ TYPE_CODE (type) = TYPE_CODE_STRUCT;
+ /* Artificial type to be used only by `info common'. */
+ TYPE_NAME (type) = "<common>";
+
+ child_die = die->child;
+ while (child_die && child_die->tag)
+ {
+ TYPE_NFIELDS (type)++;
+ child_die = sibling_die (child_die);
+ }
+
+ TYPE_FIELDS (type) = obstack_alloc (&objfile->objfile_obstack,
+ sizeof (*TYPE_FIELDS (type))
+ * TYPE_NFIELDS (type));
+ memset (TYPE_FIELDS (type), 0, sizeof (*TYPE_FIELDS (type))
+ * TYPE_NFIELDS (type));
+
+ field = TYPE_FIELDS (type);
child_die = die->child;
while (child_die && child_die->tag)
{
+ /* Create the symbol in the DW_TAG_common_block block in the current
+ symbol scope. */
sym = new_symbol (child_die, NULL, cu);
+
+ /* Undocumented in DWARF3, when it can be present? */
attr = dwarf2_attr (child_die, DW_AT_data_member_location, cu);
if (attr)
{
@@ -4726,8 +4759,25 @@ read_common_block (struct die_info *die, struct dwarf2_cu *cu)
base + decode_locdesc (DW_BLOCK (attr), cu);
add_symbol_to_list (sym, &global_symbols);
}
+
+ if (SYMBOL_CLASS (sym) == LOC_STATIC)
+ SET_FIELD_PHYSADDR (*field, SYMBOL_VALUE_ADDRESS (sym));
+ else
+ SET_FIELD_PHYSNAME (*field, SYMBOL_LINKAGE_NAME (sym));
+ FIELD_TYPE (*field) = SYMBOL_TYPE (sym);
+ FIELD_NAME (*field) = SYMBOL_NATURAL_NAME (sym);
+ field++;
child_die = sibling_die (child_die);
}
+
+ /* TYPE_LENGTH (type) is left 0 - it is only a virtual structure even
+ with no consecutive address space. */
+
+ sym = new_symbol (die, type, cu);
+ /* SYMBOL_VALUE_ADDRESS never gets used as all its fields are static. */
+ SYMBOL_VALUE_ADDRESS (sym) = base;
+
+ set_die_type (die, type, cu);
}
}
@@ -7658,7 +7708,15 @@ new_symbol (struct die_info *die, struct type *type, struct dwarf2_cu *cu)
if (attr)
{
var_decode_location (attr, sym, cu);
- attr2 = dwarf2_attr (die, DW_AT_external, cu);
+
+ /* Fortran explicitely imports any global symbols to the local
+ scope by DW_TAG_common_block. DW_AT_external means for
+ Fortran the variable is importable versus it is automatically
+ imported. */
+ if (cu->language == language_fortran)
+ attr2 = NULL;
+ else
+ attr2 = dwarf2_attr (die, DW_AT_external, cu);
if (attr2 && (DW_UNSND (attr2) != 0))
add_symbol_to_list (sym, &global_symbols);
else
@@ -7801,6 +7859,11 @@ new_symbol (struct die_info *die, struct type *type, struct dwarf2_cu *cu)
SYMBOL_CLASS (sym) = LOC_TYPEDEF;
add_symbol_to_list (sym, &global_symbols);
break;
+ case DW_TAG_common_block:
+ SYMBOL_CLASS (sym) = LOC_STATIC;
+ SYMBOL_DOMAIN (sym) = COMMON_BLOCK_DOMAIN;
+ add_symbol_to_list (sym, cu->list_in_scope);
+ break;
default:
/* Not a tag we recognize. Hopefully we aren't processing
trash data, but since we must specifically ignore things
diff --git a/gdb/f-lang.c b/gdb/f-lang.c
index d1ebd9a..5775192 100644
--- a/gdb/f-lang.c
+++ b/gdb/f-lang.c
@@ -55,20 +55,6 @@ typedef struct saved_bf_symnum SAVED_BF, *SAVED_BF_PTR;
/* Local functions */
extern void _initialize_f_language (void);
-#if 0
-static void clear_function_list (void);
-static long get_bf_for_fcn (long);
-static void clear_bf_list (void);
-static void patch_all_commons_by_name (char *, CORE_ADDR, int);
-static SAVED_F77_COMMON_PTR find_first_common_named (char *);
-static void add_common_entry (struct symbol *);
-static void add_common_block (char *, CORE_ADDR, int, char *);
-static SAVED_FUNCTION *allocate_saved_function_node (void);
-static SAVED_BF_PTR allocate_saved_bf_node (void);
-static COMMON_ENTRY_PTR allocate_common_entry_node (void);
-static SAVED_F77_COMMON_PTR allocate_saved_f77_common_node (void);
-static void patch_common_entries (SAVED_F77_COMMON_PTR, CORE_ADDR, int);
-#endif
static void f_printchar (int c, struct ui_file * stream);
static void f_emit_char (int c, struct ui_file * stream, int quoter);
@@ -458,395 +444,3 @@ _initialize_f_language (void)
add_language (&f_language_defn);
}
-
-#if 0
-static SAVED_BF_PTR
-allocate_saved_bf_node (void)
-{
- SAVED_BF_PTR new;
-
- new = (SAVED_BF_PTR) xmalloc (sizeof (SAVED_BF));
- return (new);
-}
-
-static SAVED_FUNCTION *
-allocate_saved_function_node (void)
-{
- SAVED_FUNCTION *new;
-
- new = (SAVED_FUNCTION *) xmalloc (sizeof (SAVED_FUNCTION));
- return (new);
-}
-
-static SAVED_F77_COMMON_PTR
-allocate_saved_f77_common_node (void)
-{
- SAVED_F77_COMMON_PTR new;
-
- new = (SAVED_F77_COMMON_PTR) xmalloc (sizeof (SAVED_F77_COMMON));
- return (new);
-}
-
-static COMMON_ENTRY_PTR
-allocate_common_entry_node (void)
-{
- COMMON_ENTRY_PTR new;
-
- new = (COMMON_ENTRY_PTR) xmalloc (sizeof (COMMON_ENTRY));
- return (new);
-}
-#endif
-
-SAVED_F77_COMMON_PTR head_common_list = NULL; /* Ptr to 1st saved COMMON */
-SAVED_F77_COMMON_PTR tail_common_list = NULL; /* Ptr to last saved COMMON */
-SAVED_F77_COMMON_PTR current_common = NULL; /* Ptr to current COMMON */
-
-#if 0
-static SAVED_BF_PTR saved_bf_list = NULL; /* Ptr to (.bf,function)
- list */
-static SAVED_BF_PTR saved_bf_list_end = NULL; /* Ptr to above list's end */
-static SAVED_BF_PTR current_head_bf_list = NULL; /* Current head of above list
- */
-
-static SAVED_BF_PTR tmp_bf_ptr; /* Generic temporary for use
- in macros */
-
-/* The following function simply enters a given common block onto
- the global common block chain */
-
-static void
-add_common_block (char *name, CORE_ADDR offset, int secnum, char *func_stab)
-{
- SAVED_F77_COMMON_PTR tmp;
- char *c, *local_copy_func_stab;
-
- /* If the COMMON block we are trying to add has a blank
- name (i.e. "#BLNK_COM") then we set it to __BLANK
- because the darn "#" character makes GDB's input
- parser have fits. */
-
-
- if (strcmp (name, BLANK_COMMON_NAME_ORIGINAL) == 0
- || strcmp (name, BLANK_COMMON_NAME_MF77) == 0)
- {
-
- xfree (name);
- name = alloca (strlen (BLANK_COMMON_NAME_LOCAL) + 1);
- strcpy (name, BLANK_COMMON_NAME_LOCAL);
- }
-
- tmp = allocate_saved_f77_common_node ();
-
- local_copy_func_stab = xmalloc (strlen (func_stab) + 1);
- strcpy (local_copy_func_stab, func_stab);
-
- tmp->name = xmalloc (strlen (name) + 1);
-
- /* local_copy_func_stab is a stabstring, let us first extract the
- function name from the stab by NULLing out the ':' character. */
-
-
- c = NULL;
- c = strchr (local_copy_func_stab, ':');
-
- if (c)
- *c = '\0';
- else
- error (_("Malformed function STAB found in add_common_block()"));
-
-
- tmp->owning_function = xmalloc (strlen (local_copy_func_stab) + 1);
-
- strcpy (tmp->owning_function, local_copy_func_stab);
-
- strcpy (tmp->name, name);
- tmp->offset = offset;
- tmp->next = NULL;
- tmp->entries = NULL;
- tmp->secnum = secnum;
-
- current_common = tmp;
-
- if (head_common_list == NULL)
- {
- head_common_list = tail_common_list = tmp;
- }
- else
- {
- tail_common_list->next = tmp;
- tail_common_list = tmp;
- }
-}
-#endif
-
-/* The following function simply enters a given common entry onto
- the "current_common" block that has been saved away. */
-
-#if 0
-static void
-add_common_entry (struct symbol *entry_sym_ptr)
-{
- COMMON_ENTRY_PTR tmp;
-
-
-
- /* The order of this list is important, since
- we expect the entries to appear in decl.
- order when we later issue "info common" calls */
-
- tmp = allocate_common_entry_node ();
-
- tmp->next = NULL;
- tmp->symbol = entry_sym_ptr;
-
- if (current_common == NULL)
- error (_("Attempt to add COMMON entry with no block open!"));
- else
- {
- if (current_common->entries == NULL)
- {
- current_common->entries = tmp;
- current_common->end_of_entries = tmp;
- }
- else
- {
- current_common->end_of_entries->next = tmp;
- current_common->end_of_entries = tmp;
- }
- }
-}
-#endif
-
-/* This routine finds the first encountred COMMON block named "name" */
-
-#if 0
-static SAVED_F77_COMMON_PTR
-find_first_common_named (char *name)
-{
-
- SAVED_F77_COMMON_PTR tmp;
-
- tmp = head_common_list;
-
- while (tmp != NULL)
- {
- if (strcmp (tmp->name, name) == 0)
- return (tmp);
- else
- tmp = tmp->next;
- }
- return (NULL);
-}
-#endif
-
-/* This routine finds the first encountred COMMON block named "name"
- that belongs to function funcname */
-
-SAVED_F77_COMMON_PTR
-find_common_for_function (char *name, char *funcname)
-{
-
- SAVED_F77_COMMON_PTR tmp;
-
- tmp = head_common_list;
-
- while (tmp != NULL)
- {
- if (strcmp (tmp->name, name) == 0
- && strcmp (tmp->owning_function, funcname) == 0)
- return (tmp);
- else
- tmp = tmp->next;
- }
- return (NULL);
-}
-
-
-#if 0
-
-/* The following function is called to patch up the offsets
- for the statics contained in the COMMON block named
- "name." */
-
-static void
-patch_common_entries (SAVED_F77_COMMON_PTR blk, CORE_ADDR offset, int secnum)
-{
- COMMON_ENTRY_PTR entry;
-
- blk->offset = offset; /* Keep this around for future use. */
-
- entry = blk->entries;
-
- while (entry != NULL)
- {
- SYMBOL_VALUE (entry->symbol) += offset;
- SYMBOL_SECTION (entry->symbol) = secnum;
-
- entry = entry->next;
- }
- blk->secnum = secnum;
-}
-
-/* Patch all commons named "name" that need patching.Since COMMON
- blocks occur with relative infrequency, we simply do a linear scan on
- the name. Eventually, the best way to do this will be a
- hashed-lookup. Secnum is the section number for the .bss section
- (which is where common data lives). */
-
-static void
-patch_all_commons_by_name (char *name, CORE_ADDR offset, int secnum)
-{
-
- SAVED_F77_COMMON_PTR tmp;
-
- /* For blank common blocks, change the canonical reprsentation
- of a blank name */
-
- if (strcmp (name, BLANK_COMMON_NAME_ORIGINAL) == 0
- || strcmp (name, BLANK_COMMON_NAME_MF77) == 0)
- {
- xfree (name);
- name = alloca (strlen (BLANK_COMMON_NAME_LOCAL) + 1);
- strcpy (name, BLANK_COMMON_NAME_LOCAL);
- }
-
- tmp = head_common_list;
-
- while (tmp != NULL)
- {
- if (COMMON_NEEDS_PATCHING (tmp))
- if (strcmp (tmp->name, name) == 0)
- patch_common_entries (tmp, offset, secnum);
-
- tmp = tmp->next;
- }
-}
-#endif
-
-/* This macro adds the symbol-number for the start of the function
- (the symbol number of the .bf) referenced by symnum_fcn to a
- list. This list, in reality should be a FIFO queue but since
- #line pragmas sometimes cause line ranges to get messed up
- we simply create a linear list. This list can then be searched
- first by a queueing algorithm and upon failure fall back to
- a linear scan. */
-
-#if 0
-#define ADD_BF_SYMNUM(bf_sym,fcn_sym) \
- \
- if (saved_bf_list == NULL) \
-{ \
- tmp_bf_ptr = allocate_saved_bf_node(); \
- \
- tmp_bf_ptr->symnum_bf = (bf_sym); \
- tmp_bf_ptr->symnum_fcn = (fcn_sym); \
- tmp_bf_ptr->next = NULL; \
- \
- current_head_bf_list = saved_bf_list = tmp_bf_ptr; \
- saved_bf_list_end = tmp_bf_ptr; \
- } \
-else \
-{ \
- tmp_bf_ptr = allocate_saved_bf_node(); \
- \
- tmp_bf_ptr->symnum_bf = (bf_sym); \
- tmp_bf_ptr->symnum_fcn = (fcn_sym); \
- tmp_bf_ptr->next = NULL; \
- \
- saved_bf_list_end->next = tmp_bf_ptr; \
- saved_bf_list_end = tmp_bf_ptr; \
- }
-#endif
-
-/* This function frees the entire (.bf,function) list */
-
-#if 0
-static void
-clear_bf_list (void)
-{
-
- SAVED_BF_PTR tmp = saved_bf_list;
- SAVED_BF_PTR next = NULL;
-
- while (tmp != NULL)
- {
- next = tmp->next;
- xfree (tmp);
- tmp = next;
- }
- saved_bf_list = NULL;
-}
-#endif
-
-int global_remote_debug;
-
-#if 0
-
-static long
-get_bf_for_fcn (long the_function)
-{
- SAVED_BF_PTR tmp;
- int nprobes = 0;
-
- /* First use a simple queuing algorithm (i.e. look and see if the
- item at the head of the queue is the one you want) */
-
- if (saved_bf_list == NULL)
- internal_error (__FILE__, __LINE__,
- _("cannot get .bf node off empty list"));
-
- if (current_head_bf_list != NULL)
- if (current_head_bf_list->symnum_fcn == the_function)
- {
- if (global_remote_debug)
- fprintf_unfiltered (gdb_stderr, "*");
-
- tmp = current_head_bf_list;
- current_head_bf_list = current_head_bf_list->next;
- return (tmp->symnum_bf);
- }
-
- /* If the above did not work (probably because #line directives were
- used in the sourcefile and they messed up our internal tables) we now do
- the ugly linear scan */
-
- if (global_remote_debug)
- fprintf_unfiltered (gdb_stderr, "\ndefaulting to linear scan\n");
-
- nprobes = 0;
- tmp = saved_bf_list;
- while (tmp != NULL)
- {
- nprobes++;
- if (tmp->symnum_fcn == the_function)
- {
- if (global_remote_debug)
- fprintf_unfiltered (gdb_stderr, "Found in %d probes\n", nprobes);
- current_head_bf_list = tmp->next;
- return (tmp->symnum_bf);
- }
- tmp = tmp->next;
- }
-
- return (-1);
-}
-
-static SAVED_FUNCTION_PTR saved_function_list = NULL;
-static SAVED_FUNCTION_PTR saved_function_list_end = NULL;
-
-static void
-clear_function_list (void)
-{
- SAVED_FUNCTION_PTR tmp = saved_function_list;
- SAVED_FUNCTION_PTR next = NULL;
-
- while (tmp != NULL)
- {
- next = tmp->next;
- xfree (tmp);
- tmp = next;
- }
-
- saved_function_list = NULL;
-}
-#endif
diff --git a/gdb/f-lang.h b/gdb/f-lang.h
index 93e318c..d00dc1b 100644
--- a/gdb/f-lang.h
+++ b/gdb/f-lang.h
@@ -47,41 +47,8 @@ enum f90_range_type
NONE_BOUND_DEFAULT /* "(low:high)" */
};
-struct common_entry
- {
- struct symbol *symbol; /* The symbol node corresponding
- to this component */
- struct common_entry *next; /* The next component */
- };
-
-struct saved_f77_common
- {
- char *name; /* Name of COMMON */
- char *owning_function; /* Name of parent function */
- int secnum; /* Section # of .bss */
- CORE_ADDR offset; /* Offset from .bss for
- this block */
- struct common_entry *entries; /* List of block's components */
- struct common_entry *end_of_entries; /* ptr. to end of components */
- struct saved_f77_common *next; /* Next saved COMMON block */
- };
-
-typedef struct saved_f77_common SAVED_F77_COMMON, *SAVED_F77_COMMON_PTR;
-
-typedef struct common_entry COMMON_ENTRY, *COMMON_ENTRY_PTR;
-
-extern SAVED_F77_COMMON_PTR head_common_list; /* Ptr to 1st saved COMMON */
-extern SAVED_F77_COMMON_PTR tail_common_list; /* Ptr to last saved COMMON */
-extern SAVED_F77_COMMON_PTR current_common; /* Ptr to current COMMON */
-
-extern SAVED_F77_COMMON_PTR find_common_for_function (char *, char *);
-
-#define UNINITIALIZED_SECNUM -1
-#define COMMON_NEEDS_PATCHING(blk) ((blk)->secnum == UNINITIALIZED_SECNUM)
-
#define BLANK_COMMON_NAME_ORIGINAL "#BLNK_COM" /* XLF assigned */
#define BLANK_COMMON_NAME_MF77 "__BLNK__" /* MF77 assigned */
-#define BLANK_COMMON_NAME_LOCAL "__BLANK" /* Local GDB */
/* When reasonable array bounds cannot be fetched, such as when
you ask to 'mt print symbols' and there is no stack frame and
diff --git a/gdb/f-valprint.c b/gdb/f-valprint.c
index f893b49..0036a7f 100644
--- a/gdb/f-valprint.c
+++ b/gdb/f-valprint.c
@@ -34,10 +34,8 @@
#include "gdbcore.h"
#include "command.h"
#include "block.h"
-
-#if 0
-static int there_is_a_visible_common_named (char *);
-#endif
+#include "dictionary.h"
+#include "gdb_assert.h"
extern void _initialize_f_valprint (void);
static void info_common_command (char *, int);
@@ -464,22 +462,54 @@ f_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset,
return 0;
}
-static void
-list_all_visible_commons (char *funname)
+static int
+info_common_command_for_block (struct block *block, struct frame_info *frame,
+ const char *comname)
{
- SAVED_F77_COMMON_PTR tmp;
-
- tmp = head_common_list;
-
- printf_filtered (_("All COMMON blocks visible at this level:\n\n"));
-
- while (tmp != NULL)
- {
- if (strcmp (tmp->owning_function, funname) == 0)
- printf_filtered ("%s\n", tmp->name);
-
- tmp = tmp->next;
- }
+ struct dict_iterator iter;
+ struct symbol *sym;
+ int values_printed = 0;
+ const char *name;
+ struct value_print_options opts;
+
+ get_user_print_options (&opts);
+
+ ALL_BLOCK_SYMBOLS (block, iter, sym)
+ if (SYMBOL_DOMAIN (sym) == COMMON_BLOCK_DOMAIN)
+ {
+ struct type *type = SYMBOL_TYPE (sym);
+ int index;
+
+ gdb_assert (SYMBOL_CLASS (sym) == LOC_STATIC);
+ gdb_assert (TYPE_CODE (type) == TYPE_CODE_STRUCT);
+
+ if (comname && (!SYMBOL_LINKAGE_NAME (sym)
+ || strcmp (comname, SYMBOL_LINKAGE_NAME (sym)) != 0))
+ continue;
+
+ values_printed = 1;
+ if (SYMBOL_PRINT_NAME (sym))
+ printf_filtered (_("Contents of F77 COMMON block '%s':\n"),
+ SYMBOL_PRINT_NAME (sym));
+ else
+ printf_filtered (_("Contents of blank COMMON block:\n"));
+
+ for (index = 0; index < TYPE_NFIELDS (type); index++)
+ {
+ struct value *val;
+
+ gdb_assert (field_is_static (&TYPE_FIELD (type, index)));
+ val = value_static_field (type, index);
+
+ printf_filtered ("%s = ", TYPE_FIELD_NAME (type, index));
+ value_print (val, gdb_stdout, &opts);
+ putchar_filtered ('\n');
+ }
+
+ putchar_filtered ('\n');
+ }
+
+ return values_printed;
}
/* This function is used to print out the values in a given COMMON
@@ -489,11 +519,9 @@ list_all_visible_commons (char *funname)
static void
info_common_command (char *comname, int from_tty)
{
- SAVED_F77_COMMON_PTR the_common;
- COMMON_ENTRY_PTR entry;
struct frame_info *fi;
- char *funname = 0;
- struct symbol *func;
+ struct block *block;
+ int values_printed = 0;
/* We have been told to display the contents of F77 COMMON
block supposedly visible in this function. Let us
@@ -505,138 +533,32 @@ info_common_command (char *comname, int from_tty)
/* The following is generally ripped off from stack.c's routine
print_frame_info() */
- func = find_pc_function (get_frame_pc (fi));
- if (func)
- {
- /* In certain pathological cases, the symtabs give the wrong
- function (when we are in the first function in a file which
- is compiled without debugging symbols, the previous function
- is compiled with debugging symbols, and the "foo.o" symbol
- that is supposed to tell us where the file with debugging symbols
- ends has been truncated by ar because it is longer than 15
- characters).
-
- So look in the minimal symbol tables as well, and if it comes
- up with a larger address for the function use that instead.
- I don't think this can ever cause any problems; there shouldn't
- be any minimal symbols in the middle of a function.
- FIXME: (Not necessarily true. What about text labels) */
-
- struct minimal_symbol *msymbol =
- lookup_minimal_symbol_by_pc (get_frame_pc (fi));
-
- if (msymbol != NULL
- && (SYMBOL_VALUE_ADDRESS (msymbol)
- > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
- funname = SYMBOL_LINKAGE_NAME (msymbol);
- else
- funname = SYMBOL_LINKAGE_NAME (func);
- }
- else
- {
- struct minimal_symbol *msymbol =
- lookup_minimal_symbol_by_pc (get_frame_pc (fi));
-
- if (msymbol != NULL)
- funname = SYMBOL_LINKAGE_NAME (msymbol);
- else /* Got no 'funname', code below will fail. */
- error (_("No function found for frame."));
- }
-
- /* If comname is NULL, we assume the user wishes to see the
- which COMMON blocks are visible here and then return */
-
- if (comname == 0)
+ block = get_frame_block (fi, 0);
+ if (block == NULL)
{
- list_all_visible_commons (funname);
+ printf_filtered (_("No symbol table info available.\n"));
return;
}
- the_common = find_common_for_function (comname, funname);
-
- if (the_common)
+ while (block)
{
- if (strcmp (comname, BLANK_COMMON_NAME_LOCAL) == 0)
- printf_filtered (_("Contents of blank COMMON block:\n"));
- else
- printf_filtered (_("Contents of F77 COMMON block '%s':\n"), comname);
-
- printf_filtered ("\n");
- entry = the_common->entries;
-
- while (entry != NULL)
- {
- printf_filtered ("%s = ", SYMBOL_PRINT_NAME (entry->symbol));
- print_variable_value (entry->symbol, fi, gdb_stdout);
- printf_filtered ("\n");
- entry = entry->next;
- }
+ if (info_common_command_for_block (block, fi, comname))
+ values_printed = 1;
+ /* After handling the function's top-level block, stop. Don't
+ continue to its superblock, the block of per-file symbols. */
+ if (BLOCK_FUNCTION (block))
+ break;
+ block = BLOCK_SUPERBLOCK (block);
}
- else
- printf_filtered (_("Cannot locate the common block %s in function '%s'\n"),
- comname, funname);
-}
-
-/* This function is used to determine whether there is a
- F77 common block visible at the current scope called 'comname'. */
-#if 0
-static int
-there_is_a_visible_common_named (char *comname)
-{
- SAVED_F77_COMMON_PTR the_common;
- struct frame_info *fi;
- char *funname = 0;
- struct symbol *func;
-
- if (comname == NULL)
- error (_("Cannot deal with NULL common name!"));
-
- fi = get_selected_frame (_("No frame selected"));
-
- /* The following is generally ripped off from stack.c's routine
- print_frame_info() */
-
- func = find_pc_function (fi->pc);
- if (func)
+ if (!values_printed)
{
- /* In certain pathological cases, the symtabs give the wrong
- function (when we are in the first function in a file which
- is compiled without debugging symbols, the previous function
- is compiled with debugging symbols, and the "foo.o" symbol
- that is supposed to tell us where the file with debugging symbols
- ends has been truncated by ar because it is longer than 15
- characters).
-
- So look in the minimal symbol tables as well, and if it comes
- up with a larger address for the function use that instead.
- I don't think this can ever cause any problems; there shouldn't
- be any minimal symbols in the middle of a function.
- FIXME: (Not necessarily true. What about text labels) */
-
- struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
-
- if (msymbol != NULL
- && (SYMBOL_VALUE_ADDRESS (msymbol)
- > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
- funname = SYMBOL_LINKAGE_NAME (msymbol);
+ if (comname)
+ printf_filtered (_("No common block '%s'.\n"), comname);
else
- funname = SYMBOL_LINKAGE_NAME (func);
- }
- else
- {
- struct minimal_symbol *msymbol =
- lookup_minimal_symbol_by_pc (fi->pc);
-
- if (msymbol != NULL)
- funname = SYMBOL_LINKAGE_NAME (msymbol);
+ printf_filtered (_("No common blocks.\n"));
}
-
- the_common = find_common_for_function (comname, funname);
-
- return (the_common ? 1 : 0);
}
-#endif
void
_initialize_f_valprint (void)
diff --git a/gdb/stack.c b/gdb/stack.c
index 3c1019b..8f82fd1 100644
--- a/gdb/stack.c
+++ b/gdb/stack.c
@@ -1373,6 +1373,8 @@ print_block_frame_locals (struct block *b, struct frame_info *frame,
case LOC_COMPUTED:
if (SYMBOL_IS_ARGUMENT (sym))
break;
+ if (SYMBOL_DOMAIN (sym) == COMMON_BLOCK_DOMAIN)
+ break;
values_printed = 1;
for (j = 0; j < num_tabs; j++)
fputs_filtered ("\t", stream);
diff --git a/gdb/symtab.h b/gdb/symtab.h
index a1dee4f..c34d27d 100644
--- a/gdb/symtab.h
+++ b/gdb/symtab.h
@@ -394,7 +394,10 @@ typedef enum domain_enum_tag
FUNCTIONS_DOMAIN,
/* All defined types */
- TYPES_DOMAIN
+ TYPES_DOMAIN,
+
+ /* Fortran common blocks. Their naming must be separate from VAR_DOMAIN. */
+ COMMON_BLOCK_DOMAIN
}
domain_enum;
diff --git a/gdb/testsuite/gdb.fortran/common-block.exp b/gdb/testsuite/gdb.fortran/common-block.exp
new file mode 100644
index 0000000..888f6c3
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/common-block.exp
@@ -0,0 +1,101 @@
+# Copyright 2008 Free Software Foundation, Inc.
+
+# 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 2 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, write to the Free Software
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+# This file was written by Jan Kratochvil <jan.kratochvil@redhat.com>.
+
+set testfile "common-block"
+set srcfile ${testfile}.f90
+set binfile ${objdir}/${subdir}/${testfile}
+
+if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${binfile}" executable {debug f77 quiet}] != "" } {
+ untested "Couldn't compile ${srcfile}"
+ return -1
+}
+
+gdb_exit
+gdb_start
+gdb_reinitialize_dir $srcdir/$subdir
+gdb_load ${binfile}
+
+if ![runto MAIN__] then {
+ perror "couldn't run to breakpoint MAIN__"
+ continue
+}
+
+gdb_breakpoint [gdb_get_line_number "stop-here-out"]
+gdb_continue_to_breakpoint "stop-here-out"
+
+# Common block naming with source name /foo/:
+# .symtab DW_TAG_common_block's DW_AT_name
+# Intel Fortran foo_ foo_
+# GNU Fortran foo_ foo
+#set suffix "_"
+set suffix ""
+
+set int4 {(integer\(kind=4\)|INTEGER\(4\))}
+set real4 {(real\(kind=4\)|REAL\(4\))}
+set real8 {(real\(kind=8\)|REAL\(8\))}
+
+gdb_test "whatis foo$suffix" "No symbol \"foo$suffix\" in current context."
+gdb_test "ptype foo$suffix" "No symbol \"foo$suffix\" in current context."
+gdb_test "p foo$suffix" "No symbol \"foo$suffix\" in current context."
+gdb_test "whatis fo_o$suffix" "No symbol \"fo_o$suffix\" in current context."
+gdb_test "ptype fo_o$suffix" "No symbol \"fo_o$suffix\" in current context."
+gdb_test "p fo_o$suffix" "No symbol \"fo_o$suffix\" in current context."
+
+gdb_test "info locals" "ix_x = 11\r\niy_y = 22\r\niz_z = 33\r\nix = 1\r\niy = 2\r\niz = 3" "info locals out"
+gdb_test "info common" "Contents of F77 COMMON block 'fo_o':\r\nix_x = 11\r\niy_y = 22\r\niz_z = 33\r\n\r\nContents of F77 COMMON block 'foo':\r\nix = 1\r\niy = 2\r\niz = 3" "info common out"
+
+gdb_test "ptype ix" "type = $int4" "ptype ix out"
+gdb_test "ptype iy" "type = $real4" "ptype iy out"
+gdb_test "ptype iz" "type = $real8" "ptype iz out"
+gdb_test "ptype ix_x" "type = $int4" "ptype ix_x out"
+gdb_test "ptype iy_y" "type = $real4" "ptype iy_y out"
+gdb_test "ptype iz_z" "type = $real8" "ptype iz_z out"
+
+gdb_test "p ix" " = 1 *" "p ix out"
+gdb_test "p iy" " = 2 *" "p iy out"
+gdb_test "p iz" " = 3 *" "p iz out"
+gdb_test "p ix_x" " = 11 *" "p ix_x out"
+gdb_test "p iy_y" " = 22 *" "p iy_y out"
+gdb_test "p iz_z" " = 33 *" "p iz_z out"
+
+gdb_breakpoint [gdb_get_line_number "stop-here-in"]
+gdb_continue_to_breakpoint "stop-here-in"
+
+gdb_test "whatis foo$suffix" "No symbol \"foo$suffix\" in current context." "whatis foo$suffix in"
+gdb_test "ptype foo$suffix" "No symbol \"foo$suffix\" in current context." "ptype foo$suffix in"
+gdb_test "p foo$suffix" "No symbol \"foo$suffix\" in current context." "p foo$suffix in"
+gdb_test "whatis fo_o$suffix" "No symbol \"fo_o$suffix\" in current context." "whatis fo_o$suffix in"
+gdb_test "ptype fo_o$suffix" "No symbol \"fo_o$suffix\" in current context." "ptype fo_o$suffix in"
+gdb_test "p fo_o$suffix" "No symbol \"fo_o$suffix\" in current context." "p fo_o$suffix in"
+
+gdb_test "info locals" "ix = 11\r\niy2 = 22\r\niz = 33\r\nix_x = 1\r\niy_y = 2\r\niz_z2 = 3\r\niy = 5\r\niz_z = 55" "info locals in"
+gdb_test "info common" "Contents of F77 COMMON block 'fo_o':\r\nix = 11\r\niy2 = 22\r\niz = 33\r\n\r\nContents of F77 COMMON block 'foo':\r\nix_x = 1\r\niy_y = 2\r\niz_z2 = 3" "info common in"
+
+gdb_test "ptype ix" "type = $int4" "ptype ix in"
+gdb_test "ptype iy2" "type = $real4" "ptype iy2 in"
+gdb_test "ptype iz" "type = $real8" "ptype iz in"
+gdb_test "ptype ix_x" "type = $int4" "ptype ix_x in"
+gdb_test "ptype iy_y" "type = $real4" "ptype iy_y in"
+gdb_test "ptype iz_z2" "type = $real8" "ptype iz_z2 in"
+
+gdb_test "p ix" " = 11 *" "p ix in"
+gdb_test "p iy2" " = 22 *" "p iy2 in"
+gdb_test "p iz" " = 33 *" "p iz in"
+gdb_test "p ix_x" " = 1 *" "p ix_x in"
+gdb_test "p iy_y" " = 2 *" "p iy_y in"
+gdb_test "p iz_z2" " = 3 *" "p iz_z2 in"
diff --git a/gdb/testsuite/gdb.fortran/common-block.f90 b/gdb/testsuite/gdb.fortran/common-block.f90
new file mode 100644
index 0000000..b614e8a
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/common-block.f90
@@ -0,0 +1,67 @@
+! Copyright 2008 Free Software Foundation, Inc.
+!
+! 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 2 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, write to the Free Software
+! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+!
+! Ihis file is the Fortran source file for dynamic.exp.
+! Original file written by Jakub Jelinek <jakub@redhat.com>.
+! Modified for the GDB testcase by Jan Kratochvil <jan.kratochvil@redhat.com>.
+
+subroutine in
+
+ INTEGER*4 ix
+ REAL*4 iy2
+ REAL*8 iz
+
+ INTEGER*4 ix_x
+ REAL*4 iy_y
+ REAL*8 iz_z2
+
+ common /fo_o/ix,iy2,iz
+ common /foo/ix_x,iy_y,iz_z2
+
+ iy = 5
+ iz_z = 55
+
+ if (ix .ne. 11 .or. iy2 .ne. 22.0 .or. iz .ne. 33.0) call abort
+ if (ix_x .ne. 1 .or. iy_y .ne. 2.0 .or. iz_z2 .ne. 3.0) call abort
+
+ ix = 0 ! stop-here-in
+
+end subroutine in
+
+program common_test
+
+ INTEGER*4 ix
+ REAL*4 iy
+ REAL*8 iz
+
+ INTEGER*4 ix_x
+ REAL*4 iy_y
+ REAL*8 iz_z
+
+ common /foo/ix,iy,iz
+ common /fo_o/ix_x,iy_y,iz_z
+
+ ix = 1
+ iy = 2.0
+ iz = 3.0
+
+ ix_x = 11
+ iy_y = 22.0
+ iz_z = 33.0
+
+ call in ! stop-here-out
+
+end program common_test
--
1.6.0.3