This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [Patch, fortran] PR30887 and PR30888 - overdone constraints on %VAL
*ping*
Fixes:
- %VAL( ) with non-default kinds now supported
- The following program gave a compile-time error:
+ CALL DOIT( %VAL( P ) )
+ CALL DOIT( I )
+ CALL DOIT( %VAL( P ) )
Tobias Burnus wrote:
> Paul Thomas wrote:
>
>> The attached are completely self explanatory fixes for the above to
>> %VAL problems.
>>
> [...]
> regtested on x86_64-unknown-linux-gnu.
>
> ------------------------------------------------------------------------
>
> 2007-02-22 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-22 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.
>
> Index: gcc/testsuite/gfortran.dg/c_by_val_1.f
> ===================================================================
> --- gcc/testsuite/gfortran.dg/c_by_val_1.f (Revision 122226)
> +++ gcc/testsuite/gfortran.dg/c_by_val_1.f (Arbeitskopie)
> @@ -4,9 +4,13 @@
>
> 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 @@
> 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
>
> Index: gcc/testsuite/gfortran.dg/c_by_val_4.f
> ===================================================================
> --- gcc/testsuite/gfortran.dg/c_by_val_4.f (Revision 0)
> +++ gcc/testsuite/gfortran.dg/c_by_val_4.f (Revision 0)
> @@ -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
> Index: gcc/testsuite/gfortran.dg/c_by_val.c
> ===================================================================
> --- gcc/testsuite/gfortran.dg/c_by_val.c (Revision 122226)
> +++ gcc/testsuite/gfortran.dg/c_by_val.c (Arbeitskopie)
> @@ -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 @@
> }
>
> 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 @@
> }
>
> 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 @@
> 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;
> +}
> Index: gcc/fortran/trans-expr.c
> ===================================================================
> --- gcc/fortran/trans-expr.c (Revision 122226)
> +++ gcc/fortran/trans-expr.c (Arbeitskopie)
> @@ -1934,40 +1934,12 @@
> 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);
> Index: gcc/fortran/resolve.c
> ===================================================================
> --- gcc/fortran/resolve.c (Revision 122226)
> +++ gcc/fortran/resolve.c (Arbeitskopie)
> @@ -1016,22 +1016,14 @@
> 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. */
>