X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Fmatch.c;h=e3d37d25c7e7db6297501fe0727cfc90f9f345fe;hb=b7fcd3f95fa452127c1b12fdc0d702784bccff60;hp=5012c3588ee368fce1295439d76049a063cb308a;hpb=26691d132aa2906b50fcdd86c6cb28042b10227e;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 5012c3588ee..e3d37d25c7e 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1,5 +1,5 @@ /* Matching subroutines in all sizes, shapes and colors. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -20,7 +20,6 @@ along with GCC; see the file COPYING. If not, write to the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ - #include "config.h" #include "system.h" #include "flags.h" @@ -225,7 +224,7 @@ gfc_match_small_int (int *value) do most of the work. */ match -gfc_match_st_label (gfc_st_label ** label) +gfc_match_st_label (gfc_st_label **label) { locus old_loc; match m; @@ -314,7 +313,7 @@ gfc_match_label (void) A '%' character is a mandatory space. */ int -gfc_match_strings (mstring * a) +gfc_match_strings (mstring *a) { mstring *p, *best_match; int no_match, c, possibles; @@ -348,8 +347,7 @@ gfc_match_strings (mstring * a) if (*p->mp == ' ') { /* Space matches 1+ whitespace(s). */ - if ((gfc_current_form == FORM_FREE) - && gfc_is_whitespace (c)) + if ((gfc_current_form == FORM_FREE) && gfc_is_whitespace (c)) continue; p->mp++; @@ -396,6 +394,8 @@ gfc_match_name (char *buffer) c = gfc_next_char (); if (!ISALPHA (c)) { + if (gfc_error_flag_test() == 0) + gfc_error ("Invalid character in name at %C"); gfc_current_locus = old_loc; return MATCH_NO; } @@ -415,9 +415,7 @@ gfc_match_name (char *buffer) old_loc = gfc_current_locus; c = gfc_next_char (); } - while (ISALNUM (c) - || c == '_' - || (gfc_option.flag_dollar_ok && c == '$')); + while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$')); buffer[i] = '\0'; gfc_current_locus = old_loc; @@ -430,7 +428,7 @@ gfc_match_name (char *buffer) pointer if successful. */ match -gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc) +gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc) { char buffer[GFC_MAX_SYMBOL_LEN + 1]; match m; @@ -441,7 +439,7 @@ gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc) if (host_assoc) return (gfc_get_ha_sym_tree (buffer, matched_symbol)) - ? MATCH_ERROR : MATCH_YES; + ? MATCH_ERROR : MATCH_YES; if (gfc_get_sym_tree (buffer, NULL, matched_symbol)) return MATCH_ERROR; @@ -451,7 +449,7 @@ gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc) match -gfc_match_symbol (gfc_symbol ** matched_symbol, int host_assoc) +gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc) { gfc_symtree *st; match m; @@ -461,21 +459,22 @@ gfc_match_symbol (gfc_symbol ** matched_symbol, int host_assoc) if (m == MATCH_YES) { if (st) - *matched_symbol = st->n.sym; + *matched_symbol = st->n.sym; else - *matched_symbol = NULL; + *matched_symbol = NULL; } else *matched_symbol = NULL; return m; } + /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching, we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this in matchexp.c. */ match -gfc_match_intrinsic_op (gfc_intrinsic_op * result) +gfc_match_intrinsic_op (gfc_intrinsic_op *result) { gfc_intrinsic_op op; @@ -498,15 +497,14 @@ gfc_match_intrinsic_op (gfc_intrinsic_op * result) the equals sign is seen. */ match -gfc_match_iterator (gfc_iterator * iter, int init_flag) +gfc_match_iterator (gfc_iterator *iter, int init_flag) { char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_expr *var, *e1, *e2, *e3; locus start; match m; - /* Match the start of an iterator without affecting the symbol - table. */ + /* Match the start of an iterator without affecting the symbol table. */ start = gfc_current_locus; m = gfc_match (" %n =", name); @@ -782,7 +780,7 @@ not_yes: case 'l': case 'n': case 's': - (void)va_arg (argp, void **); + (void) va_arg (argp, void **); break; case 'e': @@ -852,6 +850,15 @@ gfc_match_assignment (void) return MATCH_NO; } + if (lvalue->symtree->n.sym->attr.protected + && lvalue->symtree->n.sym->attr.use_assoc) + { + gfc_current_locus = old_loc; + gfc_free_expr (lvalue); + gfc_error ("Setting value of PROTECTED variable at %C"); + return MATCH_ERROR; + } + rvalue = NULL; m = gfc_match (" %e%t", &rvalue); if (m != MATCH_YES) @@ -898,6 +905,15 @@ gfc_match_pointer_assignment (void) if (m != MATCH_YES) goto cleanup; + if (lvalue->symtree->n.sym->attr.protected + && lvalue->symtree->n.sym->attr.use_assoc) + { + gfc_error ("Assigning to a PROTECTED pointer at %C"); + m = MATCH_ERROR; + goto cleanup; + } + + new_st.op = EXEC_POINTER_ASSIGN; new_st.expr = lvalue; new_st.expr2 = rvalue; @@ -916,6 +932,7 @@ cleanup: when just after having encountered a simple IF statement. This code is really duplicate with parts of the gfc_match_if code, but this is *much* easier. */ + static match match_arithmetic_if (void) { @@ -935,8 +952,8 @@ match_arithmetic_if (void) return MATCH_ERROR; } - if (gfc_notify_std (GFC_STD_F95_DEL, - "Obsolete: arithmetic IF statement at %C") == FAILURE) + if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: arithmetic IF statement " + "at %C") == FAILURE) return MATCH_ERROR; new_st.op = EXEC_ARITHMETIC_IF; @@ -963,7 +980,7 @@ static match match_simple_forall (void); static match match_simple_where (void); match -gfc_match_if (gfc_statement * if_type) +gfc_match_if (gfc_statement *if_type) { gfc_expr *expr; gfc_st_label *l1, *l2, *l3; @@ -994,10 +1011,8 @@ gfc_match_if (gfc_statement * if_type) { if (n == MATCH_YES) { - gfc_error - ("Block label not appropriate for arithmetic IF statement " - "at %C"); - + gfc_error ("Block label not appropriate for arithmetic IF " + "statement at %C"); gfc_free_expr (expr); return MATCH_ERROR; } @@ -1006,15 +1021,13 @@ gfc_match_if (gfc_statement * if_type) || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE) { - gfc_free_expr (expr); return MATCH_ERROR; } - if (gfc_notify_std (GFC_STD_F95_DEL, - "Obsolete: arithmetic IF statement at %C") - == FAILURE) - return MATCH_ERROR; + if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: arithmetic IF " + "statement at %C") == FAILURE) + return MATCH_ERROR; new_st.op = EXEC_ARITHMETIC_IF; new_st.expr = expr; @@ -1030,7 +1043,6 @@ gfc_match_if (gfc_statement * if_type) { new_st.op = EXEC_IF; new_st.expr = expr; - *if_type = ST_IF_BLOCK; return MATCH_YES; } @@ -1038,7 +1050,6 @@ gfc_match_if (gfc_statement * if_type) if (n == MATCH_YES) { gfc_error ("Block label is not appropriate IF statement at %C"); - gfc_free_expr (expr); return MATCH_ERROR; } @@ -1126,7 +1137,7 @@ gfc_match_if (gfc_statement * if_type) /* All else has failed, so give up. See if any of the matchers has stored an error message of some sort. */ - if (gfc_error_check () == 0) + if (gfc_error_check () == 0) gfc_error ("Unclassifiable statement in IF-clause at %C"); gfc_free_expr (expr); @@ -1238,9 +1249,8 @@ cleanup: /* Free a gfc_iterator structure. */ void -gfc_free_iterator (gfc_iterator * iter, int flag) +gfc_free_iterator (gfc_iterator *iter, int flag) { - if (iter == NULL) return; @@ -1290,8 +1300,7 @@ gfc_match_do (void) } /* match an optional comma, if no comma is found a space is obligatory. */ - if (gfc_match_char(',') != MATCH_YES - && gfc_match ("% ") != MATCH_YES) + if (gfc_match_char(',') != MATCH_YES && gfc_match ("% ") != MATCH_YES) return MATCH_NO; /* See if we have a DO WHILE. */ @@ -1436,7 +1445,6 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) match gfc_match_exit (void) { - return match_exit_cycle (ST_EXIT, EXEC_EXIT); } @@ -1446,7 +1454,6 @@ gfc_match_exit (void) match gfc_match_cycle (void) { - return match_exit_cycle (ST_CYCLE, EXEC_CYCLE); } @@ -1468,7 +1475,7 @@ gfc_match_stopcode (gfc_statement st) { m = gfc_match_small_literal_int (&stop_code, &cnt); if (m == MATCH_ERROR) - goto cleanup; + goto cleanup; if (m == MATCH_YES && cnt > 5) { @@ -1477,25 +1484,25 @@ gfc_match_stopcode (gfc_statement st) } if (m == MATCH_NO) - { - /* Try a character constant. */ - m = gfc_match_expr (&e); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) - goto syntax; - } + { + /* Try a character constant. */ + m = gfc_match_expr (&e); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) + goto syntax; + } if (gfc_match_eos () != MATCH_YES) - goto syntax; + goto syntax; } if (gfc_pure (NULL)) { gfc_error ("%s statement not allowed in PURE procedure at %C", - gfc_ascii_statement (st)); + gfc_ascii_statement (st)); goto cleanup; } @@ -1524,8 +1531,7 @@ gfc_match_pause (void) m = gfc_match_stopcode (ST_PAUSE); if (m == MATCH_YES) { - if (gfc_notify_std (GFC_STD_F95_DEL, - "Obsolete: PAUSE statement at %C") + if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: PAUSE statement at %C") == FAILURE) m = MATCH_ERROR; } @@ -1547,7 +1553,6 @@ gfc_match_stop (void) match gfc_match_continue (void) { - if (gfc_match_eos () != MATCH_YES) { gfc_syntax_error (ST_CONTINUE); @@ -1570,21 +1575,21 @@ gfc_match_assign (void) if (gfc_match (" %l", &label) == MATCH_YES) { if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE) - return MATCH_ERROR; + return MATCH_ERROR; if (gfc_match (" to %v%t", &expr) == MATCH_YES) - { - if (gfc_notify_std (GFC_STD_F95_DEL, - "Obsolete: ASSIGN statement at %C") + { + if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: ASSIGN " + "statement at %C") == FAILURE) return MATCH_ERROR; - expr->symtree->n.sym->attr.assign = 1; + expr->symtree->n.sym->attr.assign = 1; - new_st.op = EXEC_LABEL_ASSIGN; - new_st.label = label; - new_st.expr = expr; - return MATCH_YES; - } + new_st.op = EXEC_LABEL_ASSIGN; + new_st.label = label; + new_st.expr = expr; + return MATCH_YES; + } } return MATCH_NO; } @@ -1619,8 +1624,8 @@ gfc_match_goto (void) if (gfc_match_variable (&expr, 0) == MATCH_YES) { - if (gfc_notify_std (GFC_STD_F95_DEL, - "Obsolete: Assigned GOTO statement at %C") + if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: Assigned GOTO " + "statement at %C") == FAILURE) return MATCH_ERROR; @@ -1666,8 +1671,7 @@ gfc_match_goto (void) if (head == NULL) { - gfc_error ( - "Statement label list in GOTO at %C cannot be empty"); + gfc_error ("Statement label list in GOTO at %C cannot be empty"); goto syntax; } new_st.block = head; @@ -1753,7 +1757,7 @@ cleanup: /* Frees a list of gfc_alloc structures. */ void -gfc_free_alloc_list (gfc_alloc * p) +gfc_free_alloc_list (gfc_alloc *p) { gfc_alloc *q; @@ -1801,7 +1805,7 @@ gfc_match_allocate (void) goto cleanup; if (gfc_pure (NULL) - && gfc_impure_variable (tail->expr->symtree->n.sym)) + && gfc_impure_variable (tail->expr->symtree->n.sym)) { gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a " "PURE procedure"); @@ -1825,23 +1829,21 @@ gfc_match_allocate (void) { if (stat->symtree->n.sym->attr.intent == INTENT_IN) { - gfc_error - ("STAT variable '%s' of ALLOCATE statement at %C cannot be " - "INTENT(IN)", stat->symtree->n.sym->name); + gfc_error ("STAT variable '%s' of ALLOCATE statement at %C cannot " + "be INTENT(IN)", stat->symtree->n.sym->name); goto cleanup; } if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym)) { - gfc_error - ("Illegal STAT variable in ALLOCATE statement at %C for a PURE " - "procedure"); + gfc_error ("Illegal STAT variable in ALLOCATE statement at %C " + "for a PURE procedure"); goto cleanup; } if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE) { - gfc_error("STAT expression at %C must be a variable"); + gfc_error ("STAT expression at %C must be a variable"); goto cleanup; } @@ -1895,8 +1897,7 @@ gfc_match_nullify (void) if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym)) { - gfc_error - ("Illegal variable in NULLIFY at %C for a PURE procedure"); + gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure"); goto cleanup; } @@ -1971,11 +1972,10 @@ gfc_match_deallocate (void) goto cleanup; if (gfc_pure (NULL) - && gfc_impure_variable (tail->expr->symtree->n.sym)) + && gfc_impure_variable (tail->expr->symtree->n.sym)) { - gfc_error - ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE " - "procedure"); + gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C " + "for a PURE procedure"); goto cleanup; } @@ -2007,7 +2007,7 @@ gfc_match_deallocate (void) if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE) { - gfc_error("STAT expression at %C must be a variable"); + gfc_error ("STAT expression at %C must be a variable"); goto cleanup; } @@ -2057,12 +2057,12 @@ gfc_match_return (void) if (gfc_current_form == FORM_FREE) { /* The following are valid, so we can't require a blank after the - RETURN keyword: - return+1 - return(1) */ + RETURN keyword: + return+1 + return(1) */ c = gfc_peek_char (); if (ISALPHA (c) || ISDIGIT (c)) - return MATCH_NO; + return MATCH_NO; } m = gfc_match (" %e%t", &e); @@ -2081,7 +2081,7 @@ done: gfc_enclosing_unit (&s); if (s == COMP_PROGRAM && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in " - "main program at %C") == FAILURE) + "main program at %C") == FAILURE) return MATCH_ERROR; new_st.op = EXEC_RETURN; @@ -2157,7 +2157,7 @@ gfc_match_call (void) new_st.next = c = gfc_get_code (); c->op = EXEC_SELECT; - sprintf (name, "_result_%s",sym->name); + sprintf (name, "_result_%s", sym->name); gfc_get_ha_sym_tree (name, &select_st); /* Can't fail */ select_sym = select_st->n.sym; @@ -2221,13 +2221,13 @@ gfc_get_common (const char *name, int from_module) { gfc_symtree *st; static int serial = 0; - char mangled_name[GFC_MAX_SYMBOL_LEN+1]; + char mangled_name[GFC_MAX_SYMBOL_LEN + 1]; if (from_module) { /* A use associated common block is only needed to correctly layout the variables it contains. */ - snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name); + snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name); st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name); } else @@ -2286,10 +2286,10 @@ match gfc_match_common (void) { gfc_symbol *sym, **head, *tail, *other, *old_blank_common; - char name[GFC_MAX_SYMBOL_LEN+1]; + char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_common_head *t; gfc_array_spec *as; - gfc_equiv * e1, * e2; + gfc_equiv *e1, *e2; match m; gfc_gsymbol *gsym; @@ -2311,8 +2311,8 @@ gfc_match_common (void) gsym = gfc_get_gsymbol (name); if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON) { - gfc_error ("Symbol '%s' at %C is already an external symbol that is not COMMON", - name); + gfc_error ("Symbol '%s' at %C is already an external symbol that " + "is not COMMON", name); goto cleanup; } @@ -2329,7 +2329,8 @@ gfc_match_common (void) { if (gfc_current_ns->is_block_data) { - gfc_warning ("BLOCK DATA unit cannot contain blank COMMON at %C"); + gfc_warning ("BLOCK DATA unit cannot contain blank COMMON " + "at %C"); } t = &gfc_current_ns->blank_common; if (t->head == NULL) @@ -2387,9 +2388,8 @@ gfc_match_common (void) /* Derived type names must have the SEQUENCE attribute. */ if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence) { - gfc_error - ("Derived type variable in COMMON at %C does not have the " - "SEQUENCE attribute"); + gfc_error ("Derived type variable in COMMON at %C does not " + "have the SEQUENCE attribute"); goto cleanup; } @@ -2401,7 +2401,7 @@ gfc_match_common (void) tail = sym; /* Deal with an optional array specification after the - symbol name. */ + symbol name. */ m = gfc_match_array_spec (&as); if (m == MATCH_ERROR) goto cleanup; @@ -2410,9 +2410,8 @@ gfc_match_common (void) { if (as->type != AS_EXPLICIT) { - gfc_error - ("Array specification for symbol '%s' in COMMON at %C " - "must be explicit", sym->name); + gfc_error ("Array specification for symbol '%s' in COMMON " + "at %C must be explicit", sym->name); goto cleanup; } @@ -2421,9 +2420,8 @@ gfc_match_common (void) if (sym->attr.pointer) { - gfc_error - ("Symbol '%s' in COMMON at %C cannot be a POINTER array", - sym->name); + gfc_error ("Symbol '%s' in COMMON at %C cannot be a " + "POINTER array", sym->name); goto cleanup; } @@ -2439,9 +2437,9 @@ gfc_match_common (void) if (sym->attr.in_equivalence) { for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next) - { - for (e2 = e1; e2; e2 = e2->eq) - if (e2->expr->symtree->n.sym == sym) + { + for (e2 = e1; e2; e2 = e2->eq) + if (e2->expr->symtree->n.sym == sym) goto equiv_found; continue; @@ -2452,13 +2450,12 @@ gfc_match_common (void) { other = e2->expr->symtree->n.sym; if (other->common_head - && other->common_head != sym->common_head) + && other->common_head != sym->common_head) { gfc_error ("Symbol '%s', in COMMON block '%s' at " "%C is being indirectly equivalenced to " "another COMMON block '%s'", - sym->name, - sym->common_head->name, + sym->name, sym->common_head->name, other->common_head->name); goto cleanup; } @@ -2532,7 +2529,7 @@ gfc_match_block_data (void) /* Free a namelist structure. */ void -gfc_free_namelist (gfc_namelist * name) +gfc_free_namelist (gfc_namelist *name) { gfc_namelist *n; @@ -2563,9 +2560,9 @@ gfc_match_namelist (void) { if (group_name->ts.type != BT_UNKNOWN) { - gfc_error - ("Namelist group name '%s' at %C already has a basic type " - "of %s", group_name->name, gfc_typename (&group_name->ts)); + gfc_error ("Namelist group name '%s' at %C already has a basic " + "type of %s", group_name->name, + gfc_typename (&group_name->ts)); return MATCH_ERROR; } @@ -2574,7 +2571,7 @@ gfc_match_namelist (void) && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' " "at %C already is USE associated and can" "not be respecified.", group_name->name) - == FAILURE) + == FAILURE) return MATCH_ERROR; if (group_name->attr.flavor != FL_NAMELIST @@ -2598,15 +2595,15 @@ gfc_match_namelist (void) these are the only errors for the next two lines. */ if (sym->as && sym->as->type == AS_ASSUMED_SIZE) { - gfc_error ("Assumed size array '%s' in namelist '%s'at " - "%C is not allowed.", sym->name, group_name->name); + gfc_error ("Assumed size array '%s' in namelist '%s' at " + "%C is not allowed", sym->name, group_name->name); gfc_error_check (); } if (sym->as && sym->as->type == AS_ASSUMED_SHAPE - && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in " - "namelist '%s' at %C is an extension.", - sym->name, group_name->name) == FAILURE) + && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in " + "namelist '%s' at %C is an extension.", + sym->name, group_name->name) == FAILURE) gfc_error_check (); nl = gfc_get_namelist (); @@ -2675,15 +2672,13 @@ gfc_match_module (void) do this. */ void -gfc_free_equiv (gfc_equiv * eq) +gfc_free_equiv (gfc_equiv *eq) { - if (eq == NULL) return; gfc_free_equiv (eq->eq); gfc_free_equiv (eq->next); - gfc_free_expr (eq->expr); gfc_free (eq); } @@ -2741,16 +2736,14 @@ gfc_match_equivalence (void) for (ref = set->expr->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) { - gfc_error - ("Array reference in EQUIVALENCE at %C cannot be an " - "array section"); + gfc_error ("Array reference in EQUIVALENCE at %C cannot " + "be an array section"); goto cleanup; } sym = set->expr->symtree->n.sym; - if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) - == FAILURE) + if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE) goto cleanup; if (sym->attr.in_common) @@ -2787,8 +2780,7 @@ gfc_match_equivalence (void) { gfc_error ("Attempt to indirectly overlap COMMON " "blocks %s and %s by EQUIVALENCE at %C", - sym->common_head->name, - common_head->name); + sym->common_head->name, common_head->name); goto cleanup; } sym->attr.in_common = 1; @@ -2816,6 +2808,7 @@ cleanup: return MATCH_ERROR; } + /* Check that a statement function is not recursive. This is done by looking for the statement function symbol(sym) by looking recursively through its expression(e). If a reference to sym is found, true is returned. @@ -2838,8 +2831,7 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) case EXPR_FUNCTION: for (arg = e->value.function.actual; arg; arg = arg->next) { - if (sym->name == arg->name - || recursive_stmt_fcn (arg->expr, sym)) + if (sym->name == arg->name || recursive_stmt_fcn (arg->expr, sym)) return true; } @@ -2852,8 +2844,8 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) /* Catch recursion via other statement functions. */ if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION - && e->symtree->n.sym->value - && recursive_stmt_fcn (e->symtree->n.sym->value, sym)) + && e->symtree->n.sym->value + && recursive_stmt_fcn (e->symtree->n.sym->value, sym)) return true; if (e->symtree->n.sym->ts.type == BT_UNKNOWN) @@ -2871,7 +2863,7 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) case EXPR_OP: if (recursive_stmt_fcn (e->value.op.op1, sym) - || recursive_stmt_fcn (e->value.op.op2, sym)) + || recursive_stmt_fcn (e->value.op.op2, sym)) return true; break; @@ -2890,15 +2882,15 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) for (i = 0; i < ref->u.ar.dimen; i++) { if (recursive_stmt_fcn (ref->u.ar.start[i], sym) - || recursive_stmt_fcn (ref->u.ar.end[i], sym) - || recursive_stmt_fcn (ref->u.ar.stride[i], sym)) + || recursive_stmt_fcn (ref->u.ar.end[i], sym) + || recursive_stmt_fcn (ref->u.ar.stride[i], sym)) return true; } break; case REF_SUBSTRING: if (recursive_stmt_fcn (ref->u.ss.start, sym) - || recursive_stmt_fcn (ref->u.ss.end, sym)) + || recursive_stmt_fcn (ref->u.ss.end, sym)) return true; break; @@ -2947,8 +2939,7 @@ gfc_match_st_function (void) if (recursive_stmt_fcn (expr, sym)) { - gfc_error ("Statement function at %L is recursive", - &expr->where); + gfc_error ("Statement function at %L is recursive", &expr->where); return MATCH_ERROR; } @@ -2967,7 +2958,7 @@ undo_error: /* Free a single case structure. */ static void -free_case (gfc_case * p) +free_case (gfc_case *p) { if (p->low == p->high) p->high = NULL; @@ -2980,7 +2971,7 @@ free_case (gfc_case * p) /* Free a list of case structures. */ void -gfc_free_case_list (gfc_case * p) +gfc_free_case_list (gfc_case *p) { gfc_case *q; @@ -2995,7 +2986,7 @@ gfc_free_case_list (gfc_case * p) /* Match a single case selector. */ static match -match_case_selector (gfc_case ** cp) +match_case_selector (gfc_case **cp) { gfc_case *c; match m; @@ -3011,7 +3002,6 @@ match_case_selector (gfc_case ** cp) if (m == MATCH_ERROR) goto cleanup; } - else { m = gfc_match_init_expr (&c->low); @@ -3225,7 +3215,7 @@ cleanup: /* Match a WHERE statement. */ match -gfc_match_where (gfc_statement * st) +gfc_match_where (gfc_statement *st) { gfc_expr *expr; match m0, m; @@ -3242,7 +3232,6 @@ gfc_match_where (gfc_statement * st) if (gfc_match_eos () == MATCH_YES) { *st = ST_WHERE_BLOCK; - new_st.op = EXEC_WHERE; new_st.expr = expr; return MATCH_YES; @@ -3343,19 +3332,17 @@ cleanup: /* Free a list of FORALL iterators. */ void -gfc_free_forall_iterator (gfc_forall_iterator * iter) +gfc_free_forall_iterator (gfc_forall_iterator *iter) { gfc_forall_iterator *next; while (iter) { next = iter->next; - gfc_free_expr (iter->var); gfc_free_expr (iter->start); gfc_free_expr (iter->end); gfc_free_expr (iter->stride); - gfc_free (iter); iter = next; } @@ -3367,7 +3354,7 @@ gfc_free_forall_iterator (gfc_forall_iterator * iter) = :[:][, ] */ static match -match_forall_iterator (gfc_forall_iterator ** result) +match_forall_iterator (gfc_forall_iterator **result) { gfc_forall_iterator *iter; locus where; @@ -3424,8 +3411,8 @@ cleanup: /* Make sure that potential internal function references in the mask do not get messed up. */ if (iter->var - && iter->var->expr_type == EXPR_VARIABLE - && iter->var->symtree->n.sym->refs == 1) + && iter->var->expr_type == EXPR_VARIABLE + && iter->var->symtree->n.sym->refs == 1) iter->var->symtree->n.sym->attr.flavor = FL_UNKNOWN; gfc_current_locus = where; @@ -3437,7 +3424,7 @@ cleanup: /* Match the header of a FORALL statement. */ static match -match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask) +match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) { gfc_forall_iterator *head, *tail, *new; gfc_expr *msk; @@ -3503,8 +3490,8 @@ cleanup: return MATCH_ERROR; } -/* Match the rest of a simple FORALL statement that follows an IF statement. - */ +/* Match the rest of a simple FORALL statement that follows an + IF statement. */ static match match_simple_forall (void) @@ -3570,7 +3557,7 @@ cleanup: /* Match a FORALL statement. */ match -gfc_match_forall (gfc_statement * st) +gfc_match_forall (gfc_statement *st) { gfc_forall_iterator *head; gfc_expr *mask; @@ -3598,11 +3585,9 @@ gfc_match_forall (gfc_statement * st) if (gfc_match_eos () == MATCH_YES) { *st = ST_FORALL_BLOCK; - new_st.op = EXEC_FORALL; new_st.expr = mask; new_st.ext.forall_iterator = head; - return MATCH_YES; } @@ -3627,7 +3612,6 @@ gfc_match_forall (gfc_statement * st) new_st.expr = mask; new_st.ext.forall_iterator = head; new_st.block = gfc_get_code (); - new_st.block->op = EXEC_FORALL; new_st.block->next = c;