re PR fortran/30888 (%VAL construct fails with argument procedures)

2007-02-28  Tobias Burnus  <burnus@net-b.de>
	    Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/30888
	PR fortran/30887
	* resolve.c (resolve_actual_arglist): Allow by-value
	arguments and non-default-kind for %VAL().
	* trans-expr.c (conv_arglist_function): Allow
	non-default-kind for %VAL().

testsuite/
2007-02-28  Tobias Burnus  <burnus@net-b.de>
	    Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/30888
	PR fortran/30887
	* c_by_val_1.f: Test %VAL() with non-default kind.
	* c_by_val.c: Ditto.
	* c_by_val_4.f: New test.


Co-Authored-By: Paul Thomas <pault@gcc.gnu.org>

From-SVN: r122409

7 files changed, 101 insertions, 41 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 32bf7e6..33fa9ad 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,4 +1,14 @@
 2007-02-28  Tobias Burnus  <burnus@net-b.de>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30888
+	PR fortran/30887
+	* resolve.c (resolve_actual_arglist): Allow by-value
+	arguments and non-default-kind for %VAL().
+	* trans-expr.c (conv_arglist_function): Allow
+	non-default-kind for %VAL().
+
+2007-02-28  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/30968
 	* primary.c (next_string_char): Correct reading a character
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index a66d1ae..987d73b 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1016,22 +1016,14 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
 		 since same file external procedures are not resolvable
 		 in gfortran, it is a good deal easier to leave them to
 		 intrinsic.c.  */
-	      if (ptype != PROC_UNKNOWN && ptype != PROC_EXTERNAL)
+	      if (ptype != PROC_UNKNOWN
+		  && ptype != PROC_DUMMY
+		  && ptype != PROC_EXTERNAL)
 		{
 		  gfc_error ("By-value argument at %L is not allowed "
 			     "in this context", &e->where);
 		  return FAILURE;
 		}
-
-	      if (((e->ts.type == BT_REAL || e->ts.type == BT_COMPLEX)
-		   && e->ts.kind > gfc_default_real_kind)
-		  || (e->ts.kind > gfc_default_integer_kind))
-		{
-		  gfc_error ("Kind of by-value argument at %L is larger "
-			     "than default kind", &e->where);
-		  return FAILURE;
-		}
-
 	    }
 
 	  /* Statement functions have already been excluded above.  */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 839d768..b6c132b 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1934,40 +1934,12 @@ is_aliased_array (gfc_expr * e)
 static void
 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
 {
-  tree type = NULL_TREE;
   /* Pass by value for g77 %VAL(arg), pass the address
      indirectly for %LOC, else by reference.  Thus %REF
      is a "do-nothing" and %LOC is the same as an F95
      pointer.  */
   if (strncmp (name, "%VAL", 4) == 0)
-    {
-      gfc_conv_expr (se, expr);
-      /* %VAL converts argument to default kind.  */
-      switch (expr->ts.type)
-	{
-	  case BT_REAL:
-	    type = gfc_get_real_type (gfc_default_real_kind);
-	    se->expr = fold_convert (type, se->expr);
-	    break;
-	  case BT_COMPLEX:
-	    type = gfc_get_complex_type (gfc_default_complex_kind);
-	    se->expr = fold_convert (type, se->expr);
-	    break;
-	  case BT_INTEGER:
-	    type = gfc_get_int_type (gfc_default_integer_kind);
-	    se->expr = fold_convert (type, se->expr);
-	    break;
-	  case BT_LOGICAL:
-	    type = gfc_get_logical_type (gfc_default_logical_kind);
-	    se->expr = fold_convert (type, se->expr);
-	    break;
-	  /* This should have been resolved away.  */
-	  case BT_UNKNOWN: case BT_CHARACTER: case BT_DERIVED:
-	  case BT_PROCEDURE: case BT_HOLLERITH:
-	    gfc_internal_error ("Bad type in conv_arglist_function");
-	}
-	  
-    }
+    gfc_conv_expr (se, expr);
   else if (strncmp (name, "%LOC", 4) == 0)
     {
       gfc_conv_expr_reference (se, expr);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 1261449..d5d09bb 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,4 +1,13 @@
 2007-02-28  Tobias Burnus  <burnus@net-b.de>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/30888
+	PR fortran/30887
+	* c_by_val_1.f: Test %VAL() with non-default kind.
+	* c_by_val.c: Ditto.
+	* c_by_val_4.f: New test.
+
+2007-02-28  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/30968
 	* gfortran.dg/continuation_7.f90: New test.
diff --git a/gcc/testsuite/gfortran.dg/c_by_val.c b/gcc/testsuite/gfortran.dg/c_by_val.c
index daba6d2..75bec1d 100644
--- a/gcc/testsuite/gfortran.dg/c_by_val.c
+++ b/gcc/testsuite/gfortran.dg/c_by_val.c
@@ -1,9 +1,13 @@
 /*  Passing from fortran to C by value, using %VAL.  */
 
 typedef struct { float r, i; } complex;
+typedef struct { double r, i; } complex8;
 extern void f_to_f__ (float*, float, float*, float**);
+extern void f_to_f8__ (double*, double, double*, double**);
 extern void i_to_i__ (int*, int, int*, int**);
+extern void i_to_i8__ (long*, long, long*, long**);
 extern void c_to_c__ (complex*, complex, complex*, complex**);
+extern void c_to_c8__ (complex8*, complex8, complex8*, complex8**);
 extern void abort (void);
 
 void
@@ -17,6 +21,16 @@ f_to_f__(float *retval, float a1, float *a2, float **a3)
 }
 
 void
+f_to_f8__(double *retval, double a1, double *a2, double **a3)
+{
+  if ( a1 != *a2 ) abort();
+  if ( a1 != **a3 ) abort();
+  a1 = 0.0;
+  *retval = *a2 * 2.0;
+  return;
+}
+
+void
 i_to_i__(int *retval, int i1, int *i2, int **i3)
 {
   if ( i1 != *i2 ) abort();
@@ -27,6 +41,16 @@ i_to_i__(int *retval, int i1, int *i2, int **i3)
 }
 
 void
+i_to_i8__(long *retval, long i1, long *i2, long **i3)
+{
+  if ( i1 != *i2 ) abort();
+  if ( i1 != **i3 ) abort();
+  i1 = 0;
+  *retval = *i2 * 3;
+  return;
+}
+
+void
 c_to_c__(complex *retval, complex c1, complex *c2, complex **c3)
 {
   if ( c1.r != c2->r ) abort();
@@ -39,3 +63,17 @@ c_to_c__(complex *retval, complex c1, complex *c2, complex **c3)
   retval->i = c2->i * 4.0;
   return;
 }
+
+void
+c_to_c8__(complex8 *retval, complex8 c1, complex8 *c2, complex8 **c3)
+{
+  if ( c1.r != c2->r ) abort();
+  if ( c1.i != c2->i ) abort();
+  if ( c1.r != (*c3)->r ) abort();
+  if ( c1.i != (*c3)->i ) abort();
+  c1.r = 0.0;
+  c1.i = 0.0;
+  retval->r = c2->r * 4.0;
+  retval->i = c2->i * 4.0;
+  return;
+}
diff --git a/gcc/testsuite/gfortran.dg/c_by_val_1.f b/gcc/testsuite/gfortran.dg/c_by_val_1.f
index 133cc55..af1e25a 100644
--- a/gcc/testsuite/gfortran.dg/c_by_val_1.f
+++ b/gcc/testsuite/gfortran.dg/c_by_val_1.f
@@ -4,9 +4,13 @@ C { dg-options "-ff2c -w -O0" }
 
       program c_by_val_1
       external   f_to_f, i_to_i, c_to_c
+      external   f_to_f8, i_to_i8, c_to_c8
       real       a, b, c
-      integer*4  i, j, k
+      real(8)    a8, b8, c8
+      integer(4) i, j, k
+      integer(8) i8, j8, k8
       complex    u, v, w, c_to_c
+      complex(8) u8, v8, w8, c_to_c8
 
       a = 42.0
       b = 0.0
@@ -14,18 +18,36 @@ C { dg-options "-ff2c -w -O0" }
       call  f_to_f (b, %VAL (a), %REF (c), %LOC (c))
       if ((2.0 * a).ne.b) call abort ()
 
+      a8 = 43.0
+      b8 = 1.0
+      c8 = a8
+      call  f_to_f8 (b8, %VAL (a8), %REF (c8), %LOC (c8))
+      if ((2.0 * a8).ne.b8) call abort ()
+
       i = 99
       j = 0
       k = i
       call i_to_i (j, %VAL (i), %REF (k), %LOC (k))
       if ((3 * i).ne.j) call abort ()
 
+      i8 = 199
+      j8 = 10
+      k8 = i8
+      call i_to_i8 (j8, %VAL (i8), %REF (k8), %LOC (k8))
+      if ((3 * i8).ne.j8) call abort ()
+
       u = (-1.0, 2.0)
       v = (1.0, -2.0)
       w = u
       v = c_to_c (%VAL (u), %REF (w), %LOC (w))
       if ((4.0 * u).ne.v) call abort ()
 
+      u8 = (-1.0, 2.0)
+      v8 = (1.0, -2.0)
+      w8 = u8
+      v8 = c_to_c8 (%VAL (u8), %REF (w8), %LOC (w8))
+      if ((4.0 * u8).ne.v8) call abort ()
+
       stop
       end
 
diff --git a/gcc/testsuite/gfortran.dg/c_by_val_4.f b/gcc/testsuite/gfortran.dg/c_by_val_4.f
new file mode 100644
index 0000000..c8f4b04
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_by_val_4.f
@@ -0,0 +1,17 @@
+C { dg-do compile }
+C Tests the fix for PR30888, in which the dummy procedure would
+C generate an error with the %VAL argument, even though it is
+C declared EXTERNAL.
+C
+C Contributed by Peter W. Draper <p.w.draper@durham.ac.uk>
+C
+      SUBROUTINE VALTEST( DOIT )
+      EXTERNAL DOIT
+      INTEGER P
+      INTEGER I
+      I = 0
+      P = 0
+      CALL DOIT( %VAL( P ) ) ! { dg-warning "Extension: argument list function" }
+      CALL DOIT( I )
+      CALL DOIT( %VAL( P ) ) ! { dg-warning "Extension: argument list function" }
+      END