From f63782d25ebd593c4c4669d4c394a2706f15e660 Mon Sep 17 00:00:00 2001 From: Bernhard Heckel Date: Tue, 12 Jul 2016 08:19:34 +0200 Subject: [PATCH 4/7] Fortran: Typeprint, fix dangling types. Show the type of not-allocated and/or not-associated types as this is known. For array types and pointer to array types we are going to print the number of ranks. 2016-06-30 Bernhard Heckel gdb/ChangeLog: * f-typeprint.c (f_print_type): Don't bypass dangling types. (f_type_print_varspec_suffix): Add print_rank parameter. (f_type_print_varspec_suffix): 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. * gdb.fortran/print_type.exp: New. * 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. Change-Id: Ib55f28b4092cf88e34918449a2ebb6e5daafe512 --- gdb/f-typeprint.c | 95 +++++++++++++++-------------- gdb/testsuite/gdb.fortran/pointers.f90 | 80 +++++++++++++++++++++++++ gdb/testsuite/gdb.fortran/print_type.exp | 100 +++++++++++++++++++++++++++++++ gdb/testsuite/gdb.fortran/vla-ptype.exp | 12 ++-- gdb/testsuite/gdb.fortran/vla-type.exp | 7 ++- gdb/testsuite/gdb.fortran/vla-value.exp | 4 +- gdb/testsuite/gdb.mi/mi-vla-fortran.exp | 9 +-- 7 files changed, 248 insertions(+), 59 deletions(-) create mode 100644 gdb/testsuite/gdb.fortran/pointers.f90 create mode 100755 gdb/testsuite/gdb.fortran/print_type.exp Index: gdb-7.11.50.20160630/gdb/f-typeprint.c =================================================================== --- gdb-7.11.50.20160630.orig/gdb/f-typeprint.c 2016-07-16 10:54:48.749099150 +0200 +++ gdb-7.11.50.20160630/gdb/f-typeprint.c 2016-07-16 10:55:59.763667355 +0200 @@ -37,7 +37,7 @@ #endif static void f_type_print_varspec_suffix (struct type *, struct ui_file *, int, - int, int, int); + int, int, int, int); void f_type_print_varspec_prefix (struct type *, struct ui_file *, int, int); @@ -54,18 +54,6 @@ 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') @@ -87,7 +75,7 @@ so don't print an additional pair of ()'s. */ demangled_args = 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, 0); } } @@ -157,7 +145,7 @@ 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, int print_rank_only) { int upper_bound, lower_bound; @@ -181,34 +169,50 @@ fprintf_filtered (stream, "("); if (type_not_associated (type)) - val_print_not_associated (stream); + print_rank_only = 1; else if (type_not_allocated (type)) - val_print_not_allocated (stream); + print_rank_only = 1; + 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 = 1; + + 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 == 1) + 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); - - 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); - } + { + 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, + print_rank_only); + if (arrayprint_recurse_level == 1) fprintf_filtered (stream, ")"); else @@ -219,13 +223,14 @@ 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, 0); fprintf_filtered (stream, ")"); break; case TYPE_CODE_FUNC: 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, + 0); if (passed_a_ptr) fprintf_filtered (stream, ")"); @@ -376,7 +381,7 @@ 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, 0); fputs_filtered ("\n", stream); } fprintfi_filtered (level, stream, "End Type "); Index: gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/pointers.f90 =================================================================== --- /dev/null 1970-01-01 00:00:00.000000000 +0000 +++ gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/pointers.f90 2016-07-16 10:55:42.079525860 +0200 @@ -0,0 +1,80 @@ +! Copyright 2016 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 . + +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 Index: gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/print_type.exp =================================================================== --- /dev/null 1970-01-01 00:00:00.000000000 +0000 +++ gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/print_type.exp 2016-07-16 10:55:42.079525860 +0200 @@ -0,0 +1,100 @@ +# Copyright 2016 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 . + +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] + +gdb_breakpoint [gdb_get_line_number "Before pointer assignment"] +gdb_continue_to_breakpoint "Before pointer assignment" +gdb_test "ptype logp" "type = PTR TO -> \\( $logical \\)" "ptype logp, not associated" +gdb_test "ptype comp" "type = PTR TO -> \\( $complex \\)" "ptype comp, not associated" +gdb_test "ptype charp" "type = PTR TO -> \\( character\\*1 \\)" "ptype charp, not associated" +gdb_test "ptype charap" "type = PTR TO -> \\( character\\*3 \\)" "ptype charap, not associated" +gdb_test "ptype intp" "type = PTR TO -> \\( $int \\)" "ptype intp, not associated" +set test "ptype intap, not associated" +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 + } +} +gdb_test "ptype realp" "type = PTR TO -> \\( $real \\)" "ptype realp, not associated" +gdb_test "ptype twop" \ + [multi_line "type = PTR TO -> \\( Type two" \ + " $int :: ivla1\\(:\\)" \ + " $int :: ivla2\\(:,:\\)" \ + "End Type two \\)"] \ + "ptype twop, not associated" +gdb_test "ptype two" \ + [multi_line "type = Type two" \ + " $int :: ivla1\\(:\\)" \ + " $int :: 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 :: ivla1\\(:\\)" \ + " $int :: 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 \\)" Index: gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/vla-ptype.exp =================================================================== --- gdb-7.11.50.20160630.orig/gdb/testsuite/gdb.fortran/vla-ptype.exp 2016-07-16 10:54:48.749099150 +0200 +++ gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/vla-ptype.exp 2016-07-16 10:55:42.079525860 +0200 @@ -32,9 +32,9 @@ # 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 = " "ptype vla1 not initialized" -gdb_test "ptype vla2" "type = " "ptype vla2 not initialized" -gdb_test "ptype pvla" "type = " "ptype pvla not initialized" +gdb_test "ptype vla1" "type = $real \\(:,:,:\\)" "ptype vla1 not initialized" +gdb_test "ptype vla2" "type = $real \\(:,:,:\\)" "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_breakpoint [gdb_get_line_number "pvla-deassociated"] gdb_continue_to_breakpoint "pvla-deassociated" -gdb_test "ptype pvla" "type = " "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 = " "ptype vla1 not allocated" +gdb_test "ptype vla1" "type = $real \\(:,:,:\\)" "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 = " "ptype vla2 not allocated" +gdb_test "ptype vla2" "type = $real \\(:,:,:\\)" "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" Index: gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/vla-type.exp =================================================================== --- gdb-7.11.50.20160630.orig/gdb/testsuite/gdb.fortran/vla-type.exp 2016-07-16 10:54:48.749099150 +0200 +++ gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/vla-type.exp 2016-07-16 10:55:42.080525868 +0200 @@ -132,7 +132,10 @@ "End Type one" ] # Check allocation status of dynamic array and it's dynamic members -gdb_test "ptype fivedynarr" "type = " +gdb_test "ptype fivedynarr" \ + [multi_line "type = Type five" \ + " Type one :: tone" \ + "End Type five \\(:\\)" ] gdb_test "next" "" gdb_test "ptype fivedynarr(2)" \ [multi_line "type = Type five" \ @@ -141,7 +144,7 @@ "ptype fivedynarr(2), tone is not allocated" gdb_test "ptype fivedynarr(2)%tone" \ [multi_line "type = Type one" \ - " $int :: ivla\\(\\)" \ + " $int :: ivla\\(:,:,:\\)" \ "End Type one" ] \ "ptype fivedynarr(2)%tone, not allocated" Index: gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/vla-value.exp =================================================================== --- gdb-7.11.50.20160630.orig/gdb/testsuite/gdb.fortran/vla-value.exp 2016-07-16 10:54:48.749099150 +0200 +++ gdb-7.11.50.20160630/gdb/testsuite/gdb.fortran/vla-value.exp 2016-07-16 10:55:42.080525868 +0200 @@ -34,7 +34,7 @@ gdb_continue_to_breakpoint "vla1-init" gdb_test "print vla1" " = " "print non-allocated vla1" gdb_test "print &vla1" \ - " = \\\(PTR TO -> \\\( $real \\\(\\\)\\\)\\\) $hex" \ + " = \\\(PTR TO -> \\\( $real \\\(:,:,:\\\)\\\)\\\) $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)" @@ -75,7 +75,7 @@ # Try to access values in undefined pointer to VLA (dangling) gdb_test "print pvla" " = " "print undefined pvla" gdb_test "print &pvla" \ - " = \\\(PTR TO -> \\\( $real \\\(\\\)\\\)\\\) $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)" Index: gdb-7.11.50.20160630/gdb/testsuite/gdb.mi/mi-vla-fortran.exp =================================================================== --- gdb-7.11.50.20160630.orig/gdb/testsuite/gdb.mi/mi-vla-fortran.exp 2016-07-16 10:54:48.749099150 +0200 +++ gdb-7.11.50.20160630/gdb/testsuite/gdb.mi/mi-vla-fortran.exp 2016-07-16 10:55:42.080525868 +0200 @@ -17,6 +17,7 @@ # Array (VLA). load_lib mi-support.exp +load_lib fortran.exp set MIFLAGS "-i=mi" load_lib "fortran.exp" @@ -50,10 +51,10 @@ mi_gdb_test "500-data-evaluate-expression vla1" \ "500\\^done,value=\"\"" "evaluate not allocated vla" -mi_create_varobj_checked vla1_not_allocated vla1 "" \ +mi_create_varobj_checked vla1_not_allocated vla1 "$real \\(:\\)" \ "create local variable vla1_not_allocated" mi_gdb_test "501-var-info-type vla1_not_allocated" \ - "501\\^done,type=\"\"" \ + "501\\^done,type=\"$real \\(:\\)\"" \ "info type variable vla1_not_allocated" mi_gdb_test "502-var-show-format vla1_not_allocated" \ "502\\^done,format=\"natural\"" \ @@ -140,10 +141,10 @@ -re "580\\^done,value=\"\".*${mi_gdb_prompt}$" { pass $test - mi_create_varobj_checked pvla2_not_associated pvla2 "" \ + 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=\"\"" \ + "581\\^done,type=\"$real \\(:,:\\)\"" \ "info type variable pvla2_not_associated" mi_gdb_test "582-var-show-format pvla2_not_associated" \ "582\\^done,format=\"natural\"" \