* [PATCH V2 3/5] Fortran: Resolve dynamic target types of pointers.
2016-07-04 9:52 [PATCH V2 0/5] Fortran: Resolve target types of pointers Bernhard Heckel
2016-07-04 9:52 ` [PATCH V2 2/5] Fortran: Testsuite, add print of pointer types Bernhard Heckel
@ 2016-07-04 9:52 ` Bernhard Heckel
2016-07-04 15:01 ` Eli Zaretskii
2016-07-05 14:35 ` Joel Brobecker
2016-07-04 9:52 ` [PATCH V2 5/5] Fortran: Handle cyclic pointers Bernhard Heckel
` (2 subsequent siblings)
4 siblings, 2 replies; 10+ messages in thread
From: Bernhard Heckel @ 2016-07-04 9:52 UTC (permalink / raw)
To: qiyaoltc, eliz; +Cc: gdb-patches, Bernhard Heckel
Dynamic target types of pointers have to be resolved before
they can be further processed. If not, GDB wil show wrong
boundaries, size,... or even crash as it will access some
random memory.
2016-06-30 Bernhard Heckel <bernhard.heckel@intel.com>
gdb/Changelog:
* NEWS: Added new fortran feature.
* gdbtypes.c (resolve_dynamic_pointer_types): Resolve
dynamic target types.
* valops.c (value_ind): Throw error when pointer is
not associated.
gdb/Testsuite/Changelog:
* gdb.fortran/pointers.f90: Add dynamic variables.
* gdb.fortran/pointers.exp: Test dynamic variables.
* gdb.fortran/print_type.exp: Test pointer to dynamic
types.
---
gdb/NEWS | 2 +
gdb/gdbtypes.c | 83 ++++++++++++++++++++++++++++++++
gdb/testsuite/gdb.fortran/pointers.exp | 48 ++++++++++++++++++
gdb/testsuite/gdb.fortran/pointers.f90 | 17 +++++++
gdb/testsuite/gdb.fortran/print_type.exp | 10 ++++
gdb/valops.c | 3 ++
6 files changed, 163 insertions(+)
diff --git a/gdb/NEWS b/gdb/NEWS
index 3e8e7a1..bea86d3 100644
--- a/gdb/NEWS
+++ b/gdb/NEWS
@@ -3,6 +3,8 @@
*** Changes since GDB 7.11
+* Fortran: Support pointers to dynamic types.
+
* Fortran: Support structures with fields of dynamic types and
arrays of dynamic types.
diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
index 9e1759b..76ae406 100644
--- a/gdb/gdbtypes.c
+++ b/gdb/gdbtypes.c
@@ -1828,6 +1828,18 @@ is_dynamic_type_internal (struct type *type, int top_level)
switch (TYPE_CODE (type))
{
+ case TYPE_CODE_PTR:
+ {
+ /* Some Fortran compiler don't create the associated property which
+ would cause a "return 1".
+ For a correct value/type print we have to treat every pointer as
+ dynamic type to cover nullified pointers as well as dynamic target
+ types. */
+ if (current_language->la_language == language_fortran)
+ return 1;
+
+ return 0;
+ }
case TYPE_CODE_RANGE:
{
/* A range type is obviously dynamic if it has at least one
@@ -2105,6 +2117,73 @@ resolve_dynamic_struct (struct type *type,
return resolved_type;
}
+/* Worker for pointer types. */
+
+static struct type *
+resolve_dynamic_pointer (struct type *type,
+ struct property_addr_info *addr_stack)
+{
+ struct property_addr_info pinfo;
+ int is_associated;
+
+ /* If valaddr is set, the type was already resolved
+ and assigned to an value. */
+ if (0 != addr_stack->valaddr)
+ return type;
+
+ if (TYPE_OBJFILE_OWNED (type))
+ {
+ struct dynamic_prop *prop;
+ CORE_ADDR value;
+
+ type = copy_type (type);
+
+ /* Resolve associated property. */
+ 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;
+ is_associated = value;
+ }
+ else
+ {
+ /* Compiler doesn't create associated property for this pointer
+ therefore we have to check whether it is still null. */
+ if (0 != read_memory_typed_address (addr_stack->addr, type))
+ is_associated = 1;
+ else
+ is_associated = 0;
+ }
+ }
+ else
+ {
+ /* Do nothing, as this pointer is created on the fly and therefore
+ associated. For example "print *((integer*) &intvla)". */
+ is_associated = 1;
+ }
+
+ /* Don't resolve not associated pointers. */
+ if (0 == is_associated)
+ return type;
+
+ pinfo.type = check_typedef (TYPE_TARGET_TYPE (type));
+ pinfo.valaddr = NULL;
+ /* Data location attr. refers to the "address of the variable".
+ Therefore we don't derefence anything here but
+ keep the "address of the variable". */
+ if (NULL != TYPE_DATA_LOCATION (pinfo.type))
+ pinfo.addr = addr_stack->addr;
+ else
+ pinfo.addr = read_memory_typed_address (addr_stack->addr, type);
+ pinfo.next = addr_stack;
+ TYPE_TARGET_TYPE (type) =
+ resolve_dynamic_type_internal (TYPE_TARGET_TYPE (type),
+ &pinfo, 0);
+
+ return type;
+}
+
/* Worker for resolved_dynamic_type. */
static struct type *
@@ -2153,6 +2232,10 @@ resolve_dynamic_type_internal (struct type *type,
break;
}
+ case TYPE_CODE_PTR:
+ resolved_type = resolve_dynamic_pointer (type, addr_stack);
+ break;
+
case TYPE_CODE_ARRAY:
resolved_type = resolve_dynamic_array (type, addr_stack);
break;
diff --git a/gdb/testsuite/gdb.fortran/pointers.exp b/gdb/testsuite/gdb.fortran/pointers.exp
index beecbe4..310544c 100644
--- a/gdb/testsuite/gdb.fortran/pointers.exp
+++ b/gdb/testsuite/gdb.fortran/pointers.exp
@@ -59,6 +59,11 @@ gdb_test "print *realp" "Cannot access memory at address 0x0" "print *realp, not
gdb_test "print \$my_var = intp" "= \\(PTR TO -> \\( $int \\)\\) 0x0"
+gdb_breakpoint [gdb_get_line_number "Before value assignment"]
+gdb_continue_to_breakpoint "Before value assignment"
+gdb_test "print *(twop)%ivla2" "= <not allocated>"
+
+
gdb_breakpoint [gdb_get_line_number "After value assignment"]
gdb_continue_to_breakpoint "After value assignment"
gdb_test "print logp" "= \\(PTR TO -> \\( $logical \\)\\) $hex\( <.*>\)?"
@@ -71,5 +76,48 @@ gdb_test "print charap" "= \\(PTR TO -> \\( character\\*3 \\)\\) $hex\( <.*>\)?"
gdb_test "print *charap" "= 'abc'"
gdb_test "print intp" "= \\(PTR TO -> \\( $int \\)\\) $hex\( <.*>\)?"
gdb_test "print *intp" "= 10"
+set test_name "print intap, associated"
+gdb_test_multiple "print intap" $test_name {
+ -re "= \\(\\( 1, 1, 3(, 1){7}\\) \\( 1(, 1){9}\\) \\)\r\n$gdb_prompt $" {
+ pass $test_name
+ }
+ -re "= \\(PTR TO -> \\( $int \\(10,2\\)\\)\\) $hex\( <.*>\)?\r\n$gdb_prompt $" {
+ gdb_test "print *intap" "= \\(\\( 1, 1, 3(, 1){7}\\) \\( 1(, 1){9}\\) \\)"
+ pass $test_name
+ }
+}
+set test_name "print intvlap, associated"
+gdb_test_multiple "print intvlap" $test_name {
+ -re "= \\(2, 2, 2, 4(, 2){6}\\)\r\n$gdb_prompt $" {
+ pass $test_name
+ }
+ -re "= \\(PTR TO -> \\( $int \\(10\\)\\)\\) $hex\( <.*>\)?\r\n$gdb_prompt $" {
+ gdb_test "print *intvlap" "= \\(2, 2, 2, 4(, 2){6}\\)"
+ pass $test_name
+ }
+}
gdb_test "print realp" "= \\(PTR TO -> \\( $real \\)\\) $hex\( <.*>\)?"
gdb_test "print *realp" "= 3\\.14000\\d+"
+gdb_test "print arrayOfPtr(2)%p" "= \\(PTR TO -> \\( Type two \\)\\) $hex\( <.*>\)?"
+gdb_test "print *(arrayOfPtr(2)%p)" "= \\( \\(11, 12, 13\\), \\(\\( 211, 221\\) \\( 212, 222\\) \\) \\)"
+set test_name "print arrayOfPtr(3)%p"
+gdb_test_multiple $test_name $test_name {
+ -re "= <not associated>\r\n$gdb_prompt $" {
+ pass $test_name
+ }
+ -re "= \\(PTR TO -> \\( Type two \\)\\) 0x0\r\n$gdb_prompt $" {
+ pass $test_name
+ }
+}
+set test_name "print *(arrayOfPtr(3)%p), associated"
+gdb_test_multiple "print *(arrayOfPtr(3)%p)" $test_name {
+ -re "Location address is not set.\r\n$gdb_prompt $" {
+ pass $test_name
+ }
+ -re "Attempt to take contents of a not associated pointer.\r\n$gdb_prompt $" {
+ pass $test_name
+ }
+}
+gdb_test "print *((integer*) &inta + 2)" "= 3" "print temporary pointer, array"
+gdb_test "print *((integer*) &intvla + 3)" "= 4" "print temporary pointer, allocated vla"
+gdb_test "print \$pc" "= \\(PTR TO -> \\( void \\(\\)\\(\\)\\)\\) $hex <pointers\\+\\d+>" "Print program counter"
diff --git a/gdb/testsuite/gdb.fortran/pointers.f90 b/gdb/testsuite/gdb.fortran/pointers.f90
index 9ebbaa9..000193c 100644
--- a/gdb/testsuite/gdb.fortran/pointers.f90
+++ b/gdb/testsuite/gdb.fortran/pointers.f90
@@ -20,14 +20,20 @@ program pointers
integer, allocatable :: ivla2 (:, :)
end type two
+ type :: twoPtr
+ type (two), pointer :: p
+ end type twoPtr
+
logical, target :: logv
complex, target :: comv
character, target :: charv
character (len=3), target :: chara
integer, target :: intv
integer, target, dimension (10,2) :: inta
+ integer, target, allocatable, dimension (:) :: intvla
real, target :: realv
type(two), target :: twov
+ type(twoPtr) :: arrayOfPtr (3)
logical, pointer :: logp
complex, pointer :: comp
@@ -35,6 +41,7 @@ program pointers
character (len=3), pointer:: charap
integer, pointer :: intp
integer, pointer, dimension (:,:) :: intap
+ integer, pointer, dimension (:) :: intvlap
real, pointer :: realp
type(two), pointer :: twop
@@ -44,8 +51,12 @@ program pointers
nullify (charap)
nullify (intp)
nullify (intap)
+ nullify (intvlap)
nullify (realp)
nullify (twop)
+ nullify (arrayOfPtr(1)%p)
+ nullify (arrayOfPtr(2)%p)
+ nullify (arrayOfPtr(3)%p)
logp => logv ! Before pointer assignment
comp => comv
@@ -53,8 +64,10 @@ program pointers
charap => chara
intp => intv
intap => inta
+ intvlap => intvla
realp => realv
twop => twov
+ arrayOfPtr(2)%p => twov
logv = associated(logp) ! Before value assignment
comv = cmplx(1,2)
@@ -63,6 +76,10 @@ program pointers
intv = 10
inta(:,:) = 1
inta(3,1) = 3
+ allocate (intvla(10))
+ intvla(:) = 2
+ intvla(4) = 4
+ intvlap => intvla
realv = 3.14
allocate (twov%ivla1(3))
diff --git a/gdb/testsuite/gdb.fortran/print_type.exp b/gdb/testsuite/gdb.fortran/print_type.exp
index 37e19ec..1b23af3 100755
--- a/gdb/testsuite/gdb.fortran/print_type.exp
+++ b/gdb/testsuite/gdb.fortran/print_type.exp
@@ -62,6 +62,16 @@ gdb_test "ptype two" \
" $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"
diff --git a/gdb/valops.c b/gdb/valops.c
index 71fb1b3..5ef0c65 100644
--- a/gdb/valops.c
+++ b/gdb/valops.c
@@ -1554,6 +1554,9 @@ value_ind (struct value *arg1)
{
struct type *enc_type;
+ if (type_not_associated (base_type))
+ error (_("Attempt to take contents of a not associated pointer."));
+
/* We may be pointing to something embedded in a larger object.
Get the real type of the enclosing object. */
enc_type = check_typedef (value_enclosing_type (arg1));
--
2.7.1.339.g0233b80
^ permalink raw reply [flat|nested] 10+ messages in thread* [PATCH V2 5/5] Fortran: Handle cyclic pointers.
2016-07-04 9:52 [PATCH V2 0/5] Fortran: Resolve target types of pointers Bernhard Heckel
2016-07-04 9:52 ` [PATCH V2 2/5] Fortran: Testsuite, add print of pointer types Bernhard Heckel
2016-07-04 9:52 ` [PATCH V2 3/5] Fortran: Resolve dynamic target types of pointers Bernhard Heckel
@ 2016-07-04 9:52 ` Bernhard Heckel
2016-07-04 9:52 ` [PATCH V2 4/5] Fortran: Fix query of address of not-allocated types Bernhard Heckel
2016-07-04 9:52 ` [PATCH V2 1/5] Fortran: Typeprint, fix dangling types Bernhard Heckel
4 siblings, 0 replies; 10+ messages in thread
From: Bernhard Heckel @ 2016-07-04 9:52 UTC (permalink / raw)
To: qiyaoltc, eliz; +Cc: gdb-patches, Bernhard Heckel
In order to avoid endless resolving of pointers pointing to itself,
only the outermost level of dynamic types are resolved. We do this
already for reference types as well.
2016-05-25 Bernhard Heckel <bernhard.heckel@intel.com>
gdb/Changelog:
* gdbtypes.c (is_dynamic_type_internal): Resolve pointers only
at the outermost level.
gdb/testsuite/Changelog:
* pointers.f90: Add cylic pointers.
* pointers.exp: Add print of cyclic pointers.
---
gdb/gdbtypes.c | 17 ++++++++++++-----
gdb/testsuite/gdb.fortran/pointers.exp | 22 ++++++++++++++++++++++
gdb/testsuite/gdb.fortran/pointers.f90 | 12 ++++++++++++
3 files changed, 46 insertions(+), 5 deletions(-)
diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
index 76ae406..5c22ef0 100644
--- a/gdb/gdbtypes.c
+++ b/gdb/gdbtypes.c
@@ -2036,7 +2036,8 @@ resolve_dynamic_union (struct type *type,
static struct type *
resolve_dynamic_struct (struct type *type,
- struct property_addr_info *addr_stack)
+ struct property_addr_info *addr_stack,
+ int top_level)
{
struct type *resolved_type;
int i;
@@ -2081,7 +2082,7 @@ resolve_dynamic_struct (struct type *type,
TYPE_FIELD_TYPE (resolved_type, i)
= resolve_dynamic_type_internal (TYPE_FIELD_TYPE (resolved_type, i),
- &pinfo, 0);
+ &pinfo, top_level);
gdb_assert (TYPE_FIELD_LOC_KIND (resolved_type, i)
== FIELD_LOC_KIND_BITPOS);
@@ -2121,7 +2122,8 @@ resolve_dynamic_struct (struct type *type,
static struct type *
resolve_dynamic_pointer (struct type *type,
- struct property_addr_info *addr_stack)
+ struct property_addr_info *addr_stack,
+ int top_level)
{
struct property_addr_info pinfo;
int is_associated;
@@ -2167,6 +2169,11 @@ resolve_dynamic_pointer (struct type *type,
if (0 == is_associated)
return type;
+ /* To avoid endless resolving of cylic pointers, we only resolve the
+ outermost pointer type. */
+ if (!top_level)
+ return type;
+
pinfo.type = check_typedef (TYPE_TARGET_TYPE (type));
pinfo.valaddr = NULL;
/* Data location attr. refers to the "address of the variable".
@@ -2233,7 +2240,7 @@ resolve_dynamic_type_internal (struct type *type,
}
case TYPE_CODE_PTR:
- resolved_type = resolve_dynamic_pointer (type, addr_stack);
+ resolved_type = resolve_dynamic_pointer (type, addr_stack, top_level);
break;
case TYPE_CODE_ARRAY:
@@ -2249,7 +2256,7 @@ resolve_dynamic_type_internal (struct type *type,
break;
case TYPE_CODE_STRUCT:
- resolved_type = resolve_dynamic_struct (type, addr_stack);
+ resolved_type = resolve_dynamic_struct (type, addr_stack, top_level);
break;
}
}
diff --git a/gdb/testsuite/gdb.fortran/pointers.exp b/gdb/testsuite/gdb.fortran/pointers.exp
index df74743..0d2e4f6 100644
--- a/gdb/testsuite/gdb.fortran/pointers.exp
+++ b/gdb/testsuite/gdb.fortran/pointers.exp
@@ -57,6 +57,26 @@ gdb_test_multiple "print intap" $test {
gdb_test "print realp" "= \\(PTR TO -> \\( $real \\)\\) 0x0" "print realp, not associated"
gdb_test "print *realp" "Cannot access memory at address 0x0" "print *realp, not associated"
gdb_test "print \$my_var = intp" "= \\(PTR TO -> \\( $int \\)\\) 0x0"
+set test "print cyclicp1, not associated"
+gdb_test_multiple "print cyclicp1" $test {
+ -re "= \\( -?\\d+, 0x0 \\)\r\n$gdb_prompt $" {
+ pass $test
+ }
+ -re "= \\( -?\\d+, <not associated> \\)\r\n$gdb_prompt $" {
+ pass $test
+ }
+ timeout { fail "$test (timeout)" }
+}
+set test "print cyclicp1%p, not associated"
+gdb_test_multiple "print cyclicp1%p" $test {
+ -re "= \\(PTR TO -> \\( Type typewithpointer \\)\\) 0x0\r\n$gdb_prompt $" {
+ pass $test
+ }
+ -re "= <not associated>\r\n$gdb_prompt $" {
+ pass $test
+ }
+ timeout { fail "$test (timeout)" }
+}
gdb_breakpoint [gdb_get_line_number "Before value assignment"]
@@ -120,6 +140,8 @@ gdb_test_multiple "print *(arrayOfPtr(3)%p)" $test_name {
pass $test_name
}
}
+gdb_test "print cyclicp1" "= \\( 1, $hex\( <.*>\)? \\)"
+gdb_test "print cyclicp1%p" "= \\(PTR TO -> \\( Type typewithpointer \\)\\) $hex\( <.*>\)?"
gdb_test "print *((integer*) &inta + 2)" "= 3" "print temporary pointer, array"
gdb_test "print *((integer*) &intvla + 3)" "= 4" "print temporary pointer, allocated vla"
gdb_test "print \$pc" "= \\(PTR TO -> \\( void \\(\\)\\(\\)\\)\\) $hex <pointers\\+\\d+>" "Print program counter"
diff --git a/gdb/testsuite/gdb.fortran/pointers.f90 b/gdb/testsuite/gdb.fortran/pointers.f90
index 000193c..6240c87 100644
--- a/gdb/testsuite/gdb.fortran/pointers.f90
+++ b/gdb/testsuite/gdb.fortran/pointers.f90
@@ -20,6 +20,11 @@ program pointers
integer, allocatable :: ivla2 (:, :)
end type two
+ type :: typeWithPointer
+ integer i
+ type(typeWithPointer), pointer:: p
+ end type typeWithPointer
+
type :: twoPtr
type (two), pointer :: p
end type twoPtr
@@ -34,6 +39,7 @@ program pointers
real, target :: realv
type(two), target :: twov
type(twoPtr) :: arrayOfPtr (3)
+ type(typeWithPointer), target:: cyclicp1,cyclicp2
logical, pointer :: logp
complex, pointer :: comp
@@ -57,6 +63,8 @@ program pointers
nullify (arrayOfPtr(1)%p)
nullify (arrayOfPtr(2)%p)
nullify (arrayOfPtr(3)%p)
+ nullify (cyclicp1%p)
+ nullify (cyclicp2%p)
logp => logv ! Before pointer assignment
comp => comv
@@ -68,6 +76,10 @@ program pointers
realp => realv
twop => twov
arrayOfPtr(2)%p => twov
+ cyclicp1%i = 1
+ cyclicp1%p => cyclicp2
+ cyclicp2%i = 2
+ cyclicp2%p => cyclicp1
logv = associated(logp) ! Before value assignment
comv = cmplx(1,2)
--
2.7.1.339.g0233b80
^ permalink raw reply [flat|nested] 10+ messages in thread* [PATCH V2 1/5] Fortran: Typeprint, fix dangling types.
2016-07-04 9:52 [PATCH V2 0/5] Fortran: Resolve target types of pointers Bernhard Heckel
` (3 preceding siblings ...)
2016-07-04 9:52 ` [PATCH V2 4/5] Fortran: Fix query of address of not-allocated types Bernhard Heckel
@ 2016-07-04 9:52 ` Bernhard Heckel
4 siblings, 0 replies; 10+ messages in thread
From: Bernhard Heckel @ 2016-07-04 9:52 UTC (permalink / raw)
To: qiyaoltc, eliz; +Cc: gdb-patches, Bernhard Heckel
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 <bernhard.heckel@intel.com>
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.
---
gdb/f-typeprint.c | 95 +++++++++++++++++---------------
gdb/testsuite/gdb.fortran/pointers.f90 | 80 +++++++++++++++++++++++++++
gdb/testsuite/gdb.fortran/print_type.exp | 90 ++++++++++++++++++++++++++++++
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 | 12 ++--
7 files changed, 241 insertions(+), 59 deletions(-)
create mode 100644 gdb/testsuite/gdb.fortran/pointers.f90
create mode 100755 gdb/testsuite/gdb.fortran/print_type.exp
diff --git a/gdb/f-typeprint.c b/gdb/f-typeprint.c
index 920c21f..c9479a9 100644
--- a/gdb/f-typeprint.c
+++ b/gdb/f-typeprint.c
@@ -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, int);
void f_type_print_varspec_prefix (struct type *, struct ui_file *,
int, int);
@@ -54,18 +54,6 @@ 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')
@@ -87,7 +75,7 @@ f_print_type (struct type *type, const char *varstring, struct ui_file *stream,
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 @@ f_type_print_varspec_prefix (struct type *type, struct ui_file *stream,
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 @@ 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 = 1;
else if (type_not_allocated (type))
- val_print_not_allocated (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);
- }
+ 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
+ {
+ 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 @@ 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, 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 @@ 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, 0);
fputs_filtered ("\n", stream);
}
fprintfi_filtered (level, stream, "End Type ");
diff --git a/gdb/testsuite/gdb.fortran/pointers.f90 b/gdb/testsuite/gdb.fortran/pointers.f90
new file mode 100644
index 0000000..9ebbaa9
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/pointers.f90
@@ -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 <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
diff --git a/gdb/testsuite/gdb.fortran/print_type.exp b/gdb/testsuite/gdb.fortran/print_type.exp
new file mode 100755
index 0000000..37e19ec
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/print_type.exp
@@ -0,0 +1,90 @@
+# 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 <http://www.gnu.org/licenses/>.
+
+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 "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 \\)"
diff --git a/gdb/testsuite/gdb.fortran/vla-ptype.exp b/gdb/testsuite/gdb.fortran/vla-ptype.exp
index 175661f..aa5c64a 100644
--- a/gdb/testsuite/gdb.fortran/vla-ptype.exp
+++ b/gdb/testsuite/gdb.fortran/vla-ptype.exp
@@ -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 \\(:,:,:\\)" "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_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 \\(:,:,:\\)" "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 \\(:,:,:\\)" "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-type.exp b/gdb/testsuite/gdb.fortran/vla-type.exp
index 68884ce..dff49d1 100755
--- a/gdb/testsuite/gdb.fortran/vla-type.exp
+++ b/gdb/testsuite/gdb.fortran/vla-type.exp
@@ -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 \\(:\\)" ]
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 :: ivla\\(<not allocated>\\)" \
+ " $int :: ivla\\(:,:,:\\)" \
"End Type one" ] \
"ptype fivedynarr(2)%tone, not allocated"
diff --git a/gdb/testsuite/gdb.fortran/vla-value.exp b/gdb/testsuite/gdb.fortran/vla-value.exp
index 0945181..24f2a9f 100644
--- a/gdb/testsuite/gdb.fortran/vla-value.exp
+++ b/gdb/testsuite/gdb.fortran/vla-value.exp
@@ -30,7 +30,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\\\(kind=4\\\) \\\(<not allocated>\\\)\\\)\\\) $hex" \
+ " = \\\(PTR TO -> \\\( real\\\(kind=4\\\) \\\(:,:,:\\\)\\\)\\\) $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)"
@@ -71,7 +71,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\\\(kind=4\\\) \\\(<not associated>\\\)\\\)\\\) $hex" \
+ " = \\\(PTR TO -> \\\( real\\\(kind=4\\\) \\\(:,:,:\\\)\\\)\\\) $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)"
diff --git a/gdb/testsuite/gdb.mi/mi-vla-fortran.exp b/gdb/testsuite/gdb.mi/mi-vla-fortran.exp
index 333b71a..8ba59a3 100644
--- a/gdb/testsuite/gdb.mi/mi-vla-fortran.exp
+++ b/gdb/testsuite/gdb.mi/mi-vla-fortran.exp
@@ -17,6 +17,7 @@
# Array (VLA).
load_lib mi-support.exp
+load_lib fortran.exp
set MIFLAGS "-i=mi"
gdb_exit
@@ -32,6 +33,9 @@ if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${binfile}" executable \
return -1
}
+# Depending on the compiler being used, the type names can be printed differently.
+set real [fortran_real4]
+
mi_delete_breakpoints
mi_gdb_reinitialize_dir $srcdir/$subdir
mi_gdb_load ${binfile}
@@ -46,10 +50,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"
-mi_create_varobj_checked vla1_not_allocated vla1 "<not allocated>" \
+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=\"<not allocated>\"" \
+ "501\\^done,type=\"$real \\(:\\)\"" \
"info type variable vla1_not_allocated"
mi_gdb_test "502-var-show-format vla1_not_allocated" \
"502\\^done,format=\"natural\"" \
@@ -136,10 +140,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\"" \
--
2.7.1.339.g0233b80
^ permalink raw reply [flat|nested] 10+ messages in thread