+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
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. */
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);
+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
/* 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
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)
{
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)
{
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;
+}
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
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
--- /dev/null
+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