gdb/gdb-vla-intel-7of7.patch

From 1e5bd9aec9ee02c2f771e4dc997570c82d74b3b8 Mon Sep 17 00:00:00 2001
From: Bernhard Heckel <bernhard.heckel@intel.com>
Date: Tue, 12 Jul 2016 08:19:34 +0200
Subject: [PATCH 7/7] fort_dyn_array: Fortran dynamic string support

This patch changes the semantic of the Dwarf string length
attribute to reflect the standard as well as enables
correct string length calculation of dynamic strings. Add
tests for varous dynamic string evaluations.

Old:
(gdb) p my_dyn_string
Cannot access memory at address 0x605fc0

New:
(gdb) p *my_dyn_string
$1 = 'foo'

gdb/Changlog:
	* dwarf2read.c (read_tag_string_type): changed
	semantic of DW_AT_string_length to be able to
	handle Dwarf blocks as well. Support for
	DW_AT_byte_length added to get correct length
	if specified in combination with
	DW_AT_string_length.
	(attr_to_dynamic_prop): added
	functionality to add Dwarf operators to baton
	data attribute. Added post values to baton
	as required by the string evaluation case.
	(read_subrange_type): Adapt caller.
	(set_die_type): Adapt caller.
	(add_post_values_to_baton): New function.
    	* gdbtypes.c (resolve_dynamic_type): Add
    	conditions to support string types.
    	(resolve_dynamic_array): Add conditions for dynamic
    	strings and create a new string type.
    	(is_dynamic_type): Follow pointer if a string type
    	was detected, as Fortran strings are represented
    	as pointers to strings internally.

gdb/testsuite/Changelog:
	* vla-strings.f90: New file.
	* vla-strings.exp: New file.

Change-Id: I7d7f47c7a4900a7fdb51102032455b53d60e60d7
---
 gdb/dwarf2read.c                          | 158 +++++++++++++++++++++++++-----
 gdb/gdbtypes.c                            |  15 ++-
 gdb/testsuite/gdb.fortran/vla-strings.exp | 103 +++++++++++++++++++
 gdb/testsuite/gdb.fortran/vla-strings.f90 |  39 ++++++++
 4 files changed, 285 insertions(+), 30 deletions(-)
 create mode 100644 gdb/testsuite/gdb.fortran/vla-strings.exp
 create mode 100644 gdb/testsuite/gdb.fortran/vla-strings.f90

Index: gdb-7.11.90.20160807/gdb/dwarf2read.c
===================================================================
--- gdb-7.11.90.20160807.orig/gdb/dwarf2read.c	2016-08-25 16:08:17.397714936 +0200
+++ gdb-7.11.90.20160807/gdb/dwarf2read.c	2016-08-25 16:09:56.703580597 +0200
@@ -1764,7 +1764,8 @@
 
 static int attr_to_dynamic_prop (const struct attribute *attr,
 				 struct die_info *die, struct dwarf2_cu *cu,
-				 struct dynamic_prop *prop);
+				 struct dynamic_prop *prop, const gdb_byte *additional_data,
+				 int additional_data_size);
 
 /* memory allocation interface */
 
@@ -11446,7 +11447,7 @@
     {
       newobj->static_link
 	= XOBNEW (&objfile->objfile_obstack, struct dynamic_prop);
-      attr_to_dynamic_prop (attr, die, cu, newobj->static_link);
+      attr_to_dynamic_prop (attr, die, cu, newobj->static_link, NULL, 0);
     }
 
   cu->list_in_scope = &local_symbols;
@@ -14512,29 +14513,94 @@
   struct gdbarch *gdbarch = get_objfile_arch (objfile);
   struct type *type, *range_type, *index_type, *char_type;
   struct attribute *attr;
-  unsigned int length;
+  unsigned int length = UINT_MAX;
 
+  index_type = objfile_type (objfile)->builtin_int;
+  range_type = create_static_range_type (NULL, index_type, 1, length);
+
+  /* If DW_AT_string_length is defined, the length is stored in memory.  */
   attr = dwarf2_attr (die, DW_AT_string_length, cu);
   if (attr)
     {
-      length = DW_UNSND (attr);
+      if (attr_form_is_block (attr))
+	{
+	  struct attribute *byte_size, *bit_size;
+	  struct dynamic_prop high;
+
+	  byte_size = dwarf2_attr (die, DW_AT_byte_size, cu);
+	  bit_size = dwarf2_attr (die, DW_AT_bit_size, cu);
+
+	  /* DW_AT_byte_size should never occur in combination with
+	     DW_AT_bit_size.  */
+	  if (byte_size != NULL && bit_size != NULL)
+	    complaint (&symfile_complaints,
+		       _("DW_AT_byte_size AND "
+			 "DW_AT_bit_size found together at the same time."));
+
+	  /* If DW_AT_string_length AND DW_AT_byte_size exist together,
+	     DW_AT_byte_size describes the number of bytes that should be read
+	     from the length memory location.  */
+	  if (byte_size != NULL)
+	    {
+	      /* Build new dwarf2_locexpr_baton structure with additions to the
+		 data attribute, to reflect DWARF specialities to get address
+		 sizes.  */
+	      const gdb_byte append_ops[] =
+		{
+		/* DW_OP_deref_size: size of an address on the target machine
+		   (bytes), where the size will be specified by the next
+		   operand.  */
+		DW_OP_deref_size,
+		/* Operand for DW_OP_deref_size.  */
+		DW_UNSND(byte_size) };
+
+	      if (!attr_to_dynamic_prop (attr, die, cu, &high, append_ops,
+					 ARRAY_SIZE(append_ops)))
+		complaint (&symfile_complaints,
+			   _("Could not parse DW_AT_byte_size"));
+	    }
+	  else if (bit_size != NULL)
+	    complaint (&symfile_complaints,
+		       _("DW_AT_string_length AND "
+			 "DW_AT_bit_size found but not supported yet."));
+	  /* If DW_AT_string_length WITHOUT DW_AT_byte_size exist, the default
+	     is the address size of the target machine.  */
+	  else
+	    {
+	      const gdb_byte append_ops[] =
+		{ DW_OP_deref };
+
+	      if (!attr_to_dynamic_prop (attr, die, cu, &high, append_ops,
+					 ARRAY_SIZE(append_ops)))
+		complaint (&symfile_complaints,
+			   _("Could not parse DW_AT_string_length"));
+	    }
+
+	  TYPE_RANGE_DATA (range_type)->high = high;
+	}
+      else
+	{
+	  TYPE_HIGH_BOUND (range_type) = DW_UNSND(attr);
+	  TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST;
+	}
     }
   else
     {
-      /* Check for the DW_AT_byte_size attribute.  */
+      /* Check for the DW_AT_byte_size attribute, which represents the length
+	 in this case.  */
       attr = dwarf2_attr (die, DW_AT_byte_size, cu);
       if (attr)
-        {
-          length = DW_UNSND (attr);
-        }
+	{
+	  TYPE_HIGH_BOUND (range_type) = DW_UNSND(attr);
+	  TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST;
+	}
       else
-        {
-          length = 1;
-        }
+	{
+	  TYPE_HIGH_BOUND (range_type) = 1;
+	  TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST;
+	}
     }
 
-  index_type = objfile_type (objfile)->builtin_int;
-  range_type = create_static_range_type (NULL, index_type, 1, length);
   char_type = language_string_char_type (cu->language_defn, gdbarch);
   type = create_string_type (NULL, char_type, range_type);
 
@@ -14864,7 +14930,8 @@
 
 static int
 attr_to_dynamic_prop (const struct attribute *attr, struct die_info *die,
-		      struct dwarf2_cu *cu, struct dynamic_prop *prop)
+		      struct dwarf2_cu *cu, struct dynamic_prop *prop,
+		      const gdb_byte *additional_data, int additional_data_size)
 {
   struct dwarf2_property_baton *baton;
   struct obstack *obstack = &cu->objfile->objfile_obstack;
@@ -14874,14 +14941,33 @@
 
   if (attr_form_is_block (attr))
     {
-      baton = XOBNEW (obstack, struct dwarf2_property_baton);
+      baton = XOBNEW(obstack, struct dwarf2_property_baton);
       baton->referenced_type = NULL;
       baton->locexpr.per_cu = cu->per_cu;
-      baton->locexpr.size = DW_BLOCK (attr)->size;
-      baton->locexpr.data = DW_BLOCK (attr)->data;
+
+      if (additional_data != NULL && additional_data_size > 0)
+	{
+	  gdb_byte *data;
+
+	  data = (gdb_byte *) obstack_alloc(
+	      &cu->objfile->objfile_obstack,
+	      DW_BLOCK (attr)->size + additional_data_size);
+	  memcpy (data, DW_BLOCK (attr)->data, DW_BLOCK (attr)->size);
+	  memcpy (data + DW_BLOCK (attr)->size, additional_data,
+		  additional_data_size);
+
+	  baton->locexpr.data = data;
+	  baton->locexpr.size = DW_BLOCK (attr)->size + additional_data_size;
+	}
+      else
+	{
+	  baton->locexpr.data = DW_BLOCK (attr)->data;
+	  baton->locexpr.size = DW_BLOCK (attr)->size;
+	}
+
       prop->data.baton = baton;
       prop->kind = PROP_LOCEXPR;
-      gdb_assert (prop->data.baton != NULL);
+      gdb_assert(prop->data.baton != NULL);
     }
   else if (attr_form_is_ref (attr))
     {
@@ -14914,8 +15000,28 @@
 		baton = XOBNEW (obstack, struct dwarf2_property_baton);
 		baton->referenced_type = die_type (target_die, target_cu);
 		baton->locexpr.per_cu = cu->per_cu;
-		baton->locexpr.size = DW_BLOCK (target_attr)->size;
-		baton->locexpr.data = DW_BLOCK (target_attr)->data;
+
+		if (additional_data != NULL && additional_data_size > 0)
+		  {
+		    gdb_byte *data;
+
+		    data = (gdb_byte *) obstack_alloc (&cu->objfile->objfile_obstack,
+			    DW_BLOCK (target_attr)->size + additional_data_size);
+		    memcpy (data, DW_BLOCK (target_attr)->data,
+			    DW_BLOCK (target_attr)->size);
+		    memcpy (data + DW_BLOCK (target_attr)->size,
+			    additional_data, additional_data_size);
+
+		    baton->locexpr.data = data;
+		    baton->locexpr.size = (DW_BLOCK (target_attr)->size
+					   + additional_data_size);
+		  }
+		else
+		  {
+		    baton->locexpr.data = DW_BLOCK (target_attr)->data;
+		    baton->locexpr.size = DW_BLOCK (target_attr)->size;
+		  }
+
 		prop->data.baton = baton;
 		prop->kind = PROP_LOCEXPR;
 		gdb_assert (prop->data.baton != NULL);
@@ -15027,24 +15133,24 @@
 
   attr = dwarf2_attr (die, DW_AT_byte_stride, cu);
   if (attr)
-    if (!attr_to_dynamic_prop (attr, die, cu, &stride))
+    if (!attr_to_dynamic_prop (attr, die, cu, &stride, NULL, 0))
         complaint (&symfile_complaints, _("Missing DW_AT_byte_stride "
                   "- DIE at 0x%x [in module %s]"),
              die->offset.sect_off, objfile_name (cu->objfile));
 
   attr = dwarf2_attr (die, DW_AT_lower_bound, cu);
   if (attr)
-    attr_to_dynamic_prop (attr, die, cu, &low);
+    attr_to_dynamic_prop (attr, die, cu, &low, NULL, 0);
   else if (!low_default_is_valid)
     complaint (&symfile_complaints, _("Missing DW_AT_lower_bound "
 				      "- DIE at 0x%x [in module %s]"),
 	       die->offset.sect_off, objfile_name (cu->objfile));
 
   attr = dwarf2_attr (die, DW_AT_upper_bound, cu);
-  if (!attr_to_dynamic_prop (attr, die, cu, &high))
+  if (!attr_to_dynamic_prop (attr, die, cu, &high, NULL, 0))
     {
       attr = dwarf2_attr (die, DW_AT_count, cu);
-      if (attr_to_dynamic_prop (attr, die, cu, &high))
+      if (attr_to_dynamic_prop (attr, die, cu, &high, NULL, 0))
 	{
 	  /* If bounds are constant do the final calculation here.  */
 	  if (low.kind == PROP_CONST && high.kind == PROP_CONST)
@@ -22416,7 +22522,7 @@
   attr = dwarf2_attr (die, DW_AT_allocated, cu);
   if (attr_form_is_block (attr))
     {
-      if (attr_to_dynamic_prop (attr, die, cu, &prop))
+      if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0))
         add_dyn_prop (DYN_PROP_ALLOCATED, prop, type, objfile);
     }
   else if (attr != NULL)
@@ -22431,7 +22537,7 @@
   attr = dwarf2_attr (die, DW_AT_associated, cu);
   if (attr_form_is_block (attr))
     {
-      if (attr_to_dynamic_prop (attr, die, cu, &prop))
+      if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0))
         add_dyn_prop (DYN_PROP_ASSOCIATED, prop, type, objfile);
     }
   else if (attr != NULL)
@@ -22444,7 +22550,7 @@
 
   /* Read DW_AT_data_location and set in type.  */
   attr = dwarf2_attr (die, DW_AT_data_location, cu);
-  if (attr_to_dynamic_prop (attr, die, cu, &prop))
+  if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0))
     add_dyn_prop (DYN_PROP_DATA_LOCATION, prop, type, objfile);
 
   if (dwarf2_per_objfile->die_type_hash == NULL)
Index: gdb-7.11.90.20160807/gdb/gdbtypes.c
===================================================================
--- gdb-7.11.90.20160807.orig/gdb/gdbtypes.c	2016-08-25 16:08:17.397714936 +0200
+++ gdb-7.11.90.20160807/gdb/gdbtypes.c	2016-08-25 16:09:11.623187626 +0200
@@ -1851,6 +1851,7 @@
       }
 
     case TYPE_CODE_ARRAY:
+    case TYPE_CODE_STRING:
       {
 	gdb_assert (TYPE_NFIELDS (type) == 1);
 
@@ -1964,7 +1965,8 @@
   struct type *ary_dim;
   struct dynamic_prop *prop;
 
-  gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
+  gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY
+	      || TYPE_CODE (type) == TYPE_CODE_STRING);
 
   type = copy_type (type);
 
@@ -1989,13 +1991,17 @@
 
   ary_dim = check_typedef (TYPE_TARGET_TYPE (elt_type));
 
-  if (ary_dim != NULL && TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY)
+  if (ary_dim != NULL && (TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY
+      || TYPE_CODE (ary_dim) == TYPE_CODE_STRING))
     elt_type = resolve_dynamic_array (ary_dim, addr_stack);
   else
     elt_type = TYPE_TARGET_TYPE (type);
 
-  return create_array_type_with_stride (type, elt_type, range_type,
-                                        TYPE_FIELD_BITSIZE (type, 0));
+  if (TYPE_CODE (type) == TYPE_CODE_STRING)
+    return create_string_type (type, elt_type, range_type);
+  else
+    return create_array_type_with_stride (type, elt_type, range_type,
+					  TYPE_FIELD_BITSIZE (type, 0));
 }
 
 /* Resolve dynamic bounds of members of the union TYPE to static
@@ -2200,6 +2206,7 @@
  	  break;
 
 	case TYPE_CODE_ARRAY:
+	case TYPE_CODE_STRING:
 	  resolved_type = resolve_dynamic_array (type, addr_stack);
 	  break;
 
Index: gdb-7.11.90.20160807/gdb/testsuite/gdb.fortran/vla-strings.exp
===================================================================
--- /dev/null	1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.11.90.20160807/gdb/testsuite/gdb.fortran/vla-strings.exp	2016-08-25 16:09:11.624187635 +0200
@@ -0,0 +1,103 @@
+# Copyright 2016 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 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/>.
+
+standard_testfile ".f90"
+
+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
+    {debug f90 quiet}] } {
+    return -1
+}
+
+# check that all fortran standard datatypes will be
+# handled correctly when using as VLA's
+
+if ![runto_main] {
+    untested "could not run to main"
+    return -1
+}
+
+gdb_breakpoint [gdb_get_line_number "var_char-allocated-1"]
+gdb_continue_to_breakpoint "var_char-allocated-1"
+set test "whatis var_char first time"
+gdb_test_multiple "whatis var_char" $test {
+    -re "type = PTR TO -> \\( character\\*10 \\)\r\n$gdb_prompt $" {
+	    pass $test
+    }
+    -re "type = character\\*10\r\n$gdb_prompt $" {
+	    pass $test
+    }
+}
+set test "ptype var_char first time"
+gdb_test_multiple "ptype var_char" $test {
+    -re "type = PTR TO -> \\( character\\*10 \\)\r\n$gdb_prompt $" {
+	    pass $test
+    }
+    -re "type = character\\*10\r\n$gdb_prompt $" {
+	    pass $test
+    }
+}
+
+
+gdb_test "next" "\\d+.*var_char = 'foo'.*" \
+  "next to allocation status of var_char"
+gdb_test "print l" " = \\.TRUE\\." "print allocation status first time"
+
+
+gdb_breakpoint [gdb_get_line_number "var_char-filled-1"]
+gdb_continue_to_breakpoint "var_char-filled-1"
+set test "print var_char, var_char-filled-1"
+gdb_test_multiple "print var_char" $test {
+    -re "= \\(PTR TO -> \\( character\\*3 \\)\\) $hex\r\n$gdb_prompt $" {
+        gdb_test "print *var_char" "= 'foo'" "print *var_char, var_char-filled-1"
+	    pass $test
+    }
+    -re "= 'foo'\r\n$gdb_prompt $" {
+	    pass $test
+    }
+}
+set test "ptype var_char, var_char-filled-1"
+gdb_test_multiple "ptype var_char" $test {
+    -re "type = PTR TO -> \\( character\\*3 \\)\r\n$gdb_prompt $" {
+	    pass $test
+    }
+    -re "type = character\\*3\r\n$gdb_prompt $" {
+	    pass $test
+    }
+}
+gdb_test "print var_char(1)" " = 102 'f'" "print var_char(1)"
+gdb_test "print var_char(3)" " = 111 'o'" "print var_char(3)"
+
+
+gdb_breakpoint [gdb_get_line_number "var_char-filled-2"]
+gdb_continue_to_breakpoint "var_char-filled-2"
+set test "print var_char, var_char-filled-2"
+gdb_test_multiple "print var_char" $test {
+    -re "= \\(PTR TO -> \\( character\\*6 \\)\\) $hex\r\n$gdb_prompt $" {
+        gdb_test "print *var_char" "= 'foobar'" "print *var_char, var_char-filled-2"
+	    pass $test
+    }
+    -re "= 'foobar'\r\n$gdb_prompt $" {
+	    pass $test
+    }
+}
+set test "ptype var_char, var_char-filled-2"
+gdb_test_multiple "ptype var_char" $test {
+    -re "type = PTR TO -> \\( character\\*6 \\)\r\n$gdb_prompt $" {
+	    pass $test
+    }
+    -re "type = character\\*6\r\n$gdb_prompt $" {
+	    pass $test
+    }
+}
Index: gdb-7.11.90.20160807/gdb/testsuite/gdb.fortran/vla-strings.f90
===================================================================
--- /dev/null	1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.11.90.20160807/gdb/testsuite/gdb.fortran/vla-strings.f90	2016-08-25 16:09:11.624187635 +0200
@@ -0,0 +1,39 @@
+! Copyright 2016 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 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/>.
+
+program vla_strings
+  character(len=:), target, allocatable   :: var_char
+  character(len=:), pointer               :: var_char_p
+  logical                                 :: l
+
+  allocate(character(len=10) :: var_char)
+  l = allocated(var_char)                 ! var_char-allocated-1
+  var_char = 'foo'
+  deallocate(var_char)                    ! var_char-filled-1
+  l = allocated(var_char)                 ! var_char-deallocated
+  allocate(character(len=42) :: var_char)
+  l = allocated(var_char)
+  var_char = 'foobar'
+  var_char = ''                           ! var_char-filled-2
+  var_char = 'bar'                        ! var_char-empty
+  deallocate(var_char)
+  allocate(character(len=21) :: var_char)
+  l = allocated(var_char)                 ! var_char-allocated-3
+  var_char = 'johndoe'
+  var_char_p => var_char
+  l = associated(var_char_p)              ! var_char_p-associated
+  var_char_p => null()
+  l = associated(var_char_p)              ! var_char_p-not-associated
+end program vla_strings