FreeChainXenon/binutils-gdb
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

gdb/fortran: Show the type for non allocated / associated types

Browse source 
Show the type of not-allocated and/or not-associated types.  For array
types and pointer to array types we are going to print the number of
ranks.

Consider this Fortran program:

  program test
    integer, allocatable :: vla (:)
    logical l
    allocate (vla(5:12))
    l = allocated (vla)
  end program test

And this GDB session with current HEAD:

  (gdb) start
  ...
  2	  integer, allocatable :: vla (:)
  (gdb) n
  4	  allocate (vla(5:12))
  (gdb) ptype vla
  type = <not allocated>
  (gdb) p vla
  $1 = <not allocated>
  (gdb)

And the same session with this patch applied:

  (gdb) start
  ...
  2	  integer, allocatable :: vla (:)
  (gdb) n
  4	  allocate (vla(5:12))
  (gdb) ptype vla
  type = integer(kind=4), allocatable (:)
  (gdb) p vla
  $1 = <not allocated>
  (gdb)

The type of 'vla' is now printed correctly, while the value itself
still shows as '<not allocated>'.  How GDB prints the type of
associated pointers has changed in a similar way.

gdb/ChangeLog:

	* f-typeprint.c (f_print_type): Don't return early for not
	associated or not allocated types.
	(f_type_print_varspec_suffix): Add print_rank parameter and print
	ranks of array types in case they dangling.
	(f_type_print_base): Add print_rank parameter.

gdb/testsuite/ChangeLog:

	* gdb.fortran/pointers.f90: New file.
	* gdb.fortran/print_type.exp: New file.
	* gdb.fortran/vla-ptype.exp: Adapt expected results.
	* gdb.fortran/vla-type.exp: Likewise.
	* gdb.fortran/vla-value.exp: Likewise.
	* gdb.mi/mi-vla-fortran.exp: Likewise.
This commit is contained in:
Andrew Burgess 2019-03-01 11:12:33 +00:00
parent 30056ea04a
commit 584a927c5a
9 changed files with 284 additions and 58 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
gdb/ChangeLog
View file

@ -1,3 +1,12 @@
2019-06-16 Bernhard Heckel <bernhard.heckel@intel.com>
Andrew Burgess <andrew.burgess@embecosm.com>
* f-typeprint.c (f_print_type): Don't return early for not
associated or not allocated types.
(f_type_print_varspec_suffix): Add print_rank parameter and print
ranks of array types in case they dangling.
(f_type_print_base): Add print_rank parameter.
2019-06-15 Andrew Burgess <andrew.burgess@embecosm.com>
* NEWS: Mention new MI commands.

92
gdb/f-typeprint.c
View file

@ -37,7 +37,7 @@ static void f_type_print_args (struct type *, struct ui_file *);
#endif
static void f_type_print_varspec_suffix (struct type *, struct ui_file *, int,
int, int, int);
int, int, int, bool);
void f_type_print_varspec_prefix (struct type *, struct ui_file *,
int, int);
@ -53,18 +53,6 @@ f_print_type (struct type *type, const char *varstring, struct ui_file *stream,
{
enum type_code code;
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')
@ -96,7 +84,7 @@ f_print_type (struct type *type, const char *varstring, struct ui_file *stream,
demangled_args = (*varstring != '\0'
&& varstring[strlen (varstring) - 1] == ')');
f_type_print_varspec_suffix (type, stream, show, 0, demangled_args, 0);
f_type_print_varspec_suffix (type, stream, show, 0, demangled_args, 0, false);
}
}
@ -161,12 +149,17 @@ f_type_print_varspec_prefix (struct type *type, struct ui_file *stream,
/* Print any array sizes, function arguments or close parentheses
needed after the variable name (to describe its type).
Args work like c_type_print_varspec_prefix. */
Args work like c_type_print_varspec_prefix.
PRINT_RANK_ONLY is true when TYPE is an array which should be printed
without the upper and lower bounds being specified, this will occur
when the array is not allocated or not associated and so there are no
known upper or lower bounds. */
static void
f_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
int show, int passed_a_ptr, int demangled_args,
int arrayprint_recurse_level)
int arrayprint_recurse_level, bool print_rank_only)
{
/* No static variables are permitted as an error call may occur during
execution of this function. */
@ -188,36 +181,52 @@ f_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
fprintf_filtered (stream, "(");
if (type_not_associated (type))
val_print_not_associated (stream);
print_rank_only = true;
else if (type_not_allocated (type))
val_print_not_allocated (stream);
print_rank_only = true;
else if ((TYPE_ASSOCIATED_PROP (type)
&& PROP_CONST != TYPE_DYN_PROP_KIND (TYPE_ASSOCIATED_PROP (type)))
|| (TYPE_ALLOCATED_PROP (type)
&& PROP_CONST != TYPE_DYN_PROP_KIND (TYPE_ALLOCATED_PROP (type)))
|| (TYPE_DATA_LOCATION (type)
&& PROP_CONST != TYPE_DYN_PROP_KIND (TYPE_DATA_LOCATION (type))))
{
/* This case exist when we ptype a typename which has the dynamic
properties but cannot be resolved as there is no object. */
print_rank_only = true;
}
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,
print_rank_only);
if (print_rank_only)
fprintf_filtered (stream, ":");
else
{
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);
LONGEST lower_bound = f77_get_lowerbound (type);
if (lower_bound != 1) /* Not the default. */
{
LONGEST lower_bound = f77_get_lowerbound (type);
if (lower_bound != 1) /* Not the default. */
fprintf_filtered (stream, "%s:", plongest (lower_bound));
/* Make sure that, if we have an assumed size array, we
print out a warning and print the upperbound as '*'. */
/* 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
{
LONGEST upper_bound = f77_get_upperbound (type);
if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
fprintf_filtered (stream, "*");
else
{
LONGEST upper_bound = f77_get_upperbound (type);
fputs_filtered (plongest (upper_bound), 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,
print_rank_only);
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
@ -228,7 +237,7 @@ f_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
case TYPE_CODE_PTR:
case TYPE_CODE_REF:
f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0,
arrayprint_recurse_level);
arrayprint_recurse_level, false);
fprintf_filtered (stream, " )");
break;
@ -237,7 +246,8 @@ f_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
int i, nfields = TYPE_NFIELDS (type);
f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
passed_a_ptr, 0, arrayprint_recurse_level);
passed_a_ptr, 0,
arrayprint_recurse_level, false);
if (passed_a_ptr)
fprintf_filtered (stream, ") ");
fprintf_filtered (stream, "(");
@ -416,7 +426,7 @@ f_type_print_base (struct type *type, struct ui_file *stream, int show,
fputs_filtered (" :: ", stream);
fputs_filtered (TYPE_FIELD_NAME (type, index), stream);
f_type_print_varspec_suffix (TYPE_FIELD_TYPE (type, index),
stream, show - 1, 0, 0, 0);
stream, show - 1, 0, 0, 0, false);
fputs_filtered ("\n", stream);
}
fprintfi_filtered (level, stream, "End Type ");

10
gdb/testsuite/ChangeLog
View file

@ -1,3 +1,13 @@
2019-06-16 Bernhard Heckel <bernhard.heckel@intel.com>
Andrew Burgess <andrew.burgess@embecosm.com>
* gdb.fortran/pointers.f90: New file.
* gdb.fortran/print_type.exp: New file.
* gdb.fortran/vla-ptype.exp: Adapt expected results.
* gdb.fortran/vla-type.exp: Likewise.
* gdb.fortran/vla-value.exp: Likewise.
* gdb.mi/mi-vla-fortran.exp: Likewise.
2019-06-15 Andrew Burgess <andrew.burgess@embecosm.com>
* gdb.mi/mi-catch-cpp-exceptions.cc: New file.

80
gdb/testsuite/gdb.fortran/pointers.f90 Normal file
View file

@ -0,0 +1,80 @@
! Copyright 2019 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 pointers
type :: two
integer, allocatable :: ivla1 (:)
integer, allocatable :: ivla2 (:, :)
end type two
logical, target :: logv
complex, target :: comv
character, target :: charv
character (len=3), target :: chara
integer, target :: intv
integer, target, dimension (10,2) :: inta
real, target :: realv
type(two), target :: twov
logical, pointer :: logp
complex, pointer :: comp
character, pointer :: charp
character (len=3), pointer :: charap
integer, pointer :: intp
integer, pointer, dimension (:,:) :: intap
real, pointer :: realp
type(two), pointer :: twop
nullify (logp)
nullify (comp)
nullify (charp)
nullify (charap)
nullify (intp)
nullify (intap)
nullify (realp)
nullify (twop)
logp => logv ! Before pointer assignment
comp => comv
charp => charv
charap => chara
intp => intv
intap => inta
realp => realv
twop => twov
logv = associated(logp) ! Before value assignment
comv = cmplx(1,2)
charv = "a"
chara = "abc"
intv = 10
inta(:,:) = 1
inta(3,1) = 3
realv = 3.14
allocate (twov%ivla1(3))
allocate (twov%ivla2(2,2))
twov%ivla1(1) = 11
twov%ivla1(2) = 12
twov%ivla1(3) = 13
twov%ivla2(1,1) = 211
twov%ivla2(2,1) = 221
twov%ivla2(1,2) = 212
twov%ivla2(2,2) = 222
intv = intv + 1 ! After value assignment
end program pointers

114
gdb/testsuite/gdb.fortran/print_type.exp Executable file
View file

@ -0,0 +1,114 @@
# Copyright 2019 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/>.
# Check how GDB handles printing pointers, both when associated, and
# when not associated.
standard_testfile "pointers.f90"
load_lib fortran.exp
if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
{debug f90 quiet}] } {
return -1
}
if ![runto_main] {
untested "could not run to main"
return -1
}
# Depending on the compiler being used, the type names can be printed
# differently.
set logical [fortran_logical4]
set real [fortran_real4]
set int [fortran_int4]
set complex [fortran_complex4]
# Print the inferior variable VAR_NAME, and check that the result
# matches the string TYPE.
proc check_pointer_type { var_name type } {
gdb_test "ptype ${var_name}" \
"type = PTR TO -> \\( ${type} \\)"
}
gdb_breakpoint [gdb_get_line_number "Before pointer assignment"]
gdb_continue_to_breakpoint "Before pointer assignment"
with_test_prefix "pointers not associated" {
check_pointer_type "logp" "$logical"
check_pointer_type "comp" "$complex"
check_pointer_type "charp" "character\\*1"
check_pointer_type "charap" "character\\*3"
check_pointer_type "intp" "$int"
# Current gfortran seems to not mark 'intap' as a pointer. Intels
# Fortran compiler does though.
set test "ptype intap"
gdb_test_multiple "ptype intap" $test {
-re "type = PTR TO -> \\( $int \\(:,:\\) \\)\r\n$gdb_prompt $" {
pass $test
}
-re "type = $int \\(:,:\\)\r\n$gdb_prompt $" {
pass $test
}
}
check_pointer_type "realp" "$real"
check_pointer_type "twop" \
[multi_line "Type two" \
" $int, allocatable :: ivla1\\(:\\)" \
" $int, allocatable :: ivla2\\(:,:\\)" \
"End Type two"]
}
gdb_test "ptype two" \
[multi_line "type = Type two" \
" $int, allocatable :: ivla1\\(:\\)" \
" $int, allocatable :: ivla2\\(:,:\\)" \
"End Type two"]
gdb_breakpoint [gdb_get_line_number "Before value assignment"]
gdb_continue_to_breakpoint "Before value assignment"
gdb_test "ptype twop" \
[multi_line "type = PTR TO -> \\( Type two" \
" $int, allocatable :: ivla1\\(:\\)" \
" $int, allocatable :: ivla2\\(:,:\\)" \
"End Type two \\)"]
gdb_breakpoint [gdb_get_line_number "After value assignment"]
gdb_continue_to_breakpoint "After value assignment"
gdb_test "ptype logv" "type = $logical"
gdb_test "ptype comv" "type = $complex"
gdb_test "ptype charv" "type = character\\*1"
gdb_test "ptype chara" "type = character\\*3"
gdb_test "ptype intv" "type = $int"
gdb_test "ptype inta" "type = $int \\(10,2\\)"
gdb_test "ptype realv" "type = $real"
gdb_test "ptype logp" "type = PTR TO -> \\( $logical \\)"
gdb_test "ptype comp" "type = PTR TO -> \\( $complex \\)"
gdb_test "ptype charp" "type = PTR TO -> \\( character\\*1 \\)"
gdb_test "ptype charap" "type = PTR TO -> \\( character\\*3 \\)"
gdb_test "ptype intp" "type = PTR TO -> \\( $int \\)"
set test "ptype intap"
gdb_test_multiple $test $test {
-re "type = $int \\(10,2\\)\r\n$gdb_prompt $" {
pass $test
}
-re "type = PTR TO -> \\( $int \\(10,2\\)\\)\r\n$gdb_prompt $" {
pass $test
}
}
gdb_test "ptype realp" "type = PTR TO -> \\( $real \\)"

12
gdb/testsuite/gdb.fortran/vla-ptype.exp
View file

@ -32,9 +32,9 @@ set real [fortran_real4]
# 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" "type = $real, allocatable \\(:,:,:\\)" "ptype vla1 not initialized"
gdb_test "ptype vla2" "type = $real, allocatable \\(:,:,:\\)" "ptype vla2 not initialized"
gdb_test "ptype pvla" "type = $real \\(:,:,:\\)" "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)" \
@ -81,20 +81,20 @@ gdb_test "ptype vla2(5, 45, 20)" "type = $real" \
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" "type = $real \\(:,:,:\\)" "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" "type = $real, allocatable \\(:,:,:\\)" "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" "type = $real, allocatable \\(:,:,:\\)" "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"

7
gdb/testsuite/gdb.fortran/vla-type.exp
View file

@ -132,7 +132,10 @@ gdb_test "ptype fivearr(2)%tone" \
"End Type one" ]
# Check allocation status of dynamic array and it's dynamic members
gdb_test "ptype fivedynarr" "type = <not allocated>"
gdb_test "ptype fivedynarr" \
[multi_line "type = Type five" \
" Type one :: tone" \
"End Type five, allocatable \\(:\\)" ]
gdb_test "next" ""
gdb_test "ptype fivedynarr(2)" \
[multi_line "type = Type five" \
@ -141,7 +144,7 @@ gdb_test "ptype fivedynarr(2)" \
"ptype fivedynarr(2), tone is not allocated"
gdb_test "ptype fivedynarr(2)%tone" \
[multi_line "type = Type one" \
" $int, allocatable :: ivla\\(<not allocated>\\)" \
" $int, allocatable :: ivla\\(:,:,:\\)" \
"End Type one" ] \
"ptype fivedynarr(2)%tone, not allocated"

10
gdb/testsuite/gdb.fortran/vla-value.exp
View file

@ -35,7 +35,7 @@ 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, allocatable \\\(<not allocated>\\\) \\\)\\\) $hex" \
" = \\\(PTR TO -> \\\( $real, allocatable \\\(:,:,:\\\) \\\)\\\) $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)"
@ -76,7 +76,7 @@ gdb_test "print vla1(9, 9, 9)" " = 999" \
# 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 \\\(<not associated>\\\) \\\)\\\) $hex" \
" = \\\(PTR TO -> \\\( $real \\\(:,:,:\\\) \\\)\\\) $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)"
@ -134,7 +134,7 @@ if ![runto MAIN__] then {
continue
}
gdb_breakpoint [gdb_get_line_number "vla2-allocated"]
gdb_continue_to_breakpoint "vla2-allocated"
gdb_continue_to_breakpoint "vla2-allocated, second time"
# Many instructions to be executed when step over this line, and it is
# slower in remote debugging. Increase the timeout to avoid timeout
# fail.
@ -151,13 +151,13 @@ 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_continue_to_breakpoint "pvla-associated, second time"
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_continue_to_breakpoint "pvla-deassociated, second time"
gdb_test "print \$mypvar(1,3,8)" " = 1001" \
"print \$mypvar(1,3,8) after deallocated"

8
gdb/testsuite/gdb.mi/mi-vla-fortran.exp
View file

@ -51,10 +51,10 @@ mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
mi_gdb_test "500-data-evaluate-expression vla1" \
"500\\^done,value=\"<not allocated>\"" "evaluate not allocated vla, before allocation"
mi_create_varobj_checked vla1_not_allocated vla1 "<not allocated>" \
mi_create_varobj_checked vla1_not_allocated vla1 "$real, allocatable \\(:\\)" \
"create local variable vla1_not_allocated"
mi_gdb_test "501-var-info-type vla1_not_allocated" \
"501\\^done,type=\"<not allocated>\"" \
"501\\^done,type=\"$real, allocatable \\(:\\)\"" \
"info type variable vla1_not_allocated"
mi_gdb_test "502-var-show-format vla1_not_allocated" \
"502\\^done,format=\"natural\"" \
@ -146,10 +146,10 @@ gdb_expect {
-re "580\\^done,value=\"<not associated>\".*${mi_gdb_prompt}$" {
pass $test
mi_create_varobj_checked pvla2_not_associated pvla2 "<not associated>" \
mi_create_varobj_checked pvla2_not_associated pvla2 "$real \\(:,:\\)" \
"create local variable pvla2_not_associated"
mi_gdb_test "581-var-info-type pvla2_not_associated" \
"581\\^done,type=\"<not associated>\"" \
"581\\^done,type=\"$real \\(:,:\\)\"" \
"info type variable pvla2_not_associated"
mi_gdb_test "582-var-show-format pvla2_not_associated" \
"582\\^done,format=\"natural\"" \