This is the mail archive of the
gdb-patches@sourceware.org
mailing list for the GDB project.
[5/6] Fortran dynamic arrays #2: Fortran array itself
- From: Jan Kratochvil <jan dot kratochvil at redhat dot com>
- To: gdb-patches at sourceware dot org
- Date: Sat, 24 Nov 2007 00:44:20 +0100
- Subject: [5/6] Fortran dynamic arrays #2: Fortran array itself
Hi,
final support for the tags DW_AT_data_location, DW_AT_allocated and
DW_AT_associated on top of the implemented functions.
Regards,
Jan
2007-11-23 Jan Kratochvil <jan.kratochvil@redhat.com>
* Makefile.in: Update dependencies.
* dwarf2read.c: Include "f-lang.h".
(fortran_array_update): New function.
(read_array_type): New variable FORTRAN_ARRAY. Call
FORTRAN_ARRAY_UPDATE. Set TYPE_FORTRAN_ARRAY for all the created range
and array types.
(read_tag_pointer_type): New variable TARGET_TYPE.a
Split the expression to set TARGET_TYPE. Set the target
TYPE_FORTRAN_ARRAY from the pointer type.
* eval.c (evaluate_subexp_standard): New variables BYTE_STRIDE_ARRAY,
OFFSET_BYTE and ELEMENT_SIZE. Rewritten the offsets calculations to
count with the optional value TYPE_ARRAY_BYTE_STRIDE_VALUE.
* f-lang.c: Include "dwarf2block.h".
(f_value_address_get): New function.
(f_language_defn): Replace the value DEFAULT_VALUE_ADDRESS_GET with
F_VALUE_ADDRESS_GET.
* f-lang.h (f_type_object_valid_query, f_type_object_valid_to_stream)
(f_type_object_valid_error, struct fortran_array_type)
(TYPE_FORTRAN_ARRAY_DATA_LOCATION, TYPE_FORTRAN_ARRAY_ALLOCATED)
(TYPE_FORTRAN_ARRAY_ASSOCIATED): New.
* f-typeprint.c: Include "dwarf2block.h".
(f_type_object_valid_query, f_type_object_valid_to_stream)
(f_type_object_valid_error): New functions.
(f_print_type): Call F_TYPE_OBJECT_VALID_TO_STREAM.
(f_type_print_varspec_suffix): Update its prototype, function and its
callers for a new ARRAYPRINT_RECURSE_LEVEL parameter. Remove the
variable ARRAYPRINT_RECURSE_LEVEL.
* f-valprint.c (F77_DIM_SIZE): Rename to ...
(F77_DIM_COUNT): ... here. Update all its uses.
(F77_DIM_OFFSET): Rename to ...
(F77_DIM_BYTE_STRIDE): ... here. Update all its uses.
(f77_get_dynamic_lowerbound, f77_get_dynamic_upperbound): Call
F_TYPE_OBJECT_VALID_ERROR.
(f77_create_arrayprint_offset_tbl): Update the F77_DIM_BYTE_STRIDE
calculation to use the optional value TYPE_ARRAY_BYTE_STRIDE_VALUE.
(f_val_print): Call F_TYPE_OBJECT_VALID_TO_STREAM.
* gdbtypes.h (struct main_type): New field TYPE_SPECIFIC.FORTRAN_ARRAY.
(TYPE_FORTRAN_ARRAY): New macro.
Index: sources/gdb/Makefile.in
===================================================================
--- sources.orig/gdb/Makefile.in 2007-11-23 22:24:00.000000000 +0100
+++ sources/gdb/Makefile.in 2007-11-23 22:25:05.000000000 +0100
@@ -2055,7 +2055,7 @@ dwarf2read.o: dwarf2read.c $(defs_h) $(b
$(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) $(dwarf2block_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) \
@@ -2094,7 +2094,7 @@ findvar.o: findvar.c $(defs_h) $(symtab_
$(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)
@@ -2119,7 +2119,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)
Index: sources/gdb/dwarf2read.c
===================================================================
--- sources.orig/gdb/dwarf2read.c 2007-11-23 22:24:00.000000000 +0100
+++ sources/gdb/dwarf2read.c 2007-11-23 22:55:56.000000000 +0100
@@ -46,6 +46,7 @@
#include "command.h"
#include "gdbcmd.h"
#include "dwarf2block.h"
+#include "f-lang.h"
#include <fcntl.h>
#include "gdb_string.h"
@@ -4238,6 +4239,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. */
@@ -4254,6 +4305,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)
@@ -4263,6 +4315,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)
@@ -4271,6 +4330,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;
}
@@ -4311,6 +4373,8 @@ read_array_type (struct die_info *die, s
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) =
@@ -4323,6 +4387,8 @@ read_array_type (struct die_info *die, s
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) =
@@ -4547,13 +4613,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)
Index: sources/gdb/eval.c
===================================================================
--- sources.orig/gdb/eval.c 2007-11-23 22:22:12.000000000 +0100
+++ sources/gdb/eval.c 2007-11-23 22:24:34.000000000 +0100
@@ -1615,9 +1615,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);
@@ -1654,6 +1657,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. */
@@ -1674,11 +1680,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 */
Index: sources/gdb/f-lang.c
===================================================================
--- sources.orig/gdb/f-lang.c 2007-11-23 22:22:12.000000000 +0100
+++ sources/gdb/f-lang.c 2007-11-23 22:24:34.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. */
@@ -387,6 +388,29 @@ f_create_fundamental_type (struct objfil
}
return (type);
}
+
+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. */
@@ -502,7 +526,7 @@ const struct language_defn f_language_de
f_language_arch_info,
default_print_array_index,
default_pass_by_reference,
- default_value_address_get, /* Retrieve the real data value */
+ f_value_address_get, /* Retrieve the real data value */
LANG_MAGIC
};
Index: sources/gdb/f-lang.h
===================================================================
--- sources.orig/gdb/f-lang.h 2007-11-23 22:22:12.000000000 +0100
+++ sources/gdb/f-lang.h 2007-11-23 22:24:34.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
Index: sources/gdb/f-typeprint.c
===================================================================
--- sources.orig/gdb/f-typeprint.c 2007-11-23 22:22:12.000000000 +0100
+++ sources/gdb/f-typeprint.c 2007-11-23 22:24:34.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>
@@ -42,7 +43,7 @@ static void f_type_print_args (struct ty
static void print_equivalent_f77_float_type (int level, struct type *,
struct ui_file *);
-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 *,
@@ -51,6 +52,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
@@ -60,6 +105,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')
@@ -81,7 +129,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
@@ -150,12 +198,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;
@@ -174,7 +224,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);
@@ -208,7 +259,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
@@ -218,13 +270,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, ")");
Index: sources/gdb/f-valprint.c
===================================================================
--- sources.orig/gdb/f-valprint.c 2007-11-23 22:22:12.000000000 +0100
+++ sources/gdb/f-valprint.c 2007-11-23 22:24:34.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))
{
Index: sources/gdb/gdbtypes.h
===================================================================
--- sources.orig/gdb/gdbtypes.h 2007-11-23 22:24:00.000000000 +0100
+++ sources/gdb/gdbtypes.h 2007-11-23 22:24:34.000000000 +0100
@@ -529,6 +529,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;
};
@@ -878,6 +882,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