OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Tobias Burnus 2007-02-28 19:17:34 +01:00 committed by Tobias Burnus
parent c2615f3031
commit 7193e30a4d
7 changed files with 101 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
gcc/fortran/ChangeLog
View File

@ -1,3 +1,13 @@
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

14
gcc/fortran/resolve.c
View File

@ -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. */

30
gcc/fortran/trans-expr.c
View File

@ -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);

9
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,12 @@
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

38
gcc/testsuite/gfortran.dg/c_by_val.c
View File

@ -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
@ -16,6 +20,16 @@ f_to_f__(float *retval, float a1, float *a2, float **a3)
return;
}
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)
{
@ -26,6 +40,16 @@ i_to_i__(int *retval, int i1, int *i2, int **i3)
return;
}
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)
{
@ -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;
}

24
gcc/testsuite/gfortran.dg/c_by_val_1.f
View File

@ -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

17
gcc/testsuite/gfortran.dg/c_by_val_4.f Normal file
View File

@ -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