rpms
/
gdb
2
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
gdb/gdb-6.8-bz377541-fortran-dy...

2240 lines
83 KiB
Diff
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

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
Reference in New Issue View Git Blame Copy Permalink