[10/11] Fortran dynamic arrays support: Fortran array attributes

[Jan Kratochvil <jan dot kratochvil at redhat dot com>]

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-16  Jan Kratochvil  <jan.kratochvil@redhat.com>

	* dwarf2read.c: Include "f-lang.h".
	(read_array_type): New variables FORTRAN_ARRAY, FORTRAN_ARRAY_ZERO and
	FORTRAN_ARRAY_POINTER.  Set the FORTRAN_ARRAY content.  Fill in
	TYPE_FORTRAN_ARRAY for all the range types and the array types.
	* 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 "dwarf2expr.h"
	(f_type_object_valid_query, f_type_object_valid_to_stream)
	(f_type_object_valid_error): New functions.
	(f_print_type_with_address): Call F_TYPE_OBJECT_VALID_TO_STREAM.
	* f-valprint.c (f77_get_dynamic_lowerbound, f77_get_dynamic_upperbound):
	Call F_TYPE_OBJECT_VALID_ERROR.
	(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.
	* f-lang.c: Include "dwarf2expr.h".
	(f_value_address_get): New function.
	(f_language_defn): Replace the value DEFAULT_VALUE_ADDRESS_GET with
	F_VALUE_ADDRESS_GET.
	* Makefile.in: Update dependencies. 

Index: sources/gdb/dwarf2read.c
===================================================================
--- sources.orig/gdb/dwarf2read.c	2007-11-16 00:36:19.000000000 +0100
+++ sources/gdb/dwarf2read.c	2007-11-16 00:37:36.000000000 +0100
@@ -47,6 +47,7 @@
 #include "gdbcmd.h"
 #include "gdbcore.h"
 #include "exceptions.h"
+#include "f-lang.h"
 
 #include <fcntl.h>
 #include "gdb_string.h"
@@ -4262,6 +4263,10 @@ read_array_type (struct die_info *die, s
   int ndim = 0;
   struct cleanup *back_to;
   char *name;
+  struct fortran_array_type fortran_array;
+  /* Used only for checking if FORTRAN_ARRAY is non-zero.  */
+  static struct fortran_array_type fortran_array_zero;
+  struct fortran_array_type *fortran_array_pointer;
 
   /* Return if we've already decoded this type. */
   if (die->type)
@@ -4271,6 +4276,33 @@ 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.  */
+
+  memset (&fortran_array, 0, sizeof fortran_array);
+
+  attr = dwarf2_attr (die, DW_AT_data_location, cu);
+  if (attr)
+    fortran_array.data_location = DW_BLOCK (attr);
+
+  attr = dwarf2_attr (die, DW_AT_allocated, cu);
+  if (attr)
+    fortran_array.allocated = DW_BLOCK (attr);
+
+  attr = dwarf2_attr (die, DW_AT_associated, cu);
+  if (attr)
+    fortran_array.associated = DW_BLOCK (attr);
+
+  if (memcmp (&fortran_array, &fortran_array_zero, sizeof fortran_array) == 0)
+    fortran_array_pointer = NULL;
+  else
+    {
+      fortran_array_pointer = TYPE_ALLOC (element_type,
+					  sizeof *fortran_array_pointer);
+      *fortran_array_pointer = fortran_array;
+    }
+
   /* Irix 6.2 native cc creates array types without children for
      arrays with unspecified length.  */
   if (die->child == NULL)
@@ -4279,6 +4311,8 @@ 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_pointer;
       return;
     }
 
@@ -4319,6 +4353,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_pointer;
+	  TYPE_FORTRAN_ARRAY (type) = fortran_array_pointer;
 	  TYPE_ARRAY_UPPER_BOUND_TYPE (type) =
 	    TYPE_ARRAY_UPPER_BOUND_TYPE (range_types[i]);
 	  TYPE_ARRAY_LOWER_BOUND_TYPE (type) =
@@ -4331,6 +4367,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_pointer;
+	  TYPE_FORTRAN_ARRAY (type) = fortran_array_pointer;
 	  TYPE_ARRAY_UPPER_BOUND_TYPE (type) =
 	    TYPE_ARRAY_UPPER_BOUND_TYPE (range_types[i]);
 	  TYPE_ARRAY_LOWER_BOUND_TYPE (type) =
Index: sources/gdb/f-lang.h
===================================================================
--- sources.orig/gdb/f-lang.h	2007-11-16 00:37:34.000000000 +0100
+++ sources/gdb/f-lang.h	2007-11-16 00:37:36.000000000 +0100
@@ -28,6 +28,13 @@ extern void f_error (char *);	/* Defined
 extern void f_print_type_with_address (struct type *, CORE_ADDR, char *,
 				       struct ui_file *, int, int);
 
+extern const char *f_type_object_valid_query (struct type *type,
+					      CORE_ADDR address);
+extern const char *f_type_object_valid_to_stream (struct type *type,
+						  CORE_ADDR address,
+						  struct ui_file *stream);
+extern void f_type_object_valid_error (struct type *type, CORE_ADDR address);
+
 extern int f_val_print (struct type *, const gdb_byte *, int, CORE_ADDR,
 			struct ui_file *, int, int, int,
 			enum val_prettyprint);
@@ -47,6 +54,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-16 00:37:34.000000000 +0100
+++ sources/gdb/f-typeprint.c	2007-11-16 00:37:36.000000000 +0100
@@ -31,6 +31,7 @@
 #include "gdbcore.h"
 #include "target.h"
 #include "f-lang.h"
+#include "dwarf2expr.h"
 
 #include "gdb_string.h"
 #include <errno.h>
@@ -51,6 +52,51 @@ 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, CORE_ADDR address)
+{
+  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), address))
+	return N_("the array is not associated");
+
+      if (TYPE_FORTRAN_ARRAY_ALLOCATED (type) != NULL
+	  && !dwarf_block_exec (TYPE_FORTRAN_ARRAY_ALLOCATED (type), address))
+	return N_("the array is not allocated");
+    }
+  return NULL;
+}
+
+const char *
+f_type_object_valid_to_stream (struct type *type, CORE_ADDR address,
+			       struct ui_file *stream)
+{
+  const char *msg;
+
+  msg = f_type_object_valid_query (type, address);
+  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, CORE_ADDR address)
+{
+  const char *msg;
+
+  msg = f_type_object_valid_query (type, address);
+  if (msg != NULL)
+    {
+      error (_("Unable to access the object because %s."), _(msg));
+    }
+}
+
 /* LEVEL is the depth to indent lines by.  */
 
 void
@@ -61,6 +107,9 @@ f_print_type_with_address (struct type *
   enum type_code code;
   int demangled_args;
 
+  if (f_type_object_valid_to_stream (type, address, stream) != NULL)
+    return;
+
   f_type_print_base (type, stream, show, level);
   code = TYPE_CODE (type);
   if ((varstring != NULL && *varstring != '\0')
Index: sources/gdb/f-valprint.c
===================================================================
--- sources.orig/gdb/f-valprint.c	2007-11-16 00:37:34.000000000 +0100
+++ sources/gdb/f-valprint.c	2007-11-16 00:37:36.000000000 +0100
@@ -70,6 +70,8 @@ f77_get_dynamic_lowerbound (struct type 
   CORE_ADDR current_frame_addr;
   CORE_ADDR ptr_to_lower_bound;
 
+  f_type_object_valid_error (type, address);
+
   switch (TYPE_ARRAY_LOWER_BOUND_TYPE (type))
     {
     case BOUND_BY_VALUE_ON_STACK:
@@ -134,6 +136,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, address);
+
   switch (TYPE_ARRAY_UPPER_BOUND_TYPE (type))
     {
     case BOUND_BY_VALUE_ON_STACK:
@@ -384,6 +388,9 @@ f_val_print (struct type *type, const gd
   CORE_ADDR addr;
   int index;
 
+  if (f_type_object_valid_to_stream (type, address, stream) != NULL)
+    return 0;
+
   CHECK_TYPEDEF (type);
   switch (TYPE_CODE (type))
     {
Index: sources/gdb/gdbtypes.h
===================================================================
--- sources.orig/gdb/gdbtypes.h	2007-11-16 00:36:19.000000000 +0100
+++ sources/gdb/gdbtypes.h	2007-11-16 00:37:36.000000000 +0100
@@ -526,6 +526,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;
 };
 
@@ -876,6 +880,7 @@ extern CORE_ADDR type_length_get_with_ad
 #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
Index: sources/gdb/f-lang.c
===================================================================
--- sources.orig/gdb/f-lang.c	2007-11-16 00:34:57.000000000 +0100
+++ sources/gdb/f-lang.c	2007-11-16 00:37:36.000000000 +0100
@@ -31,6 +31,7 @@
 #include "f-lang.h"
 #include "valprint.h"
 #include "value.h"
+#include "dwarf2expr.h"
 
 
 /* Following is dubious stuff that had been in the xcoff reader. */
@@ -387,6 +388,37 @@ f_create_fundamental_type (struct objfil
     }
   return (type);
 }
+
+static int
+f_value_address_get(struct value *val, CORE_ADDR *address_return)
+{
+  struct type *type = value_type (val);
+  CORE_ADDR address;
+
+  address = VALUE_ADDRESS (val);
+
+  if (f_type_object_valid_query (type, address) != 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 = dwarf_block_exec (TYPE_FORTRAN_ARRAY_DATA_LOCATION (type),
+				    address);
+    }
+
+  *address_return = address;
+
+  return 1;
+}
 
 
 /* Table of operators and their precedences for printing expressions.  */
@@ -502,7 +534,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/Makefile.in
===================================================================
--- sources.orig/gdb/Makefile.in	2007-11-16 00:37:17.000000000 +0100
+++ sources/gdb/Makefile.in	2007-11-16 00:38:50.000000000 +0100
@@ -2005,7 +2005,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) $(gdbcore_h) $(exceptions_h)
+	$(gdb_string_h) $(gdb_assert_h) $(gdbcore_h) $(exceptions_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) \
@@ -2044,7 +2044,7 @@ findvar.o: findvar.c $(defs_h) $(symtab_
 	$(user_regs_h) $(block_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) $(dwarf2expr_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)
@@ -2069,7 +2069,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) $(dwarf2expr_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)