[binutils-gdb] [Ada] 'first/'last/'length of array whose bound is a discriminant

[Joel Brobecker <brobecke at sourceware dot org>]

https://sourceware.org/git/gitweb.cgi?p=binutils-gdb.git;h=bafffb51c4da50881dc5d72ec9bf9b78377ac692

commit bafffb51c4da50881dc5d72ec9bf9b78377ac692
Author: Joel Brobecker <brobecker@adacore.com>
Date:   Thu Jan 15 10:09:32 2015 +0400

    [Ada] 'first/'last/'length of array whose bound is a discriminant
    
    Consider the following code:
    
       type Table is array (Positive range <>) of Integer;
       type Object (N : Integer) is record
           Data : Table (1 .. N);
       end record;
       My_Object : Object := (N => 3, Data => (3, 5, 8));
    
    Trying to print the range and length of the My_Object.Data array yields:
    
        (gdb) print my_object.data'first
        $1 = 1
        (gdb) print my_object.data'last
        $2 = 0
        (gdb) print my_object.data'length
        $3 = 0
    
    The first one is correct, and that is thanks to the fact that
    the lower bound is statically known.  However, for the upper
    bound, and consequently the array's length, the values are incorrect.
    It should be:
    
        (gdb) print my_object.data'last
        $2 = 3
        (gdb) print my_object.data'length
        $3 = 3
    
    What happens here is that ada_array_bound_from_type sees that
    our array has a parallel "___XA" type, and therefore tries to
    use it.  In particular, it described our array's index type as:
    [...]___XDLU_1__n, which means lower bound = 1, and upper bound
    is value of "n". Unfortunately, ada_array_bound_from_type does
    not have access to the discriminant, and is therefore unable to
    compute the bound correctly.
    
    Fortunately, at this stage, the bound has already been computed
    a while ago, and therefore doesn't need to be re-computed here.
    This patch fixes the issue by ignoring that ___XA type if the array
    is marked as already fixed.
    
    This also fixes the same issue with packed arrays.
    
    gdb/ChangeLog:
    
            * ada-lang.c (ada_array_bound_from_type): Ignore array's parallel
            ___XA type if the array has already been fixed.
    
    gdb/testsuite/ChangeLog:
    
            * gdb.ada/var_arr_attrs: New testcase.

Diff:
---
 gdb/ChangeLog                                      |  5 +++
 gdb/ada-lang.c                                     | 15 +++++++--
 gdb/testsuite/ChangeLog                            |  4 +++
 gdb/testsuite/gdb.ada/var_arr_attrs.exp            | 39 ++++++++++++++++++++++
 .../gdb.ada/var_arr_attrs/foo_o115_002.adb         | 25 ++++++++++++++
 gdb/testsuite/gdb.ada/var_arr_attrs/pck.adb        | 21 ++++++++++++
 gdb/testsuite/gdb.ada/var_arr_attrs/pck.ads        | 36 ++++++++++++++++++++
 7 files changed, 143 insertions(+), 2 deletions(-)

diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index 4557c3e..cddae3c 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,3 +1,8 @@
+2015-01-15  Joel Brobecker  <brobecker@adacore.com>
+
+	* ada-lang.c (ada_array_bound_from_type): Ignore array's parallel
+	___XA type if the array has already been fixed.
+
 2015-01-14  Yao Qi  <yao@codesourcery.com>
 
 	* Makefile.in (ppc-linux.o): New rule.
diff --git a/gdb/ada-lang.c b/gdb/ada-lang.c
index ec06693..f5753f1 100644
--- a/gdb/ada-lang.c
+++ b/gdb/ada-lang.c
@@ -2928,8 +2928,19 @@ ada_array_bound_from_type (struct type *arr_type, int n, int which)
   else
     type = arr_type;
 
-  index_type_desc = ada_find_parallel_type (type, "___XA");
-  ada_fixup_array_indexes_type (index_type_desc);
+  if (TYPE_FIXED_INSTANCE (type))
+    {
+      /* The array has already been fixed, so we do not need to
+	 check the parallel ___XA type again.  That encoding has
+	 already been applied, so ignore it now.  */
+      index_type_desc = NULL;
+    }
+  else
+    {
+      index_type_desc = ada_find_parallel_type (type, "___XA");
+      ada_fixup_array_indexes_type (index_type_desc);
+    }
+
   if (index_type_desc != NULL)
     index_type = to_fixed_range_type (TYPE_FIELD_TYPE (index_type_desc, n - 1),
 				      NULL);
diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog
index 2f747b5..a71ee98 100644
--- a/gdb/testsuite/ChangeLog
+++ b/gdb/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2015-01-15  Joel Brobecker  <brobecker@adacore.com>
+
+	* gdb.ada/var_arr_attrs: New testcase.
+
 2015-01-14  Pedro Alves  <palves@redhat.com>
 	    Joel Brobecker  <brobecker@adacore.com>
 
diff --git a/gdb/testsuite/gdb.ada/var_arr_attrs.exp b/gdb/testsuite/gdb.ada/var_arr_attrs.exp
new file mode 100644
index 0000000..34caeac
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/var_arr_attrs.exp
@@ -0,0 +1,39 @@
+# Copyright 2015 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/>.
+
+load_lib "ada.exp"
+
+standard_ada_testfile foo_o115_002
+
+if {[gdb_compile_ada "${srcfile}" "${binfile}" executable [list debug]] != "" } {
+  return -1
+}
+
+clean_restart ${testfile}
+
+set bp_location [gdb_get_line_number "STOP" ${testdir}/foo_o115_002.adb]
+runto "foo_o115_002.adb:$bp_location"
+
+gdb_test "print my_object.data'first" " = 1"
+
+gdb_test "print my_object.data'last" " = 3"
+
+gdb_test "print my_object.data'length" " = 3"
+
+gdb_test "print my_small_object.data'first" " = 1"
+
+gdb_test "print my_small_object.data'last" " = 3"
+
+gdb_test "print my_small_object.data'length" " = 3"
diff --git a/gdb/testsuite/gdb.ada/var_arr_attrs/foo_o115_002.adb b/gdb/testsuite/gdb.ada/var_arr_attrs/foo_o115_002.adb
new file mode 100644
index 0000000..1b5909e
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/var_arr_attrs/foo_o115_002.adb
@@ -0,0 +1,25 @@
+--  Copyright 2015 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/>.
+
+with Pck; use Pck;
+
+procedure Foo_O115_002 is
+   My_Object : Object := (N => 3, Data => (3, 5, 8));
+   My_Small_Object : Small_Object := (N => 3, Data => (3, 5, 8));
+begin
+   Do_Nothing (My_Object'Address);             -- STOP
+   Do_Nothing (My_Small_Object'Address);
+end Foo_O115_002;
+
diff --git a/gdb/testsuite/gdb.ada/var_arr_attrs/pck.adb b/gdb/testsuite/gdb.ada/var_arr_attrs/pck.adb
new file mode 100644
index 0000000..3f490ee
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/var_arr_attrs/pck.adb
@@ -0,0 +1,21 @@
+--  Copyright 2015 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/>.
+
+package body Pck is
+   procedure Do_Nothing (A : System.Address) is
+   begin
+      null;
+   end Do_Nothing;
+end Pck;
diff --git a/gdb/testsuite/gdb.ada/var_arr_attrs/pck.ads b/gdb/testsuite/gdb.ada/var_arr_attrs/pck.ads
new file mode 100644
index 0000000..79af546
--- /dev/null
+++ b/gdb/testsuite/gdb.ada/var_arr_attrs/pck.ads
@@ -0,0 +1,36 @@
+--  Copyright 2015 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/>.
+
+with System;
+package Pck is
+
+   type Table is array (Positive range <>) of Integer;
+
+   type Object (N : Integer) is record
+       Data : Table (1 .. N);
+   end record;
+
+   type Small is new Integer range 0 .. 255;
+   for Small'Size use 8;
+
+   type Small_Table is array (Positive range <>) of Small;
+   pragma Pack (Small_Table);
+
+   type Small_Object (N : Integer) is record
+       Data : Table (1 .. N);
+   end record;
+
+   procedure Do_Nothing (A : System.Address);
+end Pck;