[11/11] Fortran dynamic arrays support: Fortran array testcase

[Jan Kratochvil <jan dot kratochvil at redhat dot com>]

Hi,

and a testcase for the Fortran dynamic arrays.

It requires the already patched gcc-4.3 to PASS.

Also found out GDB testsuite (or rather dejagnu) never find gcc-4.x gfortran as
it is no longer called `g77'.  One can workaround it by:
	ln -s `which gfortran` g77

I assume it is a dejagnu bug and its `find_g77' should find even `gfortran'.


Regards,
Jan

2007-11-16  Jan Kratochvil  <jan.kratochvil@redhat.com>

	* gdb.fortran/dynamic.exp, gdb.fortran/dynamic.f90: New files.

Index: gdb/testsuite/gdb.fortran/dynamic.exp
===================================================================
RCS file: gdb/testsuite/gdb.fortran/dynamic.exp
diff -N gdb/testsuite/gdb.fortran/dynamic.exp
--- .//dev/null	1 Jan 1970 00:00:00 -0000
+++ ./gdb/testsuite/gdb.fortran/dynamic.exp	15 Nov 2007 16:59:49 -0000
@@ -0,0 +1,136 @@
+# Copyright 2007 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.  
+
+# This file was written by Jan Kratochvil <jan.kratochvil@redhat.com>.
+
+# This file is part of the gdb testsuite.  It contains tests for dynamically
+# allocated Fortran arrays.
+# It depends on the GCC dynamic Fortran arrays DWARF support:
+# 	http://gcc.gnu.org/bugzilla/show_bug.cgi?id=22244
+
+if $tracelevel then {
+	strace $tracelevel
+}
+
+set testfile "dynamic"
+set srcfile ${testfile}.f90
+set binfile ${objdir}/${subdir}/${testfile}
+
+if  { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${binfile}" executable {debug f77 quiet}] != "" } {
+    untested "Couldn't compile ${srcfile}"
+    return -1
+}
+
+gdb_exit
+gdb_start
+gdb_reinitialize_dir $srcdir/$subdir
+gdb_load ${binfile}
+
+if ![runto MAIN__] then {
+    perror "couldn't run to breakpoint MAIN__"
+    continue
+}
+
+gdb_breakpoint [gdb_get_line_number "varx-init"]
+gdb_continue_to_breakpoint "varx-init"
+gdb_test "p varx" "\\$\[0-9\]* = <the array is not allocated>"
+gdb_test "ptype varx" "type = <the array is not allocated>"
+gdb_test "p varx(1,5,17)" "Unable to access the object because the array is not allocated\\."
+gdb_test "p varx(1,5,17)=1" "Unable to access the object because the array is not allocated\\."
+gdb_test "ptype varx(1,5,17)" "Unable to access the object because the array is not allocated\\."
+
+gdb_breakpoint [gdb_get_line_number "varx-allocated"]
+gdb_continue_to_breakpoint "varx-allocated"
+# $1 = (( ( 0, 0, 0, 0, 0, 0) ( 0, 0, 0, 0, 0, 0) --- , 0) ) ( ( 0, 0, ...) ...) ...)
+gdb_test "p varx" "\\$\[0-9\]* = \\(\[()0, .\]*\\)"
+gdb_test "ptype varx" "type = real\\*4 \\(6,5:15,17:28\\)"
+gdb_test "p l" "\\$\[0-9\]* = \\.TRUE\\."
+
+gdb_breakpoint [gdb_get_line_number "varx-filled"]
+gdb_continue_to_breakpoint "varx-filled"
+gdb_test "p varx(2, 5, 17)" "\\$\[0-9\]* = 6"
+gdb_test "p varx(1, 5, 17)" "\\$\[0-9\]* = 7"
+gdb_test "p varx(2, 6, 18)" "\\$\[0-9\]* = 8"
+gdb_test "p varx(6, 15, 28)" "\\$\[0-9\]* = 9"
+gdb_test "p varv" "\\$\[0-9\]* = <the array is not associated>"
+gdb_test "ptype varv" "type = <the array is not associated>"
+
+gdb_breakpoint [gdb_get_line_number "varv-associated"]
+gdb_continue_to_breakpoint "varv-associated"
+gdb_test "p varx(3, 7, 19)" "\\$\[0-9\]* = 6"
+gdb_test "p varv(3, 7, 19)" "\\$\[0-9\]* = 6"
+gdb_test "p l" "\\$\[0-9\]* = \\.TRUE\\."
+gdb_test "ptype varx" "type = real\\*4 \\(6,5:15,17:28\\)"
+gdb_test "ptype varv" "type = real\\*4 \\(6,5:15,17:28\\)"
+
+gdb_breakpoint [gdb_get_line_number "varv-filled"]
+gdb_continue_to_breakpoint "varv-filled"
+gdb_test "p varx(3, 7, 19)" "\\$\[0-9\]* = 10"
+gdb_test "p varv(3, 7, 19)" "\\$\[0-9\]* = 10"
+
+gdb_breakpoint [gdb_get_line_number "varv-deassociated"]
+gdb_continue_to_breakpoint "varv-deassociated"
+gdb_test "p varv" "\\$\[0-9\]* = <the array is not associated>"
+gdb_test "ptype varv" "type = <the array is not associated>"
+gdb_test "p l" "\\$\[0-9\]* = \\.FALSE\\."
+gdb_test "p varv(1,5,17)" "Unable to access the object because the array is not associated\\."
+gdb_test "ptype varv(1,5,17)" "Unable to access the object because the array is not associated\\."
+
+gdb_breakpoint [gdb_get_line_number "varx-deallocated"]
+gdb_continue_to_breakpoint "varx-deallocated"
+gdb_test "p varx" "\\$\[0-9\]* = <the array is not allocated>"
+gdb_test "ptype varx" "type = <the array is not allocated>"
+gdb_test "p l" "\\$\[0-9\]* = \\.FALSE\\."
+gdb_test "p varx(1,5,17)" "Unable to access the object because the array is not allocated\\."
+gdb_test "ptype varx(1,5,17)" "Unable to access the object because the array is not allocated\\."
+
+gdb_breakpoint [gdb_get_line_number "vary-passed"]
+gdb_continue_to_breakpoint "vary-passed"
+# $1 = (( ( 1, 1, 1, 1, 1, 1) ( 1, 1, 1, 1, 1, 1) --- , 1) ) ( ( 1, 1, ...) ...) ...)
+gdb_test "p vary" "\\$\[0-9\]* = \\(\[()1, .\]*\\)"
+
+gdb_breakpoint [gdb_get_line_number "vary-filled"]
+gdb_continue_to_breakpoint "vary-filled"
+gdb_test "ptype vary" "type = real\\*4 \\(10,10\\)"
+gdb_test "p vary(1, 1)" "\\$\[0-9\]* = 8"
+gdb_test "p vary(2, 2)" "\\$\[0-9\]* = 9"
+gdb_test "p vary(1, 3)" "\\$\[0-9\]* = 10"
+# $1 = (( ( 3, 3, 3, 3, 3, 3) ( 3, 3, 3, 3, 3, 3) --- , 3) ) ( ( 3, 3, ...) ...) ...)
+gdb_test "p varw" "\\$\[0-9\]* = \\(\[()3, .\]*\\)"
+
+gdb_breakpoint [gdb_get_line_number "varw-almostfilled"]
+gdb_continue_to_breakpoint "varw-almostfilled"
+gdb_test "ptype varw" "type = real\\*4 \\(5,4,3\\)"
+gdb_test "p varw(3,1,1)=1" "\\$\[0-9\]* = 1"
+# $1 = (( ( 6, 5, 1, 5, 5, 5) ( 5, 5, 5, 5, 5, 5) --- , 5) ) ( ( 5, 5, ...) ...) ...)
+gdb_test "p varw" "\\$\[0-9\]* = \\( *\\( *\\( *6, *5, *1,\[()5, .\]*\\)"
+gdb_test "up" ".*call foo \\(x, z\\(2:6, 4:7, 6:8\\)\\)"
+gdb_test "p z(2,4,5)" "\\$\[0-9\]* = 3"
+gdb_test "p z(2,4,6)" "\\$\[0-9\]* = 6"
+gdb_test "p z(2,4,7)" "\\$\[0-9\]* = 5"
+gdb_test "p z(4,4,6)" "\\$\[0-9\]* = 1"
+
+gdb_breakpoint [gdb_get_line_number "varz-almostfilled"]
+gdb_continue_to_breakpoint "varz-almostfilled"
+gdb_test "ptype varz" "type = PTR TO -> \\( real\\*4 \\(\\*\\)\\)"
+gdb_test "ptype vart" "type = PTR TO -> \\( real\\*4 \\(2:11,7:\\*\\)\\)"
+gdb_test "p varz(3)" "\\$\[0-9\]* = 4"
+# maps to foo::vary(1,1)
+gdb_test "p vart(2,7)" "\\$\[0-9\]* = 8"
+# maps to foo::vary(2,2)
+gdb_test "p vart(3,8)" "\\$\[0-9\]* = 9"
+# maps to foo::vary(1,3)
+gdb_test "p vart(2,9)" "\\$\[0-9\]* = 10"
Index: gdb/testsuite/gdb.fortran/dynamic.f90
===================================================================
RCS file: gdb/testsuite/gdb.fortran/dynamic.f90
diff -N gdb/testsuite/gdb.fortran/dynamic.f90
--- .//dev/null	1 Jan 1970 00:00:00 -0000
+++ ./gdb/testsuite/gdb.fortran/dynamic.f90	15 Nov 2007 16:59:49 -0000
@@ -0,0 +1,97 @@
+! Copyright 2007 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.
+!
+! Ihis file is the Fortran source file for dynamic.exp.
+! Original file written by Jakub Jelinek <jakub@redhat.com>.
+! Modified for the GDB testcase by Jan Kratochvil <jan.kratochvil@redhat.com>.
+
+subroutine baz
+  real, target, allocatable :: varx (:, :, :)
+  real, pointer :: varv (:, :, :)
+  real, target :: varu (1, 2, 3)
+  logical :: l
+  allocate (varx (1:6, 5:15, 17:28))		! varx-init
+  l = allocated (varx)
+  varx(:, :, :) = 6				! varx-allocated
+  varx(1, 5, 17) = 7
+  varx(2, 6, 18) = 8
+  varx(6, 15, 28) = 9
+  varv => varx					! varx-filled
+  l = associated (varv)
+  varv(3, 7, 19) = 10				! varv-associated
+  varv => null ()				! varv-filled
+  l = associated (varv)
+  deallocate (varx)				! varv-deassociated
+  l = allocated (varx)
+  varu(:, :, :) = 10				! varx-deallocated
+  allocate (varv (1:6, 5:15, 17:28))
+  l = associated (varv)
+  varv(:, :, :) = 6
+  varv(1, 5, 17) = 7
+  varv(2, 6, 18) = 8
+  varv(6, 15, 28) = 9
+  deallocate (varv)
+  l = associated (varv)
+  varv => varu
+  varv(1, 1, 1) = 6
+  varv(1, 2, 3) = 7
+  l = associated (varv)
+end subroutine baz
+subroutine foo (vary, varw)
+  real :: vary (:, :)
+  real :: varw (:, :, :)
+  vary(:, :) = 4				! vary-passed
+  vary(1, 1) = 8
+  vary(2, 2) = 9
+  vary(1, 3) = 10
+  varw(:, :, :) = 5				! vary-filled
+  varw(1, 1, 1) = 6
+  varw(2, 2, 2) = 7				! varw-almostfilled
+end subroutine foo
+subroutine bar (varz, vart)
+  real :: varz (*)
+  real :: vart (2:11, 7:*)
+  varz(1:3) = 4
+  varz(2) = 5					! varz-almostfilled
+end subroutine bar
+program test
+  interface
+    subroutine foo (vary, varw)
+    real :: vary (:, :)
+    real :: varw (:, :, :)
+    end subroutine
+  end interface
+  interface
+    subroutine bar (varz, vart)
+    real :: varz (*)
+    real :: vart (2:11, 7:*)
+    end subroutine
+  end interface
+  real :: x (10, 10), y (5), z(8, 8, 8)
+  x(:,:) = 1
+  y(:) = 2
+  z(:,:,:) = 3
+  call baz
+  call foo (x, z(2:6, 4:7, 6:8))
+  call bar (y, x)
+  if (x (1, 1) .ne. 8 .or. x (2, 2) .ne. 9 .or. x (1, 2) .ne. 4) call abort
+  if (x (1, 3) .ne. 10) call abort
+  if (z (2, 4, 6) .ne. 6 .or. z (3, 5, 7) .ne. 7 .or. z (2, 4, 7) .ne. 5) call abort
+  if (any (y .ne. (/4, 5, 4, 2, 2/))) call abort
+  call foo (transpose (x), z)
+  if (x (1, 1) .ne. 8 .or. x (2, 2) .ne. 9 .or. x (1, 2) .ne. 4) call abort
+  if (x (3, 1) .ne. 10) call abort
+end