===================================================================
@@ -3507,6 +3507,18 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rval
return false;
}
}
+ else
+ {
+ /* Reject assigning to an external symbol. For initializers, this
+ was already done before, in resolve_fl_procedure. */
+ if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
+ && sym->attr.proc != PROC_MODULE && !rvalue->error)
+ {
+ gfc_error ("Illegal assignment to external procedure at %L",
+ &lvalue->where);
+ return false;
+ }
+ }
if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
{
@@ -3643,7 +3655,8 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rval
NULLIFY statement. */
bool
-gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
+gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue,
+ bool suppress_type_test)
{
symbol_attribute attr, lhs_attr;
gfc_ref *ref;
@@ -3771,6 +3784,7 @@ bool
&rvalue->where);
return false;
}
+
if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer)
{
/* Check for intrinsics. */
@@ -3967,6 +3981,16 @@ bool
return true;
}
+ else
+ {
+ /* A non-proc pointer cannot point to a constant. */
+ if (rvalue->expr_type == EXPR_CONSTANT)
+ {
+ gfc_error_now ("Pointer assignment target cannot be a constant at %L",
+ &rvalue->where);
+ return false;
+ }
+ }
if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
{
@@ -3980,7 +4004,7 @@ bool
"polymorphic, or of a type with the BIND or SEQUENCE "
"attribute, to be compatible with an unlimited "
"polymorphic target", &lvalue->where);
- else
+ else if (!suppress_type_test)
gfc_error ("Different types in pointer assignment at %L; "
"attempted assignment of %s to %s", &lvalue->where,
gfc_typename (&rvalue->ts),
===================================================================
@@ -3219,7 +3219,8 @@ int gfc_kind_max (gfc_expr *, gfc_expr *);
bool gfc_check_conformance (gfc_expr *, gfc_expr *, const char *, ...) ATTRIBUTE_PRINTF_3;
bool gfc_check_assign (gfc_expr *, gfc_expr *, int, bool c = true);
-bool gfc_check_pointer_assign (gfc_expr *, gfc_expr *);
+bool gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue,
+ bool suppres_type_test = false);
bool gfc_check_assign_symbol (gfc_symbol *, gfc_component *, gfc_expr *);
gfc_expr *gfc_build_default_init_expr (gfc_typespec *, locus *);
===================================================================
@@ -11420,11 +11420,12 @@ start:
t = gfc_check_vardef_context (e, false, false, false,
_("pointer assignment"));
gfc_free_expr (e);
+
+ t = gfc_check_pointer_assign (code->expr1, code->expr2, !t) && t;
+
if (!t)
break;
- gfc_check_pointer_assign (code->expr1, code->expr2);
-
/* Assigning a class object always is a regular assign. */
if (code->expr2->ts.type == BT_CLASS
&& code->expr1->ts.type == BT_CLASS
@@ -12540,6 +12541,9 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag
{
gfc_error ("Function %qs at %L cannot have an initializer",
sym->name, &sym->declared_at);
+
+ /* Make sure no second error is issued for this. */
+ sym->value->error = 1;
return false;
}
===================================================================
@@ -14,6 +14,6 @@ contains
logical(1) function f()
end function
end interface
- f = .true._1
+ f = .true._1 ! { dg-error "Illegal assignment" }
end function f
end program test
===================================================================
@@ -26,7 +26,8 @@ program main
a = 43 ! { dg-error "variable definition context" }
ap => null() ! { dg-error "pointer association context" }
nullify(ap) ! { dg-error "pointer association context" }
- ap => at ! { dg-error "pointer association context" }
+ ap => & ! { dg-error "pointer association context" }
+ & at ! { dg-error "Pointer assignment target has PROTECTED attribute" }
ap = 3 ! OK
allocate(ap) ! { dg-error "pointer association context" }
ap = 73 ! OK
===================================================================
@@ -22,7 +22,8 @@ program main
a = 43 ! { dg-error "variable definition context" }
ap => null() ! { dg-error "pointer association context" }
nullify(ap) ! { dg-error "pointer association context" }
- ap => at ! { dg-error "pointer association context" }
+ ap => & ! { dg-error "pointer association context" }
+ & at ! { dg-error "Pointer assignment target has PROTECTED attribute" }
ap = 3 ! OK
allocate(ap) ! { dg-error "pointer association context" }
ap = 73 ! OK