2012-10-04 Tobias Burnus <burnus@net-b.de>
* expr.c (scalarize_intrinsic_call): Plug memory leak.
* frontend-passes.c (gcc_assert): Extend assert.
* interface.c (gfc_compare_derived_types): Fix comparison.
(gfc_check_operator_interface): Move up to make this error
message reachable.
(get_sym_storage_size): Remove always-true checks.
* io.c (format_lex): Add comment.
(gfc_free_wait): Free memory.
* match.c (gfc_match_select_type): Ditto.
* matchexpr.c (match_level_3): Ditto.
* primary.c (match_string_constant): Ditto.
(match_actual_arg): Check return value.
* resolve.c (gfc_resolve_substring_charlen,
resolve_typebound_generic_call, resolve_typebound_function,
resolve_typebound_subroutine): Free memory.
* trans-types.c (gfc_get_derived_type): Remove always-true check.
@@ -2059,6 +2059,8 @@ scalarize_intrinsic_call (gfc_expr *e)
free_expr0 (e);
*e = *expr;
+ /* Free "expr" but not the pointers it contains. */
+ free (expr);
gfc_free_expr (old);
return SUCCESS;
@@ -1177,7 +1177,7 @@ optimize_trim (gfc_expr *e)
/* Set the end of the reference to the call to len_trim. */
ref->u.ss.end = fcn;
- gcc_assert (*rr == NULL);
+ gcc_assert (rr != NULL && *rr == NULL);
*rr = ref;
return true;
}
@@ -449,7 +449,7 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
/* Make sure that link lists do not put this function into an
endless recursive loop! */
if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
- && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
+ && !(dt2->ts.type == BT_DERIVED && derived2 == dt2->ts.u.derived)
&& gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
return 0;
@@ -641,8 +641,12 @@ gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
&& op != INTRINSIC_NOT)
|| (args == 2 && op == INTRINSIC_NOT))
{
- gfc_error ("Operator interface at %L has the wrong number of arguments",
- &sym->declared_at);
+ if (op == INTRINSIC_ASSIGN)
+ gfc_error ("Assignment operator interface at %L must have "
+ "two arguments", &sym->declared_at);
+ else
+ gfc_error ("Operator interface at %L has the wrong number of arguments",
+ &sym->declared_at);
return false;
}
@@ -656,12 +660,6 @@ gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
"a SUBROUTINE", &sym->declared_at);
return false;
}
- if (args != 2)
- {
- gfc_error ("Assignment operator interface at %L must have "
- "two arguments", &sym->declared_at);
- return false;
- }
/* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
- First argument an array with different rank than second,
@@ -2149,7 +2147,7 @@ get_sym_storage_size (gfc_symbol *sym)
return 0;
for (i = 0; i < sym->as->rank; i++)
{
- if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
+ if (sym->as->upper[i]->expr_type != EXPR_CONSTANT
|| sym->as->lower[i]->expr_type != EXPR_CONSTANT)
return 0;
@@ -2224,9 +2222,7 @@ get_expr_storage_size (gfc_expr *e)
continue;
}
- if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
- && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
- && ref->u.ar.as->upper)
+ if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
for (i = 0; i < ref->u.ar.dimen; i++)
{
long int start, end, stride;
@@ -243,6 +243,8 @@ format_lex (void)
{
case '-':
negative_flag = 1;
+ /* Falls through. */
+
case '+':
c = next_char_not_space (&error);
if (!ISDIGIT (c))
@@ -4117,6 +4119,7 @@ gfc_free_wait (gfc_wait *wait)
gfc_free_expr (wait->iostat);
gfc_free_expr (wait->iomsg);
gfc_free_expr (wait->id);
+ free (wait);
}
@@ -5325,6 +5325,7 @@ gfc_match_select_type (void)
char name[GFC_MAX_SYMBOL_LEN];
bool class_array;
gfc_symbol *sym;
+ gfc_namespace *parent_ns;
m = gfc_match_label ();
if (m == MATCH_ERROR)
@@ -5404,7 +5405,9 @@ gfc_match_select_type (void)
return MATCH_YES;
cleanup:
- gfc_current_ns = gfc_current_ns->parent;
+ parent_ns = gfc_current_ns->parent;
+ gfc_free_namespace (gfc_current_ns);
+ gfc_current_ns = parent_ns;
return m;
}
@@ -543,7 +543,7 @@ match_level_2 (gfc_expr **result)
static match
match_level_3 (gfc_expr **result)
{
- gfc_expr *all, *e, *total;
+ gfc_expr *all, *e, *total = NULL;
locus where;
match m;
@@ -560,12 +560,12 @@ match_level_3 (gfc_expr **result)
m = match_level_2 (&e);
if (m == MATCH_NO)
+ gfc_error (expression_syntax);
+ if (m != MATCH_YES)
{
- gfc_error (expression_syntax);
gfc_free_expr (all);
+ return MATCH_ERROR;
}
- if (m != MATCH_YES)
- return MATCH_ERROR;
total = gfc_concat (all, e);
if (total == NULL)
@@ -1087,6 +1087,7 @@ got_delim:
if (!gfc_check_character_range (c, kind))
{
+ gfc_free_expr (e);
gfc_error ("Character '%s' in string at %C is not representable "
"in character kind %d", gfc_print_wide_char (c), kind);
return MATCH_ERROR;
@@ -1507,8 +1508,9 @@ match_actual_arg (gfc_expr **result)
if (sym->attr.in_common && !sym->attr.proc_pointer)
{
- gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name,
- &sym->declared_at);
+ if (gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name,
+ &sym->declared_at) == FAILURE)
+ return MATCH_ERROR;
break;
}
@@ -4964,7 +4964,11 @@ gfc_resolve_substring_charlen (gfc_expr *e)
end = NULL;
if (!start || !end)
- return;
+ {
+ gfc_free_expr (start);
+ gfc_free_expr (end);
+ return;
+ }
/* Length = (end - start +1). */
e->ts.u.cl->length = gfc_subtract (end, start);
@@ -6004,7 +6008,10 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name)
gfc_expr* po;
po = extract_compcall_passed_object (e);
if (!po)
- return FAILURE;
+ {
+ gfc_free_actual_arglist (args);
+ return FAILURE;
+ }
gcc_assert (g->specific->pass_arg_num > 0);
gcc_assert (!g->specific->error);
@@ -6253,7 +6260,10 @@ resolve_typebound_function (gfc_expr* e)
/* Treat the call as if it is a typebound procedure, in order to roll
out the correct name for the specific function. */
if (resolve_compcall (e, &name) == FAILURE)
- return FAILURE;
+ {
+ gfc_free_ref_list (new_ref);
+ return FAILURE;
+ }
ts = e->ts;
if (overridable)
@@ -6374,7 +6384,10 @@ resolve_typebound_subroutine (gfc_code *code)
}
if (resolve_typebound_call (code, &name) == FAILURE)
- return FAILURE;
+ {
+ gfc_free_ref_list (new_ref);
+ return FAILURE;
+ }
ts = code->expr1->ts;
if (overridable)
@@ -2445,7 +2445,7 @@ gfc_get_derived_type (gfc_symbol * derived)
|| c->ts.u.derived->backend_decl == NULL)
c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived);
- if (c->ts.u.derived && c->ts.u.derived->attr.is_iso_c)
+ if (c->ts.u.derived->attr.is_iso_c)
{
/* Need to copy the modified ts from the derived type. The
typespec was modified because C_PTR/C_FUNPTR are translated