[PATCH 09/11] fort_dyn_array: Fortran dynamic string support

[Sebastian Basierski <sbasierski at pl dot sii dot eu>]

From: Bernhard Heckel <bernhard.heckel@intel.com>

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.
	* gdbtypes.c (resolve_dynamic_type_internal): Handle
	string types like array types.
	(resolve_dynamic_array): Add conditions for dynamic
	strings and create a new string type.
	(is_dynamic_type_internal): Handle string types like
	array types.

gdb/testsuite/Changelog:
	* vla-strings.f90: New file.
	* vla-strings.exp: New file.
---
 gdb/dwarf2read.c                          | 153 ++++++++++++++++++----
 gdb/gdbtypes.c                            |  15 ++-
 gdb/testsuite/gdb.fortran/vla-strings.exp | 100 ++++++++++++++
 gdb/testsuite/gdb.fortran/vla-strings.f90 |  39 ++++++
 4 files changed, 274 insertions(+), 33 deletions(-)
 create mode 100644 gdb/testsuite/gdb.fortran/vla-strings.exp
 create mode 100644 gdb/testsuite/gdb.fortran/vla-strings.f90

diff --git a/gdb/dwarf2read.c b/gdb/dwarf2read.c
index 902aad3fbc..3e1965e5b4 100644
--- a/gdb/dwarf2read.c
+++ b/gdb/dwarf2read.c
@@ -1805,7 +1805,9 @@ static void read_signatured_type (struct signatured_type *);
 
 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 */
 
@@ -13826,7 +13828,7 @@ read_func_scope (struct die_info *die, struct dwarf2_cu *cu)
     {
       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, nullptr, 0);
     }
 
   cu->list_in_scope = cu->builder->get_local_symbols ();
@@ -16584,7 +16586,8 @@ read_array_type (struct die_info *die, struct dwarf2_cu *cu)
 
       byte_stride_prop
 	= (struct dynamic_prop *) alloca (sizeof (struct dynamic_prop));
-      stride_ok = attr_to_dynamic_prop (attr, die, cu, byte_stride_prop);
+      stride_ok = attr_to_dynamic_prop (attr, die, cu, byte_stride_prop,
+					nullptr, 0);
       if (!stride_ok)
 	{
 	  complaint (_("unable to read array DW_AT_byte_stride "
@@ -17343,31 +17346,90 @@ read_tag_string_type (struct die_info *die, struct dwarf2_cu *cu)
 {
   struct objfile *objfile = cu->per_cu->dwarf2_per_objfile->objfile;
   struct gdbarch *gdbarch = get_objfile_arch (objfile);
-  struct type *type, *range_type, *index_type, *char_type;
+  struct type *type, *char_type;
   struct attribute *attr;
-  unsigned int length;
+  unsigned int length = UINT_MAX;
+
+  struct type *index_type = objfile_type (objfile)->builtin_int;
+  struct type *range_type = create_static_range_type (nullptr, 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 = dwarf2_attr (die, DW_AT_byte_size, cu);
+          struct attribute *bit_size = dwarf2_attr (die, DW_AT_bit_size, cu);
+	  struct dynamic_prop high;
+
+	  /* DW_AT_byte_size should never occur in combination with
+	     DW_AT_bit_size.  */
+	  if (byte_size != nullptr && bit_size != nullptr)
+	    complaint (_("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 != nullptr)
+	    {
+	      /* 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.  */
+		  gdb_byte (DW_UNSND (byte_size))
+		};
+
+	      if (!attr_to_dynamic_prop (attr, die, cu, &high, append_ops,
+					 ARRAY_SIZE(append_ops)))
+		complaint (_("Could not parse DW_AT_byte_size"));
+	    }
+	  else if (bit_size != NULL)
+	    complaint (_("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 (_("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);
 
@@ -17735,7 +17797,8 @@ read_base_type (struct die_info *die, struct dwarf2_cu *cu)
 
 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
@@ -17749,11 +17812,26 @@ attr_to_dynamic_prop (const struct attribute *attr, struct die_info *die,
       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 != nullptr && additional_data_size > 0)
+	{
+	  gdb_byte *data = (gdb_byte *) obstack_alloc (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);
     }
   else if (attr_form_is_ref (attr))
     {
@@ -17786,11 +17864,28 @@ attr_to_dynamic_prop (const struct attribute *attr, struct die_info *die,
 		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 = (gdb_byte *) obstack_alloc (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);
 	      }
 	    else
 	      {
@@ -17898,7 +17993,7 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu)
 
   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, nullptr, 0))
         complaint (_("Missing DW_AT_byte_stride "
 				      "- DIE at 0x%s [in module %s]"),
 		   sect_offset_str (die->sect_off),
@@ -17906,7 +18001,7 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu)
 
   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, nullptr, 0);
   else if (!low_default_is_valid)
     complaint (_("Missing DW_AT_lower_bound "
 				      "- DIE at %s [in module %s]"),
@@ -17915,10 +18010,10 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu)
 
   struct attribute *attr_ub, *attr_count;
   attr = attr_ub = 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, nullptr, 0))
     {
       attr = attr_count = 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, nullptr, 0))
 	{
 	  /* If bounds are constant do the final calculation here.  */
 	  if (low.kind == PROP_CONST && high.kind == PROP_CONST)
@@ -25510,7 +25605,7 @@ set_die_type (struct die_info *die, struct type *type, struct dwarf2_cu *cu)
   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, nullptr, 0))
         add_dyn_prop (DYN_PROP_ALLOCATED, prop, type);
     }
   else if (attr != NULL)
@@ -25524,7 +25619,7 @@ set_die_type (struct die_info *die, struct type *type, struct dwarf2_cu *cu)
   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, nullptr, 0))
         add_dyn_prop (DYN_PROP_ASSOCIATED, prop, type);
     }
   else if (attr != NULL)
@@ -25536,7 +25631,7 @@ set_die_type (struct die_info *die, struct type *type, struct dwarf2_cu *cu)
 
   /* 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, nullptr, 0))
     add_dyn_prop (DYN_PROP_DATA_LOCATION, prop, type);
 
   if (dwarf2_per_objfile->die_type_hash == NULL)
diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
index 228b680a26..bb692caebf 100644
--- a/gdb/gdbtypes.c
+++ b/gdb/gdbtypes.c
@@ -1948,6 +1948,7 @@ is_dynamic_type_internal (struct type *type, int top_level)
       }
 
     case TYPE_CODE_ARRAY:
+    case TYPE_CODE_STRING:
       {
 	gdb_assert (TYPE_NFIELDS (type) == 1);
 
@@ -2065,7 +2066,8 @@ resolve_dynamic_array (struct type *type,
   struct dynamic_prop *prop;
   unsigned int bit_stride = 0;
 
-  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);
 
@@ -2090,7 +2092,8 @@ resolve_dynamic_array (struct type *type,
 
   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);
@@ -2118,8 +2121,11 @@ resolve_dynamic_array (struct type *type,
   else
     bit_stride = TYPE_FIELD_BITSIZE (type, 0);
 
-  return create_array_type_with_stride (type, elt_type, range_type, NULL,
-                                        bit_stride);
+  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,
+					  nullptr, bit_stride);
 }
 
 /* Resolve dynamic bounds of members of the union TYPE to static
@@ -2324,6 +2330,7 @@ resolve_dynamic_type_internal (struct type *type,
  	  break;
 
 	case TYPE_CODE_ARRAY:
+	case TYPE_CODE_STRING:
 	  resolved_type = resolve_dynamic_array (type, addr_stack);
 	  break;
 
diff --git a/gdb/testsuite/gdb.fortran/vla-strings.exp b/gdb/testsuite/gdb.fortran/vla-strings.exp
new file mode 100644
index 0000000000..be9107514c
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/vla-strings.exp
@@ -0,0 +1,100 @@
+# Copyright 2018 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
+}
+
+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" "print var_char(1)"
+gdb_test "print var_char(3)" " = 111" "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
+  }
+}
diff --git a/gdb/testsuite/gdb.fortran/vla-strings.f90 b/gdb/testsuite/gdb.fortran/vla-strings.f90
new file mode 100644
index 0000000000..5d393f9f40
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/vla-strings.f90
@@ -0,0 +1,39 @@
+! Copyright 2018 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
-- 
2.17.1