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, false))
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.expr1 = 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 || gfc_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.expr1 = 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 feature: Arithmetic IF "
1387 "statement at %C") == FAILURE)
1390 new_st.op = EXEC_ARITHMETIC_IF;
1391 new_st.expr1 = expr;
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 feature: Arithmetic IF "
1468 "statement at %C") == FAILURE)
1471 new_st.op = EXEC_ARITHMETIC_IF;
1472 new_st.expr1 = expr;
1477 *if_type = ST_ARITHMETIC_IF;
1481 if (gfc_match (" then%t") == MATCH_YES)
1483 new_st.op = EXEC_IF;
1484 new_st.expr1 = expr;
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;
1680 new_st.expr1 = expr;
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.label1 = label;
1794 if (new_st.op == EXEC_DO_WHILE)
1795 new_st.expr1 = 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.label1 = label;
2037 new_st.expr1 = expr;
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.label1 = 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;
2080 new_st.expr1 = expr;
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->label1 = 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->label1 = 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 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Computed GOTO "
2184 "at %C") == FAILURE)
2187 /* At this point, a computed GOTO has been fully matched and an
2188 equivalent SELECT statement constructed. */
2190 new_st.op = EXEC_SELECT;
2191 new_st.expr1 = NULL;
2193 /* Hack: For a "real" SELECT, the expression is in expr. We put
2194 it in expr2 so we can distinguish then and produce the correct
2196 new_st.expr2 = expr;
2197 new_st.block = head;
2201 gfc_syntax_error (ST_GOTO);
2203 gfc_free_statements (head);
2208 /* Frees a list of gfc_alloc structures. */
2211 gfc_free_alloc_list (gfc_alloc *p)
2218 gfc_free_expr (p->expr);
2224 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2225 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2226 It only includes the intrinsic types from the Fortran 2003 standard
2227 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2228 the implicit_flag is not needed, so it was removed. Derived types are
2229 identified by their name alone. */
2232 match_type_spec (gfc_typespec *ts)
2235 gfc_symbol *derived;
2239 old_locus = gfc_current_locus;
2241 if (gfc_match ("integer") == MATCH_YES)
2243 ts->type = BT_INTEGER;
2244 ts->kind = gfc_default_integer_kind;
2248 if (gfc_match ("real") == MATCH_YES)
2251 ts->kind = gfc_default_real_kind;
2255 if (gfc_match ("double precision") == MATCH_YES)
2258 ts->kind = gfc_default_double_kind;
2262 if (gfc_match ("complex") == MATCH_YES)
2264 ts->type = BT_COMPLEX;
2265 ts->kind = gfc_default_complex_kind;
2269 if (gfc_match ("character") == MATCH_YES)
2271 ts->type = BT_CHARACTER;
2275 if (gfc_match ("logical") == MATCH_YES)
2277 ts->type = BT_LOGICAL;
2278 ts->kind = gfc_default_logical_kind;
2282 if (gfc_match_symbol (&derived, 1) == MATCH_YES)
2284 if (derived->attr.flavor == FL_DERIVED)
2286 old_locus = gfc_current_locus;
2287 if (gfc_match (" :: ") != MATCH_YES)
2289 gfc_current_locus = old_locus;
2290 ts->type = BT_DERIVED;
2291 ts->u.derived = derived;
2292 /* Enfore F03:C401. */
2293 if (derived->attr.abstract)
2295 gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
2296 derived->name, &old_locus);
2303 if (gfc_match (" :: ") == MATCH_YES)
2305 /* Enforce F03:C476. */
2306 gfc_error ("'%s' at %L is not an accessible derived type",
2307 derived->name, &old_locus);
2312 gfc_current_locus = old_locus;
2318 /* If a type is not matched, simply return MATCH_NO. */
2323 gfc_gobble_whitespace ();
2324 if (gfc_peek_ascii_char () == '*')
2326 gfc_error ("Invalid type-spec at %C");
2330 m = gfc_match_kind_spec (ts, false);
2333 m = MATCH_YES; /* No kind specifier found. */
2339 m = gfc_match_char_spec (ts);
2342 m = MATCH_YES; /* No kind specifier found. */
2348 /* Used in gfc_match_allocate to check that a allocation-object and
2349 a source-expr are conformable. This does not catch all possible
2350 cases; in particular a runtime checking is needed. */
2353 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
2355 /* First compare rank. */
2356 if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
2358 gfc_error ("Source-expr at %L must be scalar or have the "
2359 "same rank as the allocate-object at %L",
2360 &e1->where, &e2->where);
2371 for (i = 0; i < e1->rank; i++)
2373 if (e2->ref->u.ar.end[i])
2375 mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
2376 mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
2377 mpz_add_ui (s, s, 1);
2381 mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
2384 if (mpz_cmp (e1->shape[i], s) != 0)
2386 gfc_error ("Source-expr at %L and allocate-object at %L must "
2387 "have the same shape", &e1->where, &e2->where);
2400 /* Match an ALLOCATE statement. */
2403 gfc_match_allocate (void)
2405 gfc_alloc *head, *tail;
2406 gfc_expr *stat, *errmsg, *tmp, *source;
2410 bool saw_stat, saw_errmsg, saw_source, b1, b2, b3;
2413 stat = errmsg = source = tmp = NULL;
2414 saw_stat = saw_errmsg = saw_source = false;
2416 if (gfc_match_char ('(') != MATCH_YES)
2419 /* Match an optional type-spec. */
2420 old_locus = gfc_current_locus;
2421 m = match_type_spec (&ts);
2422 if (m == MATCH_ERROR)
2424 else if (m == MATCH_NO)
2425 ts.type = BT_UNKNOWN;
2428 if (gfc_match (" :: ") == MATCH_YES)
2430 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
2431 "ALLOCATE at %L", &old_locus) == FAILURE)
2436 ts.type = BT_UNKNOWN;
2437 gfc_current_locus = old_locus;
2444 head = tail = gfc_get_alloc ();
2447 tail->next = gfc_get_alloc ();
2451 m = gfc_match_variable (&tail->expr, 0);
2454 if (m == MATCH_ERROR)
2457 if (gfc_check_do_variable (tail->expr->symtree))
2460 if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
2462 gfc_error ("Bad allocate-object at %C for a PURE procedure");
2466 /* The ALLOCATE statement had an optional typespec. Check the
2468 if (ts.type != BT_UNKNOWN)
2470 /* Enforce F03:C624. */
2471 if (!gfc_type_compatible (&tail->expr->ts, &ts))
2473 gfc_error ("Type of entity at %L is type incompatible with "
2474 "typespec", &tail->expr->where);
2478 /* Enforce F03:C627. */
2479 if (ts.kind != tail->expr->ts.kind)
2481 gfc_error ("Kind type parameter for entity at %L differs from "
2482 "the kind type parameter of the typespec",
2483 &tail->expr->where);
2488 if (tail->expr->ts.type == BT_DERIVED)
2489 tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
2491 /* FIXME: disable the checking on derived types and arrays. */
2492 b1 = !(tail->expr->ref
2493 && (tail->expr->ref->type == REF_COMPONENT
2494 || tail->expr->ref->type == REF_ARRAY));
2495 b2 = tail->expr->symtree->n.sym
2496 && !(tail->expr->symtree->n.sym->attr.allocatable
2497 || tail->expr->symtree->n.sym->attr.pointer
2498 || tail->expr->symtree->n.sym->attr.proc_pointer);
2499 b3 = tail->expr->symtree->n.sym
2500 && tail->expr->symtree->n.sym->ns
2501 && tail->expr->symtree->n.sym->ns->proc_name
2502 && (tail->expr->symtree->n.sym->ns->proc_name->attr.allocatable
2503 || tail->expr->symtree->n.sym->ns->proc_name->attr.pointer
2504 || tail->expr->symtree->n.sym->ns->proc_name->attr.proc_pointer);
2505 if (b1 && b2 && !b3)
2507 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2508 "or an allocatable variable");
2512 if (gfc_match_char (',') != MATCH_YES)
2517 m = gfc_match (" stat = %v", &tmp);
2518 if (m == MATCH_ERROR)
2525 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2532 if (gfc_check_do_variable (stat->symtree))
2535 if (gfc_match_char (',') == MATCH_YES)
2536 goto alloc_opt_list;
2539 m = gfc_match (" errmsg = %v", &tmp);
2540 if (m == MATCH_ERROR)
2544 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L",
2545 &tmp->where) == FAILURE)
2551 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2558 if (gfc_match_char (',') == MATCH_YES)
2559 goto alloc_opt_list;
2562 m = gfc_match (" source = %e", &tmp);
2563 if (m == MATCH_ERROR)
2567 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L",
2568 &tmp->where) == FAILURE)
2574 gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
2578 /* The next 3 conditionals check C631. */
2579 if (ts.type != BT_UNKNOWN)
2581 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
2582 &tmp->where, &old_locus);
2588 gfc_error ("SOURCE tag at %L requires only a single entity in "
2589 "the allocation-list", &tmp->where);
2593 gfc_resolve_expr (tmp);
2595 if (head->expr->ts.type != tmp->ts.type)
2597 gfc_error ("Type of entity at %L is type incompatible with "
2598 "source-expr at %L", &head->expr->where, &tmp->where);
2603 if (tmp->ts.kind != head->expr->ts.kind)
2605 gfc_error ("The allocate-object at %L and the source-expr at %L "
2606 "shall have the same kind type parameter",
2607 &head->expr->where, &tmp->where);
2611 /* Check C632 and restriction following Note 6.18. */
2612 if (tmp->rank > 0 && conformable_arrays (tmp, head->expr) == FAILURE)
2618 if (gfc_match_char (',') == MATCH_YES)
2619 goto alloc_opt_list;
2622 gfc_gobble_whitespace ();
2624 if (gfc_peek_char () == ')')
2629 if (gfc_match (" )%t") != MATCH_YES)
2632 new_st.op = EXEC_ALLOCATE;
2633 new_st.expr1 = stat;
2634 new_st.expr2 = errmsg;
2635 new_st.expr3 = source;
2636 new_st.ext.alloc_list = head;
2641 gfc_syntax_error (ST_ALLOCATE);
2644 gfc_free_expr (errmsg);
2645 gfc_free_expr (source);
2646 gfc_free_expr (stat);
2647 gfc_free_expr (tmp);
2648 gfc_free_alloc_list (head);
2653 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
2654 a set of pointer assignments to intrinsic NULL(). */
2657 gfc_match_nullify (void)
2665 if (gfc_match_char ('(') != MATCH_YES)
2670 m = gfc_match_variable (&p, 0);
2671 if (m == MATCH_ERROR)
2676 if (gfc_check_do_variable (p->symtree))
2679 if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
2681 gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
2685 /* build ' => NULL() '. */
2686 e = gfc_get_expr ();
2687 e->where = gfc_current_locus;
2688 e->expr_type = EXPR_NULL;
2689 e->ts.type = BT_UNKNOWN;
2691 /* Chain to list. */
2696 tail->next = gfc_get_code ();
2700 tail->op = EXEC_POINTER_ASSIGN;
2704 if (gfc_match (" )%t") == MATCH_YES)
2706 if (gfc_match_char (',') != MATCH_YES)
2713 gfc_syntax_error (ST_NULLIFY);
2716 gfc_free_statements (new_st.next);
2718 gfc_free_expr (new_st.expr1);
2719 new_st.expr1 = NULL;
2720 gfc_free_expr (new_st.expr2);
2721 new_st.expr2 = NULL;
2726 /* Match a DEALLOCATE statement. */
2729 gfc_match_deallocate (void)
2731 gfc_alloc *head, *tail;
2732 gfc_expr *stat, *errmsg, *tmp;
2734 bool saw_stat, saw_errmsg;
2737 stat = errmsg = tmp = NULL;
2738 saw_stat = saw_errmsg = false;
2740 if (gfc_match_char ('(') != MATCH_YES)
2746 head = tail = gfc_get_alloc ();
2749 tail->next = gfc_get_alloc ();
2753 m = gfc_match_variable (&tail->expr, 0);
2754 if (m == MATCH_ERROR)
2759 if (gfc_check_do_variable (tail->expr->symtree))
2762 if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
2764 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
2768 /* FIXME: disable the checking on derived types. */
2769 if (!(tail->expr->ref
2770 && (tail->expr->ref->type == REF_COMPONENT
2771 || tail->expr->ref->type == REF_ARRAY))
2772 && tail->expr->symtree->n.sym
2773 && !(tail->expr->symtree->n.sym->attr.allocatable
2774 || tail->expr->symtree->n.sym->attr.pointer
2775 || tail->expr->symtree->n.sym->attr.proc_pointer))
2777 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2778 "or an allocatable variable");
2782 if (gfc_match_char (',') != MATCH_YES)
2787 m = gfc_match (" stat = %v", &tmp);
2788 if (m == MATCH_ERROR)
2794 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2795 gfc_free_expr (tmp);
2802 if (gfc_check_do_variable (stat->symtree))
2805 if (gfc_match_char (',') == MATCH_YES)
2806 goto dealloc_opt_list;
2809 m = gfc_match (" errmsg = %v", &tmp);
2810 if (m == MATCH_ERROR)
2814 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
2815 &tmp->where) == FAILURE)
2820 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2821 gfc_free_expr (tmp);
2828 if (gfc_match_char (',') == MATCH_YES)
2829 goto dealloc_opt_list;
2832 gfc_gobble_whitespace ();
2834 if (gfc_peek_char () == ')')
2838 if (gfc_match (" )%t") != MATCH_YES)
2841 new_st.op = EXEC_DEALLOCATE;
2842 new_st.expr1 = stat;
2843 new_st.expr2 = errmsg;
2844 new_st.ext.alloc_list = head;
2849 gfc_syntax_error (ST_DEALLOCATE);
2852 gfc_free_expr (errmsg);
2853 gfc_free_expr (stat);
2854 gfc_free_alloc_list (head);
2859 /* Match a RETURN statement. */
2862 gfc_match_return (void)
2866 gfc_compile_state s;
2869 if (gfc_match_eos () == MATCH_YES)
2872 if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
2874 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2879 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Alternate RETURN "
2880 "at %C") == FAILURE)
2883 if (gfc_current_form == FORM_FREE)
2885 /* The following are valid, so we can't require a blank after the
2889 char c = gfc_peek_ascii_char ();
2890 if (ISALPHA (c) || ISDIGIT (c))
2894 m = gfc_match (" %e%t", &e);
2897 if (m == MATCH_ERROR)
2900 gfc_syntax_error (ST_RETURN);
2907 gfc_enclosing_unit (&s);
2908 if (s == COMP_PROGRAM
2909 && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
2910 "main program at %C") == FAILURE)
2913 new_st.op = EXEC_RETURN;
2920 /* Match the call of a type-bound procedure, if CALL%var has already been
2921 matched and var found to be a derived-type variable. */
2924 match_typebound_call (gfc_symtree* varst)
2932 base = gfc_get_expr ();
2933 base->expr_type = EXPR_VARIABLE;
2934 base->symtree = varst;
2935 base->where = gfc_current_locus;
2936 gfc_set_sym_referenced (varst->n.sym);
2938 m = gfc_match_varspec (base, 0, true, true);
2940 gfc_error ("Expected component reference at %C");
2944 if (gfc_match_eos () != MATCH_YES)
2946 gfc_error ("Junk after CALL at %C");
2950 if (base->expr_type == EXPR_COMPCALL)
2951 new_st.op = EXEC_COMPCALL;
2952 else if (base->expr_type == EXPR_PPC)
2953 new_st.op = EXEC_CALL_PPC;
2956 gfc_error ("Expected type-bound procedure or procedure pointer component "
2960 new_st.expr1 = base;
2966 /* Match a CALL statement. The tricky part here are possible
2967 alternate return specifiers. We handle these by having all
2968 "subroutines" actually return an integer via a register that gives
2969 the return number. If the call specifies alternate returns, we
2970 generate code for a SELECT statement whose case clauses contain
2971 GOTOs to the various labels. */
2974 gfc_match_call (void)
2976 char name[GFC_MAX_SYMBOL_LEN + 1];
2977 gfc_actual_arglist *a, *arglist;
2987 m = gfc_match ("% %n", name);
2993 if (gfc_get_ha_sym_tree (name, &st))
2998 /* If this is a variable of derived-type, it probably starts a type-bound
3000 if (sym->attr.flavor != FL_PROCEDURE && sym->ts.type == BT_DERIVED)
3001 return match_typebound_call (st);
3003 /* If it does not seem to be callable (include functions so that the
3004 right association is made. They are thrown out in resolution.)
3006 if (!sym->attr.generic
3007 && !sym->attr.subroutine
3008 && !sym->attr.function)
3010 if (!(sym->attr.external && !sym->attr.referenced))
3012 /* ...create a symbol in this scope... */
3013 if (sym->ns != gfc_current_ns
3014 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
3017 if (sym != st->n.sym)
3021 /* ...and then to try to make the symbol into a subroutine. */
3022 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
3026 gfc_set_sym_referenced (sym);
3028 if (gfc_match_eos () != MATCH_YES)
3030 m = gfc_match_actual_arglist (1, &arglist);
3033 if (m == MATCH_ERROR)
3036 if (gfc_match_eos () != MATCH_YES)
3040 /* If any alternate return labels were found, construct a SELECT
3041 statement that will jump to the right place. */
3044 for (a = arglist; a; a = a->next)
3045 if (a->expr == NULL)
3050 gfc_symtree *select_st;
3051 gfc_symbol *select_sym;
3052 char name[GFC_MAX_SYMBOL_LEN + 1];
3054 new_st.next = c = gfc_get_code ();
3055 c->op = EXEC_SELECT;
3056 sprintf (name, "_result_%s", sym->name);
3057 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
3059 select_sym = select_st->n.sym;
3060 select_sym->ts.type = BT_INTEGER;
3061 select_sym->ts.kind = gfc_default_integer_kind;
3062 gfc_set_sym_referenced (select_sym);
3063 c->expr1 = gfc_get_expr ();
3064 c->expr1->expr_type = EXPR_VARIABLE;
3065 c->expr1->symtree = select_st;
3066 c->expr1->ts = select_sym->ts;
3067 c->expr1->where = gfc_current_locus;
3070 for (a = arglist; a; a = a->next)
3072 if (a->expr != NULL)
3075 if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
3080 c->block = gfc_get_code ();
3082 c->op = EXEC_SELECT;
3084 new_case = gfc_get_case ();
3085 new_case->high = new_case->low = gfc_int_expr (i);
3086 c->ext.case_list = new_case;
3088 c->next = gfc_get_code ();
3089 c->next->op = EXEC_GOTO;
3090 c->next->label1 = a->label;
3094 new_st.op = EXEC_CALL;
3095 new_st.symtree = st;
3096 new_st.ext.actual = arglist;
3101 gfc_syntax_error (ST_CALL);
3104 gfc_free_actual_arglist (arglist);
3109 /* Given a name, return a pointer to the common head structure,
3110 creating it if it does not exist. If FROM_MODULE is nonzero, we
3111 mangle the name so that it doesn't interfere with commons defined
3112 in the using namespace.
3113 TODO: Add to global symbol tree. */
3116 gfc_get_common (const char *name, int from_module)
3119 static int serial = 0;
3120 char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
3124 /* A use associated common block is only needed to correctly layout
3125 the variables it contains. */
3126 snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
3127 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
3131 st = gfc_find_symtree (gfc_current_ns->common_root, name);
3134 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
3137 if (st->n.common == NULL)
3139 st->n.common = gfc_get_common_head ();
3140 st->n.common->where = gfc_current_locus;
3141 strcpy (st->n.common->name, name);
3144 return st->n.common;
3148 /* Match a common block name. */
3150 match match_common_name (char *name)
3154 if (gfc_match_char ('/') == MATCH_NO)
3160 if (gfc_match_char ('/') == MATCH_YES)
3166 m = gfc_match_name (name);
3168 if (m == MATCH_ERROR)
3170 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
3173 gfc_error ("Syntax error in common block name at %C");
3178 /* Match a COMMON statement. */
3181 gfc_match_common (void)
3183 gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
3184 char name[GFC_MAX_SYMBOL_LEN + 1];
3191 old_blank_common = gfc_current_ns->blank_common.head;
3192 if (old_blank_common)
3194 while (old_blank_common->common_next)
3195 old_blank_common = old_blank_common->common_next;
3202 m = match_common_name (name);
3203 if (m == MATCH_ERROR)
3206 gsym = gfc_get_gsymbol (name);
3207 if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
3209 gfc_error ("Symbol '%s' at %C is already an external symbol that "
3210 "is not COMMON", name);
3214 if (gsym->type == GSYM_UNKNOWN)
3216 gsym->type = GSYM_COMMON;
3217 gsym->where = gfc_current_locus;
3223 if (name[0] == '\0')
3225 t = &gfc_current_ns->blank_common;
3226 if (t->head == NULL)
3227 t->where = gfc_current_locus;
3231 t = gfc_get_common (name, 0);
3240 while (tail->common_next)
3241 tail = tail->common_next;
3244 /* Grab the list of symbols. */
3247 m = gfc_match_symbol (&sym, 0);
3248 if (m == MATCH_ERROR)
3253 /* Store a ref to the common block for error checking. */
3254 sym->common_block = t;
3256 /* See if we know the current common block is bind(c), and if
3257 so, then see if we can check if the symbol is (which it'll
3258 need to be). This can happen if the bind(c) attr stmt was
3259 applied to the common block, and the variable(s) already
3260 defined, before declaring the common block. */
3261 if (t->is_bind_c == 1)
3263 if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
3265 /* If we find an error, just print it and continue,
3266 cause it's just semantic, and we can see if there
3268 gfc_error_now ("Variable '%s' at %L in common block '%s' "
3269 "at %C must be declared with a C "
3270 "interoperable kind since common block "
3272 sym->name, &(sym->declared_at), t->name,
3276 if (sym->attr.is_bind_c == 1)
3277 gfc_error_now ("Variable '%s' in common block "
3278 "'%s' at %C can not be bind(c) since "
3279 "it is not global", sym->name, t->name);
3282 if (sym->attr.in_common)
3284 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
3289 if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
3290 || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
3292 if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
3293 "can only be COMMON in "
3294 "BLOCK DATA", sym->name)
3299 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
3303 tail->common_next = sym;
3309 /* Deal with an optional array specification after the
3311 m = gfc_match_array_spec (&as);
3312 if (m == MATCH_ERROR)
3317 if (as->type != AS_EXPLICIT)
3319 gfc_error ("Array specification for symbol '%s' in COMMON "
3320 "at %C must be explicit", sym->name);
3324 if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
3327 if (sym->attr.pointer)
3329 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
3330 "POINTER array", sym->name);
3339 sym->common_head = t;
3341 /* Check to see if the symbol is already in an equivalence group.
3342 If it is, set the other members as being in common. */
3343 if (sym->attr.in_equivalence)
3345 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
3347 for (e2 = e1; e2; e2 = e2->eq)
3348 if (e2->expr->symtree->n.sym == sym)
3355 for (e2 = e1; e2; e2 = e2->eq)
3357 other = e2->expr->symtree->n.sym;
3358 if (other->common_head
3359 && other->common_head != sym->common_head)
3361 gfc_error ("Symbol '%s', in COMMON block '%s' at "
3362 "%C is being indirectly equivalenced to "
3363 "another COMMON block '%s'",
3364 sym->name, sym->common_head->name,
3365 other->common_head->name);
3368 other->attr.in_common = 1;
3369 other->common_head = t;
3375 gfc_gobble_whitespace ();
3376 if (gfc_match_eos () == MATCH_YES)
3378 if (gfc_peek_ascii_char () == '/')
3380 if (gfc_match_char (',') != MATCH_YES)
3382 gfc_gobble_whitespace ();
3383 if (gfc_peek_ascii_char () == '/')
3392 gfc_syntax_error (ST_COMMON);
3395 if (old_blank_common)
3396 old_blank_common->common_next = NULL;
3398 gfc_current_ns->blank_common.head = NULL;
3399 gfc_free_array_spec (as);
3404 /* Match a BLOCK DATA program unit. */
3407 gfc_match_block_data (void)
3409 char name[GFC_MAX_SYMBOL_LEN + 1];
3413 if (gfc_match_eos () == MATCH_YES)
3415 gfc_new_block = NULL;
3419 m = gfc_match ("% %n%t", name);
3423 if (gfc_get_symbol (name, NULL, &sym))
3426 if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
3429 gfc_new_block = sym;
3435 /* Free a namelist structure. */
3438 gfc_free_namelist (gfc_namelist *name)
3442 for (; name; name = n)
3450 /* Match a NAMELIST statement. */
3453 gfc_match_namelist (void)
3455 gfc_symbol *group_name, *sym;
3459 m = gfc_match (" / %s /", &group_name);
3462 if (m == MATCH_ERROR)
3467 if (group_name->ts.type != BT_UNKNOWN)
3469 gfc_error ("Namelist group name '%s' at %C already has a basic "
3470 "type of %s", group_name->name,
3471 gfc_typename (&group_name->ts));
3475 if (group_name->attr.flavor == FL_NAMELIST
3476 && group_name->attr.use_assoc
3477 && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
3478 "at %C already is USE associated and can"
3479 "not be respecified.", group_name->name)
3483 if (group_name->attr.flavor != FL_NAMELIST
3484 && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
3485 group_name->name, NULL) == FAILURE)
3490 m = gfc_match_symbol (&sym, 1);
3493 if (m == MATCH_ERROR)
3496 if (sym->attr.in_namelist == 0
3497 && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
3500 /* Use gfc_error_check here, rather than goto error, so that
3501 these are the only errors for the next two lines. */
3502 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
3504 gfc_error ("Assumed size array '%s' in namelist '%s' at "
3505 "%C is not allowed", sym->name, group_name->name);
3509 if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl->length == NULL)
3511 gfc_error ("Assumed character length '%s' in namelist '%s' at "
3512 "%C is not allowed", sym->name, group_name->name);
3516 nl = gfc_get_namelist ();
3520 if (group_name->namelist == NULL)
3521 group_name->namelist = group_name->namelist_tail = nl;
3524 group_name->namelist_tail->next = nl;
3525 group_name->namelist_tail = nl;
3528 if (gfc_match_eos () == MATCH_YES)
3531 m = gfc_match_char (',');
3533 if (gfc_match_char ('/') == MATCH_YES)
3535 m2 = gfc_match (" %s /", &group_name);
3536 if (m2 == MATCH_YES)
3538 if (m2 == MATCH_ERROR)
3552 gfc_syntax_error (ST_NAMELIST);
3559 /* Match a MODULE statement. */
3562 gfc_match_module (void)
3566 m = gfc_match (" %s%t", &gfc_new_block);
3570 if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
3571 gfc_new_block->name, NULL) == FAILURE)
3578 /* Free equivalence sets and lists. Recursively is the easiest way to
3582 gfc_free_equiv (gfc_equiv *eq)
3587 gfc_free_equiv (eq->eq);
3588 gfc_free_equiv (eq->next);
3589 gfc_free_expr (eq->expr);
3594 /* Match an EQUIVALENCE statement. */
3597 gfc_match_equivalence (void)
3599 gfc_equiv *eq, *set, *tail;
3603 gfc_common_head *common_head = NULL;
3611 eq = gfc_get_equiv ();
3615 eq->next = gfc_current_ns->equiv;
3616 gfc_current_ns->equiv = eq;
3618 if (gfc_match_char ('(') != MATCH_YES)
3622 common_flag = FALSE;
3627 m = gfc_match_equiv_variable (&set->expr);
3628 if (m == MATCH_ERROR)
3633 /* count the number of objects. */
3636 if (gfc_match_char ('%') == MATCH_YES)
3638 gfc_error ("Derived type component %C is not a "
3639 "permitted EQUIVALENCE member");
3643 for (ref = set->expr->ref; ref; ref = ref->next)
3644 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3646 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
3647 "be an array section");
3651 sym = set->expr->symtree->n.sym;
3653 if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
3656 if (sym->attr.in_common)
3659 common_head = sym->common_head;
3662 if (gfc_match_char (')') == MATCH_YES)
3665 if (gfc_match_char (',') != MATCH_YES)
3668 set->eq = gfc_get_equiv ();
3674 gfc_error ("EQUIVALENCE at %C requires two or more objects");
3678 /* If one of the members of an equivalence is in common, then
3679 mark them all as being in common. Before doing this, check
3680 that members of the equivalence group are not in different
3683 for (set = eq; set; set = set->eq)
3685 sym = set->expr->symtree->n.sym;
3686 if (sym->common_head && sym->common_head != common_head)
3688 gfc_error ("Attempt to indirectly overlap COMMON "
3689 "blocks %s and %s by EQUIVALENCE at %C",
3690 sym->common_head->name, common_head->name);
3693 sym->attr.in_common = 1;
3694 sym->common_head = common_head;
3697 if (gfc_match_eos () == MATCH_YES)
3699 if (gfc_match_char (',') != MATCH_YES)
3706 gfc_syntax_error (ST_EQUIVALENCE);
3712 gfc_free_equiv (gfc_current_ns->equiv);
3713 gfc_current_ns->equiv = eq;
3719 /* Check that a statement function is not recursive. This is done by looking
3720 for the statement function symbol(sym) by looking recursively through its
3721 expression(e). If a reference to sym is found, true is returned.
3722 12.5.4 requires that any variable of function that is implicitly typed
3723 shall have that type confirmed by any subsequent type declaration. The
3724 implicit typing is conveniently done here. */
3726 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
3729 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
3735 switch (e->expr_type)
3738 if (e->symtree == NULL)
3741 /* Check the name before testing for nested recursion! */
3742 if (sym->name == e->symtree->n.sym->name)
3745 /* Catch recursion via other statement functions. */
3746 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
3747 && e->symtree->n.sym->value
3748 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
3751 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3752 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3757 if (e->symtree && sym->name == e->symtree->n.sym->name)
3760 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3761 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3773 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
3775 return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
3779 /* Match a statement function declaration. It is so easy to match
3780 non-statement function statements with a MATCH_ERROR as opposed to
3781 MATCH_NO that we suppress error message in most cases. */
3784 gfc_match_st_function (void)
3786 gfc_error_buf old_error;
3791 m = gfc_match_symbol (&sym, 0);
3795 gfc_push_error (&old_error);
3797 if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
3798 sym->name, NULL) == FAILURE)
3801 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
3804 m = gfc_match (" = %e%t", &expr);
3808 gfc_free_error (&old_error);
3809 if (m == MATCH_ERROR)
3812 if (recursive_stmt_fcn (expr, sym))
3814 gfc_error ("Statement function at %L is recursive", &expr->where);
3820 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
3821 "Statement function at %C") == FAILURE)
3827 gfc_pop_error (&old_error);
3832 /***************** SELECT CASE subroutines ******************/
3834 /* Free a single case structure. */
3837 free_case (gfc_case *p)
3839 if (p->low == p->high)
3841 gfc_free_expr (p->low);
3842 gfc_free_expr (p->high);
3847 /* Free a list of case structures. */
3850 gfc_free_case_list (gfc_case *p)
3862 /* Match a single case selector. */
3865 match_case_selector (gfc_case **cp)
3870 c = gfc_get_case ();
3871 c->where = gfc_current_locus;
3873 if (gfc_match_char (':') == MATCH_YES)
3875 m = gfc_match_init_expr (&c->high);
3878 if (m == MATCH_ERROR)
3883 m = gfc_match_init_expr (&c->low);
3884 if (m == MATCH_ERROR)
3889 /* If we're not looking at a ':' now, make a range out of a single
3890 target. Else get the upper bound for the case range. */
3891 if (gfc_match_char (':') != MATCH_YES)
3895 m = gfc_match_init_expr (&c->high);
3896 if (m == MATCH_ERROR)
3898 /* MATCH_NO is fine. It's OK if nothing is there! */
3906 gfc_error ("Expected initialization expression in CASE at %C");
3914 /* Match the end of a case statement. */
3917 match_case_eos (void)
3919 char name[GFC_MAX_SYMBOL_LEN + 1];
3922 if (gfc_match_eos () == MATCH_YES)
3925 /* If the case construct doesn't have a case-construct-name, we
3926 should have matched the EOS. */
3927 if (!gfc_current_block ())
3929 gfc_error ("Expected the name of the SELECT CASE construct at %C");
3933 gfc_gobble_whitespace ();
3935 m = gfc_match_name (name);
3939 if (strcmp (name, gfc_current_block ()->name) != 0)
3941 gfc_error ("Expected case name of '%s' at %C",
3942 gfc_current_block ()->name);
3946 return gfc_match_eos ();
3950 /* Match a SELECT statement. */
3953 gfc_match_select (void)
3958 m = gfc_match_label ();
3959 if (m == MATCH_ERROR)
3962 m = gfc_match (" select case ( %e )%t", &expr);
3966 new_st.op = EXEC_SELECT;
3967 new_st.expr1 = expr;
3973 /* Match a CASE statement. */
3976 gfc_match_case (void)
3978 gfc_case *c, *head, *tail;
3983 if (gfc_current_state () != COMP_SELECT)
3985 gfc_error ("Unexpected CASE statement at %C");
3989 if (gfc_match ("% default") == MATCH_YES)
3991 m = match_case_eos ();
3994 if (m == MATCH_ERROR)
3997 new_st.op = EXEC_SELECT;
3998 c = gfc_get_case ();
3999 c->where = gfc_current_locus;
4000 new_st.ext.case_list = c;
4004 if (gfc_match_char ('(') != MATCH_YES)
4009 if (match_case_selector (&c) == MATCH_ERROR)
4019 if (gfc_match_char (')') == MATCH_YES)
4021 if (gfc_match_char (',') != MATCH_YES)
4025 m = match_case_eos ();
4028 if (m == MATCH_ERROR)
4031 new_st.op = EXEC_SELECT;
4032 new_st.ext.case_list = head;
4037 gfc_error ("Syntax error in CASE-specification at %C");
4040 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
4044 /********************* WHERE subroutines ********************/
4046 /* Match the rest of a simple WHERE statement that follows an IF statement.
4050 match_simple_where (void)
4056 m = gfc_match (" ( %e )", &expr);
4060 m = gfc_match_assignment ();
4063 if (m == MATCH_ERROR)
4066 if (gfc_match_eos () != MATCH_YES)
4069 c = gfc_get_code ();
4073 c->next = gfc_get_code ();
4076 gfc_clear_new_st ();
4078 new_st.op = EXEC_WHERE;
4084 gfc_syntax_error (ST_WHERE);
4087 gfc_free_expr (expr);
4092 /* Match a WHERE statement. */
4095 gfc_match_where (gfc_statement *st)
4101 m0 = gfc_match_label ();
4102 if (m0 == MATCH_ERROR)
4105 m = gfc_match (" where ( %e )", &expr);
4109 if (gfc_match_eos () == MATCH_YES)
4111 *st = ST_WHERE_BLOCK;
4112 new_st.op = EXEC_WHERE;
4113 new_st.expr1 = expr;
4117 m = gfc_match_assignment ();
4119 gfc_syntax_error (ST_WHERE);
4123 gfc_free_expr (expr);
4127 /* We've got a simple WHERE statement. */
4129 c = gfc_get_code ();
4133 c->next = gfc_get_code ();
4136 gfc_clear_new_st ();
4138 new_st.op = EXEC_WHERE;
4145 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
4146 new_st if successful. */
4149 gfc_match_elsewhere (void)
4151 char name[GFC_MAX_SYMBOL_LEN + 1];
4155 if (gfc_current_state () != COMP_WHERE)
4157 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
4163 if (gfc_match_char ('(') == MATCH_YES)
4165 m = gfc_match_expr (&expr);
4168 if (m == MATCH_ERROR)
4171 if (gfc_match_char (')') != MATCH_YES)
4175 if (gfc_match_eos () != MATCH_YES)
4177 /* Only makes sense if we have a where-construct-name. */
4178 if (!gfc_current_block ())
4183 /* Better be a name at this point. */
4184 m = gfc_match_name (name);
4187 if (m == MATCH_ERROR)
4190 if (gfc_match_eos () != MATCH_YES)
4193 if (strcmp (name, gfc_current_block ()->name) != 0)
4195 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
4196 name, gfc_current_block ()->name);
4201 new_st.op = EXEC_WHERE;
4202 new_st.expr1 = expr;
4206 gfc_syntax_error (ST_ELSEWHERE);
4209 gfc_free_expr (expr);
4214 /******************** FORALL subroutines ********************/
4216 /* Free a list of FORALL iterators. */
4219 gfc_free_forall_iterator (gfc_forall_iterator *iter)
4221 gfc_forall_iterator *next;
4226 gfc_free_expr (iter->var);
4227 gfc_free_expr (iter->start);
4228 gfc_free_expr (iter->end);
4229 gfc_free_expr (iter->stride);
4236 /* Match an iterator as part of a FORALL statement. The format is:
4238 <var> = <start>:<end>[:<stride>]
4240 On MATCH_NO, the caller tests for the possibility that there is a
4241 scalar mask expression. */
4244 match_forall_iterator (gfc_forall_iterator **result)
4246 gfc_forall_iterator *iter;
4250 where = gfc_current_locus;
4251 iter = XCNEW (gfc_forall_iterator);
4253 m = gfc_match_expr (&iter->var);
4257 if (gfc_match_char ('=') != MATCH_YES
4258 || iter->var->expr_type != EXPR_VARIABLE)
4264 m = gfc_match_expr (&iter->start);
4268 if (gfc_match_char (':') != MATCH_YES)
4271 m = gfc_match_expr (&iter->end);
4274 if (m == MATCH_ERROR)
4277 if (gfc_match_char (':') == MATCH_NO)
4278 iter->stride = gfc_int_expr (1);
4281 m = gfc_match_expr (&iter->stride);
4284 if (m == MATCH_ERROR)
4288 /* Mark the iteration variable's symbol as used as a FORALL index. */
4289 iter->var->symtree->n.sym->forall_index = true;
4295 gfc_error ("Syntax error in FORALL iterator at %C");
4300 gfc_current_locus = where;
4301 gfc_free_forall_iterator (iter);
4306 /* Match the header of a FORALL statement. */
4309 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
4311 gfc_forall_iterator *head, *tail, *new_iter;
4315 gfc_gobble_whitespace ();
4320 if (gfc_match_char ('(') != MATCH_YES)
4323 m = match_forall_iterator (&new_iter);
4324 if (m == MATCH_ERROR)
4329 head = tail = new_iter;
4333 if (gfc_match_char (',') != MATCH_YES)
4336 m = match_forall_iterator (&new_iter);
4337 if (m == MATCH_ERROR)
4342 tail->next = new_iter;
4347 /* Have to have a mask expression. */
4349 m = gfc_match_expr (&msk);
4352 if (m == MATCH_ERROR)
4358 if (gfc_match_char (')') == MATCH_NO)
4366 gfc_syntax_error (ST_FORALL);
4369 gfc_free_expr (msk);
4370 gfc_free_forall_iterator (head);
4375 /* Match the rest of a simple FORALL statement that follows an
4379 match_simple_forall (void)
4381 gfc_forall_iterator *head;
4390 m = match_forall_header (&head, &mask);
4397 m = gfc_match_assignment ();
4399 if (m == MATCH_ERROR)
4403 m = gfc_match_pointer_assignment ();
4404 if (m == MATCH_ERROR)
4410 c = gfc_get_code ();
4412 c->loc = gfc_current_locus;
4414 if (gfc_match_eos () != MATCH_YES)
4417 gfc_clear_new_st ();
4418 new_st.op = EXEC_FORALL;
4419 new_st.expr1 = mask;
4420 new_st.ext.forall_iterator = head;
4421 new_st.block = gfc_get_code ();
4423 new_st.block->op = EXEC_FORALL;
4424 new_st.block->next = c;
4429 gfc_syntax_error (ST_FORALL);
4432 gfc_free_forall_iterator (head);
4433 gfc_free_expr (mask);
4439 /* Match a FORALL statement. */
4442 gfc_match_forall (gfc_statement *st)
4444 gfc_forall_iterator *head;
4453 m0 = gfc_match_label ();
4454 if (m0 == MATCH_ERROR)
4457 m = gfc_match (" forall");
4461 m = match_forall_header (&head, &mask);
4462 if (m == MATCH_ERROR)
4467 if (gfc_match_eos () == MATCH_YES)
4469 *st = ST_FORALL_BLOCK;
4470 new_st.op = EXEC_FORALL;
4471 new_st.expr1 = mask;
4472 new_st.ext.forall_iterator = head;
4476 m = gfc_match_assignment ();
4477 if (m == MATCH_ERROR)
4481 m = gfc_match_pointer_assignment ();
4482 if (m == MATCH_ERROR)
4488 c = gfc_get_code ();
4490 c->loc = gfc_current_locus;
4492 gfc_clear_new_st ();
4493 new_st.op = EXEC_FORALL;
4494 new_st.expr1 = mask;
4495 new_st.ext.forall_iterator = head;
4496 new_st.block = gfc_get_code ();
4497 new_st.block->op = EXEC_FORALL;
4498 new_st.block->next = c;
4504 gfc_syntax_error (ST_FORALL);
4507 gfc_free_forall_iterator (head);
4508 gfc_free_expr (mask);
4509 gfc_free_statements (c);