}
+/* Does everything to resolve an ordinary assignment. Returns true
+ if this is an interface asignment. */
+static bool
+resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
+{
+ bool rval = false;
+ gfc_expr *lhs;
+ gfc_expr *rhs;
+ int llen = 0;
+ int rlen = 0;
+ int n;
+ gfc_ref *ref;
+
+
+ if (gfc_extend_assign (code, ns) == SUCCESS)
+ {
+ lhs = code->ext.actual->expr;
+ rhs = code->ext.actual->next->expr;
+ if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
+ {
+ gfc_error ("Subroutine '%s' called instead of assignment at "
+ "%L must be PURE", code->symtree->n.sym->name,
+ &code->loc);
+ return rval;
+ }
+
+ /* Make a temporary rhs when there is a default initializer
+ and rhs is the same symbol as the lhs. */
+ if (rhs->expr_type == EXPR_VARIABLE
+ && rhs->symtree->n.sym->ts.type == BT_DERIVED
+ && has_default_initializer (rhs->symtree->n.sym->ts.derived)
+ && (lhs->symtree->n.sym == rhs->symtree->n.sym))
+ code->ext.actual->next->expr = gfc_get_parentheses (rhs);
+
+ return true;
+ }
+
+ lhs = code->expr;
+ rhs = code->expr2;
+
+ if (lhs->ts.type == BT_CHARACTER
+ && gfc_option.warn_character_truncation)
+ {
+ if (lhs->ts.cl != NULL
+ && lhs->ts.cl->length != NULL
+ && lhs->ts.cl->length->expr_type == EXPR_CONSTANT)
+ llen = mpz_get_si (lhs->ts.cl->length->value.integer);
+
+ if (rhs->expr_type == EXPR_CONSTANT)
+ rlen = rhs->value.character.length;
+
+ else if (rhs->ts.cl != NULL
+ && rhs->ts.cl->length != NULL
+ && rhs->ts.cl->length->expr_type == EXPR_CONSTANT)
+ rlen = mpz_get_si (rhs->ts.cl->length->value.integer);
+
+ if (rlen && llen && rlen > llen)
+ gfc_warning_now ("CHARACTER expression will be truncated "
+ "in assignment (%d/%d) at %L",
+ llen, rlen, &code->loc);
+ }
+
+ /* Ensure that a vector index expression for the lvalue is evaluated
+ to a temporary. */
+ if (lhs->rank)
+ {
+ for (ref = lhs->ref; ref; ref= ref->next)
+ if (ref->type == REF_ARRAY)
+ {
+ for (n = 0; n < ref->u.ar.dimen; n++)
+ if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
+ ref->u.ar.start[n]
+ = gfc_get_parentheses (ref->u.ar.start[n]);
+ }
+ }
+
+ if (gfc_pure (NULL))
+ {
+ if (gfc_impure_variable (lhs->symtree->n.sym))
+ {
+ gfc_error ("Cannot assign to variable '%s' in PURE "
+ "procedure at %L",
+ lhs->symtree->n.sym->name,
+ &lhs->where);
+ return rval;
+ }
+
+ if (lhs->ts.type == BT_DERIVED
+ && lhs->expr_type == EXPR_VARIABLE
+ && lhs->ts.derived->attr.pointer_comp
+ && gfc_impure_variable (rhs->symtree->n.sym))
+ {
+ gfc_error ("The impure variable at %L is assigned to "
+ "a derived type variable with a POINTER "
+ "component in a PURE procedure (12.6)",
+ &rhs->where);
+ return rval;
+ }
+ }
+
+ gfc_check_assign (lhs, rhs, 1);
+ return false;
+}
+
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
if (t == FAILURE)
break;
- if (gfc_extend_assign (code, ns) == SUCCESS)
- {
- gfc_expr *lhs = code->ext.actual->expr;
- gfc_expr *rhs = code->ext.actual->next->expr;
-
- if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
- {
- gfc_error ("Subroutine '%s' called instead of assignment at "
- "%L must be PURE", code->symtree->n.sym->name,
- &code->loc);
- break;
- }
-
- /* Make a temporary rhs when there is a default initializer
- and rhs is the same symbol as the lhs. */
- if (rhs->expr_type == EXPR_VARIABLE
- && rhs->symtree->n.sym->ts.type == BT_DERIVED
- && has_default_initializer (rhs->symtree->n.sym->ts.derived)
- && (lhs->symtree->n.sym == rhs->symtree->n.sym))
- code->ext.actual->next->expr = gfc_get_parentheses (rhs);
-
- goto call;
- }
-
- if (code->expr->ts.type == BT_CHARACTER
- && gfc_option.warn_character_truncation)
- {
- int llen = 0, rlen = 0;
-
- if (code->expr->ts.cl != NULL
- && code->expr->ts.cl->length != NULL
- && code->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
- llen = mpz_get_si (code->expr->ts.cl->length->value.integer);
-
- if (code->expr2->expr_type == EXPR_CONSTANT)
- rlen = code->expr2->value.character.length;
-
- else if (code->expr2->ts.cl != NULL
- && code->expr2->ts.cl->length != NULL
- && code->expr2->ts.cl->length->expr_type
- == EXPR_CONSTANT)
- rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
-
- if (rlen && llen && rlen > llen)
- gfc_warning_now ("CHARACTER expression will be truncated "
- "in assignment (%d/%d) at %L",
- llen, rlen, &code->loc);
- }
-
- if (gfc_pure (NULL))
- {
- if (gfc_impure_variable (code->expr->symtree->n.sym))
- {
- gfc_error ("Cannot assign to variable '%s' in PURE "
- "procedure at %L",
- code->expr->symtree->n.sym->name,
- &code->expr->where);
- break;
- }
-
- if (code->expr->ts.type == BT_DERIVED
- && code->expr->expr_type == EXPR_VARIABLE
- && code->expr->ts.derived->attr.pointer_comp
- && gfc_impure_variable (code->expr2->symtree->n.sym))
- {
- gfc_error ("The impure variable at %L is assigned to "
- "a derived type variable with a POINTER "
- "component in a PURE procedure (12.6)",
- &code->expr2->where);
- break;
- }
- }
+ if (resolve_ordinary_assign (code, ns))
+ goto call;
- gfc_check_assign (code->expr, code->expr2, 1);
break;
case EXEC_LABEL_ASSIGN: