From 7193e30a4d1067cd466840228e24202dc3d0db03 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Wed, 28 Feb 2007 19:17:34 +0100 Subject: [PATCH] re PR fortran/30888 (%VAL construct fails with argument procedures) 2007-02-28 Tobias Burnus Paul Thomas 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 Paul Thomas 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 From-SVN: r122409 --- gcc/fortran/ChangeLog | 10 +++++++ gcc/fortran/resolve.c | 14 ++-------- gcc/fortran/trans-expr.c | 30 +------------------- gcc/testsuite/ChangeLog | 9 ++++++ gcc/testsuite/gfortran.dg/c_by_val.c | 38 ++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/c_by_val_1.f | 24 +++++++++++++++- gcc/testsuite/gfortran.dg/c_by_val_4.f | 17 ++++++++++++ 7 files changed, 101 insertions(+), 41 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/c_by_val_4.f diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 32bf7e63da58..33fa9ad749ef 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2007-02-28 Tobias Burnus + Paul Thomas + + 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 PR fortran/30968 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index a66d1ae98070..987d73b2fb14 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 839d768318e7..b6c132bc160c 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 1261449aa727..d5d09bb95815 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2007-02-28 Tobias Burnus + Paul Thomas + + 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 PR fortran/30968 diff --git a/gcc/testsuite/gfortran.dg/c_by_val.c b/gcc/testsuite/gfortran.dg/c_by_val.c index daba6d2c52dc..75bec1d89eab 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 @@ -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; +} diff --git a/gcc/testsuite/gfortran.dg/c_by_val_1.f b/gcc/testsuite/gfortran.dg/c_by_val_1.f index 133cc55e173d..af1e25a6b88a 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 000000000000..c8f4b0484dd7 --- /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 +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 -- 2.47.2