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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@122409 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 32bf7e6..33fa9ad 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,4 +1,14 @@
 2007-02-28  Tobias Burnus  <burnus@net-b.de>
 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
 
        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 (file)
--- 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.  */
                 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;
                }
                {
                  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.  */
            }
 
          /* 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 (file)
--- 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)
 {
 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)
   /* 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);
   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 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,4 +1,13 @@
 2007-02-28  Tobias Burnus  <burnus@net-b.de>
 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.
 
        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 (file)
--- 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;
 /*  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_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_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_c__ (complex*, complex, complex*, complex**);

+extern void c_to_c8__ (complex8*, complex8, complex8*, complex8**);

 extern void abort (void);
 
 void
 extern void abort (void);
 
 void


@@ -17,6 +21,16 @@ f_to_f__(float *retval, float a1, float *a2, float **a3)
 }
 
 void
 }
 
 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();
 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
 }
 
 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();
 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;
 }
   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 (file)
--- 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
 
       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
       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    u, v, w, c_to_c

+      complex(8) u8, v8, w8, c_to_c8

 
       a = 42.0
       b = 0.0
 
       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 ()
 
       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 ()
 
       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 ()
 
       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
 
       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 (file)
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