aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/primary.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/primary.c')
-rw-r--r--gcc/fortran/primary.c51
1 files changed, 34 insertions, 17 deletions
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 7e41535..96fbddc 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1708,10 +1708,13 @@ extend_ref (gfc_expr *primary, gfc_ref *tail)
variable like member references or substrings. If equiv_flag is
set we only match stuff that is allowed inside an EQUIVALENCE
statement. sub_flag tells whether we expect a type-bound procedure found
- to be a subroutine as part of CALL or a FUNCTION. */
+ to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
+ components, 'ppc_arg' determines whether the PPC may be called (with an
+ argument list), or whether it may just be referred to as a pointer. */
match
-gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
+gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
+ bool ppc_arg)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_ref *substring, *tail;
@@ -1754,7 +1757,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
return MATCH_YES;
if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
- && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
+ && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
gfc_set_default_type (sym, 0, sym->ns);
if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
@@ -1826,6 +1829,20 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
primary->ts = component->ts;
+ if (component->attr.proc_pointer && ppc_arg
+ && !gfc_matching_procptr_assignment)
+ {
+ primary->expr_type = EXPR_PPC;
+ m = gfc_match_actual_arglist (component->attr.subroutine,
+ &primary->value.compcall.actual);
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m == MATCH_NO)
+ primary->value.compcall.actual = NULL;
+
+ break;
+ }
+
if (component->as != NULL)
{
tail = extend_ref (primary, tail);
@@ -1847,7 +1864,7 @@ check_substring:
unknown = false;
if (primary->ts.type == BT_UNKNOWN)
{
- if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
+ if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
{
gfc_set_default_type (sym, 0, sym->ns);
primary->ts = sym->ts;
@@ -1925,7 +1942,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
allocatable = attr.allocatable;
target = attr.target;
- if (pointer)
+ if (pointer || attr.proc_pointer)
target = 1;
if (ts != NULL && expr->ts.type == BT_UNKNOWN)
@@ -1971,7 +1988,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
pointer = ref->u.c.component->attr.pointer;
allocatable = ref->u.c.component->attr.allocatable;
- if (pointer)
+ if (pointer || attr.proc_pointer)
target = 1;
break;
@@ -2478,7 +2495,7 @@ gfc_match_rvalue (gfc_expr **result)
e->expr_type = EXPR_VARIABLE;
e->symtree = symtree;
- m = gfc_match_varspec (e, 0, false);
+ m = gfc_match_varspec (e, 0, false, true);
break;
case FL_PARAMETER:
@@ -2495,7 +2512,7 @@ gfc_match_rvalue (gfc_expr **result)
}
e->symtree = symtree;
- m = gfc_match_varspec (e, 0, false);
+ m = gfc_match_varspec (e, 0, false, true);
if (sym->ts.is_c_interop || sym->ts.is_iso_c)
break;
@@ -2551,7 +2568,7 @@ gfc_match_rvalue (gfc_expr **result)
e = gfc_get_expr ();
e->expr_type = EXPR_VARIABLE;
e->symtree = symtree;
- m = gfc_match_varspec (e, 0, false);
+ m = gfc_match_varspec (e, 0, false, true);
break;
}
@@ -2578,7 +2595,7 @@ gfc_match_rvalue (gfc_expr **result)
e->symtree = symtree;
e->expr_type = EXPR_VARIABLE;
- m = gfc_match_varspec (e, 0, false);
+ m = gfc_match_varspec (e, 0, false, true);
break;
}
@@ -2658,7 +2675,7 @@ gfc_match_rvalue (gfc_expr **result)
if (gfc_peek_ascii_char () == '%'
&& sym->ts.type == BT_UNKNOWN
- && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
+ && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
gfc_set_default_type (sym, 0, sym->ns);
/* If the symbol has a dimension attribute, the expression is a
@@ -2676,7 +2693,7 @@ gfc_match_rvalue (gfc_expr **result)
e = gfc_get_expr ();
e->symtree = symtree;
e->expr_type = EXPR_VARIABLE;
- m = gfc_match_varspec (e, 0, false);
+ m = gfc_match_varspec (e, 0, false, true);
break;
}
@@ -2701,7 +2718,7 @@ gfc_match_rvalue (gfc_expr **result)
/*FIXME:??? gfc_match_varspec does set this for us: */
e->ts = sym->ts;
- m = gfc_match_varspec (e, 0, false);
+ m = gfc_match_varspec (e, 0, false, true);
break;
}
@@ -2725,7 +2742,7 @@ gfc_match_rvalue (gfc_expr **result)
implicit_char = false;
if (sym->ts.type == BT_UNKNOWN)
{
- ts = gfc_get_default_type (sym,NULL);
+ ts = gfc_get_default_type (sym->name, NULL);
if (ts->type == BT_CHARACTER)
implicit_char = true;
}
@@ -2790,7 +2807,7 @@ gfc_match_rvalue (gfc_expr **result)
/* If our new function returns a character, array or structure
type, it might have subsequent references. */
- m = gfc_match_varspec (e, 0, false);
+ m = gfc_match_varspec (e, 0, false, true);
if (m == MATCH_NO)
m = MATCH_YES;
@@ -2963,7 +2980,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
if (gfc_peek_ascii_char () == '%'
&& sym->ts.type == BT_UNKNOWN
- && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
+ && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
gfc_set_default_type (sym, 0, implicit_ns);
}
@@ -2975,7 +2992,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
expr->where = where;
/* Now see if we have to do more. */
- m = gfc_match_varspec (expr, equiv_flag, false);
+ m = gfc_match_varspec (expr, equiv_flag, false, false);
if (m != MATCH_YES)
{
gfc_free_expr (expr);
generated by cgit v1.1 at 2025-05-03 17:37:42 +0000