The last version posted upstream:
0: http://sources.redhat.com/ml/gdb-patches/2007-11/msg00438.html
1: http://sources.redhat.com/ml/gdb-patches/2007-11/msg00439.html
2: http://sources.redhat.com/ml/gdb-patches/2007-11/msg00440.html
3: http://sources.redhat.com/ml/gdb-patches/2007-11/msg00441.html
4: http://sources.redhat.com/ml/gdb-patches/2007-11/msg00442.html
5: http://sources.redhat.com/ml/gdb-patches/2007-11/msg00443.html
6: http://sources.redhat.com/ml/gdb-patches/2007-11/msg00444.html
2008-02-24 Jan Kratochvil <jan.kratochvil@redhat.com>
Port to GDB-6.8pre.
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/Makefile.in gdb-6.8cvs20080219/gdb/Makefile.in
--- gdb-6.8cvs20080219-fortranless/gdb/Makefile.in 2008-02-22 08:19:37.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/Makefile.in 2008-02-22 16:59:22.000000000 +0100
@@ -758,6 +758,7 @@ disasm_h = disasm.h
doublest_h = doublest.h $(floatformat_h)
dummy_frame_h = dummy-frame.h
dfp_h = dfp.h
+dwarf2block_h = dwarf2block.h
dwarf2expr_h = dwarf2expr.h
dwarf2_frame_h = dwarf2-frame.h
dwarf2loc_h = dwarf2loc.h
@@ -1051,7 +1052,7 @@ COMMON_OBS = $(DEPFILES) $(CONFIG_OBS) $
exec.o bcache.o objfiles.o observer.o minsyms.o maint.o demangle.o \
dbxread.o coffread.o coff-pe-read.o \
dwarf2read.o mipsread.o stabsread.o corefile.o \
- dwarf2expr.o dwarf2loc.o dwarf2-frame.o \
+ dwarf2block.o dwarf2expr.o dwarf2loc.o dwarf2-frame.o \
ada-lang.o c-lang.o f-lang.o objc-lang.o \
ui-out.o cli-out.o \
varobj.o vec.o wrapper.o \
@@ -2086,6 +2087,8 @@ dummy-frame.o: dummy-frame.c $(defs_h) $
$(command_h) $(gdbcmd_h) $(gdb_string_h)
dfp.o: dfp.c $(defs_h) $(expression_h) $(gdbtypes_h) $(value_h) $(dfp_h) \
$(decimal128_h) $(decimal64_h) $(decimal32_h)
+dwarf2block.o: dwarf2block.c $(dwarf2block_h) $(defs_h) $(gdbcore_h) \
+ $(dwarf2expr_h) $(exceptions_h)
dwarf2expr.o: dwarf2expr.c $(defs_h) $(symtab_h) $(gdbtypes_h) $(value_h) \
$(gdbcore_h) $(elf_dwarf2_h) $(dwarf2expr_h)
dwarf2-frame.o: dwarf2-frame.c $(defs_h) $(dwarf2expr_h) $(elf_dwarf2_h) \
@@ -2096,13 +2099,14 @@ dwarf2-frame.o: dwarf2-frame.c $(defs_h)
dwarf2loc.o: dwarf2loc.c $(defs_h) $(ui_out_h) $(value_h) $(frame_h) \
$(gdbcore_h) $(target_h) $(inferior_h) $(ax_h) $(ax_gdb_h) \
$(regcache_h) $(objfiles_h) $(exceptions_h) $(elf_dwarf2_h) \
- $(dwarf2expr_h) $(dwarf2loc_h) $(gdb_string_h) $(gdb_assert_h)
+ $(dwarf2expr_h) $(dwarf2loc_h) $(gdb_string_h) $(gdb_assert_h) \
+ $(dwarf2block_h)
dwarf2read.o: dwarf2read.c $(defs_h) $(bfd_h) $(symtab_h) $(gdbtypes_h) \
$(objfiles_h) $(elf_dwarf2_h) $(buildsym_h) $(demangle_h) \
$(expression_h) $(filenames_h) $(macrotab_h) $(language_h) \
$(complaints_h) $(bcache_h) $(dwarf2expr_h) $(dwarf2loc_h) \
$(cp_support_h) $(hashtab_h) $(command_h) $(gdbcmd_h) \
- $(gdb_string_h) $(gdb_assert_h)
+ $(gdb_string_h) $(gdb_assert_h) $(dwarf2block_h) $(f_lang_h)
elfread.o: elfread.c $(defs_h) $(bfd_h) $(gdb_string_h) $(elf_bfd_h) \
$(elf_mips_h) $(symtab_h) $(symfile_h) $(objfiles_h) $(buildsym_h) \
$(stabsread_h) $(gdb_stabs_h) $(complaints_h) $(demangle_h) \
@@ -2138,10 +2142,10 @@ f-exp.o: f-exp.c $(defs_h) $(gdb_string_
findvar.o: findvar.c $(defs_h) $(symtab_h) $(gdbtypes_h) $(frame_h) \
$(value_h) $(gdbcore_h) $(inferior_h) $(target_h) $(gdb_string_h) \
$(gdb_assert_h) $(floatformat_h) $(symfile_h) $(regcache_h) \
- $(user_regs_h) $(block_h)
+ $(user_regs_h) $(block_h) $(dwarf2block_h)
f-lang.o: f-lang.c $(defs_h) $(gdb_string_h) $(symtab_h) $(gdbtypes_h) \
$(expression_h) $(parser_defs_h) $(language_h) $(f_lang_h) \
- $(valprint_h) $(value_h)
+ $(valprint_h) $(value_h) $(dwarf2block_h)
fork-child.o: fork-child.c $(defs_h) $(gdb_string_h) $(frame_h) \
$(inferior_h) $(target_h) $(gdb_wait_h) $(gdb_vfork_h) $(gdbcore_h) \
$(terminal_h) $(gdbthread_h) $(command_h) $(solib_h)
@@ -2166,7 +2170,7 @@ frv-tdep.o: frv-tdep.c $(defs_h) $(gdb_s
$(frv_tdep_h)
f-typeprint.o: f-typeprint.c $(defs_h) $(gdb_obstack_h) $(bfd_h) $(symtab_h) \
$(gdbtypes_h) $(expression_h) $(value_h) $(gdbcore_h) $(target_h) \
- $(f_lang_h) $(gdb_string_h)
+ $(f_lang_h) $(gdb_string_h) $(dwarf2block_h)
f-valprint.o: f-valprint.c $(defs_h) $(gdb_string_h) $(symtab_h) \
$(gdbtypes_h) $(expression_h) $(value_h) $(valprint_h) $(language_h) \
$(f_lang_h) $(frame_h) $(gdbcore_h) $(command_h) $(block_h)
@@ -2181,7 +2185,8 @@ gdb-events.o: gdb-events.c $(defs_h) $(g
gdbtypes.o: gdbtypes.c $(defs_h) $(gdb_string_h) $(bfd_h) $(symtab_h) \
$(symfile_h) $(objfiles_h) $(gdbtypes_h) $(expression_h) \
$(language_h) $(target_h) $(value_h) $(demangle_h) $(complaints_h) \
- $(gdbcmd_h) $(wrapper_h) $(cp_abi_h) $(gdb_assert_h) $(hashtab_h)
+ $(gdbcmd_h) $(wrapper_h) $(cp_abi_h) $(gdb_assert_h) $(hashtab_h) \
+ $(dwarf2block_h)
glibc-tdep.o: glibc-tdep.c $(defs_h) $(frame_h) $(symtab_h) $(symfile_h) \
$(objfiles_h) $(glibc_tdep_h)
gnu-nat.o: gnu-nat.c $(gdb_string_h) $(defs_h) $(inferior_h) $(symtab_h) \
@@ -2939,7 +2944,7 @@ tramp-frame.o: tramp-frame.c $(defs_h) $
typeprint.o: typeprint.c $(defs_h) $(gdb_obstack_h) $(bfd_h) $(symtab_h) \
$(gdbtypes_h) $(expression_h) $(value_h) $(gdbcore_h) $(command_h) \
$(gdbcmd_h) $(target_h) $(language_h) $(cp_abi_h) $(typeprint_h) \
- $(gdb_string_h)
+ $(gdb_string_h) $(dwarf2block_h)
ui-file.o: ui-file.c $(defs_h) $(ui_file_h) $(gdb_string_h)
ui-out.o: ui-out.c $(defs_h) $(gdb_string_h) $(expression_h) $(language_h) \
$(ui_out_h) $(gdb_assert_h)
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/ada-lang.c gdb-6.8cvs20080219/gdb/ada-lang.c
--- gdb-6.8cvs20080219-fortranless/gdb/ada-lang.c 2008-02-14 23:03:56.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/ada-lang.c 2008-02-22 16:47:53.000000000 +0100
@@ -11012,6 +11012,7 @@ const struct language_defn ada_language_
ada_language_arch_info,
ada_print_array_index,
default_pass_by_reference,
+ default_value_address_get, /* Retrieve the real data value */
LANG_MAGIC
};
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/c-lang.c gdb-6.8cvs20080219/gdb/c-lang.c
--- gdb-6.8cvs20080219-fortranless/gdb/c-lang.c 2008-02-14 23:03:56.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/c-lang.c 2008-02-22 17:01:17.000000000 +0100
@@ -427,6 +427,7 @@ const struct language_defn c_language_de
c_language_arch_info,
default_print_array_index,
default_pass_by_reference,
+ default_value_address_get, /* Retrieve the real data value */
LANG_MAGIC
};
@@ -540,6 +541,7 @@ const struct language_defn cplus_languag
cplus_language_arch_info,
default_print_array_index,
cp_pass_by_reference,
+ default_value_address_get, /* Retrieve the real data value */
LANG_MAGIC
};
@@ -575,6 +577,7 @@ const struct language_defn asm_language_
c_language_arch_info, /* FIXME: la_language_arch_info. */
default_print_array_index,
default_pass_by_reference,
+ default_value_address_get, /* Retrieve the real data value */
LANG_MAGIC
};
@@ -615,6 +618,7 @@ const struct language_defn minimal_langu
c_language_arch_info,
default_print_array_index,
default_pass_by_reference,
+ default_value_address_get, /* Retrieve the real data value */
LANG_MAGIC
};
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/dwarf2block.c gdb-6.8cvs20080219/gdb/dwarf2block.c
--- gdb-6.8cvs20080219-fortranless/gdb/dwarf2block.c 1970-01-01 01:00:00.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/dwarf2block.c 2008-02-22 16:49:35.000000000 +0100
@@ -0,0 +1,153 @@
+/* DWARF DW_FORM_block* expression evaluation.
+
+ Copyright (C) 2007 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/>. */
+
+#include "defs.h"
+#include "dwarf2block.h"
+#include "gdbcore.h"
+#include "dwarf2expr.h"
+#include "exceptions.h"
+
+/* This is the baton used when performing dwarf2 DW_BLOCK evaluation. */
+struct dwarf_block_baton
+{
+ CORE_ADDR address;
+};
+
+/* Read memory at ADDR (length LEN) into BUF. */
+
+static void
+dwarf_block_read_mem (void *baton, gdb_byte *buf, CORE_ADDR addr, size_t len)
+{
+ read_memory (addr, buf, len);
+}
+
+static CORE_ADDR
+dwarf_block_object_address (void *baton)
+{
+ struct dwarf_block_baton *debaton = baton;
+
+ /* The message is suppressed in DWARF_BLOCK_EXEC. */
+ if (debaton->address == 0)
+ error (_("Cannot resolve DW_OP_push_object_address for a missing object"));
+
+ return debaton->address;
+}
+
+static CORE_ADDR
+dwarf_block_read_reg (void *baton, int regnum)
+{
+ error (_("Unsupported operation for DW_FORM_block*: %s"), "read_reg");
+ return 0;
+}
+
+static void
+dwarf_block_get_frame_base (void *baton, gdb_byte **start, size_t *length)
+{
+ error (_("Unsupported operation for DW_FORM_block*: %s"), "get_frame_base");
+}
+
+static CORE_ADDR
+dwarf_block_get_tls_address (void *baton, CORE_ADDR offset)
+{
+ error (_("Unsupported operation for DW_FORM_block*: %s"), "get_tls_address");
+ return 0;
+}
+
+static CORE_ADDR dwarf_block_exec_core (struct dwarf_block *dwarf_block,
+ CORE_ADDR address)
+{
+ struct dwarf_expr_context *ctx;
+ struct dwarf_block_baton baton;
+ struct cleanup *back_to;
+ CORE_ADDR retval;
+
+ back_to = make_cleanup (null_cleanup, 0);
+
+ baton.address = address;
+
+ ctx = new_dwarf_expr_context ();
+ back_to = make_cleanup ((make_cleanup_ftype *) free_dwarf_expr_context, ctx);
+ ctx->baton = &baton;
+ ctx->read_mem = dwarf_block_read_mem;
+ ctx->get_object_address = dwarf_block_object_address;
+ ctx->read_reg = dwarf_block_read_reg;
+ ctx->get_frame_base = dwarf_block_get_frame_base;
+ ctx->get_tls_address = dwarf_block_get_tls_address;
+
+ dwarf_expr_eval (ctx, dwarf_block->data, dwarf_block->size);
+
+ if (ctx->num_pieces > 0)
+ error (_("DW_OP_piece is an unsupported result for DW_FORM_block*"));
+ if (ctx->in_reg)
+ error (_("DW_OP_reg* is an unsupported result for DW_FORM_block*"));
+
+ retval = dwarf_expr_fetch (ctx, 0);
+
+ do_cleanups (back_to);
+
+ return retval;
+}
+
+static CORE_ADDR object_address;
+
+static void
+object_address_cleanup (void *prev_save_voidp)
+{
+ CORE_ADDR *prev_save = prev_save_voidp;
+
+ object_address = *prev_save;
+ xfree (prev_save);
+}
+
+void
+object_address_set (CORE_ADDR address)
+{
+ CORE_ADDR *prev_save;
+
+ prev_save = xmalloc (sizeof *prev_save);
+ *prev_save = object_address;
+ make_cleanup (object_address_cleanup, prev_save);
+
+ object_address = address;
+}
+
+CORE_ADDR
+object_address_get (void)
+{
+ return object_address;
+}
+
+CORE_ADDR dwarf_block_exec (struct dwarf_block *dwarf_block)
+{
+ volatile struct gdb_exception e;
+ volatile CORE_ADDR retval = 0;
+
+ TRY_CATCH (e, RETURN_MASK_ERROR)
+ {
+ retval = dwarf_block_exec_core (dwarf_block, object_address);
+ }
+ /* CATCH_ERRORS would print the possible error message of
+ DWARF_BLOCK_OBJECT_ADDRESS. Sometimes it is valid as CHECK_TYPEDEF is
+ a very common call even if we still do not know any variable instance of
+ that type. We cannot fill in the right TYPE_LENGTH at that time. */
+ if (e.reason < 0)
+ return 0;
+
+ return retval;
+}
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/dwarf2block.h gdb-6.8cvs20080219/gdb/dwarf2block.h
--- gdb-6.8cvs20080219-fortranless/gdb/dwarf2block.h 1970-01-01 01:00:00.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/dwarf2block.h 2008-02-22 16:49:35.000000000 +0100
@@ -0,0 +1,36 @@
+/* DWARF DW_FORM_block* expression evaluation.
+
+ Copyright (C) 2007 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/>. */
+
+#if !defined (DWARF2BLOCK_H)
+#define DWARF2BLOCK_H 1
+
+/* Blocks are a bunch of untyped bytes. */
+struct dwarf_block
+ {
+ unsigned int size;
+ gdb_byte *data;
+ };
+
+extern CORE_ADDR dwarf_block_exec (struct dwarf_block *dwarf_block);
+
+extern void object_address_set (CORE_ADDR address);
+
+extern CORE_ADDR object_address_get (void);
+
+#endif /* !defined(DWARF2BLOCK_H) */
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/dwarf2expr.c gdb-6.8cvs20080219/gdb/dwarf2expr.c
--- gdb-6.8cvs20080219-fortranless/gdb/dwarf2expr.c 2008-02-22 08:19:37.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/dwarf2expr.c 2008-02-22 16:49:35.000000000 +0100
@@ -750,6 +750,13 @@ execute_stack_op (struct dwarf_expr_cont
ctx->initialized = 0;
goto no_push;
+ case DW_OP_push_object_address:
+ if (ctx->get_object_address == NULL)
+ error (_("DWARF-2 expression error: DW_OP_push_object_address must "
+ "have a value to push."));
+ result = (ctx->get_object_address) (ctx->baton);
+ break;
+
default:
error (_("Unhandled dwarf expression opcode 0x%x"), op);
}
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/dwarf2expr.h gdb-6.8cvs20080219/gdb/dwarf2expr.h
--- gdb-6.8cvs20080219-fortranless/gdb/dwarf2expr.h 2008-01-02 00:03:54.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/dwarf2expr.h 2008-02-22 16:49:35.000000000 +0100
@@ -61,10 +61,10 @@ struct dwarf_expr_context
The result must be live until the current expression evaluation
is complete. */
unsigned char *(*get_subr) (void *baton, off_t offset, size_t *length);
+#endif
/* Return the `object address' for DW_OP_push_object_address. */
CORE_ADDR (*get_object_address) (void *baton);
-#endif
/* The current depth of dwarf expression recursion, via DW_OP_call*,
DW_OP_fbreg, DW_OP_push_object_address, etc., and the maximum
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/dwarf2loc.c gdb-6.8cvs20080219/gdb/dwarf2loc.c
--- gdb-6.8cvs20080219-fortranless/gdb/dwarf2loc.c 2008-01-02 00:03:54.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/dwarf2loc.c 2008-02-22 16:49:35.000000000 +0100
@@ -35,6 +35,7 @@
#include "elf/dwarf2.h"
#include "dwarf2expr.h"
#include "dwarf2loc.h"
+#include "dwarf2block.h"
#include "gdb_string.h"
#include "gdb_assert.h"
@@ -252,6 +253,9 @@ dwarf2_evaluate_loc_desc (struct symbol
{
CORE_ADDR address = dwarf_expr_fetch (ctx, 0);
+ /* ADDR is set here for ALLOCATE_VALUE's CHECK_TYPEDEF for
+ DW_OP_push_object_address. */
+ object_address_set (address);
retval = allocate_value (SYMBOL_TYPE (var));
VALUE_LVAL (retval) = lval_memory;
set_value_lazy (retval, 1);
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/dwarf2read.c gdb-6.8cvs20080219/gdb/dwarf2read.c
--- gdb-6.8cvs20080219-fortranless/gdb/dwarf2read.c 2008-02-22 08:19:37.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/dwarf2read.c 2008-02-22 16:59:22.000000000 +0100
@@ -46,6 +46,8 @@
#include "top.h"
#include "command.h"
#include "gdbcmd.h"
+#include "dwarf2block.h"
+#include "f-lang.h"
#include <fcntl.h>
#include "gdb_string.h"
@@ -563,13 +565,6 @@ struct function_range
#define DW_SND(attr) ((attr)->u.snd)
#define DW_ADDR(attr) ((attr)->u.addr)
-/* Blocks are a bunch of untyped bytes. */
-struct dwarf_block
- {
- unsigned int size;
- gdb_byte *data;
- };
-
#ifndef ATTR_ALLOC_CHUNK
#define ATTR_ALLOC_CHUNK 4
#endif
@@ -1004,7 +999,14 @@ static void store_in_ref_table (unsigned
static unsigned int dwarf2_get_ref_die_offset (struct attribute *,
struct dwarf2_cu *);
-static int dwarf2_get_attr_constant_value (struct attribute *, int);
+enum dwarf2_get_attr_constant_value
+ {
+ dwarf2_attr_unknown,
+ dwarf2_attr_const,
+ dwarf2_attr_block
+ };
+static enum dwarf2_get_attr_constant_value dwarf2_get_attr_constant_value
+ (struct attribute *attr, int *val_return);
static struct die_info *follow_die_ref (struct die_info *,
struct attribute *,
@@ -4383,6 +4385,56 @@ process_enumeration_scope (struct die_in
new_symbol (die, die->type, cu);
}
+static void
+fortran_array_update (struct fortran_array_type **fortran_array_pointer,
+ struct die_info *die, struct dwarf2_cu *cu,
+ int read_data_location, struct type *memory_owner)
+{
+ struct fortran_array_type *p;
+ struct fortran_array_type fortran_array_local;
+ /* Used only for checking if FORTRAN_ARRAY is non-zero. */
+ static struct fortran_array_type fortran_array_zero;
+ struct attribute *attr;
+
+ /* Prepare FORTRAN_ARRAY_POINTER. It needs to be present in all the subarray
+ types and in all the range types at least for
+ TYPE_VERIFY_VALID_ARRAY_OBJECT. */
+
+ if (*fortran_array_pointer != NULL)
+ p = *fortran_array_pointer;
+ else
+ {
+ memset (&fortran_array_local, 0, sizeof fortran_array_local);
+ p = &fortran_array_local;
+ }
+
+ if (read_data_location)
+ {
+ attr = dwarf2_attr (die, DW_AT_data_location, cu);
+ if (attr)
+ p->data_location = DW_BLOCK (attr);
+ }
+
+ attr = dwarf2_attr (die, DW_AT_allocated, cu);
+ if (attr)
+ p->allocated = DW_BLOCK (attr);
+
+ attr = dwarf2_attr (die, DW_AT_associated, cu);
+ if (attr)
+ p->associated = DW_BLOCK (attr);
+
+ if (p != &fortran_array_local)
+ {}
+ else if (memcmp (p, &fortran_array_zero, sizeof *p) == 0)
+ *fortran_array_pointer = NULL;
+ else
+ {
+ *fortran_array_pointer = TYPE_ALLOC (memory_owner,
+ sizeof **fortran_array_pointer);
+ **fortran_array_pointer = fortran_array_local;
+ }
+}
+
/* Extract all information from a DW_TAG_array_type DIE and put it in
the DIE's type field. For now, this only handles one dimensional
arrays. */
@@ -4399,6 +4451,7 @@ read_array_type (struct die_info *die, s
int ndim = 0;
struct cleanup *back_to;
char *name;
+ struct fortran_array_type *fortran_array;
/* Return if we've already decoded this type. */
if (die->type)
@@ -4408,6 +4461,13 @@ read_array_type (struct die_info *die, s
element_type = die_type (die, cu);
+ /* Prepare FORTRAN_ARRAY_POINTER. It needs to be present in all the subarray
+ types and in all the range types at least for
+ TYPE_VERIFY_VALID_ARRAY_OBJECT. */
+
+ fortran_array = NULL;
+ fortran_array_update (&fortran_array, die, cu, 1, element_type);
+
/* Irix 6.2 native cc creates array types without children for
arrays with unspecified length. */
if (die->child == NULL)
@@ -4416,6 +4476,9 @@ read_array_type (struct die_info *die, s
range_type = create_range_type (NULL, index_type, 0, -1);
set_die_type (die, create_array_type (NULL, element_type, range_type),
cu);
+
+ TYPE_FORTRAN_ARRAY (range_type) = fortran_array;
+ TYPE_FORTRAN_ARRAY (die->type) = fortran_array;
return;
}
@@ -4452,14 +4515,31 @@ read_array_type (struct die_info *die, s
if (read_array_order (die, cu) == DW_ORD_col_major)
{
- int i = 0;
- while (i < ndim)
- type = create_array_type (NULL, type, range_types[i++]);
+ int i;
+ for (i = 0; i < ndim; i++)
+ {
+ type = create_array_type (NULL, type, range_types[i]);
+ TYPE_FORTRAN_ARRAY (range_types[i]) = fortran_array;
+ TYPE_FORTRAN_ARRAY (type) = fortran_array;
+ TYPE_ARRAY_UPPER_BOUND_TYPE (type) =
+ TYPE_ARRAY_UPPER_BOUND_TYPE (range_types[i]);
+ TYPE_ARRAY_LOWER_BOUND_TYPE (type) =
+ TYPE_ARRAY_LOWER_BOUND_TYPE (range_types[i]);
+ }
}
else
{
- while (ndim-- > 0)
- type = create_array_type (NULL, type, range_types[ndim]);
+ int i;
+ for (i = ndim - 1; i >= 0; i--)
+ {
+ type = create_array_type (NULL, type, range_types[i]);
+ TYPE_FORTRAN_ARRAY (range_types[i]) = fortran_array;
+ TYPE_FORTRAN_ARRAY (type) = fortran_array;
+ TYPE_ARRAY_UPPER_BOUND_TYPE (type) =
+ TYPE_ARRAY_UPPER_BOUND_TYPE (range_types[i]);
+ TYPE_ARRAY_LOWER_BOUND_TYPE (type) =
+ TYPE_ARRAY_LOWER_BOUND_TYPE (range_types[i]);
+ }
}
/* Understand Dwarf2 support for vector types (like they occur on
@@ -4679,13 +4759,25 @@ read_tag_pointer_type (struct die_info *
struct attribute *attr_byte_size;
struct attribute *attr_address_class;
int byte_size, addr_class;
+ struct type *target_type;
if (die->type)
{
return;
}
- type = lookup_pointer_type (die_type (die, cu));
+ target_type = die_type (die, cu);
+
+ /* Intel Fortran Compiler 10.1.008 puts DW_AT_associated into
+ DW_TAG_pointer_type pointing to its target DW_TAG_array_type.
+ GDB supports DW_AT_associated and DW_AT_allocated only for the
+ DW_TAG_array_type tags. */
+ if (TYPE_CODE (target_type) == TYPE_CODE_ARRAY
+ && TYPE_FORTRAN_ARRAY (target_type) != NULL)
+ fortran_array_update (&TYPE_FORTRAN_ARRAY (target_type), die, cu, 0,
+ target_type);
+
+ type = lookup_pointer_type (target_type);
attr_byte_size = dwarf2_attr (die, DW_AT_byte_size, cu);
if (attr_byte_size)
@@ -5048,9 +5140,9 @@ read_subrange_type (struct die_info *die
{
struct type *base_type;
struct type *range_type;
- struct attribute *attr;
- int low = 0;
- int high = -1;
+ struct attribute *attr, *byte_stride_attr;
+ int low, high, byte_stride_int;
+ enum dwarf2_get_attr_constant_value high_type, byte_stride_type;
char *name;
/* If we have already decoded this die, then nothing more to do. */
@@ -5067,42 +5159,99 @@ read_subrange_type (struct die_info *die
0, NULL, cu->objfile);
}
- if (cu->language == language_fortran)
- {
- /* FORTRAN implies a lower bound of 1, if not given. */
- low = 1;
- }
+ /* DW_AT_bit_stride is unsupported as if it would be non-constant we would
+ have to wrap it by the division by 8 or provide another value type etc. */
+ byte_stride_attr = dwarf2_attr (die, DW_AT_byte_stride, cu);
+ byte_stride_type = dwarf2_get_attr_constant_value (byte_stride_attr,
+ &byte_stride_int);
+
+ range_type = create_range_type_nfields
+ (NULL, base_type, byte_stride_type == dwarf2_attr_unknown ? 2 : 3);
- /* FIXME: For variable sized arrays either of these could be
- a variable rather than a constant value. We'll allow it,
- but we don't know how to handle it. */
attr = dwarf2_attr (die, DW_AT_lower_bound, cu);
- if (attr)
- low = dwarf2_get_attr_constant_value (attr, 0);
+ switch (dwarf2_get_attr_constant_value (attr, &low))
+ {
+ case dwarf2_attr_unknown:
+ if (cu->language == language_fortran)
+ {
+ /* FORTRAN implies a lower bound of 1, if not given. */
+ low = 1;
+ }
+ else
+ {
+ /* According to DWARF3 we should assume the value 0 only for
+ LANGUAGE_C and LANGUAGE_CPLUS. */
+ low = 0;
+ }
+ /* PASSTHRU */
+ case dwarf2_attr_const:
+ TYPE_LOW_BOUND_RAW (range_type) = low;
+ if (low >= 0)
+ TYPE_FLAGS (range_type) |= TYPE_FLAG_UNSIGNED;
+ break;
+ case dwarf2_attr_block:
+ TYPE_BOUND_IS_DWARF_BLOCK_VAR (range_type, 0)
+ |= TYPE_BOUND_IS_DWARF_BLOCK_MASK;
+ TYPE_FIELD_DWARF_BLOCK (range_type, 0) = DW_BLOCK (attr);
+ /* For auto-detection of possibly missing DW_AT_upper_bound. */
+ low = 0;
+ break;
+ }
attr = dwarf2_attr (die, DW_AT_upper_bound, cu);
- if (attr)
- {
- if (attr->form == DW_FORM_block1)
- {
- /* GCC encodes arrays with unspecified or dynamic length
- with a DW_FORM_block1 attribute.
- FIXME: GDB does not yet know how to handle dynamic
- arrays properly, treat them as arrays with unspecified
- length for now.
-
- FIXME: jimb/2003-09-22: GDB does not really know
- how to handle arrays of unspecified length
- either; we just represent them as zero-length
- arrays. Choose an appropriate upper bound given
- the lower bound we've computed above. */
- high = low - 1;
- }
- else
- high = dwarf2_get_attr_constant_value (attr, 1);
+ high_type = dwarf2_get_attr_constant_value (attr, &high);
+ if (high_type == dwarf2_attr_unknown)
+ {
+ int count;
+
+ attr = dwarf2_attr (die, DW_AT_count, cu);
+ high_type = dwarf2_get_attr_constant_value (attr, &count);
+ switch (high_type)
+ {
+ case dwarf2_attr_unknown:
+ break;
+ case dwarf2_attr_const:
+ /* We do not handle LOW being set as DW_BLOCK here. */
+ high = low + count - 1;
+ /* PASSTHRU */
+ case dwarf2_attr_block:
+ TYPE_HIGH_BOUND_IS_COUNT_VAR (range_type)
+ |= TYPE_HIGH_BOUND_IS_COUNT_MASK;
+ break;
+ }
+ }
+ switch (high_type)
+ {
+ case dwarf2_attr_unknown:
+ /* It needs to get propagated to he array type owning us. */
+ TYPE_ARRAY_UPPER_BOUND_TYPE (range_type) = BOUND_CANNOT_BE_DETERMINED;
+ high = low - 1;
+ /* PASSTHRU */
+ case dwarf2_attr_const:
+ TYPE_HIGH_BOUND_RAW (range_type) = high;
+ break;
+ case dwarf2_attr_block:
+ TYPE_BOUND_IS_DWARF_BLOCK_VAR (range_type, 1)
+ |= TYPE_BOUND_IS_DWARF_BLOCK_MASK;
+ TYPE_FIELD_DWARF_BLOCK (range_type, 1) = DW_BLOCK (attr);
+ break;
}
- range_type = create_range_type (NULL, base_type, low, high);
+ switch (byte_stride_type)
+ {
+ case dwarf2_attr_unknown:
+ break;
+ case dwarf2_attr_const:
+ if (byte_stride_int == 0)
+ warning (_("Found DW_AT_byte_stride with unsupported value 0"));
+ TYPE_HIGH_BOUND_RAW (range_type) = byte_stride_int;
+ break;
+ case dwarf2_attr_block:
+ TYPE_BOUND_IS_DWARF_BLOCK_VAR (range_type, 2)
+ |= TYPE_BOUND_IS_DWARF_BLOCK_MASK;
+ TYPE_FIELD_DWARF_BLOCK (range_type, 2) = DW_BLOCK (byte_stride_attr);
+ break;
+ }
name = dwarf2_name (die, cu);
if (name)
@@ -9058,26 +9207,35 @@ dwarf2_get_ref_die_offset (struct attrib
return result;
}
-/* Return the constant value held by the given attribute. Return -1
- if the value held by the attribute is not constant. */
+/* *VAL_RETURN is filled only for DWARF2_ATTR_CONST. */
-static int
-dwarf2_get_attr_constant_value (struct attribute *attr, int default_value)
+static enum dwarf2_get_attr_constant_value
+dwarf2_get_attr_constant_value (struct attribute *attr, int *val_return)
{
+ if (attr == NULL)
+ return dwarf2_attr_unknown;
if (attr->form == DW_FORM_sdata)
- return DW_SND (attr);
- else if (attr->form == DW_FORM_udata
- || attr->form == DW_FORM_data1
- || attr->form == DW_FORM_data2
- || attr->form == DW_FORM_data4
- || attr->form == DW_FORM_data8)
- return DW_UNSND (attr);
- else
{
- complaint (&symfile_complaints, _("Attribute value is not a constant (%s)"),
- dwarf_form_name (attr->form));
- return default_value;
+ *val_return = DW_SND (attr);
+ return dwarf2_attr_const;
+ }
+ if (attr->form == DW_FORM_udata
+ || attr->form == DW_FORM_data1
+ || attr->form == DW_FORM_data2
+ || attr->form == DW_FORM_data4
+ || attr->form == DW_FORM_data8)
+ {
+ *val_return = DW_UNSND (attr);
+ return dwarf2_attr_const;
}
+ if (attr->form == DW_FORM_block
+ || attr->form == DW_FORM_block1
+ || attr->form == DW_FORM_block2
+ || attr->form == DW_FORM_block4)
+ return dwarf2_attr_block;
+ complaint (&symfile_complaints, _("Attribute value is not a constant (%s)"),
+ dwarf_form_name (attr->form));
+ return dwarf2_attr_unknown;
}
static struct die_info *
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/eval.c gdb-6.8cvs20080219/gdb/eval.c
--- gdb-6.8cvs20080219-fortranless/gdb/eval.c 2008-02-14 23:03:57.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/eval.c 2008-02-22 16:59:22.000000000 +0100
@@ -1643,9 +1643,12 @@ evaluate_subexp_standard (struct type *e
{
int subscript_array[MAX_FORTRAN_DIMS];
int array_size_array[MAX_FORTRAN_DIMS];
+ int byte_stride_array[MAX_FORTRAN_DIMS];
int ndimensions = 1, i;
struct type *tmp_type;
int offset_item; /* The array offset where the item lives */
+ CORE_ADDR offset_byte; /* byte_stride based offset */
+ unsigned element_size;
if (nargs > MAX_FORTRAN_DIMS)
error (_("Too many subscripts for F77 (%d Max)"), MAX_FORTRAN_DIMS);
@@ -1682,6 +1685,9 @@ evaluate_subexp_standard (struct type *e
if (retcode == BOUND_FETCH_ERROR)
error (_("Cannot obtain dynamic lower bound"));
+ byte_stride_array[nargs - i - 1] =
+ TYPE_ARRAY_BYTE_STRIDE_VALUE (tmp_type);
+
array_size_array[nargs - i - 1] = upper - lower + 1;
/* Zero-normalize subscripts so that offsetting will work. */
@@ -1702,11 +1708,22 @@ evaluate_subexp_standard (struct type *e
/* Now let us calculate the offset for this item */
- offset_item = subscript_array[ndimensions - 1];
+ offset_item = 0;
+ offset_byte = 0;
+
+ for (i = ndimensions - 1; i >= 0; --i)
+ {
+ offset_item *= array_size_array[i];
+ if (byte_stride_array[i] == 0)
+ offset_item += subscript_array[i];
+ else
+ offset_byte += subscript_array[i] * byte_stride_array[i];
+ }
- for (i = ndimensions - 1; i > 0; --i)
- offset_item =
- array_size_array[i - 1] * offset_item + subscript_array[i - 1];
+ element_size = TYPE_LENGTH (TYPE_TARGET_TYPE (tmp_type));
+ if (offset_byte % element_size != 0)
+ warning (_("Fortran array stride not divisible by the element size"));
+ offset_item += offset_byte / element_size;
/* Construct a value node with the value of the offset */
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/f-lang.c gdb-6.8cvs20080219/gdb/f-lang.c
--- gdb-6.8cvs20080219-fortranless/gdb/f-lang.c 2008-02-14 23:03:57.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/f-lang.c 2008-02-22 16:59:22.000000000 +0100
@@ -31,6 +31,7 @@
#include "f-lang.h"
#include "valprint.h"
#include "value.h"
+#include "dwarf2block.h"
/* Following is dubious stuff that had been in the xcoff reader. */
@@ -222,6 +223,29 @@ f_printstr (struct ui_file *stream, cons
if (force_ellipses || i < length)
fputs_filtered ("...", stream);
}
+
+static int
+f_value_address_get (struct type *type, CORE_ADDR *address_return)
+{
+ if (f_type_object_valid_query (type) != NULL)
+ {
+ /* Do not try to evaluate DW_AT_data_location as it may even crash
+ (it would just return the value zero in the gfortran case). */
+ return 0;
+ }
+
+ /* Accelerated codepath. */
+ if (address_return == NULL)
+ return 1;
+
+ if (TYPE_CODE (type) == TYPE_CODE_ARRAY && TYPE_FORTRAN_ARRAY (type) != NULL)
+ {
+ if (TYPE_FORTRAN_ARRAY_DATA_LOCATION (type) != NULL)
+ *address_return = dwarf_block_exec (TYPE_FORTRAN_ARRAY_DATA_LOCATION (type));
+ }
+
+ return 1;
+}
/* Table of operators and their precedences for printing expressions. */
@@ -337,6 +361,7 @@ const struct language_defn f_language_de
f_language_arch_info,
default_print_array_index,
default_pass_by_reference,
+ f_value_address_get, /* Retrieve the real data value */
LANG_MAGIC
};
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/f-lang.h gdb-6.8cvs20080219/gdb/f-lang.h
--- gdb-6.8cvs20080219-fortranless/gdb/f-lang.h 2008-01-02 00:03:54.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/f-lang.h 2008-02-22 16:59:22.000000000 +0100
@@ -28,6 +28,11 @@ extern void f_error (char *); /* Defined
extern void f_print_type (struct type *, char *, struct ui_file *, int,
int);
+extern const char *f_type_object_valid_query (struct type *type);
+extern const char *f_type_object_valid_to_stream (struct type *type,
+ struct ui_file *stream);
+extern void f_type_object_valid_error (struct type *type);
+
extern int f_val_print (struct type *, const gdb_byte *, int, CORE_ADDR,
struct ui_file *, int, int, int,
enum val_prettyprint);
@@ -47,6 +52,32 @@ enum f90_range_type
NONE_BOUND_DEFAULT /* "(low:high)" */
};
+/* GNU Fortran specific - for TYPE_FORTRAN_ARRAY.
+ All the DWARF_BLOCK fields are passed for execution to DWARF_BLOCK_EXEC. */
+
+struct fortran_array_type
+{
+ /* For DW_AT_data_location. This entry is more appropriate for generic
+ MAIN_TYPE but we save the MAIN_TYPE size as it is in practice not present
+ for the other types. */
+ struct dwarf_block *data_location;
+
+ /* For DW_AT_allocated. */
+ struct dwarf_block *allocated;
+
+ /* For DW_AT_associated. */
+ struct dwarf_block *associated;
+};
+
+/* Be sure to check `TYPE_CODE (thistype) == TYPE_CODE_ARRAY
+ && TYPE_FORTRAN_ARRAY (thistype) != NULL'. */
+#define TYPE_FORTRAN_ARRAY_DATA_LOCATION(thistype) \
+ TYPE_FORTRAN_ARRAY (thistype)->data_location
+#define TYPE_FORTRAN_ARRAY_ALLOCATED(thistype) \
+ TYPE_FORTRAN_ARRAY (thistype)->allocated
+#define TYPE_FORTRAN_ARRAY_ASSOCIATED(thistype) \
+ TYPE_FORTRAN_ARRAY (thistype)->associated
+
struct common_entry
{
struct symbol *symbol; /* The symbol node corresponding
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/f-typeprint.c gdb-6.8cvs20080219/gdb/f-typeprint.c
--- gdb-6.8cvs20080219-fortranless/gdb/f-typeprint.c 2008-01-02 00:03:54.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/f-typeprint.c 2008-02-22 16:59:22.000000000 +0100
@@ -31,6 +31,7 @@
#include "gdbcore.h"
#include "target.h"
#include "f-lang.h"
+#include "dwarf2block.h"
#include "gdb_string.h"
#include <errno.h>
@@ -39,7 +40,7 @@
static void f_type_print_args (struct type *, struct ui_file *);
#endif
-static void f_type_print_varspec_suffix (struct type *, struct ui_file *,
+static void f_type_print_varspec_suffix (struct type *, struct ui_file *, int,
int, int, int);
void f_type_print_varspec_prefix (struct type *, struct ui_file *,
@@ -48,6 +49,50 @@ void f_type_print_varspec_prefix (struct
void f_type_print_base (struct type *, struct ui_file *, int, int);
+const char *
+f_type_object_valid_query (struct type *type)
+{
+ if (TYPE_CODE (type) == TYPE_CODE_ARRAY && TYPE_FORTRAN_ARRAY (type) != NULL)
+ {
+ /* DW_AT_associated has a preference over DW_AT_allocated. */
+ if (TYPE_FORTRAN_ARRAY_ASSOCIATED (type) != NULL
+ && !dwarf_block_exec (TYPE_FORTRAN_ARRAY_ASSOCIATED (type)))
+ return N_("the array is not associated");
+
+ if (TYPE_FORTRAN_ARRAY_ALLOCATED (type) != NULL
+ && !dwarf_block_exec (TYPE_FORTRAN_ARRAY_ALLOCATED (type)))
+ return N_("the array is not allocated");
+ }
+ return NULL;
+}
+
+const char *
+f_type_object_valid_to_stream (struct type *type, struct ui_file *stream)
+{
+ const char *msg;
+
+ msg = f_type_object_valid_query (type);
+ if (msg != NULL)
+ {
+ /* Assuming the content printed to STREAM should not be localized. */
+ fprintf_filtered (stream, "<%s>", msg);
+ }
+
+ return msg;
+}
+
+void
+f_type_object_valid_error (struct type *type)
+{
+ const char *msg;
+
+ msg = f_type_object_valid_query (type);
+ if (msg != NULL)
+ {
+ error (_("Unable to access the object because %s."), _(msg));
+ }
+}
+
/* LEVEL is the depth to indent lines by. */
void
@@ -57,6 +102,9 @@ f_print_type (struct type *type, char *v
enum type_code code;
int demangled_args;
+ if (f_type_object_valid_to_stream (type, stream) != NULL)
+ return;
+
f_type_print_base (type, stream, show, level);
code = TYPE_CODE (type);
if ((varstring != NULL && *varstring != '\0')
@@ -78,7 +126,7 @@ f_print_type (struct type *type, char *v
so don't print an additional pair of ()'s */
demangled_args = varstring[strlen (varstring) - 1] == ')';
- f_type_print_varspec_suffix (type, stream, show, 0, demangled_args);
+ f_type_print_varspec_suffix (type, stream, show, 0, demangled_args, 0);
}
/* Print any asterisks or open-parentheses needed before the
@@ -147,12 +195,14 @@ f_type_print_varspec_prefix (struct type
static void
f_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
- int show, int passed_a_ptr, int demangled_args)
+ int show, int passed_a_ptr, int demangled_args,
+ int arrayprint_recurse_level)
{
int upper_bound, lower_bound;
int lower_bound_was_default = 0;
- static int arrayprint_recurse_level = 0;
int retcode;
+ /* No static variables (such as ARRAYPRINT_RECURSE_LEVEL) permitted as ERROR
+ may occur during the evaluation of DWARF_BLOCK values. */
if (type == 0)
return;
@@ -171,7 +221,8 @@ f_type_print_varspec_suffix (struct type
fprintf_filtered (stream, "(");
if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY)
- f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0);
+ f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0,
+ arrayprint_recurse_level);
retcode = f77_get_dynamic_lowerbound (type, &lower_bound);
@@ -205,7 +256,8 @@ f_type_print_varspec_suffix (struct type
}
if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_ARRAY)
- f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0);
+ f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0,
+ arrayprint_recurse_level);
if (arrayprint_recurse_level == 1)
fprintf_filtered (stream, ")");
else
@@ -215,13 +267,14 @@ f_type_print_varspec_suffix (struct type
case TYPE_CODE_PTR:
case TYPE_CODE_REF:
- f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0);
+ f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0,
+ arrayprint_recurse_level);
fprintf_filtered (stream, ")");
break;
case TYPE_CODE_FUNC:
f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
- passed_a_ptr, 0);
+ passed_a_ptr, 0, arrayprint_recurse_level);
if (passed_a_ptr)
fprintf_filtered (stream, ")");
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/f-valprint.c gdb-6.8cvs20080219/gdb/f-valprint.c
--- gdb-6.8cvs20080219-fortranless/gdb/f-valprint.c 2008-02-14 23:03:57.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/f-valprint.c 2008-02-22 16:59:22.000000000 +0100
@@ -54,11 +54,11 @@ int f77_array_offset_tbl[MAX_FORTRAN_DIM
/* The following macro gives us the size of the nth dimension, Where
n is 1 based. */
-#define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
+#define F77_DIM_COUNT(n) (f77_array_offset_tbl[n][1])
-/* The following gives us the offset for row n where n is 1-based. */
+/* The following gives us the element size for row n where n is 1-based. */
-#define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
+#define F77_DIM_BYTE_STRIDE(n) (f77_array_offset_tbl[n][0])
int
f77_get_dynamic_lowerbound (struct type *type, int *lower_bound)
@@ -67,6 +67,8 @@ f77_get_dynamic_lowerbound (struct type
CORE_ADDR current_frame_addr;
CORE_ADDR ptr_to_lower_bound;
+ f_type_object_valid_error (type);
+
switch (TYPE_ARRAY_LOWER_BOUND_TYPE (type))
{
case BOUND_BY_VALUE_ON_STACK:
@@ -128,6 +130,8 @@ f77_get_dynamic_upperbound (struct type
CORE_ADDR current_frame_addr = 0;
CORE_ADDR ptr_to_upper_bound;
+ f_type_object_valid_error (type);
+
switch (TYPE_ARRAY_UPPER_BOUND_TYPE (type))
{
case BOUND_BY_VALUE_ON_STACK:
@@ -250,24 +254,29 @@ f77_create_arrayprint_offset_tbl (struct
if (retcode == BOUND_FETCH_ERROR)
error (_("Cannot obtain dynamic lower bound"));
- F77_DIM_SIZE (ndimen) = upper - lower + 1;
+ F77_DIM_COUNT (ndimen) = upper - lower + 1;
+
+ F77_DIM_BYTE_STRIDE (ndimen) =
+ TYPE_ARRAY_BYTE_STRIDE_VALUE (tmp_type);
tmp_type = TYPE_TARGET_TYPE (tmp_type);
ndimen++;
}
- /* Now we multiply eltlen by all the offsets, so that later we
+ /* Now we multiply eltlen by all the BYTE_STRIDEs, so that later we
can print out array elements correctly. Up till now we
- know an offset to apply to get the item but we also
+ know an eltlen to apply to get the item but we also
have to know how much to add to get to the next item */
ndimen--;
eltlen = TYPE_LENGTH (tmp_type);
- F77_DIM_OFFSET (ndimen) = eltlen;
+ if (F77_DIM_BYTE_STRIDE (ndimen) == 0)
+ F77_DIM_BYTE_STRIDE (ndimen) = eltlen;
while (--ndimen > 0)
{
- eltlen *= F77_DIM_SIZE (ndimen + 1);
- F77_DIM_OFFSET (ndimen) = eltlen;
+ eltlen *= F77_DIM_COUNT (ndimen + 1);
+ if (F77_DIM_BYTE_STRIDE (ndimen) == 0)
+ F77_DIM_BYTE_STRIDE (ndimen) = eltlen;
}
}
@@ -287,33 +296,33 @@ f77_print_array_1 (int nss, int ndimensi
if (nss != ndimensions)
{
- for (i = 0; (i < F77_DIM_SIZE (nss) && (*elts) < print_max); i++)
+ for (i = 0; (i < F77_DIM_COUNT (nss) && (*elts) < print_max); i++)
{
fprintf_filtered (stream, "( ");
f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
- valaddr + i * F77_DIM_OFFSET (nss),
- address + i * F77_DIM_OFFSET (nss),
+ valaddr + i * F77_DIM_BYTE_STRIDE (nss),
+ address + i * F77_DIM_BYTE_STRIDE (nss),
stream, format, deref_ref, recurse, pretty, elts);
fprintf_filtered (stream, ") ");
}
- if (*elts >= print_max && i < F77_DIM_SIZE (nss))
+ if (*elts >= print_max && i < F77_DIM_COUNT (nss))
fprintf_filtered (stream, "...");
}
else
{
- for (i = 0; i < F77_DIM_SIZE (nss) && (*elts) < print_max;
+ for (i = 0; i < F77_DIM_COUNT (nss) && (*elts) < print_max;
i++, (*elts)++)
{
val_print (TYPE_TARGET_TYPE (type),
- valaddr + i * F77_DIM_OFFSET (ndimensions),
+ valaddr + i * F77_DIM_BYTE_STRIDE (ndimensions),
0,
- address + i * F77_DIM_OFFSET (ndimensions),
+ address + i * F77_DIM_BYTE_STRIDE (ndimensions),
stream, format, deref_ref, recurse, pretty);
- if (i != (F77_DIM_SIZE (nss) - 1))
+ if (i != (F77_DIM_COUNT (nss) - 1))
fprintf_filtered (stream, ", ");
- if ((*elts == print_max - 1) && (i != (F77_DIM_SIZE (nss) - 1)))
+ if ((*elts == print_max - 1) && (i != (F77_DIM_COUNT (nss) - 1)))
fprintf_filtered (stream, "...");
}
}
@@ -372,6 +381,9 @@ f_val_print (struct type *type, const gd
CORE_ADDR addr;
int index;
+ if (f_type_object_valid_to_stream (type, stream) != NULL)
+ return 0;
+
CHECK_TYPEDEF (type);
switch (TYPE_CODE (type))
{
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/findvar.c gdb-6.8cvs20080219/gdb/findvar.c
--- gdb-6.8cvs20080219-fortranless/gdb/findvar.c 2008-01-02 00:03:54.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/findvar.c 2008-02-22 16:50:29.000000000 +0100
@@ -34,6 +34,7 @@
#include "regcache.h"
#include "user-regs.h"
#include "block.h"
+#include "dwarf2block.h"
/* Basic byte-swapping routines. GDB has needed these for a long time...
All extract a target-format integer at ADDR which is LEN bytes long. */
@@ -370,24 +371,8 @@ symbol_read_needs_frame (struct symbol *
struct value *
read_var_value (struct symbol *var, struct frame_info *frame)
{
- struct value *v;
struct type *type = SYMBOL_TYPE (var);
CORE_ADDR addr;
- int len;
-
- if (SYMBOL_CLASS (var) == LOC_COMPUTED
- || SYMBOL_CLASS (var) == LOC_COMPUTED_ARG
- || SYMBOL_CLASS (var) == LOC_REGISTER
- || SYMBOL_CLASS (var) == LOC_REGPARM)
- /* These cases do not use V. */
- v = NULL;
- else
- {
- v = allocate_value (type);
- VALUE_LVAL (v) = lval_memory; /* The most likely possibility. */
- }
-
- len = TYPE_LENGTH (type);
/* FIXME drow/2003-09-06: this call to the selected frame should be
pushed upwards to the callers. */
@@ -397,31 +382,39 @@ read_var_value (struct symbol *var, stru
switch (SYMBOL_CLASS (var))
{
case LOC_CONST:
- /* Put the constant back in target format. */
- store_signed_integer (value_contents_raw (v), len,
- (LONGEST) SYMBOL_VALUE (var));
- VALUE_LVAL (v) = not_lval;
- return v;
+ {
+ /* Put the constant back in target format. */
+ struct value *v = allocate_value (type);
+ VALUE_LVAL (v) = not_lval;
+ store_signed_integer (value_contents_raw (v), TYPE_LENGTH (type),
+ (LONGEST) SYMBOL_VALUE (var));
+ return v;
+ }
case LOC_LABEL:
- /* Put the constant back in target format. */
- if (overlay_debugging)
- {
- CORE_ADDR addr
- = symbol_overlayed_address (SYMBOL_VALUE_ADDRESS (var),
- SYMBOL_BFD_SECTION (var));
- store_typed_address (value_contents_raw (v), type, addr);
- }
- else
- store_typed_address (value_contents_raw (v), type,
- SYMBOL_VALUE_ADDRESS (var));
- VALUE_LVAL (v) = not_lval;
- return v;
+ {
+ /* Put the constant back in target format. */
+ struct value *v = allocate_value (type);
+ VALUE_LVAL (v) = not_lval;
+ if (overlay_debugging)
+ {
+ CORE_ADDR addr
+ = symbol_overlayed_address (SYMBOL_VALUE_ADDRESS (var),
+ SYMBOL_BFD_SECTION (var));
+ store_typed_address (value_contents_raw (v), type, addr);
+ }
+ else
+ store_typed_address (value_contents_raw (v), type,
+ SYMBOL_VALUE_ADDRESS (var));
+ return v;
+ }
case LOC_CONST_BYTES:
{
- memcpy (value_contents_raw (v), SYMBOL_VALUE_BYTES (var), len);
+ struct value *v = allocate_value (type);
VALUE_LVAL (v) = not_lval;
+ memcpy (value_contents_raw (v), SYMBOL_VALUE_BYTES (var),
+ TYPE_LENGTH (type));
return v;
}
@@ -503,12 +496,23 @@ addresses have not been bound by the dyn
break;
case LOC_BLOCK:
- if (overlay_debugging)
- VALUE_ADDRESS (v) = symbol_overlayed_address
- (BLOCK_START (SYMBOL_BLOCK_VALUE (var)), SYMBOL_BFD_SECTION (var));
- else
- VALUE_ADDRESS (v) = BLOCK_START (SYMBOL_BLOCK_VALUE (var));
- return v;
+ {
+ CORE_ADDR addr;
+ struct value *v;
+
+ if (overlay_debugging)
+ addr = symbol_overlayed_address
+ (BLOCK_START (SYMBOL_BLOCK_VALUE (var)), SYMBOL_BFD_SECTION (var));
+ else
+ addr = BLOCK_START (SYMBOL_BLOCK_VALUE (var));
+ /* ADDR is set here for ALLOCATE_VALUE's CHECK_TYPEDEF for
+ DW_OP_push_object_address. */
+ object_address_set (addr);
+ v = allocate_value (type);
+ VALUE_ADDRESS (v) = addr;
+ VALUE_LVAL (v) = lval_memory;
+ return v;
+ }
case LOC_REGISTER:
case LOC_REGPARM:
@@ -532,7 +536,6 @@ addresses have not been bound by the dyn
error (_("Value of register variable not available."));
addr = value_as_address (regval);
- VALUE_LVAL (v) = lval_memory;
}
else
{
@@ -572,18 +575,33 @@ addresses have not been bound by the dyn
break;
case LOC_OPTIMIZED_OUT:
- VALUE_LVAL (v) = not_lval;
- set_value_optimized_out (v, 1);
- return v;
+ {
+ struct value *v = allocate_value (type);
+
+ VALUE_LVAL (v) = not_lval;
+ set_value_optimized_out (v, 1);
+ return v;
+ }
default:
error (_("Cannot look up value of a botched symbol."));
break;
}
- VALUE_ADDRESS (v) = addr;
- set_value_lazy (v, 1);
- return v;
+ {
+ struct value *v;
+
+ /* ADDR is set here for ALLOCATE_VALUE's CHECK_TYPEDEF for
+ DW_OP_push_object_address. */
+ object_address_set (addr);
+ v = allocate_value (type);
+ VALUE_ADDRESS (v) = addr;
+ VALUE_LVAL (v) = lval_memory;
+
+ set_value_lazy (v, 1);
+
+ return v;
+ }
}
/* Install default attributes for register values. */
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/gdbtypes.c gdb-6.8cvs20080219/gdb/gdbtypes.c
--- gdb-6.8cvs20080219-fortranless/gdb/gdbtypes.c 2008-02-22 08:19:37.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/gdbtypes.c 2008-02-22 16:58:30.000000000 +0100
@@ -38,6 +38,7 @@
#include "cp-abi.h"
#include "gdb_assert.h"
#include "hashtab.h"
+#include "dwarf2block.h"
/* These variables point to the objects
representing the predefined C data types. */
@@ -682,16 +683,21 @@ allocate_stub_method (struct type *type)
RESULT_TYPE, or creating a new type, inheriting the objfile from
INDEX_TYPE.
- Indices will be of type INDEX_TYPE, and will range from LOW_BOUND
- to HIGH_BOUND, inclusive.
+ Indices will be of type INDEX_TYPE. NFIELDS should be 2 for standard
+ arrays, 3 for a custom TYPE_BYTE_STRIDE. Use CREATE_RANGE_TYPE for common
+ constant LOW_BOUND/HIGH_BOUND ranges.
+
+ You must set TYPE_FLAG_UNSIGNED yourself as being done in CREATE_RANGE_TYPE.
FIXME: Maybe we should check the TYPE_CODE of RESULT_TYPE to make
sure it is TYPE_CODE_UNDEF before we bash it into a range type? */
struct type *
-create_range_type (struct type *result_type, struct type *index_type,
- int low_bound, int high_bound)
+create_range_type_nfields (struct type *result_type, struct type *index_type,
+ int nfields)
{
+ int fieldno;
+
if (result_type == NULL)
{
result_type = alloc_type (TYPE_OBJFILE (index_type));
@@ -702,17 +708,33 @@ create_range_type (struct type *result_t
TYPE_FLAGS (result_type) |= TYPE_FLAG_TARGET_STUB;
else
TYPE_LENGTH (result_type) = TYPE_LENGTH (check_typedef (index_type));
- TYPE_NFIELDS (result_type) = 2;
+ TYPE_NFIELDS (result_type) = nfields;
TYPE_FIELDS (result_type) = (struct field *)
- TYPE_ALLOC (result_type, 2 * sizeof (struct field));
- memset (TYPE_FIELDS (result_type), 0, 2 * sizeof (struct field));
- TYPE_FIELD_BITPOS (result_type, 0) = low_bound;
- TYPE_FIELD_BITPOS (result_type, 1) = high_bound;
+ TYPE_ALLOC (result_type,
+ TYPE_NFIELDS (result_type) * sizeof (struct field));
+ memset (TYPE_FIELDS (result_type), 0,
+ TYPE_NFIELDS (result_type) * sizeof (struct field));
+
+ return (result_type);
+}
+
+/* Simplified CREATE_RANGE_TYPE_NFIELDS for constant ranges from LOW_BOUND to
+ HIGH_BOUND, inclusive. TYPE_BYTE_STRIDE is always set to zero (default
+ native target type length). */
+
+struct type *
+create_range_type (struct type *result_type, struct type *index_type,
+ int low_bound, int high_bound)
+{
+ result_type = create_range_type_nfields (result_type, index_type, 2);
+
+ TYPE_LOW_BOUND_RAW (result_type) = low_bound;
+ TYPE_HIGH_BOUND_RAW (result_type) = high_bound;
if (low_bound >= 0)
TYPE_FLAGS (result_type) |= TYPE_FLAG_UNSIGNED;
- return (result_type);
+ return result_type;
}
/* Set *LOWP and *HIGHP to the lower and upper bounds of discrete type
@@ -800,25 +822,23 @@ create_array_type (struct type *result_t
struct type *element_type,
struct type *range_type)
{
- LONGEST low_bound, high_bound;
-
if (result_type == NULL)
{
result_type = alloc_type (TYPE_OBJFILE (range_type));
}
TYPE_CODE (result_type) = TYPE_CODE_ARRAY;
TYPE_TARGET_TYPE (result_type) = element_type;
- if (get_discrete_bounds (range_type, &low_bound, &high_bound) < 0)
- low_bound = high_bound = 0;
CHECK_TYPEDEF (element_type);
- /* Be careful when setting the array length. Ada arrays can be
- empty arrays with the high_bound being smaller than the low_bound.
- In such cases, the array length should be zero. */
- if (high_bound < low_bound)
+ /* Dynamically sized arrays cannot be computed now as we may have forward
+ DWARF references here. */
+ if ((TYPE_BOUND_IS_DWARF_BLOCK_VAR (range_type, 0)
+ & TYPE_BOUND_IS_DWARF_BLOCK_MASK) != 0
+ && (TYPE_BOUND_IS_DWARF_BLOCK_VAR (range_type, 1)
+ & TYPE_BOUND_IS_DWARF_BLOCK_MASK) != 0)
TYPE_LENGTH (result_type) = 0;
else
- TYPE_LENGTH (result_type) =
- TYPE_LENGTH (element_type) * (high_bound - low_bound + 1);
+ TYPE_LENGTH (result_type) = TYPE_LENGTH (element_type)
+ * TYPE_COUNT_BOUND (range_type);
TYPE_NFIELDS (result_type) = 1;
TYPE_FIELDS (result_type) =
(struct field *) TYPE_ALLOC (result_type, sizeof (struct field));
@@ -1377,6 +1397,116 @@ stub_noname_complaint (void)
complaint (&symfile_complaints, _("stub type has NULL name"));
}
+CORE_ADDR range_type_any_field_internal (struct type *range_type, int fieldno)
+{
+ if ((TYPE_BOUND_IS_DWARF_BLOCK_VAR (range_type, fieldno)
+ & TYPE_BOUND_IS_DWARF_BLOCK_MASK) != 0)
+ return dwarf_block_exec (TYPE_FIELD_DWARF_BLOCK (range_type, fieldno));
+ else
+ return TYPE_FIELD_BITPOS (range_type, (fieldno));
+}
+
+int
+range_type_high_bound_internal (struct type *range_type)
+{
+ int raw_value = range_type_any_field_internal (range_type, 1);
+
+ if ((TYPE_HIGH_BOUND_IS_COUNT_VAR (range_type)
+ & TYPE_HIGH_BOUND_IS_COUNT_MASK) == 0)
+ {
+ /* DW_AT_upper_bound value. */
+ return raw_value;
+ }
+ else
+ {
+ /* DW_AT_count value. */
+ return TYPE_LOW_BOUND (range_type) + raw_value - 1;
+ }
+}
+
+int
+range_type_count_bound_internal (struct type *range_type)
+{
+ int raw_value = range_type_any_field_internal (range_type, 1);
+ if ((TYPE_HIGH_BOUND_IS_COUNT_VAR (range_type)
+ & TYPE_HIGH_BOUND_IS_COUNT_MASK) != 0)
+ {
+ /* DW_AT_count value. */
+ return raw_value;
+ }
+ else
+ {
+ /* DW_AT_upper_bound value. */
+ /* Be careful when getting the array length. Ada arrays can be
+ empty arrays with the high_bound being smaller than the low_bound.
+ In such cases, the array length should be zero. */
+ if (raw_value < TYPE_LOW_BOUND (range_type))
+ return 0;
+ return 1 + raw_value - TYPE_LOW_BOUND (range_type);
+ }
+}
+
+CORE_ADDR range_type_byte_stride_internal (struct type *range_type)
+{
+ if (TYPE_NFIELDS (range_type) >= 3)
+ return range_type_any_field_internal (range_type, 2);
+ else
+ {
+ /* The caller will need to call something like
+ `TYPE_LENGTH (check_typedef (element_type))
+ * TYPE_COUNT_BOUND (range_type) '. */
+ return 0;
+ }
+}
+
+/* Calculate the memory length of array TYPE.
+
+ TARGET_TYPE should be set to `check_typedef (TYPE_TARGET_TYPE (type))' as
+ a performance hint. Feel free to pass NULL. Set FULL_SPAN to return the
+ size incl. the possibly incomplete last element - it may differ from the
+ cleared FULL_SPAN return value for larger TYPE_BYTE_STRIDE values. */
+
+static CORE_ADDR
+type_length_get (struct type *type, struct type *target_type, int full_span)
+{
+ struct type *range_type;
+ int count;
+ CORE_ADDR byte_stride = 0; /* `= 0' for a false GCC warning. */
+ CORE_ADDR element_size;
+
+ if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
+ return TYPE_LENGTH (type);
+
+ /* Avoid executing TYPE_COUNT_BOUND for invalid (unallocated/unassociated)
+ Fortran arrays. The allocated data will never be used so they can be
+ zero-length. */
+ if (!LA_VALUE_ADDRESS_GET (type, NULL))
+ return 0;
+
+ range_type = TYPE_INDEX_TYPE (type);
+ count = TYPE_COUNT_BOUND (range_type);
+ if (count < 0)
+ warning (_("Object count %d < 0"), count);
+ if (count <= 0)
+ return 0;
+ if (full_span || count > 1)
+ {
+ byte_stride = TYPE_BYTE_STRIDE (range_type);
+ if (byte_stride == 0)
+ {
+ if (target_type == NULL)
+ target_type = check_typedef (TYPE_TARGET_TYPE (type));
+ byte_stride = type_length_get (target_type, NULL, 1);
+ }
+ }
+ if (full_span)
+ return count * byte_stride;
+ if (target_type == NULL)
+ target_type = check_typedef (TYPE_TARGET_TYPE (type));
+ element_size = type_length_get (target_type, NULL, 1);
+ return (count - 1) * byte_stride + element_size;
+}
+
/* Added by Bryan Boreham, Kewill, Sun Sep 17 18:07:17 1989.
If this is a stubbed struct (i.e. declared as struct foo *), see if
@@ -1520,19 +1650,8 @@ check_typedef (struct type *type)
== TYPE_CODE_RANGE))
{
/* Now recompute the length of the array type, based on its
- number of elements and the target type's length.
- Watch out for Ada null Ada arrays where the high bound
- is smaller than the low bound. */
- const int low_bound = TYPE_FIELD_BITPOS (range_type, 0);
- const int high_bound = TYPE_FIELD_BITPOS (range_type, 1);
- int nb_elements;
-
- if (high_bound < low_bound)
- nb_elements = 0;
- else
- nb_elements = high_bound - low_bound + 1;
-
- TYPE_LENGTH (type) = nb_elements * TYPE_LENGTH (target_type);
+ number of elements and the target type's length. */
+ TYPE_LENGTH (type) = type_length_get (type, target_type, 0);
TYPE_FLAGS (type) &= ~TYPE_FLAG_TARGET_STUB;
}
else if (TYPE_CODE (type) == TYPE_CODE_RANGE)
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/gdbtypes.h gdb-6.8cvs20080219/gdb/gdbtypes.h
--- gdb-6.8cvs20080219-fortranless/gdb/gdbtypes.h 2008-02-22 08:19:37.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/gdbtypes.h 2008-02-22 16:59:22.000000000 +0100
@@ -417,6 +417,9 @@ struct main_type
CORE_ADDR physaddr;
char *physname;
+
+ /* For dynamically-sized arrays. Passed to DWARF_BLOCK_EXEC. */
+ struct dwarf_block *dwarf_block;
}
loc;
@@ -427,7 +430,11 @@ struct main_type
/* This flag is zero for non-static fields, 1 for fields whose location
is specified by the label loc.physname, and 2 for fields whose location
- is specified by loc.physaddr. */
+ is specified by loc.physaddr.
+ For range bounds bit 0 cleared is for loc.bitpos and bit 0 set is for
+ loc.dwarf_block (TYPE_BOUND_IS_DWARF_BLOCK_MASK).
+ For range bounds bit 1 cleared is for DW_AT_upper_bound and bit 1 set is
+ for DW_AT_count (TYPE_HIGH_BOUND_IS_COUNT_MASK). */
unsigned int static_kind : 2;
@@ -481,6 +488,10 @@ struct main_type
targets and the second is for little endian targets. */
const struct floatformat **floatformat;
+
+ /* FORTRAN_ARRAY is for TYPE_CODE_ARRAY. */
+
+ struct fortran_array_type *fortran_array;
} type_specific;
};
@@ -766,9 +777,9 @@ extern void allocate_cplus_struct_type (
#define TYPE_POINTER_TYPE(thistype) (thistype)->pointer_type
#define TYPE_REFERENCE_TYPE(thistype) (thistype)->reference_type
#define TYPE_CHAIN(thistype) (thistype)->chain
-/* Note that if thistype is a TYPEDEF type, you have to call check_typedef.
- But check_typedef does set the TYPE_LENGTH of the TYPEDEF type,
- so you only have to call check_typedef once. Since allocate_value
+/* Note that if thistype is a TYPEDEF or ARRAY type, you have to call
+ check_typedef. But check_typedef does set the TYPE_LENGTH of the TYPEDEF
+ type, so you only have to call check_typedef once. Since allocate_value
calls check_typedef, TYPE_LENGTH (VALUE_TYPE (X)) is safe. */
#define TYPE_LENGTH(thistype) (thistype)->length
#define TYPE_OBJFILE(thistype) TYPE_MAIN_TYPE(thistype)->objfile
@@ -782,8 +793,25 @@ extern void allocate_cplus_struct_type (
#define TYPE_INSTANTIATIONS(thistype) TYPE_CPLUS_SPECIFIC(thistype)->instantiations
#define TYPE_INDEX_TYPE(type) TYPE_FIELD_TYPE (type, 0)
-#define TYPE_LOW_BOUND(range_type) TYPE_FIELD_BITPOS (range_type, 0)
-#define TYPE_HIGH_BOUND(range_type) TYPE_FIELD_BITPOS (range_type, 1)
+#define TYPE_LOW_BOUND_RAW(range_type) TYPE_FIELD_BITPOS (range_type, 0)
+#define TYPE_HIGH_BOUND_RAW(range_type) TYPE_FIELD_BITPOS (range_type, 1)
+/* `TYPE_NFIELDS (range_type) >= 3' check is required before accessing it: */
+#define TYPE_BYTE_STRIDE_RAW(range_type) TYPE_FIELD_BITPOS (range_type, 2)
+#define TYPE_LOW_BOUND(range_type) \
+ ((int) range_type_any_field_internal ((range_type), 0))
+#define TYPE_HIGH_BOUND(range_type) \
+ range_type_high_bound_internal ((range_type))
+#define TYPE_COUNT_BOUND(range_type) \
+ range_type_count_bound_internal ((range_type))
+#define TYPE_BYTE_STRIDE(type) \
+ range_type_byte_stride_internal ((type))
+
+#define TYPE_BOUND_IS_DWARF_BLOCK_MASK 1
+#define TYPE_BOUND_IS_DWARF_BLOCK_VAR(range_type, fieldno) \
+ TYPE_FIELD_STATIC_KIND (range_type, fieldno)
+#define TYPE_HIGH_BOUND_IS_COUNT_MASK 2
+#define TYPE_HIGH_BOUND_IS_COUNT_VAR(range_type) \
+ TYPE_FIELD_STATIC_KIND (range_type, 1)
/* Moto-specific stuff for FORTRAN arrays */
@@ -792,11 +820,12 @@ extern void allocate_cplus_struct_type (
#define TYPE_ARRAY_LOWER_BOUND_TYPE(thistype) \
TYPE_MAIN_TYPE(thistype)->lower_bound_type
-#define TYPE_ARRAY_UPPER_BOUND_VALUE(arraytype) \
- (TYPE_FIELD_BITPOS((TYPE_FIELD_TYPE((arraytype),0)),1))
-
#define TYPE_ARRAY_LOWER_BOUND_VALUE(arraytype) \
- (TYPE_FIELD_BITPOS((TYPE_FIELD_TYPE((arraytype),0)),0))
+ (TYPE_LOW_BOUND(TYPE_INDEX_TYPE(arraytype)))
+#define TYPE_ARRAY_UPPER_BOUND_VALUE(arraytype) \
+ (TYPE_HIGH_BOUND(TYPE_INDEX_TYPE(arraytype)))
+#define TYPE_ARRAY_BYTE_STRIDE_VALUE(arraytype) \
+ (TYPE_BYTE_STRIDE(TYPE_INDEX_TYPE(arraytype)))
/* C++ */
@@ -812,6 +841,7 @@ extern void allocate_cplus_struct_type (
#define TYPE_TYPE_SPECIFIC(thistype) TYPE_MAIN_TYPE(thistype)->type_specific
#define TYPE_CPLUS_SPECIFIC(thistype) TYPE_MAIN_TYPE(thistype)->type_specific.cplus_stuff
#define TYPE_FLOATFORMAT(thistype) TYPE_MAIN_TYPE(thistype)->type_specific.floatformat
+#define TYPE_FORTRAN_ARRAY(thistype) TYPE_MAIN_TYPE(thistype)->type_specific.fortran_array
#define TYPE_BASECLASS(thistype,index) TYPE_MAIN_TYPE(thistype)->fields[index].type
#define TYPE_N_BASECLASSES(thistype) TYPE_CPLUS_SPECIFIC(thistype)->n_baseclasses
#define TYPE_BASECLASS_NAME(thistype,index) TYPE_MAIN_TYPE(thistype)->fields[index].name
@@ -826,6 +856,7 @@ extern void allocate_cplus_struct_type (
#define FIELD_TYPE(thisfld) ((thisfld).type)
#define FIELD_NAME(thisfld) ((thisfld).name)
#define FIELD_BITPOS(thisfld) ((thisfld).loc.bitpos)
+#define FIELD_DWARF_BLOCK(thisfld) ((thisfld).loc.dwarf_block)
#define FIELD_ARTIFICIAL(thisfld) ((thisfld).artificial)
#define FIELD_BITSIZE(thisfld) ((thisfld).bitsize)
#define FIELD_STATIC_KIND(thisfld) ((thisfld).static_kind)
@@ -839,6 +870,7 @@ extern void allocate_cplus_struct_type (
#define TYPE_FIELD_TYPE(thistype, n) FIELD_TYPE(TYPE_FIELD(thistype, n))
#define TYPE_FIELD_NAME(thistype, n) FIELD_NAME(TYPE_FIELD(thistype, n))
#define TYPE_FIELD_BITPOS(thistype, n) FIELD_BITPOS(TYPE_FIELD(thistype,n))
+#define TYPE_FIELD_DWARF_BLOCK(thistype, n) FIELD_DWARF_BLOCK(TYPE_FIELD(thistype,n))
#define TYPE_FIELD_ARTIFICIAL(thistype, n) FIELD_ARTIFICIAL(TYPE_FIELD(thistype,n))
#define TYPE_FIELD_BITSIZE(thistype, n) FIELD_BITSIZE(TYPE_FIELD(thistype,n))
#define TYPE_FIELD_PACKED(thistype, n) (FIELD_BITSIZE(TYPE_FIELD(thistype,n))!=0)
@@ -1251,12 +1283,25 @@ extern struct type *make_function_type (
extern struct type *lookup_function_type (struct type *);
+extern struct type *create_range_type_nfields (struct type *result_type,
+ struct type *index_type,
+ int nfields);
+
extern struct type *create_range_type (struct type *, struct type *, int,
int);
extern struct type *create_array_type (struct type *, struct type *,
struct type *);
+extern CORE_ADDR range_type_any_field_internal (struct type *range_type,
+ int fieldno);
+
+extern int range_type_high_bound_internal (struct type *range_type);
+
+extern int range_type_count_bound_internal (struct type *range_type);
+
+extern CORE_ADDR range_type_byte_stride_internal (struct type *range_type);
+
extern struct type *create_string_type (struct type *, struct type *);
extern struct type *create_set_type (struct type *, struct type *);
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/jv-lang.c gdb-6.8cvs20080219/gdb/jv-lang.c
--- gdb-6.8cvs20080219-fortranless/gdb/jv-lang.c 2008-02-14 23:03:57.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/jv-lang.c 2008-02-22 16:47:53.000000000 +0100
@@ -1083,6 +1083,7 @@ const struct language_defn java_language
c_language_arch_info,
default_print_array_index,
default_pass_by_reference,
+ default_value_address_get, /* Retrieve the real data value */
LANG_MAGIC
};
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/language.c gdb-6.8cvs20080219/gdb/language.c
--- gdb-6.8cvs20080219-fortranless/gdb/language.c 2008-02-14 23:03:57.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/language.c 2008-02-22 16:47:53.000000000 +0100
@@ -1087,6 +1087,15 @@ default_print_array_index (struct value
fprintf_filtered (stream, "] = ");
}
+/* No *ADDRESS_RETURN change is needed as we do not support DW_AT_data_location
+ * for general types. */
+
+int
+default_value_address_get (struct type *type, CORE_ADDR *address_return)
+{
+ return 1;
+}
+
/* Define the language that is no language. */
static int
@@ -1205,6 +1214,7 @@ const struct language_defn unknown_langu
unknown_language_arch_info, /* la_language_arch_info. */
default_print_array_index,
default_pass_by_reference,
+ default_value_address_get, /* Retrieve the real data value */
LANG_MAGIC
};
@@ -1241,6 +1251,7 @@ const struct language_defn auto_language
unknown_language_arch_info, /* la_language_arch_info. */
default_print_array_index,
default_pass_by_reference,
+ default_value_address_get, /* Retrieve the real data value */
LANG_MAGIC
};
@@ -1276,6 +1287,7 @@ const struct language_defn local_languag
unknown_language_arch_info, /* la_language_arch_info. */
default_print_array_index,
default_pass_by_reference,
+ default_value_address_get, /* Retrieve the real data value */
LANG_MAGIC
};
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/language.h gdb-6.8cvs20080219/gdb/language.h
--- gdb-6.8cvs20080219-fortranless/gdb/language.h 2008-02-14 23:03:57.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/language.h 2008-02-22 16:47:53.000000000 +0100
@@ -268,6 +268,13 @@ struct language_defn
reference at the language level. */
int (*la_pass_by_reference) (struct type *type);
+ /* Return the data address (DW_AT_data_location) of TYPE into
+ *ADDRESS_RETURN. Return non-zero if the variable/data is valid.
+ You should set *ADDRESS_RETURN as VALUE_ADDRESS (VAL) as if no
+ DW_AT_data_location is present for TYPE *ADDRESS_RETURN is left
+ unchanged. ADDRESS_RETURN may be NULL. */
+ int (*la_value_address_get) (struct type *type, CORE_ADDR *address_return);
+
/* Add fields above this point, so the magic number is always last. */
/* Magic number for compat checking */
@@ -363,6 +370,9 @@ extern enum language set_language (enum
#define LA_PRINT_ARRAY_INDEX(index_value, stream, format, pretty) \
(current_language->la_print_array_index(index_value, stream, format, pretty))
+#define LA_VALUE_ADDRESS_GET(type, address_return) \
+ (current_language->la_value_address_get(type, address_return))
+
/* Test a character to decide whether it can be printed in literal form
or needs to be printed in another representation. For example,
in C the literal form of the character with octal value 141 is 'a'
@@ -470,4 +480,7 @@ int language_pass_by_reference (struct t
independent of this. */
int default_pass_by_reference (struct type *type);
+extern int default_value_address_get (struct type *type,
+ CORE_ADDR *address_return);
+
#endif /* defined (LANGUAGE_H) */
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/m2-lang.c gdb-6.8cvs20080219/gdb/m2-lang.c
--- gdb-6.8cvs20080219-fortranless/gdb/m2-lang.c 2008-02-14 23:03:58.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/m2-lang.c 2008-02-22 16:47:53.000000000 +0100
@@ -388,6 +388,7 @@ const struct language_defn m2_language_d
m2_language_arch_info,
default_print_array_index,
default_pass_by_reference,
+ default_value_address_get, /* Retrieve the real data value */
LANG_MAGIC
};
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/objc-lang.c gdb-6.8cvs20080219/gdb/objc-lang.c
--- gdb-6.8cvs20080219-fortranless/gdb/objc-lang.c 2008-02-14 23:03:59.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/objc-lang.c 2008-02-22 16:47:53.000000000 +0100
@@ -522,6 +522,7 @@ const struct language_defn objc_language
c_language_arch_info,
default_print_array_index,
default_pass_by_reference,
+ default_value_address_get, /* Retrieve the real data value */
LANG_MAGIC
};
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/p-lang.c gdb-6.8cvs20080219/gdb/p-lang.c
--- gdb-6.8cvs20080219-fortranless/gdb/p-lang.c 2008-02-14 23:03:59.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/p-lang.c 2008-02-22 16:47:53.000000000 +0100
@@ -427,6 +427,7 @@ const struct language_defn pascal_langua
pascal_language_arch_info,
default_print_array_index,
default_pass_by_reference,
+ default_value_address_get, /* Retrieve the real data value */
LANG_MAGIC
};
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/printcmd.c gdb-6.8cvs20080219/gdb/printcmd.c
--- gdb-6.8cvs20080219-fortranless/gdb/printcmd.c 2008-02-22 08:19:37.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/printcmd.c 2008-02-22 16:49:35.000000000 +0100
@@ -888,6 +888,11 @@ print_command_1 (char *exp, int inspect,
else
val = access_value_history (0);
+ /* Do not try to OBJECT_ADDRESS_SET here anything. We are interested in the
+ source variable base addresses as found by READ_VAR_VALUE. The value here
+ can be already a calculated expression address inappropriate for
+ DW_OP_push_object_address. */
+
if (voidprint || (val && value_type (val) &&
TYPE_CODE (value_type (val)) != TYPE_CODE_VOID))
{
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/scm-lang.c gdb-6.8cvs20080219/gdb/scm-lang.c
--- gdb-6.8cvs20080219-fortranless/gdb/scm-lang.c 2008-02-14 23:04:00.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/scm-lang.c 2008-02-22 16:47:53.000000000 +0100
@@ -266,6 +266,7 @@ const struct language_defn scm_language_
c_language_arch_info,
default_print_array_index,
default_pass_by_reference,
+ default_value_address_get, /* Retrieve the real data value */
LANG_MAGIC
};
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/testsuite/gdb.fortran/dynamic.exp gdb-6.8cvs20080219/gdb/testsuite/gdb.fortran/dynamic.exp
--- gdb-6.8cvs20080219-fortranless/gdb/testsuite/gdb.fortran/dynamic.exp 1970-01-01 01:00:00.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/testsuite/gdb.fortran/dynamic.exp 2008-02-22 16:59:42.000000000 +0100
@@ -0,0 +1,145 @@
+# Copyright 2007 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>.
+
+# This file is part of the gdb testsuite. It contains tests for dynamically
+# allocated Fortran arrays.
+# It depends on the GCC dynamic Fortran arrays DWARF support:
+# http://gcc.gnu.org/bugzilla/show_bug.cgi?id=22244
+
+if $tracelevel then {
+ strace $tracelevel
+}
+
+set testfile "dynamic"
+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 "varx-init"]
+gdb_continue_to_breakpoint "varx-init"
+gdb_test "p varx" "\\$\[0-9\]* = <the array is not allocated>"
+gdb_test "ptype varx" "type = <the array is not allocated>"
+gdb_test "p varx(1,5,17)" "Unable to access the object because the array is not allocated\\."
+gdb_test "p varx(1,5,17)=1" "Unable to access the object because the array is not allocated\\."
+gdb_test "ptype varx(1,5,17)" "Unable to access the object because the array is not allocated\\."
+
+gdb_breakpoint [gdb_get_line_number "varx-allocated"]
+gdb_continue_to_breakpoint "varx-allocated"
+# $1 = (( ( 0, 0, 0, 0, 0, 0) ( 0, 0, 0, 0, 0, 0) --- , 0) ) ( ( 0, 0, ...) ...) ...)
+gdb_test "ptype varx" "type = real\\*4 \\(6,5:15,17:28\\)"
+# Intel Fortran Compiler 10.1.008 uses -1 there, GCC uses 1.
+gdb_test "p l" "\\$\[0-9\]* = (\\.TRUE\\.|4294967295)"
+
+gdb_breakpoint [gdb_get_line_number "varx-filled"]
+gdb_continue_to_breakpoint "varx-filled"
+gdb_test "p varx(2, 5, 17)" "\\$\[0-9\]* = 6"
+gdb_test "p varx(1, 5, 17)" "\\$\[0-9\]* = 7"
+gdb_test "p varx(2, 6, 18)" "\\$\[0-9\]* = 8"
+gdb_test "p varx(6, 15, 28)" "\\$\[0-9\]* = 9"
+# The latter one is for the Intel Fortran Compiler 10.1.008 pointer type.
+gdb_test "p varv" "\\$\[0-9\]* = (<the array is not associated>|.*Unable to access the object because the array is not associated.)"
+gdb_test "ptype varv" "type = (<the array is not associated>|.*Unable to access the object because the array is not associated.)"
+
+gdb_breakpoint [gdb_get_line_number "varv-associated"]
+gdb_continue_to_breakpoint "varv-associated"
+gdb_test "p varx(3, 7, 19)" "\\$\[0-9\]* = 6"
+gdb_test "p varv(3, 7, 19)" "\\$\[0-9\]* = 6"
+# Intel Fortran Compiler 10.1.008 uses -1 there, GCC uses 1.
+gdb_test "p l" "\\$\[0-9\]* = (\\.TRUE\\.|4294967295)"
+gdb_test "ptype varx" "type = real\\*4 \\(6,5:15,17:28\\)"
+# Intel Fortran Compiler 10.1.008 uses the pointer type.
+gdb_test "ptype varv" "type = (PTR TO -> \\( )?real\\*4 \\(6,5:15,17:28\\)\\)?"
+
+gdb_breakpoint [gdb_get_line_number "varv-filled"]
+gdb_continue_to_breakpoint "varv-filled"
+gdb_test "p varx(3, 7, 19)" "\\$\[0-9\]* = 10"
+gdb_test "p varv(3, 7, 19)" "\\$\[0-9\]* = 10"
+
+gdb_breakpoint [gdb_get_line_number "varv-deassociated"]
+gdb_continue_to_breakpoint "varv-deassociated"
+# The latter one is for the Intel Fortran Compiler 10.1.008 pointer type.
+gdb_test "p varv" "\\$\[0-9\]* = (<the array is not associated>|.*Unable to access the object because the array is not associated.)"
+gdb_test "ptype varv" "type = (<the array is not associated>|.*Unable to access the object because the array is not associated.)"
+gdb_test "p l" "\\$\[0-9\]* = \\.FALSE\\."
+gdb_test "p varv(1,5,17)" "Unable to access the object because the array is not associated\\."
+gdb_test "ptype varv(1,5,17)" "Unable to access the object because the array is not associated\\."
+
+gdb_breakpoint [gdb_get_line_number "varx-deallocated"]
+gdb_continue_to_breakpoint "varx-deallocated"
+gdb_test "p varx" "\\$\[0-9\]* = <the array is not allocated>"
+gdb_test "ptype varx" "type = <the array is not allocated>"
+gdb_test "p l" "\\$\[0-9\]* = \\.FALSE\\."
+gdb_test "p varx(1,5,17)" "Unable to access the object because the array is not allocated\\."
+gdb_test "ptype varx(1,5,17)" "Unable to access the object because the array is not allocated\\."
+
+gdb_breakpoint [gdb_get_line_number "vary-passed"]
+gdb_continue_to_breakpoint "vary-passed"
+# $1 = (( ( 1, 1, 1, 1, 1, 1) ( 1, 1, 1, 1, 1, 1) --- , 1) ) ( ( 1, 1, ...) ...) ...)
+gdb_test "p vary" "\\$\[0-9\]* = \\(\[()1, .\]*\\)"
+
+gdb_breakpoint [gdb_get_line_number "vary-filled"]
+gdb_continue_to_breakpoint "vary-filled"
+gdb_test "ptype vary" "type = real\\*4 \\(10,10\\)"
+gdb_test "p vary(1, 1)" "\\$\[0-9\]* = 8"
+gdb_test "p vary(2, 2)" "\\$\[0-9\]* = 9"
+gdb_test "p vary(1, 3)" "\\$\[0-9\]* = 10"
+# $1 = (( ( 3, 3, 3, 3, 3, 3) ( 3, 3, 3, 3, 3, 3) --- , 3) ) ( ( 3, 3, ...) ...) ...)
+gdb_test "p varw" "\\$\[0-9\]* = \\(\[()3, .\]*\\)"
+
+gdb_breakpoint [gdb_get_line_number "varw-almostfilled"]
+gdb_continue_to_breakpoint "varw-almostfilled"
+gdb_test "ptype varw" "type = real\\*4 \\(5,4,3\\)"
+gdb_test "p varw(3,1,1)=1" "\\$\[0-9\]* = 1"
+# $1 = (( ( 6, 5, 1, 5, 5, 5) ( 5, 5, 5, 5, 5, 5) --- , 5) ) ( ( 5, 5, ...) ...) ...)
+gdb_test "p varw" "\\$\[0-9\]* = \\( *\\( *\\( *6, *5, *1,\[()5, .\]*\\)"
+# "up" works with GCC but other Fortran compilers may copy the values into the
+# outer function only on the exit of the inner function.
+gdb_test "finish" ".*call bar \\(y, x\\)"
+gdb_test "p z(2,4,5)" "\\$\[0-9\]* = 3"
+gdb_test "p z(2,4,6)" "\\$\[0-9\]* = 6"
+gdb_test "p z(2,4,7)" "\\$\[0-9\]* = 5"
+gdb_test "p z(4,4,6)" "\\$\[0-9\]* = 1"
+
+gdb_breakpoint [gdb_get_line_number "varz-almostfilled"]
+gdb_continue_to_breakpoint "varz-almostfilled"
+# GCC uses the pointer type here, Intel Fortran Compiler 10.1.008 does not.
+gdb_test "ptype varz" "type = (PTR TO -> \\( )?real\\*4 \\(\\*\\)\\)?"
+# Intel Fortran Compiler 10.1.008 has a bug here - (2:11,7:7)
+# as it produces DW_AT_lower_bound == DW_AT_upper_bound == 7.
+gdb_test "ptype vart" "type = (PTR TO -> \\( )?real\\*4 \\(2:11,7:\\*\\)\\)?"
+gdb_test "p varz(3)" "\\$\[0-9\]* = 4"
+# maps to foo::vary(1,1)
+gdb_test "p vart(2,7)" "\\$\[0-9\]* = 8"
+# maps to foo::vary(2,2)
+gdb_test "p vart(3,8)" "\\$\[0-9\]* = 9"
+# maps to foo::vary(1,3)
+gdb_test "p vart(2,9)" "\\$\[0-9\]* = 10"
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/testsuite/gdb.fortran/dynamic.f90 gdb-6.8cvs20080219/gdb/testsuite/gdb.fortran/dynamic.f90
--- gdb-6.8cvs20080219-fortranless/gdb/testsuite/gdb.fortran/dynamic.f90 1970-01-01 01:00:00.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/testsuite/gdb.fortran/dynamic.f90 2008-02-22 16:59:42.000000000 +0100
@@ -0,0 +1,97 @@
+! Copyright 2007 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 baz
+ real, target, allocatable :: varx (:, :, :)
+ real, pointer :: varv (:, :, :)
+ real, target :: varu (1, 2, 3)
+ logical :: l
+ allocate (varx (1:6, 5:15, 17:28)) ! varx-init
+ l = allocated (varx)
+ varx(:, :, :) = 6 ! varx-allocated
+ varx(1, 5, 17) = 7
+ varx(2, 6, 18) = 8
+ varx(6, 15, 28) = 9
+ varv => varx ! varx-filled
+ l = associated (varv)
+ varv(3, 7, 19) = 10 ! varv-associated
+ varv => null () ! varv-filled
+ l = associated (varv)
+ deallocate (varx) ! varv-deassociated
+ l = allocated (varx)
+ varu(:, :, :) = 10 ! varx-deallocated
+ allocate (varv (1:6, 5:15, 17:28))
+ l = associated (varv)
+ varv(:, :, :) = 6
+ varv(1, 5, 17) = 7
+ varv(2, 6, 18) = 8
+ varv(6, 15, 28) = 9
+ deallocate (varv)
+ l = associated (varv)
+ varv => varu
+ varv(1, 1, 1) = 6
+ varv(1, 2, 3) = 7
+ l = associated (varv)
+end subroutine baz
+subroutine foo (vary, varw)
+ real :: vary (:, :)
+ real :: varw (:, :, :)
+ vary(:, :) = 4 ! vary-passed
+ vary(1, 1) = 8
+ vary(2, 2) = 9
+ vary(1, 3) = 10
+ varw(:, :, :) = 5 ! vary-filled
+ varw(1, 1, 1) = 6
+ varw(2, 2, 2) = 7 ! varw-almostfilled
+end subroutine foo
+subroutine bar (varz, vart)
+ real :: varz (*)
+ real :: vart (2:11, 7:*)
+ varz(1:3) = 4
+ varz(2) = 5 ! varz-almostfilled
+end subroutine bar
+program test
+ interface
+ subroutine foo (vary, varw)
+ real :: vary (:, :)
+ real :: varw (:, :, :)
+ end subroutine
+ end interface
+ interface
+ subroutine bar (varz, vart)
+ real :: varz (*)
+ real :: vart (2:11, 7:*)
+ end subroutine
+ end interface
+ real :: x (10, 10), y (5), z(8, 8, 8)
+ x(:,:) = 1
+ y(:) = 2
+ z(:,:,:) = 3
+ call baz
+ call foo (x, z(2:6, 4:7, 6:8))
+ call bar (y, x)
+ if (x (1, 1) .ne. 8 .or. x (2, 2) .ne. 9 .or. x (1, 2) .ne. 4) call abort
+ if (x (1, 3) .ne. 10) call abort
+ if (z (2, 4, 6) .ne. 6 .or. z (3, 5, 7) .ne. 7 .or. z (2, 4, 7) .ne. 5) call abort
+ if (any (y .ne. (/4, 5, 4, 2, 2/))) call abort
+ call foo (transpose (x), z)
+ if (x (1, 1) .ne. 8 .or. x (2, 2) .ne. 9 .or. x (1, 2) .ne. 4) call abort
+ if (x (3, 1) .ne. 10) call abort
+end
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/typeprint.c gdb-6.8cvs20080219/gdb/typeprint.c
--- gdb-6.8cvs20080219-fortranless/gdb/typeprint.c 2008-02-14 23:04:00.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/typeprint.c 2008-02-22 16:49:35.000000000 +0100
@@ -33,6 +33,7 @@
#include "cp-abi.h"
#include "typeprint.h"
#include "gdb_string.h"
+#include "dwarf2block.h"
#include <errno.h>
/* For real-type printing in whatis_exp() */
@@ -130,6 +131,7 @@ whatis_exp (char *exp, int show)
val = access_value_history (0);
type = value_type (val);
+ object_address_set (VALUE_ADDRESS (val));
if (objectprint)
{
diff -u -X /home/jkratoch/.diffi.list -ruNp -x Makefile gdb-6.8cvs20080219-fortranless/gdb/valops.c gdb-6.8cvs20080219/gdb/valops.c
--- gdb-6.8cvs20080219-fortranless/gdb/valops.c 2008-02-22 08:19:37.000000000 +0100
+++ gdb-6.8cvs20080219/gdb/valops.c 2008-02-22 16:47:53.000000000 +0100
@@ -571,12 +571,21 @@ value_at_lazy (struct type *type, CORE_A
int
value_fetch_lazy (struct value *val)
{
- CORE_ADDR addr = VALUE_ADDRESS (val) + value_offset (val);
- int length = TYPE_LENGTH (value_enclosing_type (val));
+ CORE_ADDR addr;
+ int length;
- struct type *type = value_type (val);
- if (length)
- read_memory (addr, value_contents_all_raw (val), length);
+ addr = VALUE_ADDRESS (val);
+ if (LA_VALUE_ADDRESS_GET (value_type (val), &addr))
+ {
+ struct type *type = value_enclosing_type (val);
+ int length = TYPE_LENGTH (check_typedef (type));
+
+ if (length)
+ {
+ addr += value_offset (val);
+ read_memory (addr, value_contents_all_raw (val), length);
+ }
+ }
set_value_lazy (val, 0);
return 0;
@@ -880,12 +889,17 @@ struct value *
value_coerce_array (struct value *arg1)
{
struct type *type = check_typedef (value_type (arg1));
+ CORE_ADDR address;
if (VALUE_LVAL (arg1) != lval_memory)
error (_("Attempt to take address of value not located in memory."));
+ address = VALUE_ADDRESS (arg1);
+ if (!LA_VALUE_ADDRESS_GET (type, &address))
+ error (_("Attempt to take address of non-valid value."));
+
return value_from_pointer (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
- (VALUE_ADDRESS (arg1) + value_offset (arg1)));
+ address + value_offset (arg1));
}
/* Given a value which is a function, return a value which is a pointer