diff options
26 files changed, 1452 insertions, 26 deletions
diff --git a/gdb/ChangeLog b/gdb/ChangeLog index 3ca3d6be1c4..53e55aee926 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,3 +1,36 @@ +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. diff --git a/gdb/dwarf2read.c b/gdb/dwarf2read.c index 0c45d294a4e..d43c42ed583 100644 --- a/gdb/dwarf2read.c +++ b/gdb/dwarf2read.c @@ -22356,6 +22356,36 @@ set_die_type (struct die_info *die, struct type *type, struct dwarf2_cu *cu) && !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)) diff --git a/gdb/f-typeprint.c b/gdb/f-typeprint.c index 590ed73d32f..1308a3c1e26 100644 --- a/gdb/f-typeprint.c +++ b/gdb/f-typeprint.c @@ -30,6 +30,7 @@ #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 *); @@ -53,6 +54,18 @@ f_print_type (struct type *type, const char *varstring, struct ui_file *stream, 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') @@ -167,28 +180,35 @@ f_type_print_varspec_suffix (struct type *type, struct ui_file *stream, 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 diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c index 919cac9f9ab..b9850cf3d83 100644 --- a/gdb/gdbtypes.c +++ b/gdb/gdbtypes.c @@ -1080,7 +1080,9 @@ create_array_type_with_stride (struct type *result_type, 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; @@ -1819,6 +1821,12 @@ is_dynamic_type_internal (struct type *type, int top_level) || 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: @@ -1936,13 +1944,31 @@ resolve_dynamic_array (struct type *type, 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) @@ -1950,9 +1976,8 @@ resolve_dynamic_array (struct type *type, 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 @@ -3375,6 +3400,30 @@ types_deeply_equal (struct type *type1, struct type *type2) 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)); +} /* Compare one type (PARM) for compatibility with another (ARG). * PARM is intended to be the parameter type of a function; and diff --git a/gdb/gdbtypes.h b/gdb/gdbtypes.h index 0828723447b..acfa16a4734 100644 --- a/gdb/gdbtypes.h +++ b/gdb/gdbtypes.h @@ -440,6 +440,14 @@ enum dynamic_prop_node_kind /* 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. */ @@ -1258,6 +1266,12 @@ extern void allocate_gnat_aux_type (struct type *); #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 @@ -1932,4 +1946,8 @@ extern int types_equal (struct type *, struct type *); 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 */ diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog index 82d53f869f0..8f47cc180f7 100644 --- a/gdb/testsuite/ChangeLog +++ b/gdb/testsuite/ChangeLog @@ -1,3 +1,21 @@ +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 diff --git a/gdb/testsuite/gdb.fortran/vla-alloc-assoc.exp b/gdb/testsuite/gdb.fortran/vla-alloc-assoc.exp new file mode 100644 index 00000000000..ad85977381a --- /dev/null +++ b/gdb/testsuite/gdb.fortran/vla-alloc-assoc.exp @@ -0,0 +1,65 @@ +# 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" diff --git a/gdb/testsuite/gdb.fortran/vla-datatypes.exp b/gdb/testsuite/gdb.fortran/vla-datatypes.exp new file mode 100644 index 00000000000..006fce67dc3 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/vla-datatypes.exp @@ -0,0 +1,82 @@ +# 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)" diff --git a/gdb/testsuite/gdb.fortran/vla-datatypes.f90 b/gdb/testsuite/gdb.fortran/vla-datatypes.f90 new file mode 100644 index 00000000000..db25695f363 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/vla-datatypes.f90 @@ -0,0 +1,51 @@ +! 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 diff --git a/gdb/testsuite/gdb.fortran/vla-history.exp b/gdb/testsuite/gdb.fortran/vla-history.exp new file mode 100644 index 00000000000..5fbffaf7547 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/vla-history.exp @@ -0,0 +1,62 @@ +# 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" diff --git a/gdb/testsuite/gdb.fortran/vla-ptr-info.exp b/gdb/testsuite/gdb.fortran/vla-ptr-info.exp new file mode 100644 index 00000000000..c4cbb03eab2 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/vla-ptr-info.exp @@ -0,0 +1,32 @@ +# 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" diff --git a/gdb/testsuite/gdb.fortran/vla-ptype-sub.exp b/gdb/testsuite/gdb.fortran/vla-ptype-sub.exp new file mode 100644 index 00000000000..eb704a84b21 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/vla-ptype-sub.exp @@ -0,0 +1,87 @@ +# 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)" diff --git a/gdb/testsuite/gdb.fortran/vla-ptype.exp b/gdb/testsuite/gdb.fortran/vla-ptype.exp new file mode 100644 index 00000000000..c95f7b2e1c2 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/vla-ptype.exp @@ -0,0 +1,96 @@ +# 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" diff --git a/gdb/testsuite/gdb.fortran/vla-sizeof.exp b/gdb/testsuite/gdb.fortran/vla-sizeof.exp new file mode 100644 index 00000000000..ee09e984ae1 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/vla-sizeof.exp @@ -0,0 +1,46 @@ +# 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" diff --git a/gdb/testsuite/gdb.fortran/vla-sub.f90 b/gdb/testsuite/gdb.fortran/vla-sub.f90 new file mode 100644 index 00000000000..dfda411b6a3 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/vla-sub.f90 @@ -0,0 +1,82 @@ +! 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 diff --git a/gdb/testsuite/gdb.fortran/vla-value-sub-arbitrary.exp b/gdb/testsuite/gdb.fortran/vla-value-sub-arbitrary.exp new file mode 100644 index 00000000000..a9f85896503 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/vla-value-sub-arbitrary.exp @@ -0,0 +1,35 @@ +# 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)" diff --git a/gdb/testsuite/gdb.fortran/vla-value-sub-finish.exp b/gdb/testsuite/gdb.fortran/vla-value-sub-finish.exp new file mode 100644 index 00000000000..88c6254fb3c --- /dev/null +++ b/gdb/testsuite/gdb.fortran/vla-value-sub-finish.exp @@ -0,0 +1,49 @@ +# 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" + diff --git a/gdb/testsuite/gdb.fortran/vla-value-sub.exp b/gdb/testsuite/gdb.fortran/vla-value-sub.exp new file mode 100644 index 00000000000..8562ea4ddc7 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/vla-value-sub.exp @@ -0,0 +1,90 @@ +# 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)" diff --git a/gdb/testsuite/gdb.fortran/vla-value.exp b/gdb/testsuite/gdb.fortran/vla-value.exp new file mode 100644 index 00000000000..24182cc215e --- /dev/null +++ b/gdb/testsuite/gdb.fortran/vla-value.exp @@ -0,0 +1,148 @@ +# 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" diff --git a/gdb/testsuite/gdb.fortran/vla.f90 b/gdb/testsuite/gdb.fortran/vla.f90 new file mode 100644 index 00000000000..61e22b9c289 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/vla.f90 @@ -0,0 +1,56 @@ +! 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 diff --git a/gdb/testsuite/gdb.mi/mi-vla-fortran.exp b/gdb/testsuite/gdb.mi/mi-vla-fortran.exp new file mode 100644 index 00000000000..d1916237dfc --- /dev/null +++ b/gdb/testsuite/gdb.mi/mi-vla-fortran.exp @@ -0,0 +1,182 @@ +# 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 diff --git a/gdb/testsuite/gdb.mi/vla.f90 b/gdb/testsuite/gdb.mi/vla.f90 new file mode 100644 index 00000000000..0b89d34a092 --- /dev/null +++ b/gdb/testsuite/gdb.mi/vla.f90 @@ -0,0 +1,42 @@ +! 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 diff --git a/gdb/typeprint.c b/gdb/typeprint.c index 8fbd1789a89..377223a4711 100644 --- a/gdb/typeprint.c +++ b/gdb/typeprint.c @@ -727,3 +727,20 @@ Show printing of typedefs defined in classes."), NULL, 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>")); +} + diff --git a/gdb/typeprint.h b/gdb/typeprint.h index bdff41bb790..d8225f2f346 100644 --- a/gdb/typeprint.h +++ b/gdb/typeprint.h @@ -74,4 +74,8 @@ void c_type_print_varspec_suffix (struct type *, struct ui_file *, int, 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 diff --git a/gdb/valarith.c b/gdb/valarith.c index 3e349f23f5b..97145a15265 100644 --- a/gdb/valarith.c +++ b/gdb/valarith.c @@ -198,7 +198,14 @@ value_subscripted_rvalue (struct value *array, LONGEST index, int lowerbound) 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); diff --git a/gdb/valprint.c b/gdb/valprint.c index c053a817815..7e74856c910 100644 --- a/gdb/valprint.c +++ b/gdb/valprint.c @@ -34,6 +34,7 @@ #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. */ @@ -303,6 +304,18 @@ valprint_check_validity (struct ui_file *stream, { 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) @@ -1043,6 +1056,18 @@ value_check_printable (struct value *val, struct ui_file *stream, 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; } |