aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog18
-rw-r--r--gcc/fortran/interface.c3
-rw-r--r--gcc/fortran/intrinsic.c6
-rw-r--r--gcc/fortran/primary.c91
-rw-r--r--gcc/fortran/resolve.c79
-rw-r--r--gcc/fortran/trans-expr.c55
6 files changed, 238 insertions, 14 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f1042bc..7aa22fe 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,21 @@
+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
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 67a2064..04618e7 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1293,7 +1293,8 @@ compare_actual_formal (gfc_actual_arglist ** ap,
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++)
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 2ed4291..5cdf80d 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -2864,7 +2864,11 @@ keywords:
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;
}
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 66ac2f1..f67500c 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1429,6 +1429,80 @@ cleanup:
}
+/* 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
@@ -1497,13 +1571,21 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
}
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. */
@@ -1515,6 +1597,7 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
}
}
+
next:
if (gfc_match_char (')') == MATCH_YES)
break;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 2c71ae4..1b46a10 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -844,7 +844,7 @@ resolve_assumed_size_actual (gfc_expr *e)
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;
@@ -852,7 +852,6 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
for (; arg; arg = arg->next)
{
-
e = arg->expr;
if (e == NULL)
{
@@ -873,7 +872,7 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
{
if (gfc_resolve_expr (e) != SUCCESS)
return FAILURE;
- continue;
+ goto argument_list;
}
/* See if the expression node should really be a variable
@@ -938,7 +937,7 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
&& 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. */
@@ -962,7 +961,7 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
|| sym->attr.intrinsic
|| sym->attr.external)
{
- continue;
+ goto argument_list;
}
got_variable:
@@ -976,6 +975,62 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
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;
@@ -1451,6 +1506,7 @@ resolve_function (gfc_expr * expr)
const char *name;
try t;
int temp;
+ procedure_type p = PROC_INTRINSIC;
sym = NULL;
if (expr->symtree)
@@ -1467,8 +1523,11 @@ resolve_function (gfc_expr * expr)
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--;
@@ -1848,6 +1907,7 @@ static try
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)
@@ -1894,7 +1954,10 @@ resolve_call (gfc_code * c)
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. */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 6d46cd4..e534aff 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1906,6 +1906,57 @@ is_aliased_array (gfc_expr * e)
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. */
@@ -2024,6 +2075,10 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
{
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);
generated by cgit v1.1 at 2025-08-09 10:10:57 +0000