X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Fmatch.c;h=44da1bb97bd1205064a21cd21551319f11b033c7;hb=857616f6172b13aec886bb0b3e2e166f5e75622b;hp=18b943d042723079fbe715380a94dba2fd8ed0d8;hpb=f47957c745a8e05f0bd4615780ffe78c6200a003;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 18b943d0427..44da1bb97bd 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1,13 +1,14 @@ /* Matching subroutines in all sizes, shapes and colors. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 - Free Software Foundation, Inc. + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, + 2009, 2010 + 2010 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. GCC is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free -Software Foundation; either version 2, or (at your option) any later +Software Foundation; either version 3, or (at your option) any later version. GCC is distributed in the hope that it will be useful, but WITHOUT ANY @@ -16,9 +17,8 @@ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License -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. */ +along with GCC; see the file COPYING3. If not see +. */ #include "config.h" #include "system.h" @@ -27,83 +27,217 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA #include "match.h" #include "parse.h" -/* For matching and debugging purposes. Order matters here! The - unary operators /must/ precede the binary plus and minus, or - the expression parser breaks. */ - -mstring intrinsic_operators[] = { - minit ("+", INTRINSIC_UPLUS), - minit ("-", INTRINSIC_UMINUS), - minit ("+", INTRINSIC_PLUS), - minit ("-", INTRINSIC_MINUS), - minit ("**", INTRINSIC_POWER), - minit ("//", INTRINSIC_CONCAT), - minit ("*", INTRINSIC_TIMES), - minit ("/", INTRINSIC_DIVIDE), - minit (".and.", INTRINSIC_AND), - minit (".or.", INTRINSIC_OR), - minit (".eqv.", INTRINSIC_EQV), - minit (".neqv.", INTRINSIC_NEQV), - minit (".eq.", INTRINSIC_EQ_OS), - minit ("==", INTRINSIC_EQ), - minit (".ne.", INTRINSIC_NE_OS), - minit ("/=", INTRINSIC_NE), - minit (".ge.", INTRINSIC_GE_OS), - minit (">=", INTRINSIC_GE), - minit (".le.", INTRINSIC_LE_OS), - minit ("<=", INTRINSIC_LE), - minit (".lt.", INTRINSIC_LT_OS), - minit ("<", INTRINSIC_LT), - minit (".gt.", INTRINSIC_GT_OS), - minit (">", INTRINSIC_GT), - minit (".not.", INTRINSIC_NOT), - minit ("parens", INTRINSIC_PARENTHESES), - minit (NULL, INTRINSIC_NONE) -}; +int gfc_matching_ptr_assignment = 0; +int gfc_matching_procptr_assignment = 0; +bool gfc_matching_prefix = false; + +/* Stack of SELECT TYPE statements. */ +gfc_select_type_stack *select_type_stack = NULL; + +/* For debugging and diagnostic purposes. Return the textual representation + of the intrinsic operator OP. */ +const char * +gfc_op2string (gfc_intrinsic_op op) +{ + switch (op) + { + case INTRINSIC_UPLUS: + case INTRINSIC_PLUS: + return "+"; + + case INTRINSIC_UMINUS: + case INTRINSIC_MINUS: + return "-"; + + case INTRINSIC_POWER: + return "**"; + case INTRINSIC_CONCAT: + return "//"; + case INTRINSIC_TIMES: + return "*"; + case INTRINSIC_DIVIDE: + return "/"; + + case INTRINSIC_AND: + return ".and."; + case INTRINSIC_OR: + return ".or."; + case INTRINSIC_EQV: + return ".eqv."; + case INTRINSIC_NEQV: + return ".neqv."; + + case INTRINSIC_EQ_OS: + return ".eq."; + case INTRINSIC_EQ: + return "=="; + case INTRINSIC_NE_OS: + return ".ne."; + case INTRINSIC_NE: + return "/="; + case INTRINSIC_GE_OS: + return ".ge."; + case INTRINSIC_GE: + return ">="; + case INTRINSIC_LE_OS: + return ".le."; + case INTRINSIC_LE: + return "<="; + case INTRINSIC_LT_OS: + return ".lt."; + case INTRINSIC_LT: + return "<"; + case INTRINSIC_GT_OS: + return ".gt."; + case INTRINSIC_GT: + return ">"; + case INTRINSIC_NOT: + return ".not."; + + case INTRINSIC_ASSIGN: + return "="; + + case INTRINSIC_PARENTHESES: + return "parens"; + + default: + break; + } + + gfc_internal_error ("gfc_op2string(): Bad code"); + /* Not reached. */ +} /******************** Generic matching subroutines ************************/ +/* This function scans the current statement counting the opened and closed + parenthesis to make sure they are balanced. */ + +match +gfc_match_parens (void) +{ + locus old_loc, where; + int count; + gfc_instring instring; + gfc_char_t c, quote; + + old_loc = gfc_current_locus; + count = 0; + instring = NONSTRING; + quote = ' '; + + for (;;) + { + c = gfc_next_char_literal (instring); + if (c == '\n') + break; + if (quote == ' ' && ((c == '\'') || (c == '"'))) + { + quote = c; + instring = INSTRING_WARN; + continue; + } + if (quote != ' ' && c == quote) + { + quote = ' '; + instring = NONSTRING; + continue; + } + + if (c == '(' && quote == ' ') + { + count++; + where = gfc_current_locus; + } + if (c == ')' && quote == ' ') + { + count--; + where = gfc_current_locus; + } + } + + gfc_current_locus = old_loc; + + if (count > 0) + { + gfc_error ("Missing ')' in statement at or before %L", &where); + return MATCH_ERROR; + } + if (count < 0) + { + gfc_error ("Missing '(' in statement at or before %L", &where); + return MATCH_ERROR; + } + + return MATCH_YES; +} + + /* See if the next character is a special character that has escaped by a \ via the -fbackslash option. */ match -gfc_match_special_char (int *c) +gfc_match_special_char (gfc_char_t *res) { - + int len, i; + gfc_char_t c, n; match m; m = MATCH_YES; - switch (gfc_next_char_literal (1)) + switch ((c = gfc_next_char_literal (INSTRING_WARN))) { case 'a': - *c = '\a'; + *res = '\a'; break; case 'b': - *c = '\b'; + *res = '\b'; break; case 't': - *c = '\t'; + *res = '\t'; break; case 'f': - *c = '\f'; + *res = '\f'; break; case 'n': - *c = '\n'; + *res = '\n'; break; case 'r': - *c = '\r'; + *res = '\r'; break; case 'v': - *c = '\v'; + *res = '\v'; break; case '\\': - *c = '\\'; + *res = '\\'; break; case '0': - *c = '\0'; + *res = '\0'; + break; + + case 'x': + case 'u': + case 'U': + /* Hexadecimal form of wide characters. */ + len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8)); + n = 0; + for (i = 0; i < len; i++) + { + char buf[2] = { '\0', '\0' }; + + c = gfc_next_char_literal (INSTRING_WARN); + if (!gfc_wide_fits_in_byte (c) + || !gfc_check_digit ((unsigned char) c, 16)) + return MATCH_NO; + + buf[0] = (unsigned char) c; + n = n << 4; + n += strtol (buf, NULL, 16); + } + *res = n; break; + default: /* Unknown backslash codes are simply not expanded. */ m = MATCH_NO; @@ -121,14 +255,14 @@ match gfc_match_space (void) { locus old_loc; - int c; + char c; if (gfc_current_form == FORM_FIXED) return MATCH_YES; old_loc = gfc_current_locus; - c = gfc_next_char (); + c = gfc_next_ascii_char (); if (!gfc_is_whitespace (c)) { gfc_current_locus = old_loc; @@ -149,7 +283,8 @@ match gfc_match_eos (void) { locus old_loc; - int flag, c; + int flag; + char c; flag = 0; @@ -158,13 +293,13 @@ gfc_match_eos (void) old_loc = gfc_current_locus; gfc_gobble_whitespace (); - c = gfc_next_char (); + c = gfc_next_ascii_char (); switch (c) { case '!': do { - c = gfc_next_char (); + c = gfc_next_ascii_char (); } while (c != '\n'); @@ -200,8 +335,9 @@ gfc_match_small_literal_int (int *value, int *cnt) old_loc = gfc_current_locus; + *value = -1; gfc_gobble_whitespace (); - c = gfc_next_char (); + c = gfc_next_ascii_char (); if (cnt) *cnt = 0; @@ -217,7 +353,7 @@ gfc_match_small_literal_int (int *value, int *cnt) for (;;) { old_loc = gfc_current_locus; - c = gfc_next_char (); + c = gfc_next_ascii_char (); if (!ISDIGIT (c)) break; @@ -377,90 +513,6 @@ gfc_match_label (void) } -/* Try and match the input against an array of possibilities. If one - potential matching string is a substring of another, the longest - match takes precedence. Spaces in the target strings are optional - spaces that do not necessarily have to be found in the input - stream. In fixed mode, spaces never appear. If whitespace is - matched, it matches unlimited whitespace in the input. For this - reason, the 'mp' member of the mstring structure is used to track - the progress of each potential match. - - If there is no match we return the tag associated with the - terminating NULL mstring structure and leave the locus pointer - where it started. If there is a match we return the tag member of - the matched mstring and leave the locus pointer after the matched - character. - - A '%' character is a mandatory space. */ - -int -gfc_match_strings (mstring *a) -{ - mstring *p, *best_match; - int no_match, c, possibles; - locus match_loc; - - possibles = 0; - - for (p = a; p->string != NULL; p++) - { - p->mp = p->string; - possibles++; - } - - no_match = p->tag; - - best_match = NULL; - match_loc = gfc_current_locus; - - gfc_gobble_whitespace (); - - while (possibles > 0) - { - c = gfc_next_char (); - - /* Apply the next character to the current possibilities. */ - for (p = a; p->string != NULL; p++) - { - if (p->mp == NULL) - continue; - - if (*p->mp == ' ') - { - /* Space matches 1+ whitespace(s). */ - if ((gfc_current_form == FORM_FREE) && gfc_is_whitespace (c)) - continue; - - p->mp++; - } - - if (*p->mp != c) - { - /* Match failed. */ - p->mp = NULL; - possibles--; - continue; - } - - p->mp++; - if (*p->mp == '\0') - { - /* Found a match. */ - match_loc = gfc_current_locus; - best_match = p; - possibles--; - p->mp = NULL; - } - } - } - - gfc_current_locus = match_loc; - - return (best_match == NULL) ? no_match : best_match->tag; -} - - /* See if the current input looks like a name of some sort. Modifies the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long. Note that options.c restricts max_identifier_length to not more @@ -470,15 +522,16 @@ match gfc_match_name (char *buffer) { locus old_loc; - int i, c; + int i; + char c; old_loc = gfc_current_locus; gfc_gobble_whitespace (); - c = gfc_next_char (); + c = gfc_next_ascii_char (); if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore))) { - if (gfc_error_flag_test() == 0) + if (gfc_error_flag_test() == 0 && c != '(') gfc_error ("Invalid character in name at %C"); gfc_current_locus = old_loc; return MATCH_NO; @@ -497,10 +550,17 @@ gfc_match_name (char *buffer) } old_loc = gfc_current_locus; - c = gfc_next_char (); + c = gfc_next_ascii_char (); } while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$')); + if (c == '$' && !gfc_option.flag_dollar_ok) + { + gfc_error ("Invalid character '$' at %C. Use -fdollar-ok to allow it " + "as an extension"); + return MATCH_ERROR; + } + buffer[i] = '\0'; gfc_current_locus = old_loc; @@ -526,14 +586,14 @@ gfc_match_name_C (char *buffer) { locus old_loc; int i = 0; - int c; + gfc_char_t c; old_loc = gfc_current_locus; gfc_gobble_whitespace (); /* Get the next char (first possible char of name) and see if it's valid for C (either a letter or an underscore). */ - c = gfc_next_char_literal (1); + c = gfc_next_char_literal (INSTRING_WARN); /* If the user put nothing expect spaces between the quotes, it is valid and simply means there is no name= specifier and the name is the fortran @@ -554,7 +614,9 @@ gfc_match_name_C (char *buffer) /* Continue to read valid variable name characters. */ do { - buffer[i++] = c; + gcc_assert (gfc_wide_fits_in_byte (c)); + + buffer[i++] = (unsigned char) c; /* C does not define a maximum length of variable names, to my knowledge, but the compiler typically places a limit on them. @@ -571,7 +633,7 @@ gfc_match_name_C (char *buffer) old_loc = gfc_current_locus; /* Get next char; param means we're in a string. */ - c = gfc_next_char_literal (1); + c = gfc_next_char_literal (INSTRING_WARN); } while (ISALNUM (c) || c == '_'); buffer[i] = '\0'; @@ -581,7 +643,7 @@ gfc_match_name_C (char *buffer) if (c == ' ') { gfc_gobble_whitespace (); - c = gfc_peek_char (); + c = gfc_peek_ascii_char (); if (c != '"' && c != '\'') { gfc_error ("Embedded space in NAME= specifier at %C"); @@ -618,7 +680,7 @@ gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc) return (gfc_get_ha_sym_tree (buffer, matched_symbol)) ? MATCH_ERROR : MATCH_YES; - if (gfc_get_sym_tree (buffer, NULL, matched_symbol)) + if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false)) return MATCH_ERROR; return MATCH_YES; @@ -653,15 +715,224 @@ gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc) match gfc_match_intrinsic_op (gfc_intrinsic_op *result) { - gfc_intrinsic_op op; + locus orig_loc = gfc_current_locus; + char ch; - op = (gfc_intrinsic_op) gfc_match_strings (intrinsic_operators); + gfc_gobble_whitespace (); + ch = gfc_next_ascii_char (); + switch (ch) + { + case '+': + /* Matched "+". */ + *result = INTRINSIC_PLUS; + return MATCH_YES; - if (op == INTRINSIC_NONE) - return MATCH_NO; + case '-': + /* Matched "-". */ + *result = INTRINSIC_MINUS; + return MATCH_YES; - *result = op; - return MATCH_YES; + case '=': + if (gfc_next_ascii_char () == '=') + { + /* Matched "==". */ + *result = INTRINSIC_EQ; + return MATCH_YES; + } + break; + + case '<': + if (gfc_peek_ascii_char () == '=') + { + /* Matched "<=". */ + gfc_next_ascii_char (); + *result = INTRINSIC_LE; + return MATCH_YES; + } + /* Matched "<". */ + *result = INTRINSIC_LT; + return MATCH_YES; + + case '>': + if (gfc_peek_ascii_char () == '=') + { + /* Matched ">=". */ + gfc_next_ascii_char (); + *result = INTRINSIC_GE; + return MATCH_YES; + } + /* Matched ">". */ + *result = INTRINSIC_GT; + return MATCH_YES; + + case '*': + if (gfc_peek_ascii_char () == '*') + { + /* Matched "**". */ + gfc_next_ascii_char (); + *result = INTRINSIC_POWER; + return MATCH_YES; + } + /* Matched "*". */ + *result = INTRINSIC_TIMES; + return MATCH_YES; + + case '/': + ch = gfc_peek_ascii_char (); + if (ch == '=') + { + /* Matched "/=". */ + gfc_next_ascii_char (); + *result = INTRINSIC_NE; + return MATCH_YES; + } + else if (ch == '/') + { + /* Matched "//". */ + gfc_next_ascii_char (); + *result = INTRINSIC_CONCAT; + return MATCH_YES; + } + /* Matched "/". */ + *result = INTRINSIC_DIVIDE; + return MATCH_YES; + + case '.': + ch = gfc_next_ascii_char (); + switch (ch) + { + case 'a': + if (gfc_next_ascii_char () == 'n' + && gfc_next_ascii_char () == 'd' + && gfc_next_ascii_char () == '.') + { + /* Matched ".and.". */ + *result = INTRINSIC_AND; + return MATCH_YES; + } + break; + + case 'e': + if (gfc_next_ascii_char () == 'q') + { + ch = gfc_next_ascii_char (); + if (ch == '.') + { + /* Matched ".eq.". */ + *result = INTRINSIC_EQ_OS; + return MATCH_YES; + } + else if (ch == 'v') + { + if (gfc_next_ascii_char () == '.') + { + /* Matched ".eqv.". */ + *result = INTRINSIC_EQV; + return MATCH_YES; + } + } + } + break; + + case 'g': + ch = gfc_next_ascii_char (); + if (ch == 'e') + { + if (gfc_next_ascii_char () == '.') + { + /* Matched ".ge.". */ + *result = INTRINSIC_GE_OS; + return MATCH_YES; + } + } + else if (ch == 't') + { + if (gfc_next_ascii_char () == '.') + { + /* Matched ".gt.". */ + *result = INTRINSIC_GT_OS; + return MATCH_YES; + } + } + break; + + case 'l': + ch = gfc_next_ascii_char (); + if (ch == 'e') + { + if (gfc_next_ascii_char () == '.') + { + /* Matched ".le.". */ + *result = INTRINSIC_LE_OS; + return MATCH_YES; + } + } + else if (ch == 't') + { + if (gfc_next_ascii_char () == '.') + { + /* Matched ".lt.". */ + *result = INTRINSIC_LT_OS; + return MATCH_YES; + } + } + break; + + case 'n': + ch = gfc_next_ascii_char (); + if (ch == 'e') + { + ch = gfc_next_ascii_char (); + if (ch == '.') + { + /* Matched ".ne.". */ + *result = INTRINSIC_NE_OS; + return MATCH_YES; + } + else if (ch == 'q') + { + if (gfc_next_ascii_char () == 'v' + && gfc_next_ascii_char () == '.') + { + /* Matched ".neqv.". */ + *result = INTRINSIC_NEQV; + return MATCH_YES; + } + } + } + else if (ch == 'o') + { + if (gfc_next_ascii_char () == 't' + && gfc_next_ascii_char () == '.') + { + /* Matched ".not.". */ + *result = INTRINSIC_NOT; + return MATCH_YES; + } + } + break; + + case 'o': + if (gfc_next_ascii_char () == 'r' + && gfc_next_ascii_char () == '.') + { + /* Matched ".or.". */ + *result = INTRINSIC_OR; + return MATCH_YES; + } + break; + + default: + break; + } + break; + + default: + break; + } + + gfc_current_locus = orig_loc; + return MATCH_NO; } @@ -681,6 +952,8 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag) locus start; match m; + e1 = e2 = e3 = NULL; + /* Match the start of an iterator without affecting the symbol table. */ start = gfc_current_locus; @@ -694,23 +967,21 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag) if (m != MATCH_YES) return MATCH_NO; - gfc_match_char ('='); - - e1 = e2 = e3 = NULL; - - if (var->ref != NULL) + /* F2008, C617 & C565. */ + if (var->symtree->n.sym->attr.codimension) { - gfc_error ("Loop variable at %C cannot be a sub-component"); + gfc_error ("Loop variable at %C cannot be a coarray"); goto cleanup; } - if (var->symtree->n.sym->attr.intent == INTENT_IN) + if (var->ref != NULL) { - gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)", - var->symtree->n.sym->name); + gfc_error ("Loop variable at %C cannot be a sub-component"); goto cleanup; } + gfc_match_char ('='); + var->symtree->n.sym->attr.implied_index = 1; m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1); @@ -730,7 +1001,7 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag) if (gfc_match_char (',') != MATCH_YES) { - e3 = gfc_int_expr (1); + e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); goto done; } @@ -773,7 +1044,7 @@ gfc_match_char (char c) where = gfc_current_locus; gfc_gobble_whitespace (); - if (gfc_next_char () == c) + if (gfc_next_ascii_char () == c) return MATCH_YES; gfc_current_locus = where; @@ -923,7 +1194,12 @@ loop: } default: - if (c == gfc_next_char ()) + + /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't + expect an upper case character here! */ + gcc_assert (TOLOWER (c) == c); + + if (c == gfc_next_ascii_char ()) goto loop; break; } @@ -959,7 +1235,7 @@ not_yes: case 'e': case 'v': vp = va_arg (argp, void **); - gfc_free_expr (*vp); + gfc_free_expr ((struct gfc_expr *)*vp); *vp = NULL; break; } @@ -1023,15 +1299,6 @@ 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) @@ -1045,7 +1312,7 @@ gfc_match_assignment (void) gfc_set_sym_referenced (lvalue->symtree->n.sym); new_st.op = EXEC_ASSIGN; - new_st.expr = lvalue; + new_st.expr1 = lvalue; new_st.expr2 = rvalue; gfc_check_do_variable (lvalue->symtree); @@ -1066,6 +1333,8 @@ gfc_match_pointer_assignment (void) old_loc = gfc_current_locus; lvalue = rvalue = NULL; + gfc_matching_ptr_assignment = 0; + gfc_matching_procptr_assignment = 0; m = gfc_match (" %v =>", &lvalue); if (m != MATCH_YES) @@ -1074,20 +1343,20 @@ gfc_match_pointer_assignment (void) goto cleanup; } + if (lvalue->symtree->n.sym->attr.proc_pointer + || gfc_is_proc_ptr_comp (lvalue, NULL)) + gfc_matching_procptr_assignment = 1; + else + gfc_matching_ptr_assignment = 1; + m = gfc_match (" %e%t", &rvalue); + gfc_matching_ptr_assignment = 0; + gfc_matching_procptr_assignment = 0; 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.expr1 = lvalue; new_st.expr2 = rvalue; return MATCH_YES; @@ -1124,13 +1393,13 @@ match_arithmetic_if (void) return MATCH_ERROR; } - if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF statement " - "at %C") == FAILURE) + if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF " + "statement at %C") == FAILURE) return MATCH_ERROR; new_st.op = EXEC_ARITHMETIC_IF; - new_st.expr = expr; - new_st.label = l1; + new_st.expr1 = expr; + new_st.label1 = l1; new_st.label2 = l2; new_st.label3 = l3; @@ -1156,7 +1425,7 @@ gfc_match_if (gfc_statement *if_type) { gfc_expr *expr; gfc_st_label *l1, *l2, *l3; - locus old_loc; + locus old_loc, old_loc2; gfc_code *p; match m, n; @@ -1170,6 +1439,14 @@ gfc_match_if (gfc_statement *if_type) if (m != MATCH_YES) return m; + old_loc2 = gfc_current_locus; + gfc_current_locus = old_loc; + + if (gfc_match_parens () == MATCH_ERROR) + return MATCH_ERROR; + + gfc_current_locus = old_loc2; + if (gfc_match_char (')') != MATCH_YES) { gfc_error ("Syntax error in IF-expression at %C"); @@ -1197,13 +1474,13 @@ gfc_match_if (gfc_statement *if_type) return MATCH_ERROR; } - if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF " + if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF " "statement at %C") == FAILURE) return MATCH_ERROR; new_st.op = EXEC_ARITHMETIC_IF; - new_st.expr = expr; - new_st.label = l1; + new_st.expr1 = expr; + new_st.label1 = l1; new_st.label2 = l2; new_st.label3 = l3; @@ -1214,14 +1491,14 @@ gfc_match_if (gfc_statement *if_type) if (gfc_match (" then%t") == MATCH_YES) { new_st.op = EXEC_IF; - new_st.expr = expr; + new_st.expr1 = expr; *if_type = ST_IF_BLOCK; return MATCH_YES; } if (n == MATCH_YES) { - gfc_error ("Block label is not appropriate IF statement at %C"); + gfc_error ("Block label is not appropriate for IF statement at %C"); gfc_free_expr (expr); return MATCH_ERROR; } @@ -1277,6 +1554,7 @@ gfc_match_if (gfc_statement *if_type) match ("cycle", gfc_match_cycle, ST_CYCLE) match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE) match ("end file", gfc_match_endfile, ST_END_FILE) + match ("error stop", gfc_match_error_stop, ST_ERROR_STOP) match ("exit", gfc_match_exit, ST_EXIT) match ("flush", gfc_match_flush, ST_FLUSH) match ("forall", match_simple_forall, ST_FORALL) @@ -1291,6 +1569,10 @@ gfc_match_if (gfc_statement *if_type) match ("return", gfc_match_return, ST_RETURN) match ("rewind", gfc_match_rewind, ST_REWIND) match ("stop", gfc_match_stop, ST_STOP) + match ("wait", gfc_match_wait, ST_WAIT) + match ("sync all", gfc_match_sync_all, ST_SYNC_CALL); + match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); + match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); match ("where", match_simple_where, ST_WHERE) match ("write", gfc_match_write, ST_WRITE) @@ -1333,7 +1615,7 @@ got_match: *p->next = new_st; p->next->loc = gfc_current_locus; - p->expr = expr; + p->expr1 = expr; p->op = EXEC_IF; gfc_clear_new_st (); @@ -1409,7 +1691,7 @@ gfc_match_elseif (void) done: new_st.op = EXEC_IF; - new_st.expr = expr; + new_st.expr1 = expr; return MATCH_YES; cleanup: @@ -1437,45 +1719,219 @@ gfc_free_iterator (gfc_iterator *iter, int flag) } -/* Match a DO statement. */ - +/* Match a CRITICAL statement. */ match -gfc_match_do (void) +gfc_match_critical (void) { - gfc_iterator iter, *ip; - locus old_loc; - gfc_st_label *label; - match m; + gfc_st_label *label = NULL; - old_loc = gfc_current_locus; - - label = NULL; - iter.var = iter.start = iter.end = iter.step = NULL; - - m = gfc_match_label (); - if (m == MATCH_ERROR) - return m; + if (gfc_match_label () == MATCH_ERROR) + return MATCH_ERROR; - if (gfc_match (" do") != MATCH_YES) + if (gfc_match (" critical") != MATCH_YES) return MATCH_NO; - m = gfc_match_st_label (&label); - if (m == MATCH_ERROR) - goto cleanup; + if (gfc_match_st_label (&label) == MATCH_ERROR) + return MATCH_ERROR; - /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */ + if (gfc_match_eos () != MATCH_YES) + { + gfc_syntax_error (ST_CRITICAL); + return MATCH_ERROR; + } - if (gfc_match_eos () == MATCH_YES) + if (gfc_pure (NULL)) { - iter.end = gfc_logical_expr (1, NULL); - new_st.op = EXEC_DO_WHILE; - goto done; + gfc_error ("Image control statement CRITICAL at %C in PURE procedure"); + return MATCH_ERROR; + } + + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CRITICAL statement at %C") + == FAILURE) + return MATCH_ERROR; + + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return MATCH_ERROR; + } + + if (gfc_find_state (COMP_CRITICAL) == SUCCESS) + { + gfc_error ("Nested CRITICAL block at %C"); + return MATCH_ERROR; + } + + new_st.op = EXEC_CRITICAL; + + if (label != NULL + && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) + return MATCH_ERROR; + + return MATCH_YES; +} + + +/* Match a BLOCK statement. */ + +match +gfc_match_block (void) +{ + match m; + + if (gfc_match_label () == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match (" block") != MATCH_YES) + return MATCH_NO; + + /* For this to be a correct BLOCK statement, the line must end now. */ + m = gfc_match_eos (); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + return MATCH_NO; + + return MATCH_YES; +} + + +/* Match an ASSOCIATE statement. */ + +match +gfc_match_associate (void) +{ + if (gfc_match_label () == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match (" associate") != MATCH_YES) + return MATCH_NO; + + /* Match the association list. */ + if (gfc_match_char ('(') != MATCH_YES) + { + gfc_error ("Expected association list at %C"); + return MATCH_ERROR; + } + new_st.ext.block.assoc = NULL; + while (true) + { + gfc_association_list* newAssoc = gfc_get_association_list (); + gfc_association_list* a; + + /* Match the next association. */ + if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target) + != MATCH_YES) + { + gfc_error ("Expected association at %C"); + goto assocListError; + } + newAssoc->where = gfc_current_locus; + + /* Check that the current name is not yet in the list. */ + for (a = new_st.ext.block.assoc; a; a = a->next) + if (!strcmp (a->name, newAssoc->name)) + { + gfc_error ("Duplicate name '%s' in association at %C", + newAssoc->name); + goto assocListError; + } + + /* The target expression must not be coindexed. */ + if (gfc_is_coindexed (newAssoc->target)) + { + gfc_error ("Association target at %C must not be coindexed"); + goto assocListError; + } + + /* The `variable' field is left blank for now; because the target is not + yet resolved, we can't use gfc_has_vector_subscript to determine it + for now. This is set during resolution. */ + + /* Put it into the list. */ + newAssoc->next = new_st.ext.block.assoc; + new_st.ext.block.assoc = newAssoc; + + /* Try next one or end if closing parenthesis is found. */ + gfc_gobble_whitespace (); + if (gfc_peek_char () == ')') + break; + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expected ')' or ',' at %C"); + return MATCH_ERROR; + } + + continue; + +assocListError: + gfc_free (newAssoc); + goto error; + } + if (gfc_match_char (')') != MATCH_YES) + { + /* This should never happen as we peek above. */ + gcc_unreachable (); + } + + if (gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after ASSOCIATE statement at %C"); + goto error; + } + + return MATCH_YES; + +error: + gfc_free_association_list (new_st.ext.block.assoc); + return MATCH_ERROR; +} + + +/* Match a DO statement. */ + +match +gfc_match_do (void) +{ + gfc_iterator iter, *ip; + locus old_loc; + gfc_st_label *label; + match m; + + old_loc = gfc_current_locus; + + label = NULL; + iter.var = iter.start = iter.end = iter.step = NULL; + + m = gfc_match_label (); + if (m == MATCH_ERROR) + return m; + + if (gfc_match (" do") != MATCH_YES) + return MATCH_NO; + + m = gfc_match_st_label (&label); + if (m == MATCH_ERROR) + goto cleanup; + + /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */ + + if (gfc_match_eos () == MATCH_YES) + { + iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true); + new_st.op = EXEC_DO_WHILE; + goto done; } /* Match an optional comma, if no comma is found, a space is obligatory. */ if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES) return MATCH_NO; + /* Check for balanced parens. */ + + if (gfc_match_parens () == MATCH_ERROR) + return MATCH_ERROR; + /* See if we have a DO WHILE. */ if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES) { @@ -1516,10 +1972,10 @@ done: && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) goto cleanup; - new_st.label = label; + new_st.label1 = label; if (new_st.op == EXEC_DO_WHILE) - new_st.expr = iter.end; + new_st.expr1 = iter.end; else { new_st.ext.iterator = ip = gfc_get_iterator (); @@ -1543,12 +1999,16 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) gfc_state_data *p, *o; gfc_symbol *sym; match m; + int cnt; if (gfc_match_eos () == MATCH_YES) sym = NULL; else { - m = gfc_match ("% %s%t", &sym); + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symtree* stree; + + m = gfc_match ("% %n%t", name); if (m == MATCH_ERROR) return MATCH_ERROR; if (m == MATCH_NO) @@ -1557,54 +2017,124 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) return MATCH_ERROR; } + /* Find the corresponding symbol. If there's a BLOCK statement + between here and the label, it is not in gfc_current_ns but a parent + namespace! */ + stree = gfc_find_symtree_in_proc (name, gfc_current_ns); + if (!stree) + { + gfc_error ("Name '%s' in %s statement at %C is unknown", + name, gfc_ascii_statement (st)); + return MATCH_ERROR; + } + + sym = stree->n.sym; if (sym->attr.flavor != FL_LABEL) { - gfc_error ("Name '%s' in %s statement at %C is not a loop name", - sym->name, gfc_ascii_statement (st)); + gfc_error ("Name '%s' in %s statement at %C is not a construct name", + name, gfc_ascii_statement (st)); return MATCH_ERROR; } } - /* Find the loop mentioned specified by the label (or lack of a label). */ + /* Find the loop specified by the label (or lack of a label). */ for (o = NULL, p = gfc_state_stack; p; p = p->previous) - if (p->state == COMP_DO && (sym == NULL || sym == p->sym)) - break; - else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK) + if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK) o = p; + else if (p->state == COMP_CRITICAL) + { + gfc_error("%s statement at %C leaves CRITICAL construct", + gfc_ascii_statement (st)); + return MATCH_ERROR; + } + else if ((sym && sym == p->sym) || (!sym && p->state == COMP_DO)) + break; if (p == NULL) { if (sym == NULL) - gfc_error ("%s statement at %C is not within a loop", + gfc_error ("%s statement at %C is not within a construct", gfc_ascii_statement (st)); else - gfc_error ("%s statement at %C is not within loop '%s'", + gfc_error ("%s statement at %C is not within construct '%s'", gfc_ascii_statement (st), sym->name); return MATCH_ERROR; } + /* Special checks for EXIT from non-loop constructs. */ + switch (p->state) + { + case COMP_DO: + break; + + case COMP_CRITICAL: + /* This is already handled above. */ + gcc_unreachable (); + + case COMP_ASSOCIATE: + case COMP_BLOCK: + case COMP_IF: + case COMP_SELECT: + case COMP_SELECT_TYPE: + gcc_assert (sym); + if (op == EXEC_CYCLE) + { + gfc_error ("CYCLE statement at %C is not applicable to non-loop" + " construct '%s'", sym->name); + return MATCH_ERROR; + } + gcc_assert (op == EXEC_EXIT); + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: EXIT statement with no" + " do-construct-name at %C") == FAILURE) + return MATCH_ERROR; + break; + + default: + gfc_error ("%s statement at %C is not applicable to construct '%s'", + gfc_ascii_statement (st), sym->name); + return MATCH_ERROR; + } + if (o != NULL) { gfc_error ("%s statement at %C leaving OpenMP structured block", gfc_ascii_statement (st)); return MATCH_ERROR; } - else if (st == ST_EXIT - && p->previous != NULL - && p->previous->state == COMP_OMP_STRUCTURED_BLOCK - && (p->previous->head->op == EXEC_OMP_DO - || p->previous->head->op == EXEC_OMP_PARALLEL_DO)) + + for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++) + o = o->previous; + if (cnt > 0 + && o != NULL + && o->state == COMP_OMP_STRUCTURED_BLOCK + && (o->head->op == EXEC_OMP_DO + || o->head->op == EXEC_OMP_PARALLEL_DO)) { - gcc_assert (p->previous->head->next != NULL); - gcc_assert (p->previous->head->next->op == EXEC_DO - || p->previous->head->next->op == EXEC_DO_WHILE); - gfc_error ("EXIT statement at %C terminating !$OMP DO loop"); - return MATCH_ERROR; + int collapse = 1; + gcc_assert (o->head->next != NULL + && (o->head->next->op == EXEC_DO + || o->head->next->op == EXEC_DO_WHILE) + && o->previous != NULL + && o->previous->tail->op == o->head->op); + if (o->previous->tail->ext.omp_clauses != NULL + && o->previous->tail->ext.omp_clauses->collapse > 1) + collapse = o->previous->tail->ext.omp_clauses->collapse; + if (st == ST_EXIT && cnt <= collapse) + { + gfc_error ("EXIT statement at %C terminating !$OMP DO loop"); + return MATCH_ERROR; + } + if (st == ST_CYCLE && cnt < collapse) + { + gfc_error ("CYCLE statement at %C to non-innermost collapsed" + " !$OMP DO loop"); + return MATCH_ERROR; + } } - /* Save the first statement in the loop - needed by the backend. */ - new_st.ext.whichloop = p->head; + /* Save the first statement in the construct - needed by the backend. */ + new_st.ext.which_construct = p->construct; new_st.op = op; @@ -1630,57 +2160,282 @@ gfc_match_cycle (void) } -/* Match a number or character constant after a STOP or PAUSE statement. */ +/* Match a number or character constant after an (ALL) STOP or PAUSE statement. */ static match gfc_match_stopcode (gfc_statement st) { - int stop_code; gfc_expr *e; match m; - int cnt; - stop_code = -1; e = NULL; if (gfc_match_eos () != MATCH_YES) { - m = gfc_match_small_literal_int (&stop_code, &cnt); + m = gfc_match_init_expr (&e); if (m == MATCH_ERROR) goto cleanup; + if (m == MATCH_NO) + goto syntax; - if (m == MATCH_YES && cnt > 5) + if (gfc_match_eos () != MATCH_YES) + goto syntax; + } + + if (gfc_pure (NULL)) + { + gfc_error ("%s statement not allowed in PURE procedure at %C", + gfc_ascii_statement (st)); + goto cleanup; + } + + if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS) + { + gfc_error ("Image control statement STOP at %C in CRITICAL block"); + goto cleanup; + } + + if (e != NULL) + { + if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER)) { - gfc_error ("Too many digits in STOP code at %C"); + gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type", + &e->where); goto cleanup; } + if (e->rank != 0) + { + gfc_error ("STOP code at %L must be scalar", + &e->where); + goto cleanup; + } + + if (e->ts.type == BT_CHARACTER + && e->ts.kind != gfc_default_character_kind) + { + gfc_error ("STOP code at %L must be default character KIND=%d", + &e->where, (int) gfc_default_character_kind); + goto cleanup; + } + + if (e->ts.type == BT_INTEGER + && e->ts.kind != gfc_default_integer_kind) + { + gfc_error ("STOP code at %L must be default integer KIND=%d", + &e->where, (int) gfc_default_integer_kind); + goto cleanup; + } + } + + switch (st) + { + case ST_STOP: + new_st.op = EXEC_STOP; + break; + case ST_ERROR_STOP: + new_st.op = EXEC_ERROR_STOP; + break; + case ST_PAUSE: + new_st.op = EXEC_PAUSE; + break; + default: + gcc_unreachable (); + } + + new_st.expr1 = e; + new_st.ext.stop_code = -1; + + return MATCH_YES; + +syntax: + gfc_syntax_error (st); + +cleanup: + + gfc_free_expr (e); + return MATCH_ERROR; +} + + +/* Match the (deprecated) PAUSE statement. */ + +match +gfc_match_pause (void) +{ + match m; + + m = gfc_match_stopcode (ST_PAUSE); + if (m == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement" + " at %C") + == FAILURE) + m = MATCH_ERROR; + } + return m; +} + + +/* Match the STOP statement. */ + +match +gfc_match_stop (void) +{ + return gfc_match_stopcode (ST_STOP); +} + + +/* Match the ERROR STOP statement. */ + +match +gfc_match_error_stop (void) +{ + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: ERROR STOP statement at %C") + == FAILURE) + return MATCH_ERROR; + + return gfc_match_stopcode (ST_ERROR_STOP); +} + + +/* Match SYNC ALL/IMAGES/MEMORY statement. Syntax: + SYNC ALL [(sync-stat-list)] + SYNC MEMORY [(sync-stat-list)] + SYNC IMAGES (image-set [, sync-stat-list] ) + with sync-stat is int-expr or *. */ + +static match +sync_statement (gfc_statement st) +{ + match m; + gfc_expr *tmp, *imageset, *stat, *errmsg; + bool saw_stat, saw_errmsg; + + tmp = imageset = stat = errmsg = NULL; + saw_stat = saw_errmsg = false; + + if (gfc_pure (NULL)) + { + gfc_error ("Image control statement SYNC at %C in PURE procedure"); + return MATCH_ERROR; + } + + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C") + == FAILURE) + return MATCH_ERROR; + + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return MATCH_ERROR; + } + + if (gfc_find_state (COMP_CRITICAL) == SUCCESS) + { + gfc_error ("Image control statement SYNC at %C in CRITICAL block"); + return MATCH_ERROR; + } + + if (gfc_match_eos () == MATCH_YES) + { + if (st == ST_SYNC_IMAGES) + goto syntax; + goto done; + } + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + if (st == ST_SYNC_IMAGES) + { + /* Denote '*' as imageset == NULL. */ + m = gfc_match_char ('*'); + if (m == MATCH_ERROR) + goto syntax; 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) + if (gfc_match ("%e", &imageset) != MATCH_YES) goto syntax; } + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + } - if (gfc_match_eos () != MATCH_YES) + for (;;) + { + m = gfc_match (" stat = %v", &tmp); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_YES) + { + if (saw_stat) + { + gfc_error ("Redundant STAT tag found at %L ", &tmp->where); + goto cleanup; + } + stat = tmp; + saw_stat = true; + + if (gfc_match_char (',') == MATCH_YES) + continue; + } + + m = gfc_match (" errmsg = %v", &tmp); + if (m == MATCH_ERROR) goto syntax; + if (m == MATCH_YES) + { + if (saw_errmsg) + { + gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where); + goto cleanup; + } + errmsg = tmp; + saw_errmsg = true; + + if (gfc_match_char (',') == MATCH_YES) + continue; + } + + gfc_gobble_whitespace (); + + if (gfc_peek_char () == ')') + break; + + goto syntax; } - if (gfc_pure (NULL)) + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + +done: + switch (st) { - gfc_error ("%s statement not allowed in PURE procedure at %C", - gfc_ascii_statement (st)); - goto cleanup; + case ST_SYNC_ALL: + new_st.op = EXEC_SYNC_ALL; + break; + case ST_SYNC_IMAGES: + new_st.op = EXEC_SYNC_IMAGES; + break; + case ST_SYNC_MEMORY: + new_st.op = EXEC_SYNC_MEMORY; + break; + default: + gcc_unreachable (); } - new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE; - new_st.expr = e; - new_st.ext.stop_code = stop_code; + new_st.expr1 = imageset; + new_st.expr2 = stat; + new_st.expr3 = errmsg; return MATCH_YES; @@ -1688,37 +2443,39 @@ syntax: gfc_syntax_error (st); cleanup: + gfc_free_expr (tmp); + gfc_free_expr (imageset); + gfc_free_expr (stat); + gfc_free_expr (errmsg); - gfc_free_expr (e); return MATCH_ERROR; } -/* Match the (deprecated) PAUSE statement. */ +/* Match SYNC ALL statement. */ match -gfc_match_pause (void) +gfc_match_sync_all (void) { - match m; + return sync_statement (ST_SYNC_ALL); +} - m = gfc_match_stopcode (ST_PAUSE); - if (m == MATCH_YES) - { - if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement" - " at %C") - == FAILURE) - m = MATCH_ERROR; - } - return m; + +/* Match SYNC IMAGES statement. */ + +match +gfc_match_sync_images (void) +{ + return sync_statement (ST_SYNC_IMAGES); } -/* Match the STOP statement. */ +/* Match SYNC MEMORY statement. */ match -gfc_match_stop (void) +gfc_match_sync_memory (void) { - return gfc_match_stopcode (ST_STOP); + return sync_statement (ST_SYNC_MEMORY); } @@ -1760,8 +2517,8 @@ gfc_match_assign (void) expr->symtree->n.sym->attr.assign = 1; new_st.op = EXEC_LABEL_ASSIGN; - new_st.label = label; - new_st.expr = expr; + new_st.label1 = label; + new_st.expr1 = expr; return MATCH_YES; } } @@ -1790,7 +2547,7 @@ gfc_match_goto (void) return MATCH_ERROR; new_st.op = EXEC_GOTO; - new_st.label = label; + new_st.label1 = label; return MATCH_YES; } @@ -1804,7 +2561,7 @@ gfc_match_goto (void) return MATCH_ERROR; new_st.op = EXEC_GOTO; - new_st.expr = expr; + new_st.expr1 = expr; if (gfc_match_eos () == MATCH_YES) return MATCH_YES; @@ -1835,7 +2592,7 @@ gfc_match_goto (void) tail = tail->block; } - tail->label = label; + tail->label1 = label; tail->op = EXEC_GOTO; } while (gfc_match_char (',') == MATCH_YES); @@ -1881,14 +2638,15 @@ gfc_match_goto (void) } cp = gfc_get_case (); - cp->low = cp->high = gfc_int_expr (i++); + cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind, + NULL, i++); tail->op = EXEC_SELECT; tail->ext.case_list = cp; tail->next = gfc_get_code (); tail->next->op = EXEC_GOTO; - tail->next->label = label; + tail->next->label1 = label; } while (gfc_match_char (',') == MATCH_YES); @@ -1907,11 +2665,15 @@ gfc_match_goto (void) if (gfc_match (" %e%t", &expr) != MATCH_YES) goto syntax; + if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Computed GOTO " + "at %C") == FAILURE) + return MATCH_ERROR; + /* At this point, a computed GOTO has been fully matched and an equivalent SELECT statement constructed. */ new_st.op = EXEC_SELECT; - new_st.expr = NULL; + new_st.expr1 = NULL; /* Hack: For a "real" SELECT, the expression is in expr. We put it in expr2 so we can distinguish then and produce the correct @@ -1944,21 +2706,195 @@ gfc_free_alloc_list (gfc_alloc *p) } +/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of + an accessible derived type. */ + +static match +match_derived_type_spec (gfc_typespec *ts) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + locus old_locus; + gfc_symbol *derived; + + old_locus = gfc_current_locus; + + if (gfc_match ("%n", name) != MATCH_YES) + { + gfc_current_locus = old_locus; + return MATCH_NO; + } + + gfc_find_symbol (name, NULL, 1, &derived); + + if (derived && derived->attr.flavor == FL_DERIVED) + { + ts->type = BT_DERIVED; + ts->u.derived = derived; + return MATCH_YES; + } + + gfc_current_locus = old_locus; + return MATCH_NO; +} + + +/* Match a Fortran 2003 type-spec (F03:R401). This is similar to + gfc_match_decl_type_spec() from decl.c, with the following exceptions: + It only includes the intrinsic types from the Fortran 2003 standard + (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally, + the implicit_flag is not needed, so it was removed. Derived types are + identified by their name alone. */ + +static match +match_type_spec (gfc_typespec *ts) +{ + match m; + locus old_locus; + + gfc_clear_ts (ts); + gfc_gobble_whitespace (); + old_locus = gfc_current_locus; + + if (match_derived_type_spec (ts) == MATCH_YES) + { + /* Enforce F03:C401. */ + if (ts->u.derived->attr.abstract) + { + gfc_error ("Derived type '%s' at %L may not be ABSTRACT", + ts->u.derived->name, &old_locus); + return MATCH_ERROR; + } + return MATCH_YES; + } + + if (gfc_match ("integer") == MATCH_YES) + { + ts->type = BT_INTEGER; + ts->kind = gfc_default_integer_kind; + goto kind_selector; + } + + if (gfc_match ("real") == MATCH_YES) + { + ts->type = BT_REAL; + ts->kind = gfc_default_real_kind; + goto kind_selector; + } + + if (gfc_match ("double precision") == MATCH_YES) + { + ts->type = BT_REAL; + ts->kind = gfc_default_double_kind; + return MATCH_YES; + } + + if (gfc_match ("complex") == MATCH_YES) + { + ts->type = BT_COMPLEX; + ts->kind = gfc_default_complex_kind; + goto kind_selector; + } + + if (gfc_match ("character") == MATCH_YES) + { + ts->type = BT_CHARACTER; + + m = gfc_match_char_spec (ts); + + if (m == MATCH_NO) + m = MATCH_YES; + + return m; + } + + if (gfc_match ("logical") == MATCH_YES) + { + ts->type = BT_LOGICAL; + ts->kind = gfc_default_logical_kind; + goto kind_selector; + } + + /* If a type is not matched, simply return MATCH_NO. */ + gfc_current_locus = old_locus; + return MATCH_NO; + +kind_selector: + + gfc_gobble_whitespace (); + if (gfc_peek_ascii_char () == '*') + { + gfc_error ("Invalid type-spec at %C"); + return MATCH_ERROR; + } + + m = gfc_match_kind_spec (ts, false); + + if (m == MATCH_NO) + m = MATCH_YES; /* No kind specifier found. */ + + return m; +} + + /* Match an ALLOCATE statement. */ match gfc_match_allocate (void) { gfc_alloc *head, *tail; - gfc_expr *stat; + gfc_expr *stat, *errmsg, *tmp, *source, *mold; + gfc_typespec ts; + gfc_symbol *sym; match m; + locus old_locus, deferred_locus; + bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3; head = tail = NULL; - stat = NULL; + stat = errmsg = source = mold = tmp = NULL; + saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false; if (gfc_match_char ('(') != MATCH_YES) goto syntax; + /* Match an optional type-spec. */ + old_locus = gfc_current_locus; + m = match_type_spec (&ts); + if (m == MATCH_ERROR) + goto cleanup; + else if (m == MATCH_NO) + { + char name[GFC_MAX_SYMBOL_LEN + 3]; + + if (gfc_match ("%n :: ", name) == MATCH_YES) + { + gfc_error ("Error in type-spec at %L", &old_locus); + goto cleanup; + } + + ts.type = BT_UNKNOWN; + } + else + { + if (gfc_match (" :: ") == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in " + "ALLOCATE at %L", &old_locus) == FAILURE) + goto cleanup; + + if (ts.deferred) + { + gfc_error ("Type-spec at %L cannot contain a deferred " + "type parameter", &old_locus); + goto cleanup; + } + } + else + { + ts.type = BT_UNKNOWN; + gfc_current_locus = old_locus; + } + } + for (;;) { if (head == NULL) @@ -1978,58 +2914,229 @@ gfc_match_allocate (void) if (gfc_check_do_variable (tail->expr->symtree)) goto cleanup; - if (gfc_pure (NULL) - && gfc_impure_variable (tail->expr->symtree->n.sym)) + if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym)) { - gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a " - "PURE procedure"); + gfc_error ("Bad allocate-object at %C for a PURE procedure"); goto cleanup; } + if (tail->expr->ts.deferred) + { + saw_deferred = true; + deferred_locus = tail->expr->where; + } + + /* The ALLOCATE statement had an optional typespec. Check the + constraints. */ + if (ts.type != BT_UNKNOWN) + { + /* Enforce F03:C624. */ + if (!gfc_type_compatible (&tail->expr->ts, &ts)) + { + gfc_error ("Type of entity at %L is type incompatible with " + "typespec", &tail->expr->where); + goto cleanup; + } + + /* Enforce F03:C627. */ + if (ts.kind != tail->expr->ts.kind) + { + gfc_error ("Kind type parameter for entity at %L differs from " + "the kind type parameter of the typespec", + &tail->expr->where); + goto cleanup; + } + } + if (tail->expr->ts.type == BT_DERIVED) - tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived); + tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived); + + /* FIXME: disable the checking on derived types and arrays. */ + sym = tail->expr->symtree->n.sym; + b1 = !(tail->expr->ref + && (tail->expr->ref->type == REF_COMPONENT + || tail->expr->ref->type == REF_ARRAY)); + if (sym && sym->ts.type == BT_CLASS) + b2 = !(CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.class_pointer); + else + b2 = sym && !(sym->attr.allocatable || sym->attr.pointer + || sym->attr.proc_pointer); + b3 = sym && sym->ns && sym->ns->proc_name + && (sym->ns->proc_name->attr.allocatable + || sym->ns->proc_name->attr.pointer + || sym->ns->proc_name->attr.proc_pointer); + if (b1 && b2 && !b3) + { + gfc_error ("Allocate-object at %L is not a nonprocedure pointer " + "or an allocatable variable", &tail->expr->where); + goto cleanup; + } + + if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension) + { + gfc_error ("Shape specification for allocatable scalar at %C"); + goto cleanup; + } if (gfc_match_char (',') != MATCH_YES) break; - m = gfc_match (" stat = %v", &stat); +alloc_opt_list: + + m = gfc_match (" stat = %v", &tmp); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_YES) - break; - } + { + /* Enforce C630. */ + if (saw_stat) + { + gfc_error ("Redundant STAT tag found at %L ", &tmp->where); + goto cleanup; + } - if (stat != NULL) - { - if (stat->symtree->n.sym->attr.intent == INTENT_IN) + stat = tmp; + tmp = NULL; + saw_stat = true; + + if (gfc_check_do_variable (stat->symtree)) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + goto alloc_opt_list; + } + + m = gfc_match (" errmsg = %v", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) { - gfc_error ("STAT variable '%s' of ALLOCATE statement at %C cannot " - "be INTENT(IN)", stat->symtree->n.sym->name); - goto cleanup; + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L", + &tmp->where) == FAILURE) + goto cleanup; + + /* Enforce C630. */ + if (saw_errmsg) + { + gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where); + goto cleanup; + } + + errmsg = tmp; + tmp = NULL; + saw_errmsg = true; + + if (gfc_match_char (',') == MATCH_YES) + goto alloc_opt_list; } - if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym)) + m = gfc_match (" source = %e", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) { - gfc_error ("Illegal STAT variable in ALLOCATE statement at %C " - "for a PURE procedure"); - goto cleanup; + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L", + &tmp->where) == FAILURE) + goto cleanup; + + /* Enforce C630. */ + if (saw_source) + { + gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where); + goto cleanup; + } + + /* The next 2 conditionals check C631. */ + if (ts.type != BT_UNKNOWN) + { + gfc_error ("SOURCE tag at %L conflicts with the typespec at %L", + &tmp->where, &old_locus); + goto cleanup; + } + + if (head->next) + { + gfc_error ("SOURCE tag at %L requires only a single entity in " + "the allocation-list", &tmp->where); + goto cleanup; + } + + source = tmp; + tmp = NULL; + saw_source = true; + + if (gfc_match_char (',') == MATCH_YES) + goto alloc_opt_list; } - if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE) + m = gfc_match (" mold = %e", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) { - gfc_error ("STAT expression at %C must be a variable"); - goto cleanup; + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: MOLD tag at %L", + &tmp->where) == FAILURE) + goto cleanup; + + /* Check F08:C636. */ + if (saw_mold) + { + gfc_error ("Redundant MOLD tag found at %L ", &tmp->where); + goto cleanup; + } + + /* Check F08:C637. */ + if (ts.type != BT_UNKNOWN) + { + gfc_error ("MOLD tag at %L conflicts with the typespec at %L", + &tmp->where, &old_locus); + goto cleanup; + } + + mold = tmp; + tmp = NULL; + saw_mold = true; + mold->mold = 1; + + if (gfc_match_char (',') == MATCH_YES) + goto alloc_opt_list; } - gfc_check_do_variable(stat->symtree); + gfc_gobble_whitespace (); + + if (gfc_peek_char () == ')') + break; } if (gfc_match (" )%t") != MATCH_YES) goto syntax; + /* Check F08:C637. */ + if (source && mold) + { + gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L", + &mold->where, &source->where); + goto cleanup; + } + + /* Check F03:C623, */ + if (saw_deferred && ts.type == BT_UNKNOWN && !source) + { + gfc_error ("Allocate-object at %L with a deferred type parameter " + "requires either a type-spec or SOURCE tag", &deferred_locus); + goto cleanup; + } + new_st.op = EXEC_ALLOCATE; - new_st.expr = stat; - new_st.ext.alloc_list = head; + new_st.expr1 = stat; + new_st.expr2 = errmsg; + if (source) + new_st.expr3 = source; + else + new_st.expr3 = mold; + new_st.ext.alloc.list = head; + new_st.ext.alloc.ts = ts; return MATCH_YES; @@ -2037,7 +3144,11 @@ syntax: gfc_syntax_error (ST_ALLOCATE); cleanup: + gfc_free_expr (errmsg); + gfc_free_expr (source); gfc_free_expr (stat); + gfc_free_expr (mold); + if (tmp && tmp->expr_type) gfc_free_expr (tmp); gfc_free_alloc_list (head); return MATCH_ERROR; } @@ -2069,17 +3180,8 @@ gfc_match_nullify (void) if (gfc_check_do_variable (p->symtree)) goto cleanup; - if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym)) - { - gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure"); - goto cleanup; - } - /* build ' => NULL() '. */ - e = gfc_get_expr (); - e->where = gfc_current_locus; - e->expr_type = EXPR_NULL; - e->ts.type = BT_UNKNOWN; + e = gfc_get_null_expr (&gfc_current_locus); /* Chain to list. */ if (tail == NULL) @@ -2091,7 +3193,7 @@ gfc_match_nullify (void) } tail->op = EXEC_POINTER_ASSIGN; - tail->expr = p; + tail->expr1 = p; tail->expr2 = e; if (gfc_match (" )%t") == MATCH_YES) @@ -2107,6 +3209,11 @@ syntax: cleanup: gfc_free_statements (new_st.next); + new_st.next = NULL; + gfc_free_expr (new_st.expr1); + new_st.expr1 = NULL; + gfc_free_expr (new_st.expr2); + new_st.expr2 = NULL; return MATCH_ERROR; } @@ -2117,11 +3224,14 @@ match gfc_match_deallocate (void) { gfc_alloc *head, *tail; - gfc_expr *stat; + gfc_expr *stat, *errmsg, *tmp; + gfc_symbol *sym; match m; + bool saw_stat, saw_errmsg, b1, b2; head = tail = NULL; - stat = NULL; + stat = errmsg = tmp = NULL; + saw_stat = saw_errmsg = false; if (gfc_match_char ('(') != MATCH_YES) goto syntax; @@ -2145,55 +3255,94 @@ gfc_match_deallocate (void) if (gfc_check_do_variable (tail->expr->symtree)) goto cleanup; - if (gfc_pure (NULL) - && gfc_impure_variable (tail->expr->symtree->n.sym)) + sym = tail->expr->symtree->n.sym; + + if (gfc_pure (NULL) && gfc_impure_variable (sym)) + { + gfc_error ("Illegal allocate-object at %C for a PURE procedure"); + goto cleanup; + } + + /* FIXME: disable the checking on derived types. */ + b1 = !(tail->expr->ref + && (tail->expr->ref->type == REF_COMPONENT + || tail->expr->ref->type == REF_ARRAY)); + if (sym && sym->ts.type == BT_CLASS) + b2 = !(CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.class_pointer); + else + b2 = sym && !(sym->attr.allocatable || sym->attr.pointer + || sym->attr.proc_pointer); + if (b1 && b2) { - gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C " - "for a PURE procedure"); + gfc_error ("Allocate-object at %C is not a nonprocedure pointer " + "or an allocatable variable"); goto cleanup; } if (gfc_match_char (',') != MATCH_YES) break; - m = gfc_match (" stat = %v", &stat); +dealloc_opt_list: + + m = gfc_match (" stat = %v", &tmp); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_YES) - break; - } - - if (stat != NULL) - { - if (stat->symtree->n.sym->attr.intent == INTENT_IN) { - gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C " - "cannot be INTENT(IN)", stat->symtree->n.sym->name); - goto cleanup; + if (saw_stat) + { + gfc_error ("Redundant STAT tag found at %L ", &tmp->where); + gfc_free_expr (tmp); + goto cleanup; + } + + stat = tmp; + saw_stat = true; + + if (gfc_check_do_variable (stat->symtree)) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + goto dealloc_opt_list; } - if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym)) + m = gfc_match (" errmsg = %v", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) { - gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C " - "for a PURE procedure"); - goto cleanup; - } + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L", + &tmp->where) == FAILURE) + goto cleanup; + + if (saw_errmsg) + { + gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where); + gfc_free_expr (tmp); + goto cleanup; + } - if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE) - { - gfc_error ("STAT expression at %C must be a variable"); - goto cleanup; + errmsg = tmp; + saw_errmsg = true; + + if (gfc_match_char (',') == MATCH_YES) + goto dealloc_opt_list; } - gfc_check_do_variable(stat->symtree); + gfc_gobble_whitespace (); + + if (gfc_peek_char () == ')') + break; } if (gfc_match (" )%t") != MATCH_YES) goto syntax; new_st.op = EXEC_DEALLOCATE; - new_st.expr = stat; - new_st.ext.alloc_list = head; + new_st.expr1 = stat; + new_st.expr2 = errmsg; + new_st.ext.alloc.list = head; return MATCH_YES; @@ -2201,6 +3350,7 @@ syntax: gfc_syntax_error (ST_DEALLOCATE); cleanup: + gfc_free_expr (errmsg); gfc_free_expr (stat); gfc_free_alloc_list (head); return MATCH_ERROR; @@ -2215,9 +3365,15 @@ gfc_match_return (void) gfc_expr *e; match m; gfc_compile_state s; - int c; e = NULL; + + if (gfc_find_state (COMP_CRITICAL) == SUCCESS) + { + gfc_error ("Image control statement RETURN at %C in CRITICAL block"); + return MATCH_ERROR; + } + if (gfc_match_eos () == MATCH_YES) goto done; @@ -2228,13 +3384,17 @@ gfc_match_return (void) goto cleanup; } + if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Alternate RETURN " + "at %C") == FAILURE) + return MATCH_ERROR; + 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) */ - c = gfc_peek_char (); + char c = gfc_peek_ascii_char (); if (ISALPHA (c) || ISDIGIT (c)) return MATCH_NO; } @@ -2259,7 +3419,50 @@ done: return MATCH_ERROR; new_st.op = EXEC_RETURN; - new_st.expr = e; + new_st.expr1 = e; + + return MATCH_YES; +} + + +/* Match the call of a type-bound procedure, if CALL%var has already been + matched and var found to be a derived-type variable. */ + +static match +match_typebound_call (gfc_symtree* varst) +{ + gfc_expr* base; + match m; + + base = gfc_get_expr (); + base->expr_type = EXPR_VARIABLE; + base->symtree = varst; + base->where = gfc_current_locus; + gfc_set_sym_referenced (varst->n.sym); + + m = gfc_match_varspec (base, 0, true, true); + if (m == MATCH_NO) + gfc_error ("Expected component reference at %C"); + if (m != MATCH_YES) + return MATCH_ERROR; + + if (gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after CALL at %C"); + return MATCH_ERROR; + } + + if (base->expr_type == EXPR_COMPCALL) + new_st.op = EXEC_COMPCALL; + else if (base->expr_type == EXPR_PPC) + new_st.op = EXEC_CALL_PPC; + else + { + gfc_error ("Expected type-bound procedure or procedure pointer component " + "at %C"); + return MATCH_ERROR; + } + new_st.expr1 = base; return MATCH_YES; } @@ -2297,17 +3500,30 @@ gfc_match_call (void) sym = st->n.sym; - /* If it does not seem to be callable... */ + /* If this is a variable of derived-type, it probably starts a type-bound + procedure call. */ + if ((sym->attr.flavor != FL_PROCEDURE + || gfc_is_function_return_value (sym, gfc_current_ns)) + && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)) + return match_typebound_call (st); + + /* If it does not seem to be callable (include functions so that the + right association is made. They are thrown out in resolution.) + ... */ if (!sym->attr.generic - && !sym->attr.subroutine) + && !sym->attr.subroutine + && !sym->attr.function) { - /* ...create a symbol in this scope... */ - if (sym->ns != gfc_current_ns - && gfc_get_sym_tree (name, NULL, &st) == 1) - return MATCH_ERROR; + if (!(sym->attr.external && !sym->attr.referenced)) + { + /* ...create a symbol in this scope... */ + if (sym->ns != gfc_current_ns + && gfc_get_sym_tree (name, NULL, &st, false) == 1) + return MATCH_ERROR; - if (sym != st->n.sym) - sym = st->n.sym; + if (sym != st->n.sym) + sym = st->n.sym; + } /* ...and then to try to make the symbol into a subroutine. */ if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE) @@ -2351,11 +3567,11 @@ gfc_match_call (void) select_sym->ts.type = BT_INTEGER; select_sym->ts.kind = gfc_default_integer_kind; gfc_set_sym_referenced (select_sym); - c->expr = gfc_get_expr (); - c->expr->expr_type = EXPR_VARIABLE; - c->expr->symtree = select_st; - c->expr->ts = select_sym->ts; - c->expr->where = gfc_current_locus; + c->expr1 = gfc_get_expr (); + c->expr1->expr_type = EXPR_VARIABLE; + c->expr1->symtree = select_st; + c->expr1->ts = select_sym->ts; + c->expr1->where = gfc_current_locus; i = 0; for (a = arglist; a; a = a->next) @@ -2373,12 +3589,13 @@ gfc_match_call (void) c->op = EXEC_SELECT; new_case = gfc_get_case (); - new_case->high = new_case->low = gfc_int_expr (i); + new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i); + new_case->low = new_case->high; c->ext.case_list = new_case; c->next = gfc_get_code (); c->next->op = EXEC_GOTO; - c->next->label = a->label; + c->next->label1 = a->label; } } @@ -2513,11 +3730,6 @@ gfc_match_common (void) if (name[0] == '\0') { - if (gfc_current_ns->is_block_data) - { - gfc_warning ("BLOCK DATA unit cannot contain blank COMMON " - "at %C"); - } t = &gfc_current_ns->blank_common; if (t->head == NULL) t->where = gfc_current_locus; @@ -2582,32 +3794,19 @@ gfc_match_common (void) goto cleanup; } - if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE) - goto cleanup; - - if (sym->value != NULL && sym->value->expr_type != EXPR_NULL - && (name[0] == '\0' || !sym->attr.data)) + if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL) + || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA) { - if (name[0] == '\0') - gfc_error ("Previously initialized symbol '%s' in " - "blank COMMON block at %C", sym->name); - else - gfc_error ("Previously initialized symbol '%s' in " - "COMMON block '%s' at %C", sym->name, name); - goto cleanup; + if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C " + "can only be COMMON in " + "BLOCK DATA", sym->name) + == FAILURE) + goto cleanup; } if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE) goto cleanup; - /* 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"); - goto cleanup; - } - if (tail != NULL) tail->common_next = sym; else @@ -2617,7 +3816,7 @@ gfc_match_common (void) /* Deal with an optional array specification after the symbol name. */ - m = gfc_match_array_spec (&as); + m = gfc_match_array_spec (&as, true, true); if (m == MATCH_ERROR) goto cleanup; @@ -2684,12 +3883,12 @@ gfc_match_common (void) gfc_gobble_whitespace (); if (gfc_match_eos () == MATCH_YES) goto done; - if (gfc_peek_char () == '/') + if (gfc_peek_ascii_char () == '/') break; if (gfc_match_char (',') != MATCH_YES) goto syntax; gfc_gobble_whitespace (); - if (gfc_peek_char () == '/') + if (gfc_peek_ascii_char () == '/') break; } } @@ -2815,19 +4014,13 @@ gfc_match_namelist (void) gfc_error_check (); } - if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL) + if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl->length == NULL) { gfc_error ("Assumed character length '%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_error_check (); - nl = gfc_get_namelist (); nl->sym = sym; sym->refs++; @@ -2894,18 +4087,25 @@ gfc_match_module (void) do this. */ void -gfc_free_equiv (gfc_equiv *eq) +gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop) { - if (eq == NULL) + if (eq == stop) return; gfc_free_equiv (eq->eq); - gfc_free_equiv (eq->next); + gfc_free_equiv_until (eq->next, stop); gfc_free_expr (eq->expr); gfc_free (eq); } +void +gfc_free_equiv (gfc_equiv *eq) +{ + gfc_free_equiv_until (eq, NULL); +} + + /* Match an EQUIVALENCE statement. */ match @@ -3012,7 +4212,10 @@ gfc_match_equivalence (void) if (gfc_match_eos () == MATCH_YES) break; if (gfc_match_char (',') != MATCH_YES) - goto syntax; + { + gfc_error ("Expecting a comma in EQUIVALENCE at %C"); + goto cleanup; + } } return MATCH_YES; @@ -3037,13 +4240,12 @@ cleanup: 12.5.4 requires that any variable of function that is implicitly typed shall have that type confirmed by any subsequent type declaration. The implicit typing is conveniently done here. */ +static bool +recursive_stmt_fcn (gfc_expr *, gfc_symbol *); static bool -recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) +check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED) { - gfc_actual_arglist *arg; - gfc_ref *ref; - int i; if (e == NULL) return false; @@ -3051,12 +4253,6 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) switch (e->expr_type) { case EXPR_FUNCTION: - for (arg = e->value.function.actual; arg; arg = arg->next) - { - if (sym->name == arg->name || recursive_stmt_fcn (arg->expr, sym)) - return true; - } - if (e->symtree == NULL) return false; @@ -3083,46 +4279,18 @@ recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) gfc_set_default_type (e->symtree->n.sym, 0, NULL); break; - case EXPR_OP: - if (recursive_stmt_fcn (e->value.op.op1, sym) - || recursive_stmt_fcn (e->value.op.op2, sym)) - return true; - break; - default: break; } - /* Component references do not need to be checked. */ - if (e->ref) - { - for (ref = e->ref; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_ARRAY: - 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)) - return true; - } - break; - - case REF_SUBSTRING: - if (recursive_stmt_fcn (ref->u.ss.start, sym) - || recursive_stmt_fcn (ref->u.ss.end, sym)) - return true; + return false; +} - break; - default: - break; - } - } - } - return false; +static bool +recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) +{ + return gfc_traverse_expr (e, sym, check_stmt_fcn, 0); } @@ -3167,6 +4335,10 @@ gfc_match_st_function (void) sym->value = expr; + if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: " + "Statement function at %C") == FAILURE) + return MATCH_ERROR; + return MATCH_YES; undo_error: @@ -3271,10 +4443,7 @@ match_case_eos (void) /* If the case construct doesn't have a case-construct-name, we should have matched the EOS. */ if (!gfc_current_block ()) - { - gfc_error ("Expected the name of the SELECT CASE construct at %C"); - return MATCH_ERROR; - } + return MATCH_NO; gfc_gobble_whitespace (); @@ -3284,7 +4453,7 @@ match_case_eos (void) if (strcmp (name, gfc_current_block ()->name) != 0) { - gfc_error ("Expected case name of '%s' at %C", + gfc_error ("Expected block name '%s' of SELECT construct at %C", gfc_current_block ()->name); return MATCH_ERROR; } @@ -3310,9 +4479,139 @@ gfc_match_select (void) return m; new_st.op = EXEC_SELECT; - new_st.expr = expr; + new_st.expr1 = expr; + + return MATCH_YES; +} + + +/* Push the current selector onto the SELECT TYPE stack. */ + +static void +select_type_push (gfc_symbol *sel) +{ + gfc_select_type_stack *top = gfc_get_select_type_stack (); + top->selector = sel; + top->tmp = NULL; + top->prev = select_type_stack; + + select_type_stack = top; +} + + +/* Set the temporary for the current SELECT TYPE selector. */ + +static void +select_type_set_tmp (gfc_typespec *ts) +{ + char name[GFC_MAX_SYMBOL_LEN]; + gfc_symtree *tmp; + + if (!ts) + { + select_type_stack->tmp = NULL; + return; + } + + if (!gfc_type_is_extensible (ts->u.derived)) + return; + + if (ts->type == BT_CLASS) + sprintf (name, "__tmp_class_%s", ts->u.derived->name); + else + sprintf (name, "__tmp_type_%s", ts->u.derived->name); + gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); + gfc_add_type (tmp->n.sym, ts, NULL); + gfc_set_sym_referenced (tmp->n.sym); + gfc_add_pointer (&tmp->n.sym->attr, NULL); + gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); + if (ts->type == BT_CLASS) + { + gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr, + &tmp->n.sym->as, false); + tmp->n.sym->attr.class_ok = 1; + } + tmp->n.sym->attr.select_type_temporary = 1; + + /* Add an association for it, so the rest of the parser knows it is + an associate-name. The target will be set during resolution. */ + tmp->n.sym->assoc = gfc_get_association_list (); + tmp->n.sym->assoc->dangling = 1; + tmp->n.sym->assoc->st = tmp; + + select_type_stack->tmp = tmp; +} + + +/* Match a SELECT TYPE statement. */ + +match +gfc_match_select_type (void) +{ + gfc_expr *expr1, *expr2 = NULL; + match m; + char name[GFC_MAX_SYMBOL_LEN]; + + m = gfc_match_label (); + if (m == MATCH_ERROR) + return m; + + m = gfc_match (" select type ( "); + if (m != MATCH_YES) + return m; + + gfc_current_ns = gfc_build_block_ns (gfc_current_ns); + + m = gfc_match (" %n => %e", name, &expr2); + if (m == MATCH_YES) + { + expr1 = gfc_get_expr(); + expr1->expr_type = EXPR_VARIABLE; + if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false)) + { + m = MATCH_ERROR; + goto cleanup; + } + if (expr2->ts.type == BT_UNKNOWN) + expr1->symtree->n.sym->attr.untyped = 1; + else + expr1->symtree->n.sym->ts = expr2->ts; + expr1->symtree->n.sym->attr.flavor = FL_VARIABLE; + expr1->symtree->n.sym->attr.referenced = 1; + expr1->symtree->n.sym->attr.class_ok = 1; + } + else + { + m = gfc_match (" %e ", &expr1); + if (m != MATCH_YES) + goto cleanup; + } + + m = gfc_match (" )%t"); + if (m != MATCH_YES) + goto cleanup; + + /* Check for F03:C811. */ + if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL)) + { + gfc_error ("Selector in SELECT TYPE at %C is not a named variable; " + "use associate-name=>"); + m = MATCH_ERROR; + goto cleanup; + } + + new_st.op = EXEC_SELECT_TYPE; + new_st.expr1 = expr1; + new_st.expr2 = expr2; + new_st.ext.block.ns = gfc_current_ns; + + select_type_push (expr1->symtree->n.sym); return MATCH_YES; + +cleanup: + gfc_current_ns = gfc_current_ns->parent; + return m; } @@ -3380,13 +4679,139 @@ gfc_match_case (void) return MATCH_YES; syntax: - gfc_error ("Syntax error in CASE-specification at %C"); + gfc_error ("Syntax error in CASE specification at %C"); cleanup: gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */ return MATCH_ERROR; } + +/* Match a TYPE IS statement. */ + +match +gfc_match_type_is (void) +{ + gfc_case *c = NULL; + match m; + + if (gfc_current_state () != COMP_SELECT_TYPE) + { + gfc_error ("Unexpected TYPE IS statement at %C"); + return MATCH_ERROR; + } + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + c = gfc_get_case (); + c->where = gfc_current_locus; + + /* TODO: Once unlimited polymorphism is implemented, we will need to call + match_type_spec here. */ + if (match_derived_type_spec (&c->ts) == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT_TYPE; + new_st.ext.case_list = c; + + /* Create temporary variable. */ + select_type_set_tmp (&c->ts); + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in TYPE IS specification at %C"); + +cleanup: + if (c != NULL) + gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ + return MATCH_ERROR; +} + + +/* Match a CLASS IS or CLASS DEFAULT statement. */ + +match +gfc_match_class_is (void) +{ + gfc_case *c = NULL; + match m; + + if (gfc_current_state () != COMP_SELECT_TYPE) + return MATCH_NO; + + if (gfc_match ("% default") == MATCH_YES) + { + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT_TYPE; + c = gfc_get_case (); + c->where = gfc_current_locus; + c->ts.type = BT_UNKNOWN; + new_st.ext.case_list = c; + select_type_set_tmp (NULL); + return MATCH_YES; + } + + m = gfc_match ("% is"); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + c = gfc_get_case (); + c->where = gfc_current_locus; + + if (match_derived_type_spec (&c->ts) == MATCH_ERROR) + goto cleanup; + + if (c->ts.type == BT_DERIVED) + c->ts.type = BT_CLASS; + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT_TYPE; + new_st.ext.case_list = c; + + /* Create temporary variable. */ + select_type_set_tmp (&c->ts); + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in CLASS IS specification at %C"); + +cleanup: + if (c != NULL) + gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ + return MATCH_ERROR; +} + + /********************* WHERE subroutines ********************/ /* Match the rest of a simple WHERE statement that follows an IF statement. @@ -3415,7 +4840,7 @@ match_simple_where (void) c = gfc_get_code (); c->op = EXEC_WHERE; - c->expr = expr; + c->expr1 = expr; c->next = gfc_get_code (); *c->next = new_st; @@ -3456,7 +4881,7 @@ gfc_match_where (gfc_statement *st) { *st = ST_WHERE_BLOCK; new_st.op = EXEC_WHERE; - new_st.expr = expr; + new_st.expr1 = expr; return MATCH_YES; } @@ -3475,7 +4900,7 @@ gfc_match_where (gfc_statement *st) c = gfc_get_code (); c->op = EXEC_WHERE; - c->expr = expr; + c->expr1 = expr; c->next = gfc_get_code (); *c->next = new_st; @@ -3545,7 +4970,7 @@ gfc_match_elsewhere (void) } new_st.op = EXEC_WHERE; - new_st.expr = expr; + new_st.expr1 = expr; return MATCH_YES; syntax: @@ -3594,7 +5019,7 @@ match_forall_iterator (gfc_forall_iterator **result) match m; where = gfc_current_locus; - iter = gfc_getmem (sizeof (gfc_forall_iterator)); + iter = XCNEW (gfc_forall_iterator); m = gfc_match_expr (&iter->var); if (m != MATCH_YES) @@ -3621,7 +5046,7 @@ match_forall_iterator (gfc_forall_iterator **result) goto cleanup; if (gfc_match_char (':') == MATCH_NO) - iter->stride = gfc_int_expr (1); + iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); else { m = gfc_match_expr (&iter->stride); @@ -3654,7 +5079,7 @@ cleanup: static match match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) { - gfc_forall_iterator *head, *tail, *new; + gfc_forall_iterator *head, *tail, *new_iter; gfc_expr *msk; match m; @@ -3666,27 +5091,27 @@ match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) if (gfc_match_char ('(') != MATCH_YES) return MATCH_NO; - m = match_forall_iterator (&new); + m = match_forall_iterator (&new_iter); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) goto syntax; - head = tail = new; + head = tail = new_iter; for (;;) { if (gfc_match_char (',') != MATCH_YES) break; - m = match_forall_iterator (&new); + m = match_forall_iterator (&new_iter); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_YES) { - tail->next = new; - tail = new; + tail->next = new_iter; + tail = new_iter; continue; } @@ -3762,7 +5187,7 @@ match_simple_forall (void) gfc_clear_new_st (); new_st.op = EXEC_FORALL; - new_st.expr = mask; + new_st.expr1 = mask; new_st.ext.forall_iterator = head; new_st.block = gfc_get_code (); @@ -3814,7 +5239,7 @@ gfc_match_forall (gfc_statement *st) { *st = ST_FORALL_BLOCK; new_st.op = EXEC_FORALL; - new_st.expr = mask; + new_st.expr1 = mask; new_st.ext.forall_iterator = head; return MATCH_YES; } @@ -3837,7 +5262,7 @@ gfc_match_forall (gfc_statement *st) gfc_clear_new_st (); new_st.op = EXEC_FORALL; - new_st.expr = mask; + new_st.expr1 = mask; new_st.ext.forall_iterator = head; new_st.block = gfc_get_code (); new_st.block->op = EXEC_FORALL;