+2006-12-31 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/23060
+ * intrinsic.c (compare_actual_formal ): Distinguish argument
+ list functions from keywords.
+ * intrinsic.c (sort_actual): If formal is NULL, the presence of
+ an argument list function actual is an error.
+ * trans-expr.c (conv_arglist_function) : New function to
+ implement argument list functions %VAL, %REF and %LOC.
+ (gfc_conv_function_call): Call it.
+ * resolve.c (resolve_actual_arglist): Add arg ptype and check
+ argument list functions.
+ (resolve_function, resolve_call): Set value of ptype before
+ calls to resolve_actual_arglist.
+ * primary.c (match_arg_list_function): New function.
+ (gfc_match_actual_arglist): Call it before trying for a
+ keyword argument.
+
2006-12-28 Paul Thomas <pault@gcc.gnu.org>
PR fortran/30034
for (a = actual; a; a = a->next, f = f->next)
{
- if (a->name != NULL)
+ /* Look for keywords but ignore g77 extensions like %VAL. */
+ if (a->name != NULL && a->name[0] != '%')
{
i = 0;
for (f = formal; f; f = f->next, i++)
if (f == NULL)
{
- gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
+ if (a->name[0] == '%')
+ gfc_error ("Argument list function at %L is not allowed in this "
+ "context", where);
+ else
+ gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
a->name, name, where);
return FAILURE;
}
}
+/* Match an argument list function, such as %VAL. */
+
+static match
+match_arg_list_function (gfc_actual_arglist *result)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ locus old_locus;
+ match m;
+
+ old_locus = gfc_current_locus;
+
+ if (gfc_match_char ('%') != MATCH_YES)
+ {
+ m = MATCH_NO;
+ goto cleanup;
+ }
+
+ m = gfc_match ("%n (", name);
+ if (m != MATCH_YES)
+ goto cleanup;
+
+ if (name[0] != '\0')
+ {
+ switch (name[0])
+ {
+ case 'l':
+ if (strncmp(name, "loc", 3) == 0)
+ {
+ result->name = "%LOC";
+ break;
+ }
+ case 'r':
+ if (strncmp(name, "ref", 3) == 0)
+ {
+ result->name = "%REF";
+ break;
+ }
+ case 'v':
+ if (strncmp(name, "val", 3) == 0)
+ {
+ result->name = "%VAL";
+ break;
+ }
+ default:
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ }
+
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
+ "function at %C") == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
+ m = match_actual_arg (&result->expr);
+ if (m != MATCH_YES)
+ goto cleanup;
+
+ if (gfc_match_char (')') != MATCH_YES)
+ {
+ m = MATCH_NO;
+ goto cleanup;
+ }
+
+ return MATCH_YES;
+
+cleanup:
+ gfc_current_locus = old_locus;
+ return m;
+}
+
+
/* Matches an actual argument list of a function or subroutine, from
the opening parenthesis to the closing parenthesis. The argument
list is assumed to allow keyword arguments because we don't know if
}
else
{
- /* See if we have the first keyword argument. */
- m = match_keyword_arg (tail, head);
- if (m == MATCH_YES)
- seen_keyword = 1;
+ /* Try an argument list function, like %VAL. */
+ m = match_arg_list_function (tail);
if (m == MATCH_ERROR)
goto cleanup;
+ /* See if we have the first keyword argument. */
+ if (m == MATCH_NO)
+ {
+ m = match_keyword_arg (tail, head);
+ if (m == MATCH_YES)
+ seen_keyword = 1;
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ }
+
if (m == MATCH_NO)
{
/* Try for a non-keyword argument. */
}
}
+
next:
if (gfc_match_char (')') == MATCH_YES)
break;
references. */
static try
-resolve_actual_arglist (gfc_actual_arglist * arg)
+resolve_actual_arglist (gfc_actual_arglist * arg, procedure_type ptype)
{
gfc_symbol *sym;
gfc_symtree *parent_st;
for (; arg; arg = arg->next)
{
-
e = arg->expr;
if (e == NULL)
{
{
if (gfc_resolve_expr (e) != SUCCESS)
return FAILURE;
- continue;
+ goto argument_list;
}
/* See if the expression node should really be a variable
&& sym->ns->parent->proc_name == sym)))
goto got_variable;
- continue;
+ goto argument_list;
}
/* See if the name is a module procedure in a parent unit. */
|| sym->attr.intrinsic
|| sym->attr.external)
{
- continue;
+ goto argument_list;
}
got_variable:
e->ref->u.ar.type = AR_FULL;
e->ref->u.ar.as = sym->as;
}
+
+ argument_list:
+ /* Check argument list functions %VAL, %LOC and %REF. There is
+ nothing to do for %REF. */
+ if (arg->name && arg->name[0] == '%')
+ {
+ if (strncmp ("%VAL", arg->name, 4) == 0)
+ {
+ if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
+ {
+ gfc_error ("By-value argument at %L is not of numeric "
+ "type", &e->where);
+ return FAILURE;
+ }
+
+ if (e->rank)
+ {
+ gfc_error ("By-value argument at %L cannot be an array or "
+ "an array section", &e->where);
+ return FAILURE;
+ }
+
+ /* Intrinsics are still PROC_UNKNOWN here. However,
+ 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)
+ {
+ 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. */
+ else if (strncmp ("%LOC", arg->name, 4) == 0
+ && e->ts.type == BT_PROCEDURE)
+ {
+ if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
+ {
+ gfc_error ("Passing internal procedure at %L by location "
+ "not allowed", &e->where);
+ return FAILURE;
+ }
+ }
+ }
}
return SUCCESS;
const char *name;
try t;
int temp;
+ procedure_type p = PROC_INTRINSIC;
sym = NULL;
if (expr->symtree)
of procedure, once the procedure itself is resolved. */
need_full_assumed_size++;
- if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
- return FAILURE;
+ if (expr->symtree && expr->symtree->n.sym)
+ p = expr->symtree->n.sym->attr.proc;
+
+ if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
+ return FAILURE;
/* Resume assumed_size checking. */
need_full_assumed_size--;
resolve_call (gfc_code * c)
{
try t;
+ procedure_type ptype = PROC_INTRINSIC;
if (c->symtree && c->symtree->n.sym
&& c->symtree->n.sym->ts.type != BT_UNKNOWN)
of procedure, once the procedure itself is resolved. */
need_full_assumed_size++;
- if (resolve_actual_arglist (c->ext.actual) == FAILURE)
+ if (c->symtree && c->symtree->n.sym)
+ ptype = c->symtree->n.sym->attr.proc;
+
+ if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
return FAILURE;
/* Resume assumed_size checking. */
return false;
}
+/* Generate the code for argument list functions. */
+
+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");
+ }
+
+ }
+ else if (strncmp (name, "%LOC", 4) == 0)
+ {
+ gfc_conv_expr_reference (se, expr);
+ se->expr = gfc_build_addr_expr (NULL, se->expr);
+ }
+ else if (strncmp (name, "%REF", 4) == 0)
+ gfc_conv_expr_reference (se, expr);
+ else
+ gfc_error ("Unknown argument list function at %L", &expr->where);
+}
+
+
/* Generate code for a procedure call. Note can return se->post != NULL.
If se->direct_byref is set then se->expr contains the return parameter.
Return nonzero, if the call has alternate specifiers. */
{
gfc_conv_expr (&parmse, e);
}
+ else if (arg->name && arg->name[0] == '%')
+ /* Argument list functions %VAL, %LOC and %REF are signalled
+ through arg->name. */
+ conv_arglist_function (&parmse, arg->expr, arg->name);
else
{
gfc_conv_expr_reference (&parmse, e);
+2006-12-31 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/23060
+ * gfortran.dg/c_by_val.c: Called by c_by_val_1.f.
+ * gfortran.dg/c_by_val_1.f: New test.
+ * gfortran.dg/c_by_val_2.f: New test.
+ * gfortran.dg/c_by_val_3.f: New test.
+
2006-12-30 Thomas Koenig <Thomas.Koenig@online.de>
PR libfortran/30321
--- /dev/null
+/* Passing from fortran to C by value, using %VAL. */
+
+typedef struct { float r, i; } complex;
+extern void f_to_f__ (float*, float, float*, float**);
+extern void i_to_i__ (int*, int, int*, int**);
+extern void c_to_c__ (complex*, complex, complex*, complex**);
+extern void abort (void);
+
+void
+f_to_f__(float *retval, float a1, float *a2, float **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();
+ 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();
+ 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;
+}
--- /dev/null
+C { dg-do run }
+C { dg-additional-sources c_by_val.c }
+C { dg-options "-ff2c -w -O0" }
+
+ program c_by_val_1
+ external f_to_f, i_to_i, c_to_c
+ real a, b, c
+ integer*4 i, j, k
+ complex u, v, w, c_to_c
+
+ a = 42.0
+ b = 0.0
+ c = a
+ call f_to_f (b, %VAL (a), %REF (c), %LOC (c))
+ if ((2.0 * a).ne.b) 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 ()
+
+ 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 ()
+
+ stop
+ end
+
--- /dev/null
+! { dg-do compile }
+! { dg-options "-w" }
+
+program c_by_val_2
+ external bar
+ real (4) :: bar, ar(2) = (/1.0,2.0/)
+ type :: mytype
+ integer :: i
+ end type mytype
+ type(mytype) :: z
+ character(8) :: c = "blooey"
+ print *, sin (%VAL(2.0)) ! { dg-error "not allowed in this context" }
+ print *, foo (%VAL(1.0)) ! { dg-error "not allowed in this context" }
+ call foobar (%VAL(0.5)) ! { dg-error "not allowed in this context" }
+ print *, bar (%VAL(z)) ! { dg-error "not of numeric type" }
+ print *, bar (%VAL(c)) ! { dg-error "not of numeric type" }
+ print *, bar (%VAL(ar)) ! { dg-error "cannot be an array" }
+ print *, bar (%VAL(0.0))
+contains
+ function foo (a)
+ real(4) :: a, foo
+ foo = cos (a)
+ end function foo
+ subroutine foobar (a)
+ real(4) :: a
+ print *, a
+ end subroutine foobar
+end program c_by_val_2
+
--- /dev/null
+! { dg-do compile }
+! { dg-options "-std=f95" }
+program c_by_val_3
+ external bar
+ real (4) :: bar
+ print *, bar (%VAL(0.0)) ! { dg-error "argument list function" }
+end program c_by_val_3
projects / thirdparty / gcc.git / commitdiff
