1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
29 int gfc_matching_procptr_assignment = 0;
30 bool gfc_matching_prefix = false;
32 /* For debugging and diagnostic purposes. Return the textual representation
33 of the intrinsic operator OP. */
35 gfc_op2string (gfc_intrinsic_op op)
43 case INTRINSIC_UMINUS:
49 case INTRINSIC_CONCAT:
53 case INTRINSIC_DIVIDE:
92 case INTRINSIC_ASSIGN:
95 case INTRINSIC_PARENTHESES:
102 gfc_internal_error ("gfc_op2string(): Bad code");
107 /******************** Generic matching subroutines ************************/
109 /* This function scans the current statement counting the opened and closed
110 parenthesis to make sure they are balanced. */
113 gfc_match_parens (void)
115 locus old_loc, where;
119 old_loc = gfc_current_locus;
126 c = gfc_next_char_literal (instring);
129 if (quote == ' ' && ((c == '\'') || (c == '"')))
135 if (quote != ' ' && c == quote)
142 if (c == '(' && quote == ' ')
145 where = gfc_current_locus;
147 if (c == ')' && quote == ' ')
150 where = gfc_current_locus;
154 gfc_current_locus = old_loc;
158 gfc_error ("Missing ')' in statement at or before %L", &where);
163 gfc_error ("Missing '(' in statement at or before %L", &where);
171 /* See if the next character is a special character that has
172 escaped by a \ via the -fbackslash option. */
175 gfc_match_special_char (gfc_char_t *res)
183 switch ((c = gfc_next_char_literal (1)))
216 /* Hexadecimal form of wide characters. */
217 len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8));
219 for (i = 0; i < len; i++)
221 char buf[2] = { '\0', '\0' };
223 c = gfc_next_char_literal (1);
224 if (!gfc_wide_fits_in_byte (c)
225 || !gfc_check_digit ((unsigned char) c, 16))
228 buf[0] = (unsigned char) c;
230 n += strtol (buf, NULL, 16);
236 /* Unknown backslash codes are simply not expanded. */
245 /* In free form, match at least one space. Always matches in fixed
249 gfc_match_space (void)
254 if (gfc_current_form == FORM_FIXED)
257 old_loc = gfc_current_locus;
259 c = gfc_next_ascii_char ();
260 if (!gfc_is_whitespace (c))
262 gfc_current_locus = old_loc;
266 gfc_gobble_whitespace ();
272 /* Match an end of statement. End of statement is optional
273 whitespace, followed by a ';' or '\n' or comment '!'. If a
274 semicolon is found, we continue to eat whitespace and semicolons. */
287 old_loc = gfc_current_locus;
288 gfc_gobble_whitespace ();
290 c = gfc_next_ascii_char ();
296 c = gfc_next_ascii_char ();
313 gfc_current_locus = old_loc;
314 return (flag) ? MATCH_YES : MATCH_NO;
318 /* Match a literal integer on the input, setting the value on
319 MATCH_YES. Literal ints occur in kind-parameters as well as
320 old-style character length specifications. If cnt is non-NULL it
321 will be set to the number of digits. */
324 gfc_match_small_literal_int (int *value, int *cnt)
330 old_loc = gfc_current_locus;
333 gfc_gobble_whitespace ();
334 c = gfc_next_ascii_char ();
340 gfc_current_locus = old_loc;
349 old_loc = gfc_current_locus;
350 c = gfc_next_ascii_char ();
355 i = 10 * i + c - '0';
360 gfc_error ("Integer too large at %C");
365 gfc_current_locus = old_loc;
374 /* Match a small, constant integer expression, like in a kind
375 statement. On MATCH_YES, 'value' is set. */
378 gfc_match_small_int (int *value)
385 m = gfc_match_expr (&expr);
389 p = gfc_extract_int (expr, &i);
390 gfc_free_expr (expr);
403 /* This function is the same as the gfc_match_small_int, except that
404 we're keeping the pointer to the expr. This function could just be
405 removed and the previously mentioned one modified, though all calls
406 to it would have to be modified then (and there were a number of
407 them). Return MATCH_ERROR if fail to extract the int; otherwise,
408 return the result of gfc_match_expr(). The expr (if any) that was
409 matched is returned in the parameter expr. */
412 gfc_match_small_int_expr (int *value, gfc_expr **expr)
418 m = gfc_match_expr (expr);
422 p = gfc_extract_int (*expr, &i);
435 /* Matches a statement label. Uses gfc_match_small_literal_int() to
436 do most of the work. */
439 gfc_match_st_label (gfc_st_label **label)
445 old_loc = gfc_current_locus;
447 m = gfc_match_small_literal_int (&i, &cnt);
453 gfc_error ("Too many digits in statement label at %C");
459 gfc_error ("Statement label at %C is zero");
463 *label = gfc_get_st_label (i);
468 gfc_current_locus = old_loc;
473 /* Match and validate a label associated with a named IF, DO or SELECT
474 statement. If the symbol does not have the label attribute, we add
475 it. We also make sure the symbol does not refer to another
476 (active) block. A matched label is pointed to by gfc_new_block. */
479 gfc_match_label (void)
481 char name[GFC_MAX_SYMBOL_LEN + 1];
484 gfc_new_block = NULL;
486 m = gfc_match (" %n :", name);
490 if (gfc_get_symbol (name, NULL, &gfc_new_block))
492 gfc_error ("Label name '%s' at %C is ambiguous", name);
496 if (gfc_new_block->attr.flavor == FL_LABEL)
498 gfc_error ("Duplicate construct label '%s' at %C", name);
502 if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
503 gfc_new_block->name, NULL) == FAILURE)
510 /* See if the current input looks like a name of some sort. Modifies
511 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
512 Note that options.c restricts max_identifier_length to not more
513 than GFC_MAX_SYMBOL_LEN. */
516 gfc_match_name (char *buffer)
522 old_loc = gfc_current_locus;
523 gfc_gobble_whitespace ();
525 c = gfc_next_ascii_char ();
526 if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore)))
528 if (gfc_error_flag_test() == 0 && c != '(')
529 gfc_error ("Invalid character in name at %C");
530 gfc_current_locus = old_loc;
540 if (i > gfc_option.max_identifier_length)
542 gfc_error ("Name at %C is too long");
546 old_loc = gfc_current_locus;
547 c = gfc_next_ascii_char ();
549 while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));
551 if (c == '$' && !gfc_option.flag_dollar_ok)
553 gfc_error ("Invalid character '$' at %C. Use -fdollar-ok to allow it "
559 gfc_current_locus = old_loc;
565 /* Match a valid name for C, which is almost the same as for Fortran,
566 except that you can start with an underscore, etc.. It could have
567 been done by modifying the gfc_match_name, but this way other
568 things C allows can be added, such as no limits on the length.
569 Right now, the length is limited to the same thing as Fortran..
570 Also, by rewriting it, we use the gfc_next_char_C() to prevent the
571 input characters from being automatically lower cased, since C is
572 case sensitive. The parameter, buffer, is used to return the name
573 that is matched. Return MATCH_ERROR if the name is too long
574 (though this is a self-imposed limit), MATCH_NO if what we're
575 seeing isn't a name, and MATCH_YES if we successfully match a C
579 gfc_match_name_C (char *buffer)
585 old_loc = gfc_current_locus;
586 gfc_gobble_whitespace ();
588 /* Get the next char (first possible char of name) and see if
589 it's valid for C (either a letter or an underscore). */
590 c = gfc_next_char_literal (1);
592 /* If the user put nothing expect spaces between the quotes, it is valid
593 and simply means there is no name= specifier and the name is the fortran
594 symbol name, all lowercase. */
595 if (c == '"' || c == '\'')
598 gfc_current_locus = old_loc;
602 if (!ISALPHA (c) && c != '_')
604 gfc_error ("Invalid C name in NAME= specifier at %C");
608 /* Continue to read valid variable name characters. */
611 gcc_assert (gfc_wide_fits_in_byte (c));
613 buffer[i++] = (unsigned char) c;
615 /* C does not define a maximum length of variable names, to my
616 knowledge, but the compiler typically places a limit on them.
617 For now, i'll use the same as the fortran limit for simplicity,
618 but this may need to be changed to a dynamic buffer that can
619 be realloc'ed here if necessary, or more likely, a larger
621 if (i > gfc_option.max_identifier_length)
623 gfc_error ("Name at %C is too long");
627 old_loc = gfc_current_locus;
629 /* Get next char; param means we're in a string. */
630 c = gfc_next_char_literal (1);
631 } while (ISALNUM (c) || c == '_');
634 gfc_current_locus = old_loc;
636 /* See if we stopped because of whitespace. */
639 gfc_gobble_whitespace ();
640 c = gfc_peek_ascii_char ();
641 if (c != '"' && c != '\'')
643 gfc_error ("Embedded space in NAME= specifier at %C");
648 /* If we stopped because we had an invalid character for a C name, report
649 that to the user by returning MATCH_NO. */
650 if (c != '"' && c != '\'')
652 gfc_error ("Invalid C name in NAME= specifier at %C");
660 /* Match a symbol on the input. Modifies the pointer to the symbol
661 pointer if successful. */
664 gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
666 char buffer[GFC_MAX_SYMBOL_LEN + 1];
669 m = gfc_match_name (buffer);
674 return (gfc_get_ha_sym_tree (buffer, matched_symbol))
675 ? MATCH_ERROR : MATCH_YES;
677 if (gfc_get_sym_tree (buffer, NULL, matched_symbol))
685 gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
690 m = gfc_match_sym_tree (&st, host_assoc);
695 *matched_symbol = st->n.sym;
697 *matched_symbol = NULL;
700 *matched_symbol = NULL;
705 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
706 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
710 gfc_match_intrinsic_op (gfc_intrinsic_op *result)
712 locus orig_loc = gfc_current_locus;
715 gfc_gobble_whitespace ();
716 ch = gfc_next_ascii_char ();
721 *result = INTRINSIC_PLUS;
726 *result = INTRINSIC_MINUS;
730 if (gfc_next_ascii_char () == '=')
733 *result = INTRINSIC_EQ;
739 if (gfc_peek_ascii_char () == '=')
742 gfc_next_ascii_char ();
743 *result = INTRINSIC_LE;
747 *result = INTRINSIC_LT;
751 if (gfc_peek_ascii_char () == '=')
754 gfc_next_ascii_char ();
755 *result = INTRINSIC_GE;
759 *result = INTRINSIC_GT;
763 if (gfc_peek_ascii_char () == '*')
766 gfc_next_ascii_char ();
767 *result = INTRINSIC_POWER;
771 *result = INTRINSIC_TIMES;
775 ch = gfc_peek_ascii_char ();
779 gfc_next_ascii_char ();
780 *result = INTRINSIC_NE;
786 gfc_next_ascii_char ();
787 *result = INTRINSIC_CONCAT;
791 *result = INTRINSIC_DIVIDE;
795 ch = gfc_next_ascii_char ();
799 if (gfc_next_ascii_char () == 'n'
800 && gfc_next_ascii_char () == 'd'
801 && gfc_next_ascii_char () == '.')
803 /* Matched ".and.". */
804 *result = INTRINSIC_AND;
810 if (gfc_next_ascii_char () == 'q')
812 ch = gfc_next_ascii_char ();
815 /* Matched ".eq.". */
816 *result = INTRINSIC_EQ_OS;
821 if (gfc_next_ascii_char () == '.')
823 /* Matched ".eqv.". */
824 *result = INTRINSIC_EQV;
832 ch = gfc_next_ascii_char ();
835 if (gfc_next_ascii_char () == '.')
837 /* Matched ".ge.". */
838 *result = INTRINSIC_GE_OS;
844 if (gfc_next_ascii_char () == '.')
846 /* Matched ".gt.". */
847 *result = INTRINSIC_GT_OS;
854 ch = gfc_next_ascii_char ();
857 if (gfc_next_ascii_char () == '.')
859 /* Matched ".le.". */
860 *result = INTRINSIC_LE_OS;
866 if (gfc_next_ascii_char () == '.')
868 /* Matched ".lt.". */
869 *result = INTRINSIC_LT_OS;
876 ch = gfc_next_ascii_char ();
879 ch = gfc_next_ascii_char ();
882 /* Matched ".ne.". */
883 *result = INTRINSIC_NE_OS;
888 if (gfc_next_ascii_char () == 'v'
889 && gfc_next_ascii_char () == '.')
891 /* Matched ".neqv.". */
892 *result = INTRINSIC_NEQV;
899 if (gfc_next_ascii_char () == 't'
900 && gfc_next_ascii_char () == '.')
902 /* Matched ".not.". */
903 *result = INTRINSIC_NOT;
910 if (gfc_next_ascii_char () == 'r'
911 && gfc_next_ascii_char () == '.')
913 /* Matched ".or.". */
914 *result = INTRINSIC_OR;
928 gfc_current_locus = orig_loc;
933 /* Match a loop control phrase:
935 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
937 If the final integer expression is not present, a constant unity
938 expression is returned. We don't return MATCH_ERROR until after
939 the equals sign is seen. */
942 gfc_match_iterator (gfc_iterator *iter, int init_flag)
944 char name[GFC_MAX_SYMBOL_LEN + 1];
945 gfc_expr *var, *e1, *e2, *e3;
949 /* Match the start of an iterator without affecting the symbol table. */
951 start = gfc_current_locus;
952 m = gfc_match (" %n =", name);
953 gfc_current_locus = start;
958 m = gfc_match_variable (&var, 0);
962 gfc_match_char ('=');
966 if (var->ref != NULL)
968 gfc_error ("Loop variable at %C cannot be a sub-component");
972 if (var->symtree->n.sym->attr.intent == INTENT_IN)
974 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
975 var->symtree->n.sym->name);
979 var->symtree->n.sym->attr.implied_index = 1;
981 m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
984 if (m == MATCH_ERROR)
987 if (gfc_match_char (',') != MATCH_YES)
990 m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
993 if (m == MATCH_ERROR)
996 if (gfc_match_char (',') != MATCH_YES)
998 e3 = gfc_int_expr (1);
1002 m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
1003 if (m == MATCH_ERROR)
1007 gfc_error ("Expected a step value in iterator at %C");
1019 gfc_error ("Syntax error in iterator at %C");
1030 /* Tries to match the next non-whitespace character on the input.
1031 This subroutine does not return MATCH_ERROR. */
1034 gfc_match_char (char c)
1038 where = gfc_current_locus;
1039 gfc_gobble_whitespace ();
1041 if (gfc_next_ascii_char () == c)
1044 gfc_current_locus = where;
1049 /* General purpose matching subroutine. The target string is a
1050 scanf-like format string in which spaces correspond to arbitrary
1051 whitespace (including no whitespace), characters correspond to
1052 themselves. The %-codes are:
1054 %% Literal percent sign
1055 %e Expression, pointer to a pointer is set
1056 %s Symbol, pointer to the symbol is set
1057 %n Name, character buffer is set to name
1058 %t Matches end of statement.
1059 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1060 %l Matches a statement label
1061 %v Matches a variable expression (an lvalue)
1062 % Matches a required space (in free form) and optional spaces. */
1065 gfc_match (const char *target, ...)
1067 gfc_st_label **label;
1076 old_loc = gfc_current_locus;
1077 va_start (argp, target);
1087 gfc_gobble_whitespace ();
1098 vp = va_arg (argp, void **);
1099 n = gfc_match_expr ((gfc_expr **) vp);
1110 vp = va_arg (argp, void **);
1111 n = gfc_match_variable ((gfc_expr **) vp, 0);
1122 vp = va_arg (argp, void **);
1123 n = gfc_match_symbol ((gfc_symbol **) vp, 0);
1134 np = va_arg (argp, char *);
1135 n = gfc_match_name (np);
1146 label = va_arg (argp, gfc_st_label **);
1147 n = gfc_match_st_label (label);
1158 ip = va_arg (argp, int *);
1159 n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
1170 if (gfc_match_eos () != MATCH_YES)
1178 if (gfc_match_space () == MATCH_YES)
1184 break; /* Fall through to character matcher. */
1187 gfc_internal_error ("gfc_match(): Bad match code %c", c);
1192 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1193 expect an upper case character here! */
1194 gcc_assert (TOLOWER (c) == c);
1196 if (c == gfc_next_ascii_char ())
1206 /* Clean up after a failed match. */
1207 gfc_current_locus = old_loc;
1208 va_start (argp, target);
1211 for (; matches > 0; matches--)
1213 while (*p++ != '%');
1221 /* Matches that don't have to be undone */
1226 (void) va_arg (argp, void **);
1231 vp = va_arg (argp, void **);
1232 gfc_free_expr ((struct gfc_expr *)*vp);
1245 /*********************** Statement level matching **********************/
1247 /* Matches the start of a program unit, which is the program keyword
1248 followed by an obligatory symbol. */
1251 gfc_match_program (void)
1256 m = gfc_match ("% %s%t", &sym);
1260 gfc_error ("Invalid form of PROGRAM statement at %C");
1264 if (m == MATCH_ERROR)
1267 if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
1270 gfc_new_block = sym;
1276 /* Match a simple assignment statement. */
1279 gfc_match_assignment (void)
1281 gfc_expr *lvalue, *rvalue;
1285 old_loc = gfc_current_locus;
1288 m = gfc_match (" %v =", &lvalue);
1291 gfc_current_locus = old_loc;
1292 gfc_free_expr (lvalue);
1297 m = gfc_match (" %e%t", &rvalue);
1300 gfc_current_locus = old_loc;
1301 gfc_free_expr (lvalue);
1302 gfc_free_expr (rvalue);
1306 gfc_set_sym_referenced (lvalue->symtree->n.sym);
1308 new_st.op = EXEC_ASSIGN;
1309 new_st.expr = lvalue;
1310 new_st.expr2 = rvalue;
1312 gfc_check_do_variable (lvalue->symtree);
1318 /* Match a pointer assignment statement. */
1321 gfc_match_pointer_assignment (void)
1323 gfc_expr *lvalue, *rvalue;
1327 old_loc = gfc_current_locus;
1329 lvalue = rvalue = NULL;
1330 gfc_matching_procptr_assignment = 0;
1332 m = gfc_match (" %v =>", &lvalue);
1339 if (lvalue->symtree->n.sym->attr.proc_pointer
1340 || is_proc_ptr_comp (lvalue, NULL))
1341 gfc_matching_procptr_assignment = 1;
1343 m = gfc_match (" %e%t", &rvalue);
1344 gfc_matching_procptr_assignment = 0;
1348 new_st.op = EXEC_POINTER_ASSIGN;
1349 new_st.expr = lvalue;
1350 new_st.expr2 = rvalue;
1355 gfc_current_locus = old_loc;
1356 gfc_free_expr (lvalue);
1357 gfc_free_expr (rvalue);
1362 /* We try to match an easy arithmetic IF statement. This only happens
1363 when just after having encountered a simple IF statement. This code
1364 is really duplicate with parts of the gfc_match_if code, but this is
1368 match_arithmetic_if (void)
1370 gfc_st_label *l1, *l2, *l3;
1374 m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
1378 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1379 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1380 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1382 gfc_free_expr (expr);
1386 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF statement "
1387 "at %C") == FAILURE)
1390 new_st.op = EXEC_ARITHMETIC_IF;
1400 /* The IF statement is a bit of a pain. First of all, there are three
1401 forms of it, the simple IF, the IF that starts a block and the
1404 There is a problem with the simple IF and that is the fact that we
1405 only have a single level of undo information on symbols. What this
1406 means is for a simple IF, we must re-match the whole IF statement
1407 multiple times in order to guarantee that the symbol table ends up
1408 in the proper state. */
1410 static match match_simple_forall (void);
1411 static match match_simple_where (void);
1414 gfc_match_if (gfc_statement *if_type)
1417 gfc_st_label *l1, *l2, *l3;
1418 locus old_loc, old_loc2;
1422 n = gfc_match_label ();
1423 if (n == MATCH_ERROR)
1426 old_loc = gfc_current_locus;
1428 m = gfc_match (" if ( %e", &expr);
1432 old_loc2 = gfc_current_locus;
1433 gfc_current_locus = old_loc;
1435 if (gfc_match_parens () == MATCH_ERROR)
1438 gfc_current_locus = old_loc2;
1440 if (gfc_match_char (')') != MATCH_YES)
1442 gfc_error ("Syntax error in IF-expression at %C");
1443 gfc_free_expr (expr);
1447 m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
1453 gfc_error ("Block label not appropriate for arithmetic IF "
1455 gfc_free_expr (expr);
1459 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1460 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1461 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1463 gfc_free_expr (expr);
1467 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF "
1468 "statement at %C") == FAILURE)
1471 new_st.op = EXEC_ARITHMETIC_IF;
1477 *if_type = ST_ARITHMETIC_IF;
1481 if (gfc_match (" then%t") == MATCH_YES)
1483 new_st.op = EXEC_IF;
1485 *if_type = ST_IF_BLOCK;
1491 gfc_error ("Block label is not appropriate for IF statement at %C");
1492 gfc_free_expr (expr);
1496 /* At this point the only thing left is a simple IF statement. At
1497 this point, n has to be MATCH_NO, so we don't have to worry about
1498 re-matching a block label. From what we've got so far, try
1499 matching an assignment. */
1501 *if_type = ST_SIMPLE_IF;
1503 m = gfc_match_assignment ();
1507 gfc_free_expr (expr);
1508 gfc_undo_symbols ();
1509 gfc_current_locus = old_loc;
1511 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1512 assignment was found. For MATCH_NO, continue to call the various
1514 if (m == MATCH_ERROR)
1517 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
1519 m = gfc_match_pointer_assignment ();
1523 gfc_free_expr (expr);
1524 gfc_undo_symbols ();
1525 gfc_current_locus = old_loc;
1527 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
1529 /* Look at the next keyword to see which matcher to call. Matching
1530 the keyword doesn't affect the symbol table, so we don't have to
1531 restore between tries. */
1533 #define match(string, subr, statement) \
1534 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1538 match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1539 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1540 match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1541 match ("call", gfc_match_call, ST_CALL)
1542 match ("close", gfc_match_close, ST_CLOSE)
1543 match ("continue", gfc_match_continue, ST_CONTINUE)
1544 match ("cycle", gfc_match_cycle, ST_CYCLE)
1545 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1546 match ("end file", gfc_match_endfile, ST_END_FILE)
1547 match ("exit", gfc_match_exit, ST_EXIT)
1548 match ("flush", gfc_match_flush, ST_FLUSH)
1549 match ("forall", match_simple_forall, ST_FORALL)
1550 match ("go to", gfc_match_goto, ST_GOTO)
1551 match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1552 match ("inquire", gfc_match_inquire, ST_INQUIRE)
1553 match ("nullify", gfc_match_nullify, ST_NULLIFY)
1554 match ("open", gfc_match_open, ST_OPEN)
1555 match ("pause", gfc_match_pause, ST_NONE)
1556 match ("print", gfc_match_print, ST_WRITE)
1557 match ("read", gfc_match_read, ST_READ)
1558 match ("return", gfc_match_return, ST_RETURN)
1559 match ("rewind", gfc_match_rewind, ST_REWIND)
1560 match ("stop", gfc_match_stop, ST_STOP)
1561 match ("wait", gfc_match_wait, ST_WAIT)
1562 match ("where", match_simple_where, ST_WHERE)
1563 match ("write", gfc_match_write, ST_WRITE)
1565 /* The gfc_match_assignment() above may have returned a MATCH_NO
1566 where the assignment was to a named constant. Check that
1567 special case here. */
1568 m = gfc_match_assignment ();
1571 gfc_error ("Cannot assign to a named constant at %C");
1572 gfc_free_expr (expr);
1573 gfc_undo_symbols ();
1574 gfc_current_locus = old_loc;
1578 /* All else has failed, so give up. See if any of the matchers has
1579 stored an error message of some sort. */
1580 if (gfc_error_check () == 0)
1581 gfc_error ("Unclassifiable statement in IF-clause at %C");
1583 gfc_free_expr (expr);
1588 gfc_error ("Syntax error in IF-clause at %C");
1591 gfc_free_expr (expr);
1595 /* At this point, we've matched the single IF and the action clause
1596 is in new_st. Rearrange things so that the IF statement appears
1599 p = gfc_get_code ();
1600 p->next = gfc_get_code ();
1602 p->next->loc = gfc_current_locus;
1607 gfc_clear_new_st ();
1609 new_st.op = EXEC_IF;
1618 /* Match an ELSE statement. */
1621 gfc_match_else (void)
1623 char name[GFC_MAX_SYMBOL_LEN + 1];
1625 if (gfc_match_eos () == MATCH_YES)
1628 if (gfc_match_name (name) != MATCH_YES
1629 || gfc_current_block () == NULL
1630 || gfc_match_eos () != MATCH_YES)
1632 gfc_error ("Unexpected junk after ELSE statement at %C");
1636 if (strcmp (name, gfc_current_block ()->name) != 0)
1638 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1639 name, gfc_current_block ()->name);
1647 /* Match an ELSE IF statement. */
1650 gfc_match_elseif (void)
1652 char name[GFC_MAX_SYMBOL_LEN + 1];
1656 m = gfc_match (" ( %e ) then", &expr);
1660 if (gfc_match_eos () == MATCH_YES)
1663 if (gfc_match_name (name) != MATCH_YES
1664 || gfc_current_block () == NULL
1665 || gfc_match_eos () != MATCH_YES)
1667 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1671 if (strcmp (name, gfc_current_block ()->name) != 0)
1673 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1674 name, gfc_current_block ()->name);
1679 new_st.op = EXEC_IF;
1684 gfc_free_expr (expr);
1689 /* Free a gfc_iterator structure. */
1692 gfc_free_iterator (gfc_iterator *iter, int flag)
1698 gfc_free_expr (iter->var);
1699 gfc_free_expr (iter->start);
1700 gfc_free_expr (iter->end);
1701 gfc_free_expr (iter->step);
1708 /* Match a DO statement. */
1713 gfc_iterator iter, *ip;
1715 gfc_st_label *label;
1718 old_loc = gfc_current_locus;
1721 iter.var = iter.start = iter.end = iter.step = NULL;
1723 m = gfc_match_label ();
1724 if (m == MATCH_ERROR)
1727 if (gfc_match (" do") != MATCH_YES)
1730 m = gfc_match_st_label (&label);
1731 if (m == MATCH_ERROR)
1734 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
1736 if (gfc_match_eos () == MATCH_YES)
1738 iter.end = gfc_logical_expr (1, NULL);
1739 new_st.op = EXEC_DO_WHILE;
1743 /* Match an optional comma, if no comma is found, a space is obligatory. */
1744 if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
1747 /* Check for balanced parens. */
1749 if (gfc_match_parens () == MATCH_ERROR)
1752 /* See if we have a DO WHILE. */
1753 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1755 new_st.op = EXEC_DO_WHILE;
1759 /* The abortive DO WHILE may have done something to the symbol
1760 table, so we start over. */
1761 gfc_undo_symbols ();
1762 gfc_current_locus = old_loc;
1764 gfc_match_label (); /* This won't error. */
1765 gfc_match (" do "); /* This will work. */
1767 gfc_match_st_label (&label); /* Can't error out. */
1768 gfc_match_char (','); /* Optional comma. */
1770 m = gfc_match_iterator (&iter, 0);
1773 if (m == MATCH_ERROR)
1776 iter.var->symtree->n.sym->attr.implied_index = 0;
1777 gfc_check_do_variable (iter.var->symtree);
1779 if (gfc_match_eos () != MATCH_YES)
1781 gfc_syntax_error (ST_DO);
1785 new_st.op = EXEC_DO;
1789 && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1792 new_st.label = label;
1794 if (new_st.op == EXEC_DO_WHILE)
1795 new_st.expr = iter.end;
1798 new_st.ext.iterator = ip = gfc_get_iterator ();
1805 gfc_free_iterator (&iter, 0);
1811 /* Match an EXIT or CYCLE statement. */
1814 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1816 gfc_state_data *p, *o;
1820 if (gfc_match_eos () == MATCH_YES)
1824 m = gfc_match ("% %s%t", &sym);
1825 if (m == MATCH_ERROR)
1829 gfc_syntax_error (st);
1833 if (sym->attr.flavor != FL_LABEL)
1835 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1836 sym->name, gfc_ascii_statement (st));
1841 /* Find the loop mentioned specified by the label (or lack of a label). */
1842 for (o = NULL, p = gfc_state_stack; p; p = p->previous)
1843 if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1845 else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
1851 gfc_error ("%s statement at %C is not within a loop",
1852 gfc_ascii_statement (st));
1854 gfc_error ("%s statement at %C is not within loop '%s'",
1855 gfc_ascii_statement (st), sym->name);
1862 gfc_error ("%s statement at %C leaving OpenMP structured block",
1863 gfc_ascii_statement (st));
1866 else if (st == ST_EXIT
1867 && p->previous != NULL
1868 && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
1869 && (p->previous->head->op == EXEC_OMP_DO
1870 || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
1872 gcc_assert (p->previous->head->next != NULL);
1873 gcc_assert (p->previous->head->next->op == EXEC_DO
1874 || p->previous->head->next->op == EXEC_DO_WHILE);
1875 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1879 /* Save the first statement in the loop - needed by the backend. */
1880 new_st.ext.whichloop = p->head;
1888 /* Match the EXIT statement. */
1891 gfc_match_exit (void)
1893 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1897 /* Match the CYCLE statement. */
1900 gfc_match_cycle (void)
1902 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1906 /* Match a number or character constant after a STOP or PAUSE statement. */
1909 gfc_match_stopcode (gfc_statement st)
1919 if (gfc_match_eos () != MATCH_YES)
1921 m = gfc_match_small_literal_int (&stop_code, &cnt);
1922 if (m == MATCH_ERROR)
1925 if (m == MATCH_YES && cnt > 5)
1927 gfc_error ("Too many digits in STOP code at %C");
1933 /* Try a character constant. */
1934 m = gfc_match_expr (&e);
1935 if (m == MATCH_ERROR)
1939 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1943 if (gfc_match_eos () != MATCH_YES)
1947 if (gfc_pure (NULL))
1949 gfc_error ("%s statement not allowed in PURE procedure at %C",
1950 gfc_ascii_statement (st));
1954 new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1956 new_st.ext.stop_code = stop_code;
1961 gfc_syntax_error (st);
1970 /* Match the (deprecated) PAUSE statement. */
1973 gfc_match_pause (void)
1977 m = gfc_match_stopcode (ST_PAUSE);
1980 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
1989 /* Match the STOP statement. */
1992 gfc_match_stop (void)
1994 return gfc_match_stopcode (ST_STOP);
1998 /* Match a CONTINUE statement. */
2001 gfc_match_continue (void)
2003 if (gfc_match_eos () != MATCH_YES)
2005 gfc_syntax_error (ST_CONTINUE);
2009 new_st.op = EXEC_CONTINUE;
2014 /* Match the (deprecated) ASSIGN statement. */
2017 gfc_match_assign (void)
2020 gfc_st_label *label;
2022 if (gfc_match (" %l", &label) == MATCH_YES)
2024 if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
2026 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
2028 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
2033 expr->symtree->n.sym->attr.assign = 1;
2035 new_st.op = EXEC_LABEL_ASSIGN;
2036 new_st.label = label;
2045 /* Match the GO TO statement. As a computed GOTO statement is
2046 matched, it is transformed into an equivalent SELECT block. No
2047 tree is necessary, and the resulting jumps-to-jumps are
2048 specifically optimized away by the back end. */
2051 gfc_match_goto (void)
2053 gfc_code *head, *tail;
2056 gfc_st_label *label;
2060 if (gfc_match (" %l%t", &label) == MATCH_YES)
2062 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2065 new_st.op = EXEC_GOTO;
2066 new_st.label = label;
2070 /* The assigned GO TO statement. */
2072 if (gfc_match_variable (&expr, 0) == MATCH_YES)
2074 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
2079 new_st.op = EXEC_GOTO;
2082 if (gfc_match_eos () == MATCH_YES)
2085 /* Match label list. */
2086 gfc_match_char (',');
2087 if (gfc_match_char ('(') != MATCH_YES)
2089 gfc_syntax_error (ST_GOTO);
2096 m = gfc_match_st_label (&label);
2100 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2104 head = tail = gfc_get_code ();
2107 tail->block = gfc_get_code ();
2111 tail->label = label;
2112 tail->op = EXEC_GOTO;
2114 while (gfc_match_char (',') == MATCH_YES);
2116 if (gfc_match (")%t") != MATCH_YES)
2121 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2124 new_st.block = head;
2129 /* Last chance is a computed GO TO statement. */
2130 if (gfc_match_char ('(') != MATCH_YES)
2132 gfc_syntax_error (ST_GOTO);
2141 m = gfc_match_st_label (&label);
2145 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2149 head = tail = gfc_get_code ();
2152 tail->block = gfc_get_code ();
2156 cp = gfc_get_case ();
2157 cp->low = cp->high = gfc_int_expr (i++);
2159 tail->op = EXEC_SELECT;
2160 tail->ext.case_list = cp;
2162 tail->next = gfc_get_code ();
2163 tail->next->op = EXEC_GOTO;
2164 tail->next->label = label;
2166 while (gfc_match_char (',') == MATCH_YES);
2168 if (gfc_match_char (')') != MATCH_YES)
2173 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2177 /* Get the rest of the statement. */
2178 gfc_match_char (',');
2180 if (gfc_match (" %e%t", &expr) != MATCH_YES)
2183 /* At this point, a computed GOTO has been fully matched and an
2184 equivalent SELECT statement constructed. */
2186 new_st.op = EXEC_SELECT;
2189 /* Hack: For a "real" SELECT, the expression is in expr. We put
2190 it in expr2 so we can distinguish then and produce the correct
2192 new_st.expr2 = expr;
2193 new_st.block = head;
2197 gfc_syntax_error (ST_GOTO);
2199 gfc_free_statements (head);
2204 /* Frees a list of gfc_alloc structures. */
2207 gfc_free_alloc_list (gfc_alloc *p)
2214 gfc_free_expr (p->expr);
2220 /* Match an ALLOCATE statement. */
2223 gfc_match_allocate (void)
2225 gfc_alloc *head, *tail;
2226 gfc_expr *stat, *errmsg, *tmp;
2228 bool saw_stat, saw_errmsg;
2231 stat = errmsg = tmp = NULL;
2232 saw_stat = saw_errmsg = false;
2234 if (gfc_match_char ('(') != MATCH_YES)
2240 head = tail = gfc_get_alloc ();
2243 tail->next = gfc_get_alloc ();
2247 m = gfc_match_variable (&tail->expr, 0);
2250 if (m == MATCH_ERROR)
2253 if (gfc_check_do_variable (tail->expr->symtree))
2256 if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
2258 gfc_error ("Bad allocate-object at %C for a PURE procedure");
2262 if (tail->expr->ts.type == BT_DERIVED)
2263 tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
2265 /* FIXME: disable the checking on derived types and arrays. */
2266 if (!(tail->expr->ref
2267 && (tail->expr->ref->type == REF_COMPONENT
2268 || tail->expr->ref->type == REF_ARRAY))
2269 && tail->expr->symtree->n.sym
2270 && !(tail->expr->symtree->n.sym->attr.allocatable
2271 || tail->expr->symtree->n.sym->attr.pointer
2272 || tail->expr->symtree->n.sym->attr.proc_pointer))
2274 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2275 "or an allocatable variable");
2279 if (gfc_match_char (',') != MATCH_YES)
2284 m = gfc_match (" stat = %v", &tmp);
2285 if (m == MATCH_ERROR)
2291 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2292 gfc_free_expr (tmp);
2299 if (gfc_check_do_variable (stat->symtree))
2302 if (gfc_match_char (',') == MATCH_YES)
2303 goto alloc_opt_list;
2306 m = gfc_match (" errmsg = %v", &tmp);
2307 if (m == MATCH_ERROR)
2311 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
2312 &tmp->where) == FAILURE)
2317 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2318 gfc_free_expr (tmp);
2325 if (gfc_match_char (',') == MATCH_YES)
2326 goto alloc_opt_list;
2329 gfc_gobble_whitespace ();
2331 if (gfc_peek_char () == ')')
2336 if (gfc_match (" )%t") != MATCH_YES)
2339 new_st.op = EXEC_ALLOCATE;
2341 new_st.expr2 = errmsg;
2342 new_st.ext.alloc_list = head;
2347 gfc_syntax_error (ST_ALLOCATE);
2350 gfc_free_expr (errmsg);
2351 gfc_free_expr (stat);
2352 gfc_free_alloc_list (head);
2357 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
2358 a set of pointer assignments to intrinsic NULL(). */
2361 gfc_match_nullify (void)
2369 if (gfc_match_char ('(') != MATCH_YES)
2374 m = gfc_match_variable (&p, 0);
2375 if (m == MATCH_ERROR)
2380 if (gfc_check_do_variable (p->symtree))
2383 if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
2385 gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
2389 /* build ' => NULL() '. */
2390 e = gfc_get_expr ();
2391 e->where = gfc_current_locus;
2392 e->expr_type = EXPR_NULL;
2393 e->ts.type = BT_UNKNOWN;
2395 /* Chain to list. */
2400 tail->next = gfc_get_code ();
2404 tail->op = EXEC_POINTER_ASSIGN;
2408 if (gfc_match (" )%t") == MATCH_YES)
2410 if (gfc_match_char (',') != MATCH_YES)
2417 gfc_syntax_error (ST_NULLIFY);
2420 gfc_free_statements (new_st.next);
2425 /* Match a DEALLOCATE statement. */
2428 gfc_match_deallocate (void)
2430 gfc_alloc *head, *tail;
2431 gfc_expr *stat, *errmsg, *tmp;
2433 bool saw_stat, saw_errmsg;
2436 stat = errmsg = tmp = NULL;
2437 saw_stat = saw_errmsg = false;
2439 if (gfc_match_char ('(') != MATCH_YES)
2445 head = tail = gfc_get_alloc ();
2448 tail->next = gfc_get_alloc ();
2452 m = gfc_match_variable (&tail->expr, 0);
2453 if (m == MATCH_ERROR)
2458 if (gfc_check_do_variable (tail->expr->symtree))
2461 if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
2463 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
2467 /* FIXME: disable the checking on derived types. */
2468 if (!(tail->expr->ref
2469 && (tail->expr->ref->type == REF_COMPONENT
2470 || tail->expr->ref->type == REF_ARRAY))
2471 && tail->expr->symtree->n.sym
2472 && !(tail->expr->symtree->n.sym->attr.allocatable
2473 || tail->expr->symtree->n.sym->attr.pointer
2474 || tail->expr->symtree->n.sym->attr.proc_pointer))
2476 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2477 "or an allocatable variable");
2481 if (gfc_match_char (',') != MATCH_YES)
2486 m = gfc_match (" stat = %v", &tmp);
2487 if (m == MATCH_ERROR)
2493 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2494 gfc_free_expr (tmp);
2501 if (gfc_check_do_variable (stat->symtree))
2504 if (gfc_match_char (',') == MATCH_YES)
2505 goto dealloc_opt_list;
2508 m = gfc_match (" errmsg = %v", &tmp);
2509 if (m == MATCH_ERROR)
2513 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
2514 &tmp->where) == FAILURE)
2519 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2520 gfc_free_expr (tmp);
2527 if (gfc_match_char (',') == MATCH_YES)
2528 goto dealloc_opt_list;
2531 gfc_gobble_whitespace ();
2533 if (gfc_peek_char () == ')')
2537 if (gfc_match (" )%t") != MATCH_YES)
2540 new_st.op = EXEC_DEALLOCATE;
2542 new_st.expr2 = errmsg;
2543 new_st.ext.alloc_list = head;
2548 gfc_syntax_error (ST_DEALLOCATE);
2551 gfc_free_expr (errmsg);
2552 gfc_free_expr (stat);
2553 gfc_free_alloc_list (head);
2558 /* Match a RETURN statement. */
2561 gfc_match_return (void)
2565 gfc_compile_state s;
2568 if (gfc_match_eos () == MATCH_YES)
2571 if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
2573 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2578 if (gfc_current_form == FORM_FREE)
2580 /* The following are valid, so we can't require a blank after the
2584 char c = gfc_peek_ascii_char ();
2585 if (ISALPHA (c) || ISDIGIT (c))
2589 m = gfc_match (" %e%t", &e);
2592 if (m == MATCH_ERROR)
2595 gfc_syntax_error (ST_RETURN);
2602 gfc_enclosing_unit (&s);
2603 if (s == COMP_PROGRAM
2604 && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
2605 "main program at %C") == FAILURE)
2608 new_st.op = EXEC_RETURN;
2615 /* Match the call of a type-bound procedure, if CALL%var has already been
2616 matched and var found to be a derived-type variable. */
2619 match_typebound_call (gfc_symtree* varst)
2627 base = gfc_get_expr ();
2628 base->expr_type = EXPR_VARIABLE;
2629 base->symtree = varst;
2630 base->where = gfc_current_locus;
2631 gfc_set_sym_referenced (varst->n.sym);
2633 m = gfc_match_varspec (base, 0, true, true);
2635 gfc_error ("Expected component reference at %C");
2639 if (gfc_match_eos () != MATCH_YES)
2641 gfc_error ("Junk after CALL at %C");
2645 if (base->expr_type == EXPR_COMPCALL)
2646 new_st.op = EXEC_COMPCALL;
2647 else if (base->expr_type == EXPR_PPC)
2648 new_st.op = EXEC_CALL_PPC;
2651 gfc_error ("Expected type-bound procedure or procedure pointer component "
2661 /* Match a CALL statement. The tricky part here are possible
2662 alternate return specifiers. We handle these by having all
2663 "subroutines" actually return an integer via a register that gives
2664 the return number. If the call specifies alternate returns, we
2665 generate code for a SELECT statement whose case clauses contain
2666 GOTOs to the various labels. */
2669 gfc_match_call (void)
2671 char name[GFC_MAX_SYMBOL_LEN + 1];
2672 gfc_actual_arglist *a, *arglist;
2682 m = gfc_match ("% %n", name);
2688 if (gfc_get_ha_sym_tree (name, &st))
2693 /* If this is a variable of derived-type, it probably starts a type-bound
2695 if (sym->attr.flavor != FL_PROCEDURE && sym->ts.type == BT_DERIVED)
2696 return match_typebound_call (st);
2698 /* If it does not seem to be callable (include functions so that the
2699 right association is made. They are thrown out in resolution.)
2701 if (!sym->attr.generic
2702 && !sym->attr.subroutine
2703 && !sym->attr.function)
2705 if (!(sym->attr.external && !sym->attr.referenced))
2707 /* ...create a symbol in this scope... */
2708 if (sym->ns != gfc_current_ns
2709 && gfc_get_sym_tree (name, NULL, &st) == 1)
2712 if (sym != st->n.sym)
2716 /* ...and then to try to make the symbol into a subroutine. */
2717 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2721 gfc_set_sym_referenced (sym);
2723 if (gfc_match_eos () != MATCH_YES)
2725 m = gfc_match_actual_arglist (1, &arglist);
2728 if (m == MATCH_ERROR)
2731 if (gfc_match_eos () != MATCH_YES)
2735 /* If any alternate return labels were found, construct a SELECT
2736 statement that will jump to the right place. */
2739 for (a = arglist; a; a = a->next)
2740 if (a->expr == NULL)
2745 gfc_symtree *select_st;
2746 gfc_symbol *select_sym;
2747 char name[GFC_MAX_SYMBOL_LEN + 1];
2749 new_st.next = c = gfc_get_code ();
2750 c->op = EXEC_SELECT;
2751 sprintf (name, "_result_%s", sym->name);
2752 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
2754 select_sym = select_st->n.sym;
2755 select_sym->ts.type = BT_INTEGER;
2756 select_sym->ts.kind = gfc_default_integer_kind;
2757 gfc_set_sym_referenced (select_sym);
2758 c->expr = gfc_get_expr ();
2759 c->expr->expr_type = EXPR_VARIABLE;
2760 c->expr->symtree = select_st;
2761 c->expr->ts = select_sym->ts;
2762 c->expr->where = gfc_current_locus;
2765 for (a = arglist; a; a = a->next)
2767 if (a->expr != NULL)
2770 if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2775 c->block = gfc_get_code ();
2777 c->op = EXEC_SELECT;
2779 new_case = gfc_get_case ();
2780 new_case->high = new_case->low = gfc_int_expr (i);
2781 c->ext.case_list = new_case;
2783 c->next = gfc_get_code ();
2784 c->next->op = EXEC_GOTO;
2785 c->next->label = a->label;
2789 new_st.op = EXEC_CALL;
2790 new_st.symtree = st;
2791 new_st.ext.actual = arglist;
2796 gfc_syntax_error (ST_CALL);
2799 gfc_free_actual_arglist (arglist);
2804 /* Given a name, return a pointer to the common head structure,
2805 creating it if it does not exist. If FROM_MODULE is nonzero, we
2806 mangle the name so that it doesn't interfere with commons defined
2807 in the using namespace.
2808 TODO: Add to global symbol tree. */
2811 gfc_get_common (const char *name, int from_module)
2814 static int serial = 0;
2815 char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
2819 /* A use associated common block is only needed to correctly layout
2820 the variables it contains. */
2821 snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2822 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2826 st = gfc_find_symtree (gfc_current_ns->common_root, name);
2829 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2832 if (st->n.common == NULL)
2834 st->n.common = gfc_get_common_head ();
2835 st->n.common->where = gfc_current_locus;
2836 strcpy (st->n.common->name, name);
2839 return st->n.common;
2843 /* Match a common block name. */
2845 match match_common_name (char *name)
2849 if (gfc_match_char ('/') == MATCH_NO)
2855 if (gfc_match_char ('/') == MATCH_YES)
2861 m = gfc_match_name (name);
2863 if (m == MATCH_ERROR)
2865 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2868 gfc_error ("Syntax error in common block name at %C");
2873 /* Match a COMMON statement. */
2876 gfc_match_common (void)
2878 gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
2879 char name[GFC_MAX_SYMBOL_LEN + 1];
2886 old_blank_common = gfc_current_ns->blank_common.head;
2887 if (old_blank_common)
2889 while (old_blank_common->common_next)
2890 old_blank_common = old_blank_common->common_next;
2897 m = match_common_name (name);
2898 if (m == MATCH_ERROR)
2901 gsym = gfc_get_gsymbol (name);
2902 if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
2904 gfc_error ("Symbol '%s' at %C is already an external symbol that "
2905 "is not COMMON", name);
2909 if (gsym->type == GSYM_UNKNOWN)
2911 gsym->type = GSYM_COMMON;
2912 gsym->where = gfc_current_locus;
2918 if (name[0] == '\0')
2920 t = &gfc_current_ns->blank_common;
2921 if (t->head == NULL)
2922 t->where = gfc_current_locus;
2926 t = gfc_get_common (name, 0);
2935 while (tail->common_next)
2936 tail = tail->common_next;
2939 /* Grab the list of symbols. */
2942 m = gfc_match_symbol (&sym, 0);
2943 if (m == MATCH_ERROR)
2948 /* Store a ref to the common block for error checking. */
2949 sym->common_block = t;
2951 /* See if we know the current common block is bind(c), and if
2952 so, then see if we can check if the symbol is (which it'll
2953 need to be). This can happen if the bind(c) attr stmt was
2954 applied to the common block, and the variable(s) already
2955 defined, before declaring the common block. */
2956 if (t->is_bind_c == 1)
2958 if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
2960 /* If we find an error, just print it and continue,
2961 cause it's just semantic, and we can see if there
2963 gfc_error_now ("Variable '%s' at %L in common block '%s' "
2964 "at %C must be declared with a C "
2965 "interoperable kind since common block "
2967 sym->name, &(sym->declared_at), t->name,
2971 if (sym->attr.is_bind_c == 1)
2972 gfc_error_now ("Variable '%s' in common block "
2973 "'%s' at %C can not be bind(c) since "
2974 "it is not global", sym->name, t->name);
2977 if (sym->attr.in_common)
2979 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2984 if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
2985 || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
2987 if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
2988 "can only be COMMON in "
2989 "BLOCK DATA", sym->name)
2994 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2998 tail->common_next = sym;
3004 /* Deal with an optional array specification after the
3006 m = gfc_match_array_spec (&as);
3007 if (m == MATCH_ERROR)
3012 if (as->type != AS_EXPLICIT)
3014 gfc_error ("Array specification for symbol '%s' in COMMON "
3015 "at %C must be explicit", sym->name);
3019 if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
3022 if (sym->attr.pointer)
3024 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
3025 "POINTER array", sym->name);
3034 sym->common_head = t;
3036 /* Check to see if the symbol is already in an equivalence group.
3037 If it is, set the other members as being in common. */
3038 if (sym->attr.in_equivalence)
3040 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
3042 for (e2 = e1; e2; e2 = e2->eq)
3043 if (e2->expr->symtree->n.sym == sym)
3050 for (e2 = e1; e2; e2 = e2->eq)
3052 other = e2->expr->symtree->n.sym;
3053 if (other->common_head
3054 && other->common_head != sym->common_head)
3056 gfc_error ("Symbol '%s', in COMMON block '%s' at "
3057 "%C is being indirectly equivalenced to "
3058 "another COMMON block '%s'",
3059 sym->name, sym->common_head->name,
3060 other->common_head->name);
3063 other->attr.in_common = 1;
3064 other->common_head = t;
3070 gfc_gobble_whitespace ();
3071 if (gfc_match_eos () == MATCH_YES)
3073 if (gfc_peek_ascii_char () == '/')
3075 if (gfc_match_char (',') != MATCH_YES)
3077 gfc_gobble_whitespace ();
3078 if (gfc_peek_ascii_char () == '/')
3087 gfc_syntax_error (ST_COMMON);
3090 if (old_blank_common)
3091 old_blank_common->common_next = NULL;
3093 gfc_current_ns->blank_common.head = NULL;
3094 gfc_free_array_spec (as);
3099 /* Match a BLOCK DATA program unit. */
3102 gfc_match_block_data (void)
3104 char name[GFC_MAX_SYMBOL_LEN + 1];
3108 if (gfc_match_eos () == MATCH_YES)
3110 gfc_new_block = NULL;
3114 m = gfc_match ("% %n%t", name);
3118 if (gfc_get_symbol (name, NULL, &sym))
3121 if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
3124 gfc_new_block = sym;
3130 /* Free a namelist structure. */
3133 gfc_free_namelist (gfc_namelist *name)
3137 for (; name; name = n)
3145 /* Match a NAMELIST statement. */
3148 gfc_match_namelist (void)
3150 gfc_symbol *group_name, *sym;
3154 m = gfc_match (" / %s /", &group_name);
3157 if (m == MATCH_ERROR)
3162 if (group_name->ts.type != BT_UNKNOWN)
3164 gfc_error ("Namelist group name '%s' at %C already has a basic "
3165 "type of %s", group_name->name,
3166 gfc_typename (&group_name->ts));
3170 if (group_name->attr.flavor == FL_NAMELIST
3171 && group_name->attr.use_assoc
3172 && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
3173 "at %C already is USE associated and can"
3174 "not be respecified.", group_name->name)
3178 if (group_name->attr.flavor != FL_NAMELIST
3179 && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
3180 group_name->name, NULL) == FAILURE)
3185 m = gfc_match_symbol (&sym, 1);
3188 if (m == MATCH_ERROR)
3191 if (sym->attr.in_namelist == 0
3192 && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
3195 /* Use gfc_error_check here, rather than goto error, so that
3196 these are the only errors for the next two lines. */
3197 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
3199 gfc_error ("Assumed size array '%s' in namelist '%s' at "
3200 "%C is not allowed", sym->name, group_name->name);
3204 if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL)
3206 gfc_error ("Assumed character length '%s' in namelist '%s' at "
3207 "%C is not allowed", sym->name, group_name->name);
3211 nl = gfc_get_namelist ();
3215 if (group_name->namelist == NULL)
3216 group_name->namelist = group_name->namelist_tail = nl;
3219 group_name->namelist_tail->next = nl;
3220 group_name->namelist_tail = nl;
3223 if (gfc_match_eos () == MATCH_YES)
3226 m = gfc_match_char (',');
3228 if (gfc_match_char ('/') == MATCH_YES)
3230 m2 = gfc_match (" %s /", &group_name);
3231 if (m2 == MATCH_YES)
3233 if (m2 == MATCH_ERROR)
3247 gfc_syntax_error (ST_NAMELIST);
3254 /* Match a MODULE statement. */
3257 gfc_match_module (void)
3261 m = gfc_match (" %s%t", &gfc_new_block);
3265 if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
3266 gfc_new_block->name, NULL) == FAILURE)
3273 /* Free equivalence sets and lists. Recursively is the easiest way to
3277 gfc_free_equiv (gfc_equiv *eq)
3282 gfc_free_equiv (eq->eq);
3283 gfc_free_equiv (eq->next);
3284 gfc_free_expr (eq->expr);
3289 /* Match an EQUIVALENCE statement. */
3292 gfc_match_equivalence (void)
3294 gfc_equiv *eq, *set, *tail;
3298 gfc_common_head *common_head = NULL;
3306 eq = gfc_get_equiv ();
3310 eq->next = gfc_current_ns->equiv;
3311 gfc_current_ns->equiv = eq;
3313 if (gfc_match_char ('(') != MATCH_YES)
3317 common_flag = FALSE;
3322 m = gfc_match_equiv_variable (&set->expr);
3323 if (m == MATCH_ERROR)
3328 /* count the number of objects. */
3331 if (gfc_match_char ('%') == MATCH_YES)
3333 gfc_error ("Derived type component %C is not a "
3334 "permitted EQUIVALENCE member");
3338 for (ref = set->expr->ref; ref; ref = ref->next)
3339 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3341 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
3342 "be an array section");
3346 sym = set->expr->symtree->n.sym;
3348 if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
3351 if (sym->attr.in_common)
3354 common_head = sym->common_head;
3357 if (gfc_match_char (')') == MATCH_YES)
3360 if (gfc_match_char (',') != MATCH_YES)
3363 set->eq = gfc_get_equiv ();
3369 gfc_error ("EQUIVALENCE at %C requires two or more objects");
3373 /* If one of the members of an equivalence is in common, then
3374 mark them all as being in common. Before doing this, check
3375 that members of the equivalence group are not in different
3378 for (set = eq; set; set = set->eq)
3380 sym = set->expr->symtree->n.sym;
3381 if (sym->common_head && sym->common_head != common_head)
3383 gfc_error ("Attempt to indirectly overlap COMMON "
3384 "blocks %s and %s by EQUIVALENCE at %C",
3385 sym->common_head->name, common_head->name);
3388 sym->attr.in_common = 1;
3389 sym->common_head = common_head;
3392 if (gfc_match_eos () == MATCH_YES)
3394 if (gfc_match_char (',') != MATCH_YES)
3401 gfc_syntax_error (ST_EQUIVALENCE);
3407 gfc_free_equiv (gfc_current_ns->equiv);
3408 gfc_current_ns->equiv = eq;
3414 /* Check that a statement function is not recursive. This is done by looking
3415 for the statement function symbol(sym) by looking recursively through its
3416 expression(e). If a reference to sym is found, true is returned.
3417 12.5.4 requires that any variable of function that is implicitly typed
3418 shall have that type confirmed by any subsequent type declaration. The
3419 implicit typing is conveniently done here. */
3421 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
3424 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
3430 switch (e->expr_type)
3433 if (e->symtree == NULL)
3436 /* Check the name before testing for nested recursion! */
3437 if (sym->name == e->symtree->n.sym->name)
3440 /* Catch recursion via other statement functions. */
3441 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
3442 && e->symtree->n.sym->value
3443 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
3446 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3447 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3452 if (e->symtree && sym->name == e->symtree->n.sym->name)
3455 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3456 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3468 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
3470 return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
3474 /* Match a statement function declaration. It is so easy to match
3475 non-statement function statements with a MATCH_ERROR as opposed to
3476 MATCH_NO that we suppress error message in most cases. */
3479 gfc_match_st_function (void)
3481 gfc_error_buf old_error;
3486 m = gfc_match_symbol (&sym, 0);
3490 gfc_push_error (&old_error);
3492 if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
3493 sym->name, NULL) == FAILURE)
3496 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
3499 m = gfc_match (" = %e%t", &expr);
3503 gfc_free_error (&old_error);
3504 if (m == MATCH_ERROR)
3507 if (recursive_stmt_fcn (expr, sym))
3509 gfc_error ("Statement function at %L is recursive", &expr->where);
3518 gfc_pop_error (&old_error);
3523 /***************** SELECT CASE subroutines ******************/
3525 /* Free a single case structure. */
3528 free_case (gfc_case *p)
3530 if (p->low == p->high)
3532 gfc_free_expr (p->low);
3533 gfc_free_expr (p->high);
3538 /* Free a list of case structures. */
3541 gfc_free_case_list (gfc_case *p)
3553 /* Match a single case selector. */
3556 match_case_selector (gfc_case **cp)
3561 c = gfc_get_case ();
3562 c->where = gfc_current_locus;
3564 if (gfc_match_char (':') == MATCH_YES)
3566 m = gfc_match_init_expr (&c->high);
3569 if (m == MATCH_ERROR)
3574 m = gfc_match_init_expr (&c->low);
3575 if (m == MATCH_ERROR)
3580 /* If we're not looking at a ':' now, make a range out of a single
3581 target. Else get the upper bound for the case range. */
3582 if (gfc_match_char (':') != MATCH_YES)
3586 m = gfc_match_init_expr (&c->high);
3587 if (m == MATCH_ERROR)
3589 /* MATCH_NO is fine. It's OK if nothing is there! */
3597 gfc_error ("Expected initialization expression in CASE at %C");
3605 /* Match the end of a case statement. */
3608 match_case_eos (void)
3610 char name[GFC_MAX_SYMBOL_LEN + 1];
3613 if (gfc_match_eos () == MATCH_YES)
3616 /* If the case construct doesn't have a case-construct-name, we
3617 should have matched the EOS. */
3618 if (!gfc_current_block ())
3620 gfc_error ("Expected the name of the SELECT CASE construct at %C");
3624 gfc_gobble_whitespace ();
3626 m = gfc_match_name (name);
3630 if (strcmp (name, gfc_current_block ()->name) != 0)
3632 gfc_error ("Expected case name of '%s' at %C",
3633 gfc_current_block ()->name);
3637 return gfc_match_eos ();
3641 /* Match a SELECT statement. */
3644 gfc_match_select (void)
3649 m = gfc_match_label ();
3650 if (m == MATCH_ERROR)
3653 m = gfc_match (" select case ( %e )%t", &expr);
3657 new_st.op = EXEC_SELECT;
3664 /* Match a CASE statement. */
3667 gfc_match_case (void)
3669 gfc_case *c, *head, *tail;
3674 if (gfc_current_state () != COMP_SELECT)
3676 gfc_error ("Unexpected CASE statement at %C");
3680 if (gfc_match ("% default") == MATCH_YES)
3682 m = match_case_eos ();
3685 if (m == MATCH_ERROR)
3688 new_st.op = EXEC_SELECT;
3689 c = gfc_get_case ();
3690 c->where = gfc_current_locus;
3691 new_st.ext.case_list = c;
3695 if (gfc_match_char ('(') != MATCH_YES)
3700 if (match_case_selector (&c) == MATCH_ERROR)
3710 if (gfc_match_char (')') == MATCH_YES)
3712 if (gfc_match_char (',') != MATCH_YES)
3716 m = match_case_eos ();
3719 if (m == MATCH_ERROR)
3722 new_st.op = EXEC_SELECT;
3723 new_st.ext.case_list = head;
3728 gfc_error ("Syntax error in CASE-specification at %C");
3731 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
3735 /********************* WHERE subroutines ********************/
3737 /* Match the rest of a simple WHERE statement that follows an IF statement.
3741 match_simple_where (void)
3747 m = gfc_match (" ( %e )", &expr);
3751 m = gfc_match_assignment ();
3754 if (m == MATCH_ERROR)
3757 if (gfc_match_eos () != MATCH_YES)
3760 c = gfc_get_code ();
3764 c->next = gfc_get_code ();
3767 gfc_clear_new_st ();
3769 new_st.op = EXEC_WHERE;
3775 gfc_syntax_error (ST_WHERE);
3778 gfc_free_expr (expr);
3783 /* Match a WHERE statement. */
3786 gfc_match_where (gfc_statement *st)
3792 m0 = gfc_match_label ();
3793 if (m0 == MATCH_ERROR)
3796 m = gfc_match (" where ( %e )", &expr);
3800 if (gfc_match_eos () == MATCH_YES)
3802 *st = ST_WHERE_BLOCK;
3803 new_st.op = EXEC_WHERE;
3808 m = gfc_match_assignment ();
3810 gfc_syntax_error (ST_WHERE);
3814 gfc_free_expr (expr);
3818 /* We've got a simple WHERE statement. */
3820 c = gfc_get_code ();
3824 c->next = gfc_get_code ();
3827 gfc_clear_new_st ();
3829 new_st.op = EXEC_WHERE;
3836 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3837 new_st if successful. */
3840 gfc_match_elsewhere (void)
3842 char name[GFC_MAX_SYMBOL_LEN + 1];
3846 if (gfc_current_state () != COMP_WHERE)
3848 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3854 if (gfc_match_char ('(') == MATCH_YES)
3856 m = gfc_match_expr (&expr);
3859 if (m == MATCH_ERROR)
3862 if (gfc_match_char (')') != MATCH_YES)
3866 if (gfc_match_eos () != MATCH_YES)
3868 /* Only makes sense if we have a where-construct-name. */
3869 if (!gfc_current_block ())
3874 /* Better be a name at this point. */
3875 m = gfc_match_name (name);
3878 if (m == MATCH_ERROR)
3881 if (gfc_match_eos () != MATCH_YES)
3884 if (strcmp (name, gfc_current_block ()->name) != 0)
3886 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3887 name, gfc_current_block ()->name);
3892 new_st.op = EXEC_WHERE;
3897 gfc_syntax_error (ST_ELSEWHERE);
3900 gfc_free_expr (expr);
3905 /******************** FORALL subroutines ********************/
3907 /* Free a list of FORALL iterators. */
3910 gfc_free_forall_iterator (gfc_forall_iterator *iter)
3912 gfc_forall_iterator *next;
3917 gfc_free_expr (iter->var);
3918 gfc_free_expr (iter->start);
3919 gfc_free_expr (iter->end);
3920 gfc_free_expr (iter->stride);
3927 /* Match an iterator as part of a FORALL statement. The format is:
3929 <var> = <start>:<end>[:<stride>]
3931 On MATCH_NO, the caller tests for the possibility that there is a
3932 scalar mask expression. */
3935 match_forall_iterator (gfc_forall_iterator **result)
3937 gfc_forall_iterator *iter;
3941 where = gfc_current_locus;
3942 iter = XCNEW (gfc_forall_iterator);
3944 m = gfc_match_expr (&iter->var);
3948 if (gfc_match_char ('=') != MATCH_YES
3949 || iter->var->expr_type != EXPR_VARIABLE)
3955 m = gfc_match_expr (&iter->start);
3959 if (gfc_match_char (':') != MATCH_YES)
3962 m = gfc_match_expr (&iter->end);
3965 if (m == MATCH_ERROR)
3968 if (gfc_match_char (':') == MATCH_NO)
3969 iter->stride = gfc_int_expr (1);
3972 m = gfc_match_expr (&iter->stride);
3975 if (m == MATCH_ERROR)
3979 /* Mark the iteration variable's symbol as used as a FORALL index. */
3980 iter->var->symtree->n.sym->forall_index = true;
3986 gfc_error ("Syntax error in FORALL iterator at %C");
3991 gfc_current_locus = where;
3992 gfc_free_forall_iterator (iter);
3997 /* Match the header of a FORALL statement. */
4000 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
4002 gfc_forall_iterator *head, *tail, *new_iter;
4006 gfc_gobble_whitespace ();
4011 if (gfc_match_char ('(') != MATCH_YES)
4014 m = match_forall_iterator (&new_iter);
4015 if (m == MATCH_ERROR)
4020 head = tail = new_iter;
4024 if (gfc_match_char (',') != MATCH_YES)
4027 m = match_forall_iterator (&new_iter);
4028 if (m == MATCH_ERROR)
4033 tail->next = new_iter;
4038 /* Have to have a mask expression. */
4040 m = gfc_match_expr (&msk);
4043 if (m == MATCH_ERROR)
4049 if (gfc_match_char (')') == MATCH_NO)
4057 gfc_syntax_error (ST_FORALL);
4060 gfc_free_expr (msk);
4061 gfc_free_forall_iterator (head);
4066 /* Match the rest of a simple FORALL statement that follows an
4070 match_simple_forall (void)
4072 gfc_forall_iterator *head;
4081 m = match_forall_header (&head, &mask);
4088 m = gfc_match_assignment ();
4090 if (m == MATCH_ERROR)
4094 m = gfc_match_pointer_assignment ();
4095 if (m == MATCH_ERROR)
4101 c = gfc_get_code ();
4103 c->loc = gfc_current_locus;
4105 if (gfc_match_eos () != MATCH_YES)
4108 gfc_clear_new_st ();
4109 new_st.op = EXEC_FORALL;
4111 new_st.ext.forall_iterator = head;
4112 new_st.block = gfc_get_code ();
4114 new_st.block->op = EXEC_FORALL;
4115 new_st.block->next = c;
4120 gfc_syntax_error (ST_FORALL);
4123 gfc_free_forall_iterator (head);
4124 gfc_free_expr (mask);
4130 /* Match a FORALL statement. */
4133 gfc_match_forall (gfc_statement *st)
4135 gfc_forall_iterator *head;
4144 m0 = gfc_match_label ();
4145 if (m0 == MATCH_ERROR)
4148 m = gfc_match (" forall");
4152 m = match_forall_header (&head, &mask);
4153 if (m == MATCH_ERROR)
4158 if (gfc_match_eos () == MATCH_YES)
4160 *st = ST_FORALL_BLOCK;
4161 new_st.op = EXEC_FORALL;
4163 new_st.ext.forall_iterator = head;
4167 m = gfc_match_assignment ();
4168 if (m == MATCH_ERROR)
4172 m = gfc_match_pointer_assignment ();
4173 if (m == MATCH_ERROR)
4179 c = gfc_get_code ();
4181 c->loc = gfc_current_locus;
4183 gfc_clear_new_st ();
4184 new_st.op = EXEC_FORALL;
4186 new_st.ext.forall_iterator = head;
4187 new_st.block = gfc_get_code ();
4188 new_st.block->op = EXEC_FORALL;
4189 new_st.block->next = c;
4195 gfc_syntax_error (ST_FORALL);
4198 gfc_free_forall_iterator (head);
4199 gfc_free_expr (mask);
4200 gfc_free_statements (c);