+2015-10-21 Keven Boell <keven.boell@intel.com>
+
+ * dwarf2read.c (set_die_type): Add read of
+ DW_AT_allocated and DW_AT_associated.
+ * f-typeprint.c: New include of typeprint.h
+ (f_print_type): Add check for allocated/associated
+ status of type.
+ (f_type_print_varspec_suffix): Add check for
+ * gdbtypes.c (create_array_type_with_stride):
+ Add check for valid data location of type in
+ case allocated or associated attributes are set.
+ Length of an array should be only calculated if
+ allocated or associated is resolved as true.
+ (is_dynamic_type_internal): Add check for allocated/
+ associated.
+ (resolve_dynamic_array): Evaluate allocated/associated
+ properties.
+ * gdbtypes.h (enum dynamic_prop_node_kind): <DYN_PROP_ALLOCATED>
+ <DYN_PROP_ASSOCIATED>: New enums.
+ (TYPE_ALLOCATED_PROP, TYPE_ASSOCIATED_PROP): New macros.
+ (type_not_allocated): New function.
+ (type_not_associated): New function.
+ * valarith.c (value_subscripted_rvalue): Add check for
+ allocated/associated.
+ * valprint.c: New include of typeprint.h.
+ (valprint_check_validity): Add check for allocated/associated.
+ (value_check_printable): Add check for allocated/
+ associated.
+ * typeprint.h (val_print_not_allocated): New function.
+ (val_print_not_associated): New function.
+ * typeprint.c (val_print_not_allocated): New function.
+ (val_print_not_associated): New function.
+
2015-10-21 Antoine Tremblay <antoine.tremblay@ericsson.com>
* Makefile.in: Add arm.c/o.
&& !HAVE_GNAT_AUX_INFO (type))
INIT_GNAT_SPECIFIC (type);
+ /* Read DW_AT_allocated and set in type. */
+ attr = dwarf2_attr (die, DW_AT_allocated, cu);
+ if (attr_form_is_block (attr))
+ {
+ if (attr_to_dynamic_prop (attr, die, cu, &prop))
+ add_dyn_prop (DYN_PROP_ALLOCATED, prop, type, objfile);
+ }
+ else if (attr != NULL)
+ {
+ complaint (&symfile_complaints,
+ _("DW_AT_allocated has the wrong form (%s) at DIE 0x%x"),
+ (attr != NULL ? dwarf_form_name (attr->form) : "n/a"),
+ die->offset.sect_off);
+ }
+
+ /* Read DW_AT_associated and set in type. */
+ attr = dwarf2_attr (die, DW_AT_associated, cu);
+ if (attr_form_is_block (attr))
+ {
+ if (attr_to_dynamic_prop (attr, die, cu, &prop))
+ add_dyn_prop (DYN_PROP_ASSOCIATED, prop, type, objfile);
+ }
+ else if (attr != NULL)
+ {
+ complaint (&symfile_complaints,
+ _("DW_AT_associated has the wrong form (%s) at DIE 0x%x"),
+ (attr != NULL ? dwarf_form_name (attr->form) : "n/a"),
+ die->offset.sect_off);
+ }
+
/* 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))
#include "gdbcore.h"
#include "target.h"
#include "f-lang.h"
+#include "typeprint.h"
#if 0 /* Currently unused. */
static void f_type_print_args (struct type *, struct ui_file *);
enum type_code code;
int demangled_args;
+ if (type_not_associated (type))
+ {
+ val_print_not_associated (stream);
+ return;
+ }
+
+ if (type_not_allocated (type))
+ {
+ val_print_not_allocated (stream);
+ return;
+ }
+
f_type_print_base (type, stream, show, level);
code = TYPE_CODE (type);
if ((varstring != NULL && *varstring != '\0')
if (arrayprint_recurse_level == 1)
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,
- arrayprint_recurse_level);
-
- lower_bound = f77_get_lowerbound (type);
- if (lower_bound != 1) /* Not the default. */
- fprintf_filtered (stream, "%d:", lower_bound);
-
- /* Make sure that, if we have an assumed size array, we
- print out a warning and print the upperbound as '*'. */
-
- if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
- fprintf_filtered (stream, "*");
+ if (type_not_associated (type))
+ val_print_not_associated (stream);
+ else if (type_not_allocated (type))
+ val_print_not_allocated (stream);
else
- {
- upper_bound = f77_get_upperbound (type);
- fprintf_filtered (stream, "%d", upper_bound);
- }
-
- if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_ARRAY)
- f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0,
- arrayprint_recurse_level);
+ {
+ if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY)
+ f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
+ 0, 0, arrayprint_recurse_level);
+
+ lower_bound = f77_get_lowerbound (type);
+ if (lower_bound != 1) /* Not the default. */
+ fprintf_filtered (stream, "%d:", lower_bound);
+
+ /* Make sure that, if we have an assumed size array, we
+ print out a warning and print the upperbound as '*'. */
+
+ if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
+ fprintf_filtered (stream, "*");
+ else
+ {
+ upper_bound = f77_get_upperbound (type);
+ fprintf_filtered (stream, "%d", upper_bound);
+ }
+
+ if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_ARRAY)
+ 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
TYPE_CODE (result_type) = TYPE_CODE_ARRAY;
TYPE_TARGET_TYPE (result_type) = element_type;
- if (has_static_range (TYPE_RANGE_DATA (range_type)))
+ if (has_static_range (TYPE_RANGE_DATA (range_type))
+ && (!type_not_associated (result_type)
+ && !type_not_allocated (result_type)))
{
LONGEST low_bound, high_bound;
|| TYPE_DATA_LOCATION_KIND (type) == PROP_LOCLIST))
return 1;
+ if (TYPE_ASSOCIATED_PROP (type))
+ return 1;
+
+ if (TYPE_ALLOCATED_PROP (type))
+ return 1;
+
switch (TYPE_CODE (type))
{
case TYPE_CODE_RANGE:
struct type *elt_type;
struct type *range_type;
struct type *ary_dim;
+ struct dynamic_prop *prop;
gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
+ type = copy_type (type);
+
elt_type = type;
range_type = check_typedef (TYPE_INDEX_TYPE (elt_type));
range_type = resolve_dynamic_range (range_type, addr_stack);
+ /* Resolve allocated/associated here before creating a new array type, which
+ will update the length of the array accordingly. */
+ prop = TYPE_ALLOCATED_PROP (type);
+ if (prop != NULL && dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+ {
+ TYPE_DYN_PROP_ADDR (prop) = value;
+ TYPE_DYN_PROP_KIND (prop) = PROP_CONST;
+ }
+ prop = TYPE_ASSOCIATED_PROP (type);
+ if (prop != NULL && dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+ {
+ TYPE_DYN_PROP_ADDR (prop) = value;
+ TYPE_DYN_PROP_KIND (prop) = PROP_CONST;
+ }
+
ary_dim = check_typedef (TYPE_TARGET_TYPE (elt_type));
if (ary_dim != NULL && TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY)
else
elt_type = TYPE_TARGET_TYPE (type);
- return create_array_type_with_stride (copy_type (type),
- elt_type, range_type,
- TYPE_FIELD_BITSIZE (type, 0));
+ 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
return result;
}
+
+/* Allocated status of type TYPE. Return zero if type TYPE is allocated.
+ Otherwise return one. */
+
+int
+type_not_allocated (const struct type *type)
+{
+ struct dynamic_prop *prop = TYPE_ALLOCATED_PROP (type);
+
+ return (prop && TYPE_DYN_PROP_KIND (prop) == PROP_CONST
+ && !TYPE_DYN_PROP_ADDR (prop));
+}
+
+/* Associated status of type TYPE. Return zero if type TYPE is associated.
+ Otherwise return one. */
+
+int
+type_not_associated (const struct type *type)
+{
+ struct dynamic_prop *prop = TYPE_ASSOCIATED_PROP (type);
+
+ return (prop && TYPE_DYN_PROP_KIND (prop) == PROP_CONST
+ && !TYPE_DYN_PROP_ADDR (prop));
+}
\f
/* Compare one type (PARM) for compatibility with another (ARG).
* PARM is intended to be the parameter type of a function; and
/* A property providing a type's data location.
Evaluating this field yields to the location of an object's data. */
DYN_PROP_DATA_LOCATION,
+
+ /* A property representing DW_AT_allocated. The presence of this attribute
+ indicates that the object of the type can be allocated/deallocated. */
+ DYN_PROP_ALLOCATED,
+
+ /* A property representing DW_AT_allocated. The presence of this attribute
+ indicated that the object of the type can be associated. */
+ DYN_PROP_ASSOCIATED,
};
/* * List for dynamic type attributes. */
#define TYPE_DATA_LOCATION_KIND(thistype) \
TYPE_DATA_LOCATION (thistype)->kind
+/* Property accessors for the type allocated/associated. */
+#define TYPE_ALLOCATED_PROP(thistype) \
+ get_dyn_prop (DYN_PROP_ALLOCATED, thistype)
+#define TYPE_ASSOCIATED_PROP(thistype) \
+ get_dyn_prop (DYN_PROP_ASSOCIATED, thistype)
+
/* Attribute accessors for dynamic properties. */
#define TYPE_DYN_PROP_LIST(thistype) \
TYPE_MAIN_TYPE(thistype)->dyn_prop_list
extern int types_deeply_equal (struct type *, struct type *);
+extern int type_not_allocated (const struct type *type);
+
+extern int type_not_associated (const struct type *type);
+
#endif /* GDBTYPES_H */
+2015-10-21 Keven Boell <keven.boell@intel.com>
+
+ * gdb.fortran/vla-alloc-assoc.exp: New file.
+ * gdb.fortran/vla-datatypes.exp: New file.
+ * gdb.fortran/vla-datatypes.f90: New file.
+ * gdb.fortran/vla-history.exp: New file.
+ * gdb.fortran/vla-ptype-sub.exp: New file.
+ * gdb.fortran/vla-ptype.exp: New file.
+ * gdb.fortran/vla-sizeof.exp: New file.
+ * gdb.fortran/vla-sub.f90: New file.
+ * gdb.fortran/vla-value-sub-arbitrary.exp: New file.
+ * gdb.fortran/vla-value-sub-finish.exp: New file.
+ * gdb.fortran/vla-value-sub.exp: New file.
+ * gdb.fortran/vla-value.exp: New file.
+ * gdb.fortran/vla-ptr-info.exp: New file.
+ * gdb.mi/mi-vla-fortran.exp: New file.
+ * gdb.mi/vla.f90: New file.
+
2015-10-21 Sandra Loosemore <sandra@codesourcery.com>
* gdb.base/freebpcmd.exp: Use with_timeout_factor instead
--- /dev/null
+# 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/>.
+
+standard_testfile "vla.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
+}
+
+# Check the association status of various types of VLA's
+# and pointer to VLA's.
+gdb_breakpoint [gdb_get_line_number "vla1-allocated"]
+gdb_continue_to_breakpoint "vla1-allocated"
+gdb_test "print l" " = \\.TRUE\\." \
+ "print vla1 allocation status (allocated)"
+
+gdb_breakpoint [gdb_get_line_number "vla2-allocated"]
+gdb_continue_to_breakpoint "vla2-allocated"
+gdb_test "print l" " = \\.TRUE\\." \
+ "print vla2 allocation status (allocated)"
+
+gdb_breakpoint [gdb_get_line_number "pvla-associated"]
+gdb_continue_to_breakpoint "pvla-associated"
+gdb_test "print l" " = \\.TRUE\\." \
+ "print pvla associated status (associated)"
+
+gdb_breakpoint [gdb_get_line_number "pvla-re-associated"]
+gdb_continue_to_breakpoint "pvla-re-associated"
+gdb_test "print l" " = \\.TRUE\\." \
+ "print pvla associated status (re-associated)"
+
+gdb_breakpoint [gdb_get_line_number "pvla-deassociated"]
+gdb_continue_to_breakpoint "pvla-deassociated"
+gdb_test "print l" " = \\.FALSE\\." \
+ "print pvla allocation status (deassociated)"
+
+gdb_breakpoint [gdb_get_line_number "vla1-deallocated"]
+gdb_continue_to_breakpoint "vla1-deallocated"
+gdb_test "print l" " = \\.FALSE\\." \
+ "print vla1 allocation status (deallocated)"
+gdb_test "print vla1" " = <not allocated>" \
+ "print deallocated vla1"
+
+gdb_breakpoint [gdb_get_line_number "vla2-deallocated"]
+gdb_continue_to_breakpoint "vla2-deallocated"
+gdb_test "print l" " = \\.FALSE\\." "print vla2 deallocated"
+gdb_test "print vla2" " = <not allocated>" "print deallocated vla2"
--- /dev/null
+# 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/>.
+
+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 "vlas-allocated"]
+gdb_continue_to_breakpoint "vlas-allocated"
+gdb_test "next" " = allocated\\\(realvla\\\)" \
+ "next to allocation status of intvla"
+gdb_test "print l" " = \\.TRUE\\." "intvla allocated"
+gdb_test "next" " = allocated\\\(complexvla\\\)" \
+ "next to allocation status of realvla"
+gdb_test "print l" " = \\.TRUE\\." "realvla allocated"
+gdb_test "next" " = allocated\\\(logicalvla\\\)" \
+ "next to allocation status of complexvla"
+gdb_test "print l" " = \\.TRUE\\." "complexvla allocated"
+gdb_test "next" " = allocated\\\(charactervla\\\)" \
+ "next to allocation status of logicalvla"
+gdb_test "print l" " = \\.TRUE\\." "logicalvla allocated"
+gdb_test "next" "intvla\\\(:,:,:\\\) = 1" \
+ "next to allocation status of charactervla"
+gdb_test "print l" " = \\.TRUE\\." "charactervla allocated"
+
+gdb_breakpoint [gdb_get_line_number "vlas-initialized"]
+gdb_continue_to_breakpoint "vlas-initialized"
+gdb_test "ptype intvla" "type = integer\\\(kind=4\\\) \\\(11,22,33\\\)" \
+ "ptype intvla"
+gdb_test "ptype realvla" "type = real\\\(kind=4\\\) \\\(11,22,33\\\)" \
+ "ptype realvla"
+gdb_test "ptype complexvla" "type = complex\\\(kind=4\\\) \\\(11,22,33\\\)" \
+ "ptype complexvla"
+gdb_test "ptype logicalvla" "type = logical\\\(kind=4\\\) \\\(11,22,33\\\)" \
+ "ptype logicalvla"
+gdb_test "ptype charactervla" "type = character\\\*1 \\\(11,22,33\\\)" \
+ "ptype charactervla"
+
+gdb_test "print intvla(5,5,5)" " = 1" "print intvla(5,5,5) (1st)"
+gdb_test "print realvla(5,5,5)" " = 3.14\\d+" \
+ "print realvla(5,5,5) (1st)"
+gdb_test "print complexvla(5,5,5)" " = \\\(2,-3\\\)" \
+ "print complexvla(5,5,5) (1st)"
+gdb_test "print logicalvla(5,5,5)" " = \\.TRUE\\." \
+ "print logicalvla(5,5,5) (1st)"
+gdb_test "print charactervla(5,5,5)" " = 'K'" \
+ "print charactervla(5,5,5) (1st)"
+
+gdb_breakpoint [gdb_get_line_number "vlas-modified"]
+gdb_continue_to_breakpoint "vlas-modified"
+gdb_test "print intvla(5,5,5)" " = 42" "print intvla(5,5,5) (2nd)"
+gdb_test "print realvla(5,5,5)" " = 4.13\\d+" \
+ "print realvla(5,5,5) (2nd)"
+gdb_test "print complexvla(5,5,5)" " = \\\(-3,2\\\)" \
+ "print complexvla(5,5,5) (2nd)"
+gdb_test "print logicalvla(5,5,5)" " = \\.FALSE\\." \
+ "print logicalvla(5,5,5) (2nd)"
+gdb_test "print charactervla(5,5,5)" " = 'X'" \
+ "print charactervla(5,5,5) (2nd)"
--- /dev/null
+! 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 2 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, write to the Free Software
+! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+program vla_primitives
+ integer, allocatable :: intvla(:, :, :)
+ real, allocatable :: realvla(:, :, :)
+ complex, allocatable :: complexvla(:, :, :)
+ logical, allocatable :: logicalvla(:, :, :)
+ character, allocatable :: charactervla(:, :, :)
+ logical :: l
+
+ allocate (intvla (11,22,33))
+ allocate (realvla (11,22,33))
+ allocate (complexvla (11,22,33))
+ allocate (logicalvla (11,22,33))
+ allocate (charactervla (11,22,33))
+
+ l = allocated(intvla) ! vlas-allocated
+ l = allocated(realvla)
+ l = allocated(complexvla)
+ l = allocated(logicalvla)
+ l = allocated(charactervla)
+
+ intvla(:,:,:) = 1
+ realvla(:,:,:) = 3.14
+ complexvla(:,:,:) = cmplx(2.0,-3.0)
+ logicalvla(:,:,:) = .TRUE.
+ charactervla(:,:,:) = char(75)
+
+ intvla(5,5,5) = 42 ! vlas-initialized
+ realvla(5,5,5) = 4.13
+ complexvla(5,5,5) = cmplx(-3.0,2.0)
+ logicalvla(5,5,5) = .FALSE.
+ charactervla(5,5,5) = 'X'
+
+ ! dummy statement for bp
+ l = .FALSE. ! vlas-modified
+end program vla_primitives
--- /dev/null
+# 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/>.
+
+standard_testfile "vla.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
+}
+
+# Set some breakpoints and print complete vla.
+gdb_breakpoint [gdb_get_line_number "vla1-init"]
+gdb_continue_to_breakpoint "vla1-init"
+gdb_test "print vla1" " = <not allocated>" "print non-allocated vla1"
+
+gdb_breakpoint [gdb_get_line_number "vla2-allocated"]
+gdb_continue_to_breakpoint "vla2-allocated"
+gdb_test "print vla1" " = \\( *\\( *\\( *0, *0, *0,\[()0, .\]*\\)" \
+ "print vla1 allocated"
+gdb_test "print vla2" " = \\( *\\( *\\( *0, *0, *0,\[()0, .\]*\\)" \
+ "print vla2 allocated"
+
+gdb_breakpoint [gdb_get_line_number "vla1-filled"]
+gdb_continue_to_breakpoint "vla1-filled"
+gdb_test "print vla1" \
+ " = \\( *\\( *\\( *1311, *1311, *1311,\[()1311, .\]*\\)" \
+ "print vla1 filled"
+
+# Try to access history values for full vla prints.
+gdb_test "print \$1" " = <not allocated>" "print \$1"
+gdb_test "print \$2" " = \\( *\\( *\\( *0, *0, *0,\[()0, .\]*\\)" \
+ "print \$2"
+gdb_test "print \$3" " = \\( *\\( *\\( *0, *0, *0,\[()0, .\]*\\)" \
+ "print \$3"
+gdb_test "print \$4" \
+ " = \\( *\\( *\\( *1311, *1311, *1311,\[()1311, .\]*\\)" "print \$4"
+
+gdb_breakpoint [gdb_get_line_number "vla2-filled"]
+gdb_continue_to_breakpoint "vla2-filled"
+gdb_test "print vla2(1,43,20)" " = 1311" "print vla2(1,43,20)"
+gdb_test "print vla1(1,3,8)" " = 1001" "print vla2(1,3,8)"
+
+# Try to access history values for vla values.
+gdb_test "print \$9" " = 1311" "print \$9"
+gdb_test "print \$10" " = 1001" "print \$10"
--- /dev/null
+# 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/>.
+
+standard_testfile "vla.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
+}
+
+# Check the status of a pointer to a dynamic array.
+gdb_breakpoint [gdb_get_line_number "pvla-associated"]
+gdb_continue_to_breakpoint "pvla-associated"
+gdb_test "print &pvla" " = \\(PTR TO -> \\( real\\(kind=4\\) \\(10,10,10\\)\\)\\) ${hex}" \
+ "print pvla pointer information"
--- /dev/null
+# 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/>.
+
+standard_testfile "vla-sub.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
+}
+
+# Pass fixed array to function and handle them as vla in function.
+gdb_breakpoint [gdb_get_line_number "not-filled"]
+gdb_continue_to_breakpoint "not-filled (1st)"
+gdb_test "ptype array1" "type = integer\\\(kind=4\\\) \\\(42,42\\\)" \
+ "ptype array1 (passed fixed)"
+gdb_test "ptype array2" "type = real\\\(kind=4\\\) \\\(42,42,42\\\)" \
+ "ptype array2 (passed fixed)"
+gdb_test "ptype array1(40, 10)" "type = integer\\\(kind=4\\\)" \
+ "ptype array1(40, 10) (passed fixed)"
+gdb_test "ptype array2(13, 11, 5)" "type = real\\\(kind=4\\\)" \
+ "ptype array2(13, 11, 5) (passed fixed)"
+
+# Pass sub arrays to function and handle them as vla in function.
+gdb_continue_to_breakpoint "not-filled (2nd)"
+gdb_test "ptype array1" "type = integer\\\(kind=4\\\) \\\(6,6\\\)" \
+ "ptype array1 (passed sub-array)"
+gdb_test "ptype array2" "type = real\\\(kind=4\\\) \\\(6,6,6\\\)" \
+ "ptype array2 (passed sub-array)"
+gdb_test "ptype array1(3, 3)" "type = integer\\\(kind=4\\\)" \
+ "ptype array1(3, 3) (passed sub-array)"
+gdb_test "ptype array2(4, 4, 4)" "type = real\\\(kind=4\\\)" \
+ "ptype array2(4, 4, 4) (passed sub-array)"
+
+# Check ptype outside of bounds. This should not crash GDB.
+gdb_test "ptype array1(100, 100)" "no such vector element" \
+ "ptype array1(100, 100) subarray do not crash (passed sub-array)"
+gdb_test "ptype array2(100, 100, 100)" "no such vector element" \
+ "ptype array2(100, 100, 100) subarray do not crash (passed sub-array)"
+
+# Pass vla to function.
+gdb_continue_to_breakpoint "not-filled (3rd)"
+gdb_test "ptype array1" "type = integer\\\(kind=4\\\) \\\(20,20\\\)" \
+ "ptype array1 (passed vla)"
+gdb_test "ptype array2" "type = real\\\(kind=4\\\) \\\(10,10,10\\\)" \
+ "ptype array2 (passed vla)"
+gdb_test "ptype array1(3, 3)" "type = integer\\\(kind=4\\\)" \
+ "ptype array1(3, 3) (passed vla)"
+gdb_test "ptype array2(4, 4, 4)" "type = real\\\(kind=4\\\)" \
+ "ptype array2(4, 4, 4) (passed vla)"
+
+# Check ptype outside of bounds. This should not crash GDB.
+gdb_test "ptype array1(100, 100)" "no such vector element" \
+ "ptype array1(100, 100) VLA do not crash (passed vla)"
+gdb_test "ptype array2(100, 100, 100)" "no such vector element" \
+ "ptype array2(100, 100, 100) VLA do not crash (passed vla)"
+
+# Pass fixed array to function and handle it as VLA of arbitrary length in
+# function.
+gdb_breakpoint [gdb_get_line_number "end-of-bar"]
+gdb_continue_to_breakpoint "end-of-bar"
+gdb_test "ptype array1" \
+ "type = (PTR TO -> \\( )?integer(\\(kind=4\\)|\\*4) \\(\\*\\)\\)?" \
+ "ptype array1 (arbitrary length)"
+gdb_test "ptype array2" \
+ "type = (PTR TO -> \\( )?integer(\\(kind=4\\)|\\*4) \\(4:9,10:\\*\\)\\)?" \
+ "ptype array2 (arbitrary length)"
+gdb_test "ptype array1(100)" "type = integer\\\(kind=4\\\)" \
+ "ptype array1(100) (arbitrary length)"
+gdb_test "ptype array2(4,100)" "type = integer\\\(kind=4\\\)" \
+ "ptype array2(4,100) (arbitrary length)"
--- /dev/null
+# 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/>.
+
+standard_testfile "vla.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
+}
+
+# Check the ptype of various VLA states and pointer to VLA's.
+gdb_breakpoint [gdb_get_line_number "vla1-init"]
+gdb_continue_to_breakpoint "vla1-init"
+gdb_test "ptype vla1" "type = <not allocated>" "ptype vla1 not initialized"
+gdb_test "ptype vla2" "type = <not allocated>" "ptype vla2 not initialized"
+gdb_test "ptype pvla" "type = <not associated>" "ptype pvla not initialized"
+gdb_test "ptype vla1(3, 6, 9)" "no such vector element \\\(vector not allocated\\\)" \
+ "ptype vla1(3, 6, 9) not initialized"
+gdb_test "ptype vla2(5, 45, 20)" \
+ "no such vector element \\\(vector not allocated\\\)" \
+ "ptype vla1(5, 45, 20) not initialized"
+
+gdb_breakpoint [gdb_get_line_number "vla1-allocated"]
+gdb_continue_to_breakpoint "vla1-allocated"
+gdb_test "ptype vla1" "type = real\\\(kind=4\\\) \\\(10,10,10\\\)" \
+ "ptype vla1 allocated"
+
+gdb_breakpoint [gdb_get_line_number "vla2-allocated"]
+gdb_continue_to_breakpoint "vla2-allocated"
+gdb_test "ptype vla2" "type = real\\\(kind=4\\\) \\\(7,42:50,13:35\\\)" \
+ "ptype vla2 allocated"
+
+gdb_breakpoint [gdb_get_line_number "vla1-filled"]
+gdb_continue_to_breakpoint "vla1-filled"
+gdb_test "ptype vla1" "type = real\\\(kind=4\\\) \\\(10,10,10\\\)" \
+ "ptype vla1 filled"
+gdb_test "ptype vla1(3, 6, 9)" "type = real\\\(kind=4\\\)" \
+ "ptype vla1(3, 6, 9)"
+
+gdb_breakpoint [gdb_get_line_number "vla2-filled"]
+gdb_continue_to_breakpoint "vla2-filled"
+gdb_test "ptype vla2" "type = real\\\(kind=4\\\) \\\(7,42:50,13:35\\\)" \
+ "ptype vla2 filled"
+gdb_test "ptype vla2(5, 45, 20)" "type = real\\\(kind=4\\\)" \
+ "ptype vla1(5, 45, 20) filled"
+
+gdb_breakpoint [gdb_get_line_number "pvla-associated"]
+gdb_continue_to_breakpoint "pvla-associated"
+gdb_test "ptype pvla" "type = real\\\(kind=4\\\) \\\(10,10,10\\\)" \
+ "ptype pvla associated"
+gdb_test "ptype pvla(3, 6, 9)" "type = real\\\(kind=4\\\)" \
+ "ptype pvla(3, 6, 9)"
+
+gdb_breakpoint [gdb_get_line_number "pvla-re-associated"]
+gdb_continue_to_breakpoint "pvla-re-associated"
+gdb_test "ptype pvla" "type = real\\\(kind=4\\\) \\\(7,42:50,13:35\\\)" \
+ "ptype pvla re-associated"
+gdb_test "ptype vla2(5, 45, 20)" "type = real\\\(kind=4\\\)" \
+ "ptype vla1(5, 45, 20) re-associated"
+
+gdb_breakpoint [gdb_get_line_number "pvla-deassociated"]
+gdb_continue_to_breakpoint "pvla-deassociated"
+gdb_test "ptype pvla" "type = <not associated>" "ptype pvla deassociated"
+gdb_test "ptype pvla(5, 45, 20)" \
+ "no such vector element \\\(vector not associated\\\)" \
+ "ptype pvla(5, 45, 20) not associated"
+
+gdb_breakpoint [gdb_get_line_number "vla1-deallocated"]
+gdb_continue_to_breakpoint "vla1-deallocated"
+gdb_test "ptype vla1" "type = <not allocated>" "ptype vla1 not allocated"
+gdb_test "ptype vla1(3, 6, 9)" "no such vector element \\\(vector not allocated\\\)" \
+ "ptype vla1(3, 6, 9) not allocated"
+
+gdb_breakpoint [gdb_get_line_number "vla2-deallocated"]
+gdb_continue_to_breakpoint "vla2-deallocated"
+gdb_test "ptype vla2" "type = <not allocated>" "ptype vla2 not allocated"
+gdb_test "ptype vla2(5, 45, 20)" \
+ "no such vector element \\\(vector not allocated\\\)" \
+ "ptype vla2(5, 45, 20) not allocated"
--- /dev/null
+# 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/>.
+
+standard_testfile "vla.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
+}
+
+# Try to access values in non allocated VLA
+gdb_breakpoint [gdb_get_line_number "vla1-init"]
+gdb_continue_to_breakpoint "vla1-init"
+gdb_test "print sizeof(vla1)" " = 0" "print sizeof non-allocated vla1"
+
+# Try to access value in allocated VLA
+gdb_breakpoint [gdb_get_line_number "vla2-allocated"]
+gdb_continue_to_breakpoint "vla2-allocated"
+gdb_test "print sizeof(vla1)" " = 4000" "print sizeof allocated vla1"
+
+# Try to access values in undefined pointer to VLA (dangling)
+gdb_breakpoint [gdb_get_line_number "vla1-filled"]
+gdb_continue_to_breakpoint "vla1-filled"
+gdb_test "print sizeof(pvla)" " = 0" "print sizeof non-associated pvla"
+
+# Try to access values in pointer to VLA and compare them
+gdb_breakpoint [gdb_get_line_number "pvla-associated"]
+gdb_continue_to_breakpoint "pvla-associated"
+gdb_test "print sizeof(pvla)" " = 4000" "print sizeof associated pvla"
--- /dev/null
+! 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 2 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, write to the Free Software
+! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+!
+! Original file written by Jakub Jelinek <jakub@redhat.com> and
+! Jan Kratochvil <jan.kratochvil@redhat.com>.
+! Modified for the GDB testcases by Keven Boell <keven.boell@intel.com>.
+
+subroutine foo (array1, array2)
+ integer :: array1 (:, :)
+ real :: array2 (:, :, :)
+
+ array1(:,:) = 5 ! not-filled
+ array1(1, 1) = 30
+
+ array2(:,:,:) = 6 ! array1-filled
+ array2(:,:,:) = 3
+ array2(1,1,1) = 30
+ array2(3,3,3) = 90 ! array2-almost-filled
+end subroutine
+
+subroutine bar (array1, array2)
+ integer :: array1 (*)
+ integer :: array2 (4:9, 10:*)
+
+ array1(5:10) = 1311
+ array1(7) = 1
+ array1(100) = 100
+ array2(4,10) = array1(7)
+ array2(4,100) = array1(7)
+ return ! end-of-bar
+end subroutine
+
+program vla_sub
+ interface
+ subroutine foo (array1, array2)
+ integer :: array1 (:, :)
+ real :: array2 (:, :, :)
+ end subroutine
+ end interface
+ interface
+ subroutine bar (array1, array2)
+ integer :: array1 (*)
+ integer :: array2 (4:9, 10:*)
+ end subroutine
+ end interface
+
+ real, allocatable :: vla1 (:, :, :)
+ integer, allocatable :: vla2 (:, :)
+
+ ! used for subroutine
+ integer :: sub_arr1(42, 42)
+ real :: sub_arr2(42, 42, 42)
+ integer :: sub_arr3(42)
+
+ sub_arr1(:,:) = 1 ! vla2-deallocated
+ sub_arr2(:,:,:) = 2
+ sub_arr3(:) = 3
+
+ call foo(sub_arr1, sub_arr2)
+ call foo(sub_arr1(5:10, 5:10), sub_arr2(10:15,10:15,10:15))
+
+ allocate (vla1 (10,10,10))
+ allocate (vla2 (20,20))
+ vla1(:,:,:) = 1311
+ vla2(:,:) = 42
+ call foo(vla2, vla1)
+
+ call bar(sub_arr3, sub_arr1)
+end program vla_sub
--- /dev/null
+# 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/>.
+
+standard_testfile "vla-sub.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
+}
+
+# Check VLA with arbitary length and check that elements outside of
+# bounds of the passed VLA can be accessed correctly.
+gdb_breakpoint [gdb_get_line_number "end-of-bar"]
+gdb_continue_to_breakpoint "end-of-bar"
+gdb_test "p array1(42)" " = 3" "print arbitary array1(42)"
+gdb_test "p array1(100)" " = 100" "print arbitary array1(100)"
+gdb_test "p array2(4,10)" " = 1" "print arbitary array2(4,10)"
+gdb_test "p array2(4,100)" " = 1" "print arbitary array2(4,100)"
--- /dev/null
+# 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/>.
+
+standard_testfile "vla-sub.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
+}
+
+# "up" works with GCC but other Fortran compilers may copy the values into the
+# outer function only on the exit of the inner function.
+# We need both variants as depending on the arch we optionally may still be
+# executing the caller line or not after `finish'.
+
+gdb_breakpoint [gdb_get_line_number "array2-almost-filled"]
+gdb_continue_to_breakpoint "array2-almost-filled"
+gdb_test "print array2" " = \\( *\\( *\\( *30, *3, *3,\[()3, .\]*\\)" \
+ "print array2 in foo after it was filled"
+gdb_test "print array2(2,1,1)=20" " = 20" \
+ "set array(2,2,2) to 20 in subroutine"
+gdb_test "print array2" " = \\( *\\( *\\( *30, *20, *3,\[()3, .\]*\\)" \
+ "print array2 in foo after it was mofified in debugger"
+
+gdb_test "finish" \
+ ".*(foo\\\(sub_arr1\\\(5:10, 5:10\\\), sub_arr2\\\(10:15,10:15,10:15\\\)\\\)|foo \\\(array1=..., array2=...\\\).*)" \
+ "finish function"
+gdb_test "p sub_arr1(5, 7)" " = 5" "sub_arr1(5, 7) after finish"
+gdb_test "p sub_arr1(1, 1)" " = 30" "sub_arr1(1, 1) after finish"
+gdb_test "p sub_arr2(1, 1, 1)" " = 30" "sub_arr2(1, 1, 1) after finish"
+gdb_test "p sub_arr2(2, 1, 1)" " = 20" "sub_arr2(2, 1, 1) after finish"
+
--- /dev/null
+# 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/>.
+
+standard_testfile "vla-sub.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
+}
+
+# Check the values of VLA's in subroutine can be evaluated correctly
+
+# Try to access values from a fixed array handled as VLA in subroutine.
+gdb_breakpoint [gdb_get_line_number "not-filled"]
+gdb_continue_to_breakpoint "not-filled (1st)"
+gdb_test "print array1" " = \\(\[()1, .\]*\\)" \
+ "print passed array1 in foo (passed fixed array)"
+
+gdb_breakpoint [gdb_get_line_number "array1-filled"]
+gdb_continue_to_breakpoint "array1-filled (1st)"
+gdb_test "print array1(5, 7)" " = 5" \
+ "print array1(5, 7) after filled in foo (passed fixed array)"
+gdb_test "print array1(1, 1)" " = 30" \
+ "print array1(1, 1) after filled in foo (passed fixed array)"
+
+gdb_breakpoint [gdb_get_line_number "array2-almost-filled"]
+gdb_continue_to_breakpoint "array2-almost-filled (1st)"
+gdb_test "print array2" " = \\( *\\( *\\( *30, *3, *3,\[()3, .\]*\\)" \
+ "print array2 in foo after it was filled (passed fixed array)"
+gdb_test "print array2(2,1,1)=20" " = 20" \
+ "set array(2,2,2) to 20 in subroutine (passed fixed array)"
+gdb_test "print array2" " = \\( *\\( *\\( *30, *20, *3,\[()3, .\]*\\)" \
+ "print array2 in foo after it was mofified in debugger (passed fixed array)"
+
+
+# Try to access values from a fixed sub-array handled as VLA in subroutine.
+gdb_continue_to_breakpoint "not-filled (2nd)"
+gdb_test "print array1" " = \\(\[()5, .\]*\\)" \
+ "print passed array1 in foo (passed sub-array)"
+
+gdb_continue_to_breakpoint "array1-filled (2nd)"
+gdb_test "print array1(5, 5)" " = 5" \
+ "print array1(5, 5) after filled in foo (passed sub-array)"
+gdb_test "print array1(1, 1)" " = 30" \
+ "print array1(1, 1) after filled in foo (passed sub-array)"
+
+gdb_continue_to_breakpoint "array2-almost-filled (2nd)"
+gdb_test "print array2" " = \\( *\\( *\\( *30, *3, *3,\[()3, .\]*\\)" \
+ "print array2 in foo after it was filled (passed sub-array)"
+gdb_test "print array2(2,1,1)=20" " = 20" \
+ "set array(2,2,2) to 20 in subroutine (passed sub-array)"
+gdb_test "print array2" " = \\( *\\( *\\( *30, *20, *3,\[()3, .\]*\\)" \
+ "print array2 in foo after it was mofified in debugger (passed sub-array)"
+
+
+# Try to access values from a VLA passed to subroutine.
+gdb_continue_to_breakpoint "not-filled (3rd)"
+gdb_test "print array1" " = \\(\[()42, .\]*\\)" \
+ "print passed array1 in foo (passed vla)"
+
+gdb_continue_to_breakpoint "array1-filled (3rd)"
+gdb_test "print array1(5, 5)" " = 5" \
+ "print array1(5, 5) after filled in foo (passed vla)"
+gdb_test "print array1(1, 1)" " = 30" \
+ "print array1(1, 1) after filled in foo (passed vla)"
+
+gdb_continue_to_breakpoint "array2-almost-filled (3rd)"
+gdb_test "print array2" " = \\( *\\( *\\( *30, *3, *3,\[()3, .\]*\\)" \
+ "print array2 in foo after it was filled (passed vla)"
+gdb_test "print array2(2,1,1)=20" " = 20" \
+ "set array(2,2,2) to 20 in subroutine (passed vla)"
+gdb_test "print array2" " = \\( *\\( *\\( *30, *20, *3,\[()3, .\]*\\)" \
+ "print array2 in foo after it was mofified in debugger (passed vla)"
--- /dev/null
+# 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/>.
+
+standard_testfile "vla.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
+}
+
+# Try to access values in non allocated VLA
+gdb_breakpoint [gdb_get_line_number "vla1-init"]
+gdb_continue_to_breakpoint "vla1-init"
+gdb_test "print vla1" " = <not allocated>" "print non-allocated vla1"
+gdb_test "print &vla1" \
+ " = \\\(PTR TO -> \\\( real\\\(kind=4\\\) \\\(<not allocated>\\\)\\\)\\\) $hex" \
+ "print non-allocated &vla1"
+gdb_test "print vla1(1,1,1)" "no such vector element \\\(vector not allocated\\\)" \
+ "print member in non-allocated vla1 (1)"
+gdb_test "print vla1(101,202,303)" \
+ "no such vector element \\\(vector not allocated\\\)" \
+ "print member in non-allocated vla1 (2)"
+gdb_test "print vla1(5,2,18)=1" "no such vector element \\\(vector not allocated\\\)" \
+ "set member in non-allocated vla1"
+
+# Try to access value in allocated VLA
+gdb_breakpoint [gdb_get_line_number "vla2-allocated"]
+gdb_continue_to_breakpoint "vla2-allocated"
+gdb_test "next" "\\d+(\\t|\\s)+vla1\\\(3, 6, 9\\\) = 42" \
+ "step over value assignment of vla1"
+gdb_test "print &vla1" \
+ " = \\\(PTR TO -> \\\( real\\\(kind=4\\\) \\\(10,10,10\\\)\\\)\\\) $hex" \
+ "print allocated &vla1"
+gdb_test "print vla1(3, 6, 9)" " = 1311" "print allocated vla1(3,6,9)"
+gdb_test "print vla1(1, 3, 8)" " = 1311" "print allocated vla1(1,3,8)"
+gdb_test "print vla1(9, 9, 9) = 999" " = 999" \
+ "print allocated vla1(9,9,9)=1"
+
+# Try to access values in allocated VLA after specific assignment
+gdb_breakpoint [gdb_get_line_number "vla1-filled"]
+gdb_continue_to_breakpoint "vla1-filled"
+gdb_test "print vla1(3, 6, 9)" " = 42" \
+ "print allocated vla1(3,6,9) after specific assignment (filled)"
+gdb_test "print vla1(1, 3, 8)" " = 1001" \
+ "print allocated vla1(1,3,8) after specific assignment (filled)"
+gdb_test "print vla1(9, 9, 9)" " = 999" \
+ "print allocated vla1(9,9,9) after assignment in debugger (filled)"
+
+# Try to access values in undefined pointer to VLA (dangling)
+gdb_test "print pvla" " = <not associated>" "print undefined pvla"
+gdb_test "print &pvla" \
+ " = \\\(PTR TO -> \\\( real\\\(kind=4\\\) \\\(<not associated>\\\)\\\)\\\) $hex" \
+ "print non-associated &pvla"
+gdb_test "print pvla(1, 3, 8)" "no such vector element \\\(vector not associated\\\)" \
+ "print undefined pvla(1,3,8)"
+
+# Try to access values in pointer to VLA and compare them
+gdb_breakpoint [gdb_get_line_number "pvla-associated"]
+gdb_continue_to_breakpoint "pvla-associated"
+gdb_test "print &pvla" \
+ " = \\\(PTR TO -> \\\( real\\\(kind=4\\\) \\\(10,10,10\\\)\\\)\\\) $hex" \
+ "print associated &pvla"
+gdb_test "print pvla(3, 6, 9)" " = 42" "print associated pvla(3,6,9)"
+gdb_test "print pvla(1, 3, 8)" " = 1001" "print associated pvla(1,3,8)"
+gdb_test "print pvla(9, 9, 9)" " = 999" "print associated pvla(9,9,9)"
+
+# Fill values to VLA using pointer and check
+gdb_breakpoint [gdb_get_line_number "pvla-re-associated"]
+gdb_continue_to_breakpoint "pvla-re-associated"
+gdb_test "print pvla(5, 45, 20)" \
+ " = 1" "print pvla(5, 45, 20) after filled using pointer"
+gdb_test "print vla2(5, 45, 20)" \
+ " = 1" "print vla2(5, 45, 20) after filled using pointer"
+gdb_test "print pvla(7, 45, 14)" " = 2" \
+ "print pvla(7, 45, 14) after filled using pointer"
+gdb_test "print vla2(7, 45, 14)" " = 2" \
+ "print vla2(7, 45, 14) after filled using pointer"
+
+# Try to access values of deassociated VLA pointer
+gdb_breakpoint [gdb_get_line_number "pvla-deassociated"]
+gdb_continue_to_breakpoint "pvla-deassociated"
+gdb_test "print pvla(5, 45, 20)" \
+ "no such vector element \\\(vector not associated\\\)" \
+ "print pvla(5, 45, 20) after deassociated"
+gdb_test "print pvla(7, 45, 14)" \
+ "no such vector element \\\(vector not associated\\\)" \
+ "print pvla(7, 45, 14) after dissasociated"
+gdb_test "print pvla" " = <not associated>" \
+ "print vla1 after deassociated"
+
+# Try to access values of deallocated VLA
+gdb_breakpoint [gdb_get_line_number "vla1-deallocated"]
+gdb_continue_to_breakpoint "vla1-deallocated"
+gdb_test "print vla1(3, 6, 9)" "no such vector element \\\(vector not allocated\\\)" \
+ "print allocated vla1(3,6,9) after specific assignment (deallocated)"
+gdb_test "print vla1(1, 3, 8)" "no such vector element \\\(vector not allocated\\\)" \
+ "print allocated vla1(1,3,8) after specific assignment (deallocated)"
+gdb_test "print vla1(9, 9, 9)" "no such vector element \\\(vector not allocated\\\)" \
+ "print allocated vla1(9,9,9) after assignment in debugger (deallocated)"
+
+
+# Try to assign VLA to user variable
+clean_restart ${testfile}
+
+if ![runto MAIN__] then {
+ perror "couldn't run to breakpoint MAIN__"
+ continue
+}
+gdb_breakpoint [gdb_get_line_number "vla2-allocated"]
+gdb_continue_to_breakpoint "vla2-allocated"
+gdb_test "next" "\\d+.*vla1\\(3, 6, 9\\) = 42" "next (1)"
+
+gdb_test_no_output "set \$myvar = vla1" "set \$myvar = vla1"
+gdb_test "print \$myvar" \
+ " = \\( *\\( *\\( *1311, *1311, *1311,\[()1311, .\]*\\)" \
+ "print \$myvar set to vla1"
+
+gdb_test "next" "\\d+.*vla1\\(1, 3, 8\\) = 1001" "next (2)"
+gdb_test "print \$myvar(3,6,9)" " = 1311" "print \$myvar(3,6,9)"
+
+gdb_breakpoint [gdb_get_line_number "pvla-associated"]
+gdb_continue_to_breakpoint "pvla-associated"
+gdb_test_no_output "set \$mypvar = pvla" "set \$mypvar = pvla"
+gdb_test "print \$mypvar(1,3,8)" " = 1001" "print \$mypvar(1,3,8)"
+
+# deallocate pointer and make sure user defined variable still has the
+# right value.
+gdb_breakpoint [gdb_get_line_number "pvla-deassociated"]
+gdb_continue_to_breakpoint "pvla-deassociated"
+gdb_test "print \$mypvar(1,3,8)" " = 1001" \
+ "print \$mypvar(1,3,8) after deallocated"
--- /dev/null
+! 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/>.
+
+program vla
+ real, target, allocatable :: vla1 (:, :, :)
+ real, target, allocatable :: vla2 (:, :, :)
+ real, target, allocatable :: vla3 (:, :)
+ real, pointer :: pvla (:, :, :)
+ logical :: l
+
+ allocate (vla1 (10,10,10)) ! vla1-init
+ l = allocated(vla1)
+
+ allocate (vla2 (1:7,42:50,13:35)) ! vla1-allocated
+ l = allocated(vla2)
+
+ vla1(:, :, :) = 1311 ! vla2-allocated
+ vla1(3, 6, 9) = 42
+ vla1(1, 3, 8) = 1001
+ vla1(6, 2, 7) = 13
+
+ vla2(:, :, :) = 1311 ! vla1-filled
+ vla2(5, 45, 20) = 42
+
+ pvla => vla1 ! vla2-filled
+ l = associated(pvla)
+
+ pvla => vla2 ! pvla-associated
+ l = associated(pvla)
+ pvla(5, 45, 20) = 1
+ pvla(7, 45, 14) = 2
+
+ pvla => null() ! pvla-re-associated
+ l = associated(pvla)
+
+ deallocate (vla1) ! pvla-deassociated
+ l = allocated(vla1)
+
+ deallocate (vla2) ! vla1-deallocated
+ l = allocated(vla2)
+
+ allocate (vla3 (2,2)) ! vla2-deallocated
+ vla3(:,:) = 13
+end program vla
--- /dev/null
+# 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/>.
+
+# Verify that, using the MI, we can evaluate a simple C Variable Length
+# Array (VLA).
+
+load_lib mi-support.exp
+set MIFLAGS "-i=mi"
+
+gdb_exit
+if [mi_gdb_start] {
+ continue
+}
+
+standard_testfile vla.f90
+
+if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${binfile}" executable \
+ {debug f90}] != "" } {
+ untested mi-vla-fortran.exp
+ return -1
+}
+
+mi_delete_breakpoints
+mi_gdb_reinitialize_dir $srcdir/$subdir
+mi_gdb_load ${binfile}
+
+set bp_lineno [gdb_get_line_number "vla1-not-allocated"]
+mi_create_breakpoint "-t vla.f90:$bp_lineno" 1 "del" "vla" \
+ ".*vla.f90" $bp_lineno $hex \
+ "insert breakpoint at line $bp_lineno (vla not allocated)"
+mi_run_cmd
+mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
+ { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
+mi_gdb_test "500-data-evaluate-expression vla1" \
+ "500\\^done,value=\"<not allocated>\"" "evaluate not allocated vla"
+
+mi_create_varobj_checked vla1_not_allocated vla1 "<not allocated>" \
+ "create local variable vla1_not_allocated"
+mi_gdb_test "501-var-info-type vla1_not_allocated" \
+ "501\\^done,type=\"<not allocated>\"" \
+ "info type variable vla1_not_allocated"
+mi_gdb_test "502-var-show-format vla1_not_allocated" \
+ "502\\^done,format=\"natural\"" \
+ "show format variable vla1_not_allocated"
+mi_gdb_test "503-var-evaluate-expression vla1_not_allocated" \
+ "503\\^done,value=\"\\\[0\\\]\"" \
+ "eval variable vla1_not_allocated"
+mi_list_array_varobj_children_with_index "vla1_not_allocated" "0" "1" \
+ "real\\\(kind=4\\\)" "get children of vla1_not_allocated"
+
+
+
+set bp_lineno [gdb_get_line_number "vla1-allocated"]
+mi_create_breakpoint "-t vla.f90:$bp_lineno" 2 "del" "vla" ".*vla.f90" \
+ $bp_lineno $hex "insert breakpoint at line $bp_lineno (vla allocated)"
+mi_run_cmd
+mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
+ { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
+mi_gdb_test "510-data-evaluate-expression vla1" \
+ "510\\^done,value=\"\\(0, 0, 0, 0, 0\\)\"" "evaluate allocated vla"
+
+mi_create_varobj_checked vla1_allocated vla1 "real\\\(kind=4\\\) \\\(5\\\)" \
+ "create local variable vla1_allocated"
+mi_gdb_test "511-var-info-type vla1_allocated" \
+ "511\\^done,type=\"real\\\(kind=4\\\) \\\(5\\\)\"" \
+ "info type variable vla1_allocated"
+mi_gdb_test "512-var-show-format vla1_allocated" \
+ "512\\^done,format=\"natural\"" \
+ "show format variable vla1_allocated"
+mi_gdb_test "513-var-evaluate-expression vla1_allocated" \
+ "513\\^done,value=\"\\\[5\\\]\"" \
+ "eval variable vla1_allocated"
+mi_list_array_varobj_children_with_index "vla1_allocated" "5" "1" \
+ "real\\\(kind=4\\\)" "get children of vla1_allocated"
+
+
+set bp_lineno [gdb_get_line_number "vla1-filled"]
+mi_create_breakpoint "-t vla.f90:$bp_lineno" 3 "del" "vla" ".*vla.f90" \
+ $bp_lineno $hex "insert breakpoint at line $bp_lineno"
+mi_run_cmd
+mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
+ { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
+mi_gdb_test "520-data-evaluate-expression vla1" \
+ "520\\^done,value=\"\\(1, 1, 1, 1, 1\\)\"" "evaluate filled vla"
+
+
+set bp_lineno [gdb_get_line_number "vla1-modified"]
+mi_create_breakpoint "-t vla.f90:$bp_lineno" 4 "del" "vla" ".*vla.f90" \
+ $bp_lineno $hex "insert breakpoint at line $bp_lineno"
+mi_run_cmd
+mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
+ { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
+mi_gdb_test "530-data-evaluate-expression vla1" \
+ "530\\^done,value=\"\\(1, 42, 1, 24, 1\\)\"" "evaluate filled vla"
+mi_gdb_test "540-data-evaluate-expression vla1(1)" \
+ "540\\^done,value=\"1\"" "evaluate filled vla"
+mi_gdb_test "550-data-evaluate-expression vla1(2)" \
+ "550\\^done,value=\"42\"" "evaluate filled vla"
+mi_gdb_test "560-data-evaluate-expression vla1(4)" \
+ "560\\^done,value=\"24\"" "evaluate filled vla"
+
+
+set bp_lineno [gdb_get_line_number "vla1-deallocated"]
+mi_create_breakpoint "-t vla.f90:$bp_lineno" 5 "del" "vla" ".*vla.f90" \
+ $bp_lineno $hex "insert breakpoint at line $bp_lineno"
+mi_run_cmd
+mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
+ { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
+mi_gdb_test "570-data-evaluate-expression vla1" \
+ "570\\^done,value=\"<not allocated>\"" "evaluate not allocated vla"
+
+
+set bp_lineno [gdb_get_line_number "pvla2-not-associated"]
+mi_create_breakpoint "-t vla.f90:$bp_lineno" 6 "del" "vla" ".*vla.f90" \
+ $bp_lineno $hex "insert breakpoint at line $bp_lineno"
+mi_run_cmd
+mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
+ { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
+mi_gdb_test "580-data-evaluate-expression pvla2" \
+ "580\\^done,value=\"<not associated>\"" "evaluate not associated vla"
+
+mi_create_varobj_checked pvla2_not_associated pvla2 "<not associated>" \
+ "create local variable pvla2_not_associated"
+mi_gdb_test "581-var-info-type pvla2_not_associated" \
+ "581\\^done,type=\"<not associated>\"" \
+ "info type variable pvla2_not_associated"
+mi_gdb_test "582-var-show-format pvla2_not_associated" \
+ "582\\^done,format=\"natural\"" \
+ "show format variable pvla2_not_associated"
+mi_gdb_test "583-var-evaluate-expression pvla2_not_associated" \
+ "583\\^done,value=\"\\\[0\\\]\"" \
+ "eval variable pvla2_not_associated"
+mi_list_array_varobj_children_with_index "pvla2_not_associated" "0" "1" \
+ "real\\\(kind=4\\\)" "get children of pvla2_not_associated"
+
+
+set bp_lineno [gdb_get_line_number "pvla2-associated"]
+mi_create_breakpoint "-t vla.f90:$bp_lineno" 7 "del" "vla" ".*vla.f90" \
+ $bp_lineno $hex "insert breakpoint at line $bp_lineno"
+mi_run_cmd
+mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
+ { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
+mi_gdb_test "590-data-evaluate-expression pvla2" \
+ "590\\^done,value=\"\\(\\( 2, 2, 2, 2, 2\\) \\( 2, 2, 2, 2, 2\\) \\)\"" \
+ "evaluate associated vla"
+
+mi_create_varobj_checked pvla2_associated pvla2 \
+ "real\\\(kind=4\\\) \\\(5,2\\\)" "create local variable pvla2_associated"
+mi_gdb_test "591-var-info-type pvla2_associated" \
+ "591\\^done,type=\"real\\\(kind=4\\\) \\\(5,2\\\)\"" \
+ "info type variable pvla2_associated"
+mi_gdb_test "592-var-show-format pvla2_associated" \
+ "592\\^done,format=\"natural\"" \
+ "show format variable pvla2_associated"
+mi_gdb_test "593-var-evaluate-expression pvla2_associated" \
+ "593\\^done,value=\"\\\[2\\\]\"" \
+ "eval variable pvla2_associated"
+
+
+set bp_lineno [gdb_get_line_number "pvla2-set-to-null"]
+mi_create_breakpoint "-t vla.f90:$bp_lineno" 8 "del" "vla" ".*vla.f90" \
+ $bp_lineno $hex "insert breakpoint at line $bp_lineno"
+mi_run_cmd
+mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
+ { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
+mi_gdb_test "600-data-evaluate-expression pvla2" \
+ "600\\^done,value=\"<not associated>\"" "evaluate vla pointer set to null"
+
+mi_gdb_exit
+return 0
--- /dev/null
+! 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/>.
+
+program vla
+ real, allocatable :: vla1 (:)
+ real, target, allocatable :: vla2(:, :)
+ real, pointer :: pvla2 (:, :)
+ logical :: l
+
+ allocate (vla1 (5)) ! vla1-not-allocated
+ l = allocated(vla1) ! vla1-allocated
+
+ vla1(:) = 1
+ vla1(2) = 42 ! vla1-filled
+ vla1(4) = 24
+
+ deallocate (vla1) ! vla1-modified
+ l = allocated(vla1) ! vla1-deallocated
+
+ allocate (vla2 (5, 2))
+ vla2(:, :) = 2
+
+ pvla2 => vla2 ! pvla2-not-associated
+ l = associated(pvla2) ! pvla2-associated
+
+ pvla2(2, 1) = 42
+
+ pvla2 => null()
+ l = associated(pvla2) ! pvla2-set-to-null
+end program vla
show_print_type_typedefs,
&setprinttypelist, &showprinttypelist);
}
+
+/* Print <not allocated> status to stream STREAM. */
+
+void
+val_print_not_allocated (struct ui_file *stream)
+{
+ fprintf_filtered (stream, _("<not allocated>"));
+}
+
+/* Print <not associated> status to stream STREAM. */
+
+void
+val_print_not_associated (struct ui_file *stream)
+{
+ fprintf_filtered (stream, _("<not associated>"));
+}
+
void c_type_print_args (struct type *, struct ui_file *, int, enum language,
const struct type_print_options *);
+extern void val_print_not_allocated (struct ui_file *stream);
+
+extern void val_print_not_associated (struct ui_file *stream);
+
#endif
if (index < lowerbound || (!TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (array_type)
&& elt_offs >= type_length_units (array_type)))
- error (_("no such vector element"));
+ {
+ if (type_not_associated (array_type))
+ error (_("no such vector element (vector not associated)"));
+ else if (type_not_allocated (array_type))
+ error (_("no such vector element (vector not allocated)"));
+ else
+ error (_("no such vector element"));
+ }
if (VALUE_LVAL (array) == lval_memory && value_lazy (array))
v = allocate_value_lazy (elt_type);
#include "ada-lang.h"
#include "gdb_obstack.h"
#include "charset.h"
+#include "typeprint.h"
#include <ctype.h>
/* Maximum number of wchars returned from wchar_iterate. */
{
type = check_typedef (type);
+ if (type_not_associated (type))
+ {
+ val_print_not_associated (stream);
+ return 0;
+ }
+
+ if (type_not_allocated (type))
+ {
+ val_print_not_allocated (stream);
+ return 0;
+ }
+
if (TYPE_CODE (type) != TYPE_CODE_UNION
&& TYPE_CODE (type) != TYPE_CODE_STRUCT
&& TYPE_CODE (type) != TYPE_CODE_ARRAY)
return 0;
}
+ if (type_not_associated (value_type (val)))
+ {
+ val_print_not_associated (stream);
+ return 0;
+ }
+
+ if (type_not_allocated (value_type (val)))
+ {
+ val_print_not_allocated (stream);
+ return 0;
+ }
+
return 1;
}
projects / binutils-gdb.git / commitdiff