re PR fortran/31668 (%VAL rejected for PROC_MODULE and PROC_INTERNAL procedures)

fortran/
2007-04-25  Tobias Burnus  <burnus@net-b.de>

	PR fortran/31668
	* error.c (error_print): Fix %% support.
	* intrinsic.c (sort_actual): Improve error message.
	* resolve.c (resolve_actual_arglist): Allow %VAL for
	interfaces defined in the module declaration part.

testsuite/
2007-04-25  Tobias Burnus  <burnus@net-b.de>

	PR fortran/31668
	* gfortran.dg/c_by_val_2.f90: Add rejection test of %VAL with
	statement functions.
	* gfortran.dg/c_by_val_5.f90: New test.

From-SVN: r124147

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 4d880d8..32affbe 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2007-04-25  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/31668
+       * error.c (error_print): Fix %% support.
+       * intrinsic.c (sort_actual): Improve error message.
+       * resolve.c (resolve_actual_arglist): Allow %VAL for
+       interfaces defined in the module declaration part.
+
 2007-04-25  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
        PR libfortran/31299

diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c
index 7348847..241c6a4 100644 (file)
--- a/gcc/fortran/error.c
+++ b/gcc/fortran/error.c
@@ -414,7 +414,10 @@ error_print (const char *type, const char *format0, va_list argp)
        continue;
 
       if (*format == '%')
-       continue;
+       {
+         format++;
+         continue;
+       }
 
       if (ISDIGIT (*format))
        {

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 2210dc2..d77cf55 100644 (file)
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -2861,8 +2861,8 @@ keywords:
       if (f == NULL)
        {
          if (a->name[0] == '%')
-           gfc_error ("Argument list function at %L is not allowed in this "
-                      "context", where);
+           gfc_error ("The argument list functions %%VAL, %%LOC or %%REF "
+                      "are not allowed in this context at %L", where);
          else
            gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
                       a->name, name, where);

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index c759f69..55f1390 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1040,7 +1040,8 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
                 intrinsic.c.  */
              if (ptype != PROC_UNKNOWN
                  && ptype != PROC_DUMMY
-                 && ptype != PROC_EXTERNAL)
+                 && ptype != PROC_EXTERNAL
+                 && ptype != PROC_MODULE)
                {
                  gfc_error ("By-value argument at %L is not allowed "
                             "in this context", &e->where);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 52629ab..0722463 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2007-04-25  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/31668
+       * gfortran.dg/c_by_val_2.f90: Add rejection test of %VAL with
+       statement functions.
+       * gfortran.dg/c_by_val_5.f90: New test.
+
 2007-04-25  Wolfgang Gellerich  <gellerich@de.ibm.com>
 
        * gfortran.dg/equiv_6.f90 (set_arrays): Replaced subroutine
@@ -23,19 +30,19 @@
 
 2007-04-24  Douglas Gregor  <doug.gregor@gmail.com>
 
-       * g++.old-deja/g++.pt/defarg6.C: Only run with
-       -std=gnu++98.
-       * g++.old-deja/g++.pt/ucnid-1.C: Ditto.
-       * g++.dg/cpp0x/variadic61.C: Ditto.
-       * g++.dg/cpp0x/warn_cxx0x.C: Ditto.
-       * g++.dg/cpp0x/variadic62.C: Ditto.
-       * g++.dg/template/meminit1.C: Ditto.
-       * g++.dg/template/operator7.C: Ditto.
-       * g++.dg/template/static15.C: Ditto.
-       * g++.dg/template/invalid1.C: Ditto.
-       * g++.dg/template/shift1.C: Ditto.
-       * g++.dg/template/error10.C: Ditto.
-       
+       * g++.old-deja/g++.pt/defarg6.C: Only run with
+       -std=gnu++98.
+       * g++.old-deja/g++.pt/ucnid-1.C: Ditto.
+       * g++.dg/cpp0x/variadic61.C: Ditto.
+       * g++.dg/cpp0x/warn_cxx0x.C: Ditto.
+       * g++.dg/cpp0x/variadic62.C: Ditto.
+       * g++.dg/template/meminit1.C: Ditto.
+       * g++.dg/template/operator7.C: Ditto.
+       * g++.dg/template/static15.C: Ditto.
+       * g++.dg/template/invalid1.C: Ditto.
+       * g++.dg/template/shift1.C: Ditto.
+       * g++.dg/template/error10.C: Ditto.
+
 2007-04-24  Simon Martin  <simartin@users.sourceforge.net>
 
        PR diagnostic/25923
@@ -134,7 +141,7 @@
 
 2007-04-22  Revital Eres  <eres@il.ibm.com>
 
-        * gcc.dg/var-expand2.c: New test.
+       * gcc.dg/var-expand2.c: New test.
 
 2007-04-22  Revital Eres  <eres@il.ibm.com>
 

diff --git a/gcc/testsuite/gfortran.dg/c_by_val_2.f90 b/gcc/testsuite/gfortran.dg/c_by_val_2.f90
index 6aadd98..5d638cb 100644 (file)
--- a/gcc/testsuite/gfortran.dg/c_by_val_2.f90
+++ b/gcc/testsuite/gfortran.dg/c_by_val_2.f90
@@ -9,6 +9,11 @@ program c_by_val_2
   end type mytype
   type(mytype)  :: z
   character(8)  :: c = "blooey"
+  real :: stmfun, x
+  stmfun(x)=x**2
+
+  x = 5
+  print *, stmfun(%VAL(x))   ! { dg-error "not allowed in this context" }
   print *, sin (%VAL(2.0))   ! { dg-error "not allowed in this context" }
   print *, foo (%VAL(1.0))   ! { dg-error "not allowed in this context" }
   call  foobar (%VAL(0.5))   ! { dg-error "not allowed in this context" }

diff --git a/gcc/testsuite/gfortran.dg/c_by_val_5.f90 b/gcc/testsuite/gfortran.dg/c_by_val_5.f90
new file mode 100644 (file)
index 0000000..90ef299
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_by_val_5.f90
@@ -0,0 +1,69 @@
+! { dg-do run }
+! Overwrite -pedantic setting:
+! { dg-options "-Wall" }
+!
+! Tests the fix for PR31668, in which %VAL was rejected for
+! module and internal procedures.
+! 
+
+subroutine bmp_write(nx)
+  implicit none
+  integer, value :: nx
+  if(nx /= 10) call abort()
+  nx = 11
+  if(nx /= 11) call abort()
+end subroutine bmp_write
+
+module x
+ implicit none
+ ! The following interface does in principle
+ ! not match the procedure (missing VALUE attribute)
+ ! However, this occures in real-world code calling
+ ! C routines where an interface is better than
+ ! "external" only.
+ interface
+   subroutine bmp_write(nx)
+     integer :: nx
+   end subroutine bmp_write
+ end interface
+contains
+   SUBROUTINE Grid2BMP(NX)
+     INTEGER, INTENT(IN) :: NX
+     if(nx /= 10) call abort()
+     call bmp_write(%val(nx))
+     if(nx /= 10) call abort()
+   END SUBROUTINE Grid2BMP
+END module x
+
+! The following test is possible and
+! accepted by other compilers, but
+! does not make much sense.
+! Either one uses VALUE then %VAL is
+! not needed or the function will give
+! wrong results.
+!
+!subroutine test()
+!    implicit none
+!    integer :: n
+!    n = 5
+!    if(n /= 5) call abort()
+!    call test2(%VAL(n))
+!    if(n /= 5) call abort()
+!  contains
+!    subroutine test2(a)
+!      integer, value :: a
+!      if(a /= 5) call abort()
+!      a = 2
+!      if(a /= 2) call abort()
+!    end subroutine test2
+!end subroutine test
+
+program main
+  use x
+  implicit none
+!  external test
+  call Grid2BMP(10)
+!  call test()
+end program main
+
+! { dg-final { cleanup-modules "x" } }