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);
1296 if (lvalue->symtree->n.sym->attr.is_protected
1297 && lvalue->symtree->n.sym->attr.use_assoc)
1299 gfc_current_locus = old_loc;
1300 gfc_free_expr (lvalue);
1301 gfc_error ("Setting value of PROTECTED variable at %C");
1306 m = gfc_match (" %e%t", &rvalue);
1309 gfc_current_locus = old_loc;
1310 gfc_free_expr (lvalue);
1311 gfc_free_expr (rvalue);
1315 gfc_set_sym_referenced (lvalue->symtree->n.sym);
1317 new_st.op = EXEC_ASSIGN;
1318 new_st.expr = lvalue;
1319 new_st.expr2 = rvalue;
1321 gfc_check_do_variable (lvalue->symtree);
1327 /* Match a pointer assignment statement. */
1330 gfc_match_pointer_assignment (void)
1332 gfc_expr *lvalue, *rvalue;
1336 old_loc = gfc_current_locus;
1338 lvalue = rvalue = NULL;
1339 gfc_matching_procptr_assignment = 0;
1341 m = gfc_match (" %v =>", &lvalue);
1348 if (lvalue->symtree->n.sym->attr.proc_pointer)
1349 gfc_matching_procptr_assignment = 1;
1351 m = gfc_match (" %e%t", &rvalue);
1352 gfc_matching_procptr_assignment = 0;
1356 if (lvalue->symtree->n.sym->attr.is_protected
1357 && lvalue->symtree->n.sym->attr.use_assoc)
1359 gfc_error ("Assigning to a PROTECTED pointer at %C");
1364 new_st.op = EXEC_POINTER_ASSIGN;
1365 new_st.expr = lvalue;
1366 new_st.expr2 = rvalue;
1371 gfc_current_locus = old_loc;
1372 gfc_free_expr (lvalue);
1373 gfc_free_expr (rvalue);
1378 /* We try to match an easy arithmetic IF statement. This only happens
1379 when just after having encountered a simple IF statement. This code
1380 is really duplicate with parts of the gfc_match_if code, but this is
1384 match_arithmetic_if (void)
1386 gfc_st_label *l1, *l2, *l3;
1390 m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
1394 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1395 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1396 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1398 gfc_free_expr (expr);
1402 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF statement "
1403 "at %C") == FAILURE)
1406 new_st.op = EXEC_ARITHMETIC_IF;
1416 /* The IF statement is a bit of a pain. First of all, there are three
1417 forms of it, the simple IF, the IF that starts a block and the
1420 There is a problem with the simple IF and that is the fact that we
1421 only have a single level of undo information on symbols. What this
1422 means is for a simple IF, we must re-match the whole IF statement
1423 multiple times in order to guarantee that the symbol table ends up
1424 in the proper state. */
1426 static match match_simple_forall (void);
1427 static match match_simple_where (void);
1430 gfc_match_if (gfc_statement *if_type)
1433 gfc_st_label *l1, *l2, *l3;
1434 locus old_loc, old_loc2;
1438 n = gfc_match_label ();
1439 if (n == MATCH_ERROR)
1442 old_loc = gfc_current_locus;
1444 m = gfc_match (" if ( %e", &expr);
1448 old_loc2 = gfc_current_locus;
1449 gfc_current_locus = old_loc;
1451 if (gfc_match_parens () == MATCH_ERROR)
1454 gfc_current_locus = old_loc2;
1456 if (gfc_match_char (')') != MATCH_YES)
1458 gfc_error ("Syntax error in IF-expression at %C");
1459 gfc_free_expr (expr);
1463 m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
1469 gfc_error ("Block label not appropriate for arithmetic IF "
1471 gfc_free_expr (expr);
1475 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1476 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1477 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1479 gfc_free_expr (expr);
1483 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF "
1484 "statement at %C") == FAILURE)
1487 new_st.op = EXEC_ARITHMETIC_IF;
1493 *if_type = ST_ARITHMETIC_IF;
1497 if (gfc_match (" then%t") == MATCH_YES)
1499 new_st.op = EXEC_IF;
1501 *if_type = ST_IF_BLOCK;
1507 gfc_error ("Block label is not appropriate for IF statement at %C");
1508 gfc_free_expr (expr);
1512 /* At this point the only thing left is a simple IF statement. At
1513 this point, n has to be MATCH_NO, so we don't have to worry about
1514 re-matching a block label. From what we've got so far, try
1515 matching an assignment. */
1517 *if_type = ST_SIMPLE_IF;
1519 m = gfc_match_assignment ();
1523 gfc_free_expr (expr);
1524 gfc_undo_symbols ();
1525 gfc_current_locus = old_loc;
1527 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1528 assignment was found. For MATCH_NO, continue to call the various
1530 if (m == MATCH_ERROR)
1533 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
1535 m = gfc_match_pointer_assignment ();
1539 gfc_free_expr (expr);
1540 gfc_undo_symbols ();
1541 gfc_current_locus = old_loc;
1543 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
1545 /* Look at the next keyword to see which matcher to call. Matching
1546 the keyword doesn't affect the symbol table, so we don't have to
1547 restore between tries. */
1549 #define match(string, subr, statement) \
1550 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1554 match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1555 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1556 match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1557 match ("call", gfc_match_call, ST_CALL)
1558 match ("close", gfc_match_close, ST_CLOSE)
1559 match ("continue", gfc_match_continue, ST_CONTINUE)
1560 match ("cycle", gfc_match_cycle, ST_CYCLE)
1561 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1562 match ("end file", gfc_match_endfile, ST_END_FILE)
1563 match ("exit", gfc_match_exit, ST_EXIT)
1564 match ("flush", gfc_match_flush, ST_FLUSH)
1565 match ("forall", match_simple_forall, ST_FORALL)
1566 match ("go to", gfc_match_goto, ST_GOTO)
1567 match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1568 match ("inquire", gfc_match_inquire, ST_INQUIRE)
1569 match ("nullify", gfc_match_nullify, ST_NULLIFY)
1570 match ("open", gfc_match_open, ST_OPEN)
1571 match ("pause", gfc_match_pause, ST_NONE)
1572 match ("print", gfc_match_print, ST_WRITE)
1573 match ("read", gfc_match_read, ST_READ)
1574 match ("return", gfc_match_return, ST_RETURN)
1575 match ("rewind", gfc_match_rewind, ST_REWIND)
1576 match ("stop", gfc_match_stop, ST_STOP)
1577 match ("wait", gfc_match_wait, ST_WAIT)
1578 match ("where", match_simple_where, ST_WHERE)
1579 match ("write", gfc_match_write, ST_WRITE)
1581 /* The gfc_match_assignment() above may have returned a MATCH_NO
1582 where the assignment was to a named constant. Check that
1583 special case here. */
1584 m = gfc_match_assignment ();
1587 gfc_error ("Cannot assign to a named constant at %C");
1588 gfc_free_expr (expr);
1589 gfc_undo_symbols ();
1590 gfc_current_locus = old_loc;
1594 /* All else has failed, so give up. See if any of the matchers has
1595 stored an error message of some sort. */
1596 if (gfc_error_check () == 0)
1597 gfc_error ("Unclassifiable statement in IF-clause at %C");
1599 gfc_free_expr (expr);
1604 gfc_error ("Syntax error in IF-clause at %C");
1607 gfc_free_expr (expr);
1611 /* At this point, we've matched the single IF and the action clause
1612 is in new_st. Rearrange things so that the IF statement appears
1615 p = gfc_get_code ();
1616 p->next = gfc_get_code ();
1618 p->next->loc = gfc_current_locus;
1623 gfc_clear_new_st ();
1625 new_st.op = EXEC_IF;
1634 /* Match an ELSE statement. */
1637 gfc_match_else (void)
1639 char name[GFC_MAX_SYMBOL_LEN + 1];
1641 if (gfc_match_eos () == MATCH_YES)
1644 if (gfc_match_name (name) != MATCH_YES
1645 || gfc_current_block () == NULL
1646 || gfc_match_eos () != MATCH_YES)
1648 gfc_error ("Unexpected junk after ELSE statement at %C");
1652 if (strcmp (name, gfc_current_block ()->name) != 0)
1654 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1655 name, gfc_current_block ()->name);
1663 /* Match an ELSE IF statement. */
1666 gfc_match_elseif (void)
1668 char name[GFC_MAX_SYMBOL_LEN + 1];
1672 m = gfc_match (" ( %e ) then", &expr);
1676 if (gfc_match_eos () == MATCH_YES)
1679 if (gfc_match_name (name) != MATCH_YES
1680 || gfc_current_block () == NULL
1681 || gfc_match_eos () != MATCH_YES)
1683 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1687 if (strcmp (name, gfc_current_block ()->name) != 0)
1689 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1690 name, gfc_current_block ()->name);
1695 new_st.op = EXEC_IF;
1700 gfc_free_expr (expr);
1705 /* Free a gfc_iterator structure. */
1708 gfc_free_iterator (gfc_iterator *iter, int flag)
1714 gfc_free_expr (iter->var);
1715 gfc_free_expr (iter->start);
1716 gfc_free_expr (iter->end);
1717 gfc_free_expr (iter->step);
1724 /* Match a DO statement. */
1729 gfc_iterator iter, *ip;
1731 gfc_st_label *label;
1734 old_loc = gfc_current_locus;
1737 iter.var = iter.start = iter.end = iter.step = NULL;
1739 m = gfc_match_label ();
1740 if (m == MATCH_ERROR)
1743 if (gfc_match (" do") != MATCH_YES)
1746 m = gfc_match_st_label (&label);
1747 if (m == MATCH_ERROR)
1750 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
1752 if (gfc_match_eos () == MATCH_YES)
1754 iter.end = gfc_logical_expr (1, NULL);
1755 new_st.op = EXEC_DO_WHILE;
1759 /* Match an optional comma, if no comma is found, a space is obligatory. */
1760 if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
1763 /* Check for balanced parens. */
1765 if (gfc_match_parens () == MATCH_ERROR)
1768 /* See if we have a DO WHILE. */
1769 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1771 new_st.op = EXEC_DO_WHILE;
1775 /* The abortive DO WHILE may have done something to the symbol
1776 table, so we start over. */
1777 gfc_undo_symbols ();
1778 gfc_current_locus = old_loc;
1780 gfc_match_label (); /* This won't error. */
1781 gfc_match (" do "); /* This will work. */
1783 gfc_match_st_label (&label); /* Can't error out. */
1784 gfc_match_char (','); /* Optional comma. */
1786 m = gfc_match_iterator (&iter, 0);
1789 if (m == MATCH_ERROR)
1792 iter.var->symtree->n.sym->attr.implied_index = 0;
1793 gfc_check_do_variable (iter.var->symtree);
1795 if (gfc_match_eos () != MATCH_YES)
1797 gfc_syntax_error (ST_DO);
1801 new_st.op = EXEC_DO;
1805 && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1808 new_st.label = label;
1810 if (new_st.op == EXEC_DO_WHILE)
1811 new_st.expr = iter.end;
1814 new_st.ext.iterator = ip = gfc_get_iterator ();
1821 gfc_free_iterator (&iter, 0);
1827 /* Match an EXIT or CYCLE statement. */
1830 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1832 gfc_state_data *p, *o;
1836 if (gfc_match_eos () == MATCH_YES)
1840 m = gfc_match ("% %s%t", &sym);
1841 if (m == MATCH_ERROR)
1845 gfc_syntax_error (st);
1849 if (sym->attr.flavor != FL_LABEL)
1851 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1852 sym->name, gfc_ascii_statement (st));
1857 /* Find the loop mentioned specified by the label (or lack of a label). */
1858 for (o = NULL, p = gfc_state_stack; p; p = p->previous)
1859 if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1861 else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
1867 gfc_error ("%s statement at %C is not within a loop",
1868 gfc_ascii_statement (st));
1870 gfc_error ("%s statement at %C is not within loop '%s'",
1871 gfc_ascii_statement (st), sym->name);
1878 gfc_error ("%s statement at %C leaving OpenMP structured block",
1879 gfc_ascii_statement (st));
1882 else if (st == ST_EXIT
1883 && p->previous != NULL
1884 && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
1885 && (p->previous->head->op == EXEC_OMP_DO
1886 || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
1888 gcc_assert (p->previous->head->next != NULL);
1889 gcc_assert (p->previous->head->next->op == EXEC_DO
1890 || p->previous->head->next->op == EXEC_DO_WHILE);
1891 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1895 /* Save the first statement in the loop - needed by the backend. */
1896 new_st.ext.whichloop = p->head;
1904 /* Match the EXIT statement. */
1907 gfc_match_exit (void)
1909 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1913 /* Match the CYCLE statement. */
1916 gfc_match_cycle (void)
1918 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1922 /* Match a number or character constant after a STOP or PAUSE statement. */
1925 gfc_match_stopcode (gfc_statement st)
1935 if (gfc_match_eos () != MATCH_YES)
1937 m = gfc_match_small_literal_int (&stop_code, &cnt);
1938 if (m == MATCH_ERROR)
1941 if (m == MATCH_YES && cnt > 5)
1943 gfc_error ("Too many digits in STOP code at %C");
1949 /* Try a character constant. */
1950 m = gfc_match_expr (&e);
1951 if (m == MATCH_ERROR)
1955 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1959 if (gfc_match_eos () != MATCH_YES)
1963 if (gfc_pure (NULL))
1965 gfc_error ("%s statement not allowed in PURE procedure at %C",
1966 gfc_ascii_statement (st));
1970 new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1972 new_st.ext.stop_code = stop_code;
1977 gfc_syntax_error (st);
1986 /* Match the (deprecated) PAUSE statement. */
1989 gfc_match_pause (void)
1993 m = gfc_match_stopcode (ST_PAUSE);
1996 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
2005 /* Match the STOP statement. */
2008 gfc_match_stop (void)
2010 return gfc_match_stopcode (ST_STOP);
2014 /* Match a CONTINUE statement. */
2017 gfc_match_continue (void)
2019 if (gfc_match_eos () != MATCH_YES)
2021 gfc_syntax_error (ST_CONTINUE);
2025 new_st.op = EXEC_CONTINUE;
2030 /* Match the (deprecated) ASSIGN statement. */
2033 gfc_match_assign (void)
2036 gfc_st_label *label;
2038 if (gfc_match (" %l", &label) == MATCH_YES)
2040 if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
2042 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
2044 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
2049 expr->symtree->n.sym->attr.assign = 1;
2051 new_st.op = EXEC_LABEL_ASSIGN;
2052 new_st.label = label;
2061 /* Match the GO TO statement. As a computed GOTO statement is
2062 matched, it is transformed into an equivalent SELECT block. No
2063 tree is necessary, and the resulting jumps-to-jumps are
2064 specifically optimized away by the back end. */
2067 gfc_match_goto (void)
2069 gfc_code *head, *tail;
2072 gfc_st_label *label;
2076 if (gfc_match (" %l%t", &label) == MATCH_YES)
2078 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2081 new_st.op = EXEC_GOTO;
2082 new_st.label = label;
2086 /* The assigned GO TO statement. */
2088 if (gfc_match_variable (&expr, 0) == MATCH_YES)
2090 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
2095 new_st.op = EXEC_GOTO;
2098 if (gfc_match_eos () == MATCH_YES)
2101 /* Match label list. */
2102 gfc_match_char (',');
2103 if (gfc_match_char ('(') != MATCH_YES)
2105 gfc_syntax_error (ST_GOTO);
2112 m = gfc_match_st_label (&label);
2116 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2120 head = tail = gfc_get_code ();
2123 tail->block = gfc_get_code ();
2127 tail->label = label;
2128 tail->op = EXEC_GOTO;
2130 while (gfc_match_char (',') == MATCH_YES);
2132 if (gfc_match (")%t") != MATCH_YES)
2137 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2140 new_st.block = head;
2145 /* Last chance is a computed GO TO statement. */
2146 if (gfc_match_char ('(') != MATCH_YES)
2148 gfc_syntax_error (ST_GOTO);
2157 m = gfc_match_st_label (&label);
2161 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2165 head = tail = gfc_get_code ();
2168 tail->block = gfc_get_code ();
2172 cp = gfc_get_case ();
2173 cp->low = cp->high = gfc_int_expr (i++);
2175 tail->op = EXEC_SELECT;
2176 tail->ext.case_list = cp;
2178 tail->next = gfc_get_code ();
2179 tail->next->op = EXEC_GOTO;
2180 tail->next->label = label;
2182 while (gfc_match_char (',') == MATCH_YES);
2184 if (gfc_match_char (')') != MATCH_YES)
2189 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2193 /* Get the rest of the statement. */
2194 gfc_match_char (',');
2196 if (gfc_match (" %e%t", &expr) != MATCH_YES)
2199 /* At this point, a computed GOTO has been fully matched and an
2200 equivalent SELECT statement constructed. */
2202 new_st.op = EXEC_SELECT;
2205 /* Hack: For a "real" SELECT, the expression is in expr. We put
2206 it in expr2 so we can distinguish then and produce the correct
2208 new_st.expr2 = expr;
2209 new_st.block = head;
2213 gfc_syntax_error (ST_GOTO);
2215 gfc_free_statements (head);
2220 /* Frees a list of gfc_alloc structures. */
2223 gfc_free_alloc_list (gfc_alloc *p)
2230 gfc_free_expr (p->expr);
2236 /* Match an ALLOCATE statement. */
2239 gfc_match_allocate (void)
2241 gfc_alloc *head, *tail;
2248 if (gfc_match_char ('(') != MATCH_YES)
2254 head = tail = gfc_get_alloc ();
2257 tail->next = gfc_get_alloc ();
2261 m = gfc_match_variable (&tail->expr, 0);
2264 if (m == MATCH_ERROR)
2267 if (gfc_check_do_variable (tail->expr->symtree))
2271 && gfc_impure_variable (tail->expr->symtree->n.sym))
2273 gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
2278 if (tail->expr->ts.type == BT_DERIVED)
2279 tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
2281 if (gfc_match_char (',') != MATCH_YES)
2284 m = gfc_match (" stat = %v", &stat);
2285 if (m == MATCH_ERROR)
2292 gfc_check_do_variable(stat->symtree);
2294 if (gfc_match (" )%t") != MATCH_YES)
2297 new_st.op = EXEC_ALLOCATE;
2299 new_st.ext.alloc_list = head;
2304 gfc_syntax_error (ST_ALLOCATE);
2307 gfc_free_expr (stat);
2308 gfc_free_alloc_list (head);
2313 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
2314 a set of pointer assignments to intrinsic NULL(). */
2317 gfc_match_nullify (void)
2325 if (gfc_match_char ('(') != MATCH_YES)
2330 m = gfc_match_variable (&p, 0);
2331 if (m == MATCH_ERROR)
2336 if (gfc_check_do_variable (p->symtree))
2339 if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
2341 gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
2345 /* build ' => NULL() '. */
2346 e = gfc_get_expr ();
2347 e->where = gfc_current_locus;
2348 e->expr_type = EXPR_NULL;
2349 e->ts.type = BT_UNKNOWN;
2351 /* Chain to list. */
2356 tail->next = gfc_get_code ();
2360 tail->op = EXEC_POINTER_ASSIGN;
2364 if (gfc_match (" )%t") == MATCH_YES)
2366 if (gfc_match_char (',') != MATCH_YES)
2373 gfc_syntax_error (ST_NULLIFY);
2376 gfc_free_statements (new_st.next);
2381 /* Match a DEALLOCATE statement. */
2384 gfc_match_deallocate (void)
2386 gfc_alloc *head, *tail;
2393 if (gfc_match_char ('(') != MATCH_YES)
2399 head = tail = gfc_get_alloc ();
2402 tail->next = gfc_get_alloc ();
2406 m = gfc_match_variable (&tail->expr, 0);
2407 if (m == MATCH_ERROR)
2412 if (gfc_check_do_variable (tail->expr->symtree))
2416 && gfc_impure_variable (tail->expr->symtree->n.sym))
2418 gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
2419 "for a PURE procedure");
2423 if (gfc_match_char (',') != MATCH_YES)
2426 m = gfc_match (" stat = %v", &stat);
2427 if (m == MATCH_ERROR)
2434 gfc_check_do_variable(stat->symtree);
2436 if (gfc_match (" )%t") != MATCH_YES)
2439 new_st.op = EXEC_DEALLOCATE;
2441 new_st.ext.alloc_list = head;
2446 gfc_syntax_error (ST_DEALLOCATE);
2449 gfc_free_expr (stat);
2450 gfc_free_alloc_list (head);
2455 /* Match a RETURN statement. */
2458 gfc_match_return (void)
2462 gfc_compile_state s;
2465 if (gfc_match_eos () == MATCH_YES)
2468 if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
2470 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2475 if (gfc_current_form == FORM_FREE)
2477 /* The following are valid, so we can't require a blank after the
2481 char c = gfc_peek_ascii_char ();
2482 if (ISALPHA (c) || ISDIGIT (c))
2486 m = gfc_match (" %e%t", &e);
2489 if (m == MATCH_ERROR)
2492 gfc_syntax_error (ST_RETURN);
2499 gfc_enclosing_unit (&s);
2500 if (s == COMP_PROGRAM
2501 && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
2502 "main program at %C") == FAILURE)
2505 new_st.op = EXEC_RETURN;
2512 /* Match the call of a type-bound procedure, if CALL%var has already been
2513 matched and var found to be a derived-type variable. */
2516 match_typebound_call (gfc_symtree* varst)
2524 base = gfc_get_expr ();
2525 base->expr_type = EXPR_VARIABLE;
2526 base->symtree = varst;
2527 base->where = gfc_current_locus;
2529 m = gfc_match_varspec (base, 0, true);
2531 gfc_error ("Expected component reference at %C");
2535 if (gfc_match_eos () != MATCH_YES)
2537 gfc_error ("Junk after CALL at %C");
2541 if (base->expr_type != EXPR_COMPCALL)
2543 gfc_error ("Expected type-bound procedure reference at %C");
2547 new_st.op = EXEC_COMPCALL;
2554 /* Match a CALL statement. The tricky part here are possible
2555 alternate return specifiers. We handle these by having all
2556 "subroutines" actually return an integer via a register that gives
2557 the return number. If the call specifies alternate returns, we
2558 generate code for a SELECT statement whose case clauses contain
2559 GOTOs to the various labels. */
2562 gfc_match_call (void)
2564 char name[GFC_MAX_SYMBOL_LEN + 1];
2565 gfc_actual_arglist *a, *arglist;
2575 m = gfc_match ("% %n", name);
2581 if (gfc_get_ha_sym_tree (name, &st))
2586 /* If this is a variable of derived-type, it probably starts a type-bound
2588 if (sym->attr.flavor != FL_PROCEDURE && sym->ts.type == BT_DERIVED)
2589 return match_typebound_call (st);
2591 /* If it does not seem to be callable... */
2592 if (!sym->attr.generic
2593 && !sym->attr.subroutine)
2595 if (!(sym->attr.external && !sym->attr.referenced))
2597 /* ...create a symbol in this scope... */
2598 if (sym->ns != gfc_current_ns
2599 && gfc_get_sym_tree (name, NULL, &st) == 1)
2602 if (sym != st->n.sym)
2606 /* ...and then to try to make the symbol into a subroutine. */
2607 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2611 gfc_set_sym_referenced (sym);
2613 if (gfc_match_eos () != MATCH_YES)
2615 m = gfc_match_actual_arglist (1, &arglist);
2618 if (m == MATCH_ERROR)
2621 if (gfc_match_eos () != MATCH_YES)
2625 /* If any alternate return labels were found, construct a SELECT
2626 statement that will jump to the right place. */
2629 for (a = arglist; a; a = a->next)
2630 if (a->expr == NULL)
2635 gfc_symtree *select_st;
2636 gfc_symbol *select_sym;
2637 char name[GFC_MAX_SYMBOL_LEN + 1];
2639 new_st.next = c = gfc_get_code ();
2640 c->op = EXEC_SELECT;
2641 sprintf (name, "_result_%s", sym->name);
2642 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
2644 select_sym = select_st->n.sym;
2645 select_sym->ts.type = BT_INTEGER;
2646 select_sym->ts.kind = gfc_default_integer_kind;
2647 gfc_set_sym_referenced (select_sym);
2648 c->expr = gfc_get_expr ();
2649 c->expr->expr_type = EXPR_VARIABLE;
2650 c->expr->symtree = select_st;
2651 c->expr->ts = select_sym->ts;
2652 c->expr->where = gfc_current_locus;
2655 for (a = arglist; a; a = a->next)
2657 if (a->expr != NULL)
2660 if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2665 c->block = gfc_get_code ();
2667 c->op = EXEC_SELECT;
2669 new_case = gfc_get_case ();
2670 new_case->high = new_case->low = gfc_int_expr (i);
2671 c->ext.case_list = new_case;
2673 c->next = gfc_get_code ();
2674 c->next->op = EXEC_GOTO;
2675 c->next->label = a->label;
2679 new_st.op = EXEC_CALL;
2680 new_st.symtree = st;
2681 new_st.ext.actual = arglist;
2686 gfc_syntax_error (ST_CALL);
2689 gfc_free_actual_arglist (arglist);
2694 /* Given a name, return a pointer to the common head structure,
2695 creating it if it does not exist. If FROM_MODULE is nonzero, we
2696 mangle the name so that it doesn't interfere with commons defined
2697 in the using namespace.
2698 TODO: Add to global symbol tree. */
2701 gfc_get_common (const char *name, int from_module)
2704 static int serial = 0;
2705 char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
2709 /* A use associated common block is only needed to correctly layout
2710 the variables it contains. */
2711 snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2712 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2716 st = gfc_find_symtree (gfc_current_ns->common_root, name);
2719 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2722 if (st->n.common == NULL)
2724 st->n.common = gfc_get_common_head ();
2725 st->n.common->where = gfc_current_locus;
2726 strcpy (st->n.common->name, name);
2729 return st->n.common;
2733 /* Match a common block name. */
2735 match match_common_name (char *name)
2739 if (gfc_match_char ('/') == MATCH_NO)
2745 if (gfc_match_char ('/') == MATCH_YES)
2751 m = gfc_match_name (name);
2753 if (m == MATCH_ERROR)
2755 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2758 gfc_error ("Syntax error in common block name at %C");
2763 /* Match a COMMON statement. */
2766 gfc_match_common (void)
2768 gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
2769 char name[GFC_MAX_SYMBOL_LEN + 1];
2776 old_blank_common = gfc_current_ns->blank_common.head;
2777 if (old_blank_common)
2779 while (old_blank_common->common_next)
2780 old_blank_common = old_blank_common->common_next;
2787 m = match_common_name (name);
2788 if (m == MATCH_ERROR)
2791 gsym = gfc_get_gsymbol (name);
2792 if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
2794 gfc_error ("Symbol '%s' at %C is already an external symbol that "
2795 "is not COMMON", name);
2799 if (gsym->type == GSYM_UNKNOWN)
2801 gsym->type = GSYM_COMMON;
2802 gsym->where = gfc_current_locus;
2808 if (name[0] == '\0')
2810 t = &gfc_current_ns->blank_common;
2811 if (t->head == NULL)
2812 t->where = gfc_current_locus;
2816 t = gfc_get_common (name, 0);
2825 while (tail->common_next)
2826 tail = tail->common_next;
2829 /* Grab the list of symbols. */
2832 m = gfc_match_symbol (&sym, 0);
2833 if (m == MATCH_ERROR)
2838 /* Store a ref to the common block for error checking. */
2839 sym->common_block = t;
2841 /* See if we know the current common block is bind(c), and if
2842 so, then see if we can check if the symbol is (which it'll
2843 need to be). This can happen if the bind(c) attr stmt was
2844 applied to the common block, and the variable(s) already
2845 defined, before declaring the common block. */
2846 if (t->is_bind_c == 1)
2848 if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
2850 /* If we find an error, just print it and continue,
2851 cause it's just semantic, and we can see if there
2853 gfc_error_now ("Variable '%s' at %L in common block '%s' "
2854 "at %C must be declared with a C "
2855 "interoperable kind since common block "
2857 sym->name, &(sym->declared_at), t->name,
2861 if (sym->attr.is_bind_c == 1)
2862 gfc_error_now ("Variable '%s' in common block "
2863 "'%s' at %C can not be bind(c) since "
2864 "it is not global", sym->name, t->name);
2867 if (sym->attr.in_common)
2869 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2874 if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
2875 || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
2877 if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
2878 "can only be COMMON in "
2879 "BLOCK DATA", sym->name)
2884 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2888 tail->common_next = sym;
2894 /* Deal with an optional array specification after the
2896 m = gfc_match_array_spec (&as);
2897 if (m == MATCH_ERROR)
2902 if (as->type != AS_EXPLICIT)
2904 gfc_error ("Array specification for symbol '%s' in COMMON "
2905 "at %C must be explicit", sym->name);
2909 if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2912 if (sym->attr.pointer)
2914 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
2915 "POINTER array", sym->name);
2924 sym->common_head = t;
2926 /* Check to see if the symbol is already in an equivalence group.
2927 If it is, set the other members as being in common. */
2928 if (sym->attr.in_equivalence)
2930 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
2932 for (e2 = e1; e2; e2 = e2->eq)
2933 if (e2->expr->symtree->n.sym == sym)
2940 for (e2 = e1; e2; e2 = e2->eq)
2942 other = e2->expr->symtree->n.sym;
2943 if (other->common_head
2944 && other->common_head != sym->common_head)
2946 gfc_error ("Symbol '%s', in COMMON block '%s' at "
2947 "%C is being indirectly equivalenced to "
2948 "another COMMON block '%s'",
2949 sym->name, sym->common_head->name,
2950 other->common_head->name);
2953 other->attr.in_common = 1;
2954 other->common_head = t;
2960 gfc_gobble_whitespace ();
2961 if (gfc_match_eos () == MATCH_YES)
2963 if (gfc_peek_ascii_char () == '/')
2965 if (gfc_match_char (',') != MATCH_YES)
2967 gfc_gobble_whitespace ();
2968 if (gfc_peek_ascii_char () == '/')
2977 gfc_syntax_error (ST_COMMON);
2980 if (old_blank_common)
2981 old_blank_common->common_next = NULL;
2983 gfc_current_ns->blank_common.head = NULL;
2984 gfc_free_array_spec (as);
2989 /* Match a BLOCK DATA program unit. */
2992 gfc_match_block_data (void)
2994 char name[GFC_MAX_SYMBOL_LEN + 1];
2998 if (gfc_match_eos () == MATCH_YES)
3000 gfc_new_block = NULL;
3004 m = gfc_match ("% %n%t", name);
3008 if (gfc_get_symbol (name, NULL, &sym))
3011 if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
3014 gfc_new_block = sym;
3020 /* Free a namelist structure. */
3023 gfc_free_namelist (gfc_namelist *name)
3027 for (; name; name = n)
3035 /* Match a NAMELIST statement. */
3038 gfc_match_namelist (void)
3040 gfc_symbol *group_name, *sym;
3044 m = gfc_match (" / %s /", &group_name);
3047 if (m == MATCH_ERROR)
3052 if (group_name->ts.type != BT_UNKNOWN)
3054 gfc_error ("Namelist group name '%s' at %C already has a basic "
3055 "type of %s", group_name->name,
3056 gfc_typename (&group_name->ts));
3060 if (group_name->attr.flavor == FL_NAMELIST
3061 && group_name->attr.use_assoc
3062 && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
3063 "at %C already is USE associated and can"
3064 "not be respecified.", group_name->name)
3068 if (group_name->attr.flavor != FL_NAMELIST
3069 && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
3070 group_name->name, NULL) == FAILURE)
3075 m = gfc_match_symbol (&sym, 1);
3078 if (m == MATCH_ERROR)
3081 if (sym->attr.in_namelist == 0
3082 && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
3085 /* Use gfc_error_check here, rather than goto error, so that
3086 these are the only errors for the next two lines. */
3087 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
3089 gfc_error ("Assumed size array '%s' in namelist '%s' at "
3090 "%C is not allowed", sym->name, group_name->name);
3094 if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL)
3096 gfc_error ("Assumed character length '%s' in namelist '%s' at "
3097 "%C is not allowed", sym->name, group_name->name);
3101 nl = gfc_get_namelist ();
3105 if (group_name->namelist == NULL)
3106 group_name->namelist = group_name->namelist_tail = nl;
3109 group_name->namelist_tail->next = nl;
3110 group_name->namelist_tail = nl;
3113 if (gfc_match_eos () == MATCH_YES)
3116 m = gfc_match_char (',');
3118 if (gfc_match_char ('/') == MATCH_YES)
3120 m2 = gfc_match (" %s /", &group_name);
3121 if (m2 == MATCH_YES)
3123 if (m2 == MATCH_ERROR)
3137 gfc_syntax_error (ST_NAMELIST);
3144 /* Match a MODULE statement. */
3147 gfc_match_module (void)
3151 m = gfc_match (" %s%t", &gfc_new_block);
3155 if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
3156 gfc_new_block->name, NULL) == FAILURE)
3163 /* Free equivalence sets and lists. Recursively is the easiest way to
3167 gfc_free_equiv (gfc_equiv *eq)
3172 gfc_free_equiv (eq->eq);
3173 gfc_free_equiv (eq->next);
3174 gfc_free_expr (eq->expr);
3179 /* Match an EQUIVALENCE statement. */
3182 gfc_match_equivalence (void)
3184 gfc_equiv *eq, *set, *tail;
3188 gfc_common_head *common_head = NULL;
3196 eq = gfc_get_equiv ();
3200 eq->next = gfc_current_ns->equiv;
3201 gfc_current_ns->equiv = eq;
3203 if (gfc_match_char ('(') != MATCH_YES)
3207 common_flag = FALSE;
3212 m = gfc_match_equiv_variable (&set->expr);
3213 if (m == MATCH_ERROR)
3218 /* count the number of objects. */
3221 if (gfc_match_char ('%') == MATCH_YES)
3223 gfc_error ("Derived type component %C is not a "
3224 "permitted EQUIVALENCE member");
3228 for (ref = set->expr->ref; ref; ref = ref->next)
3229 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3231 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
3232 "be an array section");
3236 sym = set->expr->symtree->n.sym;
3238 if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
3241 if (sym->attr.in_common)
3244 common_head = sym->common_head;
3247 if (gfc_match_char (')') == MATCH_YES)
3250 if (gfc_match_char (',') != MATCH_YES)
3253 set->eq = gfc_get_equiv ();
3259 gfc_error ("EQUIVALENCE at %C requires two or more objects");
3263 /* If one of the members of an equivalence is in common, then
3264 mark them all as being in common. Before doing this, check
3265 that members of the equivalence group are not in different
3268 for (set = eq; set; set = set->eq)
3270 sym = set->expr->symtree->n.sym;
3271 if (sym->common_head && sym->common_head != common_head)
3273 gfc_error ("Attempt to indirectly overlap COMMON "
3274 "blocks %s and %s by EQUIVALENCE at %C",
3275 sym->common_head->name, common_head->name);
3278 sym->attr.in_common = 1;
3279 sym->common_head = common_head;
3282 if (gfc_match_eos () == MATCH_YES)
3284 if (gfc_match_char (',') != MATCH_YES)
3291 gfc_syntax_error (ST_EQUIVALENCE);
3297 gfc_free_equiv (gfc_current_ns->equiv);
3298 gfc_current_ns->equiv = eq;
3304 /* Check that a statement function is not recursive. This is done by looking
3305 for the statement function symbol(sym) by looking recursively through its
3306 expression(e). If a reference to sym is found, true is returned.
3307 12.5.4 requires that any variable of function that is implicitly typed
3308 shall have that type confirmed by any subsequent type declaration. The
3309 implicit typing is conveniently done here. */
3311 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
3314 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
3320 switch (e->expr_type)
3323 if (e->symtree == NULL)
3326 /* Check the name before testing for nested recursion! */
3327 if (sym->name == e->symtree->n.sym->name)
3330 /* Catch recursion via other statement functions. */
3331 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
3332 && e->symtree->n.sym->value
3333 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
3336 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3337 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3342 if (e->symtree && sym->name == e->symtree->n.sym->name)
3345 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3346 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3358 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
3360 return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
3364 /* Match a statement function declaration. It is so easy to match
3365 non-statement function statements with a MATCH_ERROR as opposed to
3366 MATCH_NO that we suppress error message in most cases. */
3369 gfc_match_st_function (void)
3371 gfc_error_buf old_error;
3376 m = gfc_match_symbol (&sym, 0);
3380 gfc_push_error (&old_error);
3382 if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
3383 sym->name, NULL) == FAILURE)
3386 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
3389 m = gfc_match (" = %e%t", &expr);
3393 gfc_free_error (&old_error);
3394 if (m == MATCH_ERROR)
3397 if (recursive_stmt_fcn (expr, sym))
3399 gfc_error ("Statement function at %L is recursive", &expr->where);
3408 gfc_pop_error (&old_error);
3413 /***************** SELECT CASE subroutines ******************/
3415 /* Free a single case structure. */
3418 free_case (gfc_case *p)
3420 if (p->low == p->high)
3422 gfc_free_expr (p->low);
3423 gfc_free_expr (p->high);
3428 /* Free a list of case structures. */
3431 gfc_free_case_list (gfc_case *p)
3443 /* Match a single case selector. */
3446 match_case_selector (gfc_case **cp)
3451 c = gfc_get_case ();
3452 c->where = gfc_current_locus;
3454 if (gfc_match_char (':') == MATCH_YES)
3456 m = gfc_match_init_expr (&c->high);
3459 if (m == MATCH_ERROR)
3464 m = gfc_match_init_expr (&c->low);
3465 if (m == MATCH_ERROR)
3470 /* If we're not looking at a ':' now, make a range out of a single
3471 target. Else get the upper bound for the case range. */
3472 if (gfc_match_char (':') != MATCH_YES)
3476 m = gfc_match_init_expr (&c->high);
3477 if (m == MATCH_ERROR)
3479 /* MATCH_NO is fine. It's OK if nothing is there! */
3487 gfc_error ("Expected initialization expression in CASE at %C");
3495 /* Match the end of a case statement. */
3498 match_case_eos (void)
3500 char name[GFC_MAX_SYMBOL_LEN + 1];
3503 if (gfc_match_eos () == MATCH_YES)
3506 /* If the case construct doesn't have a case-construct-name, we
3507 should have matched the EOS. */
3508 if (!gfc_current_block ())
3510 gfc_error ("Expected the name of the SELECT CASE construct at %C");
3514 gfc_gobble_whitespace ();
3516 m = gfc_match_name (name);
3520 if (strcmp (name, gfc_current_block ()->name) != 0)
3522 gfc_error ("Expected case name of '%s' at %C",
3523 gfc_current_block ()->name);
3527 return gfc_match_eos ();
3531 /* Match a SELECT statement. */
3534 gfc_match_select (void)
3539 m = gfc_match_label ();
3540 if (m == MATCH_ERROR)
3543 m = gfc_match (" select case ( %e )%t", &expr);
3547 new_st.op = EXEC_SELECT;
3554 /* Match a CASE statement. */
3557 gfc_match_case (void)
3559 gfc_case *c, *head, *tail;
3564 if (gfc_current_state () != COMP_SELECT)
3566 gfc_error ("Unexpected CASE statement at %C");
3570 if (gfc_match ("% default") == MATCH_YES)
3572 m = match_case_eos ();
3575 if (m == MATCH_ERROR)
3578 new_st.op = EXEC_SELECT;
3579 c = gfc_get_case ();
3580 c->where = gfc_current_locus;
3581 new_st.ext.case_list = c;
3585 if (gfc_match_char ('(') != MATCH_YES)
3590 if (match_case_selector (&c) == MATCH_ERROR)
3600 if (gfc_match_char (')') == MATCH_YES)
3602 if (gfc_match_char (',') != MATCH_YES)
3606 m = match_case_eos ();
3609 if (m == MATCH_ERROR)
3612 new_st.op = EXEC_SELECT;
3613 new_st.ext.case_list = head;
3618 gfc_error ("Syntax error in CASE-specification at %C");
3621 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
3625 /********************* WHERE subroutines ********************/
3627 /* Match the rest of a simple WHERE statement that follows an IF statement.
3631 match_simple_where (void)
3637 m = gfc_match (" ( %e )", &expr);
3641 m = gfc_match_assignment ();
3644 if (m == MATCH_ERROR)
3647 if (gfc_match_eos () != MATCH_YES)
3650 c = gfc_get_code ();
3654 c->next = gfc_get_code ();
3657 gfc_clear_new_st ();
3659 new_st.op = EXEC_WHERE;
3665 gfc_syntax_error (ST_WHERE);
3668 gfc_free_expr (expr);
3673 /* Match a WHERE statement. */
3676 gfc_match_where (gfc_statement *st)
3682 m0 = gfc_match_label ();
3683 if (m0 == MATCH_ERROR)
3686 m = gfc_match (" where ( %e )", &expr);
3690 if (gfc_match_eos () == MATCH_YES)
3692 *st = ST_WHERE_BLOCK;
3693 new_st.op = EXEC_WHERE;
3698 m = gfc_match_assignment ();
3700 gfc_syntax_error (ST_WHERE);
3704 gfc_free_expr (expr);
3708 /* We've got a simple WHERE statement. */
3710 c = gfc_get_code ();
3714 c->next = gfc_get_code ();
3717 gfc_clear_new_st ();
3719 new_st.op = EXEC_WHERE;
3726 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3727 new_st if successful. */
3730 gfc_match_elsewhere (void)
3732 char name[GFC_MAX_SYMBOL_LEN + 1];
3736 if (gfc_current_state () != COMP_WHERE)
3738 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3744 if (gfc_match_char ('(') == MATCH_YES)
3746 m = gfc_match_expr (&expr);
3749 if (m == MATCH_ERROR)
3752 if (gfc_match_char (')') != MATCH_YES)
3756 if (gfc_match_eos () != MATCH_YES)
3758 /* Only makes sense if we have a where-construct-name. */
3759 if (!gfc_current_block ())
3764 /* Better be a name at this point. */
3765 m = gfc_match_name (name);
3768 if (m == MATCH_ERROR)
3771 if (gfc_match_eos () != MATCH_YES)
3774 if (strcmp (name, gfc_current_block ()->name) != 0)
3776 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3777 name, gfc_current_block ()->name);
3782 new_st.op = EXEC_WHERE;
3787 gfc_syntax_error (ST_ELSEWHERE);
3790 gfc_free_expr (expr);
3795 /******************** FORALL subroutines ********************/
3797 /* Free a list of FORALL iterators. */
3800 gfc_free_forall_iterator (gfc_forall_iterator *iter)
3802 gfc_forall_iterator *next;
3807 gfc_free_expr (iter->var);
3808 gfc_free_expr (iter->start);
3809 gfc_free_expr (iter->end);
3810 gfc_free_expr (iter->stride);
3817 /* Match an iterator as part of a FORALL statement. The format is:
3819 <var> = <start>:<end>[:<stride>]
3821 On MATCH_NO, the caller tests for the possibility that there is a
3822 scalar mask expression. */
3825 match_forall_iterator (gfc_forall_iterator **result)
3827 gfc_forall_iterator *iter;
3831 where = gfc_current_locus;
3832 iter = XCNEW (gfc_forall_iterator);
3834 m = gfc_match_expr (&iter->var);
3838 if (gfc_match_char ('=') != MATCH_YES
3839 || iter->var->expr_type != EXPR_VARIABLE)
3845 m = gfc_match_expr (&iter->start);
3849 if (gfc_match_char (':') != MATCH_YES)
3852 m = gfc_match_expr (&iter->end);
3855 if (m == MATCH_ERROR)
3858 if (gfc_match_char (':') == MATCH_NO)
3859 iter->stride = gfc_int_expr (1);
3862 m = gfc_match_expr (&iter->stride);
3865 if (m == MATCH_ERROR)
3869 /* Mark the iteration variable's symbol as used as a FORALL index. */
3870 iter->var->symtree->n.sym->forall_index = true;
3876 gfc_error ("Syntax error in FORALL iterator at %C");
3881 gfc_current_locus = where;
3882 gfc_free_forall_iterator (iter);
3887 /* Match the header of a FORALL statement. */
3890 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
3892 gfc_forall_iterator *head, *tail, *new_iter;
3896 gfc_gobble_whitespace ();
3901 if (gfc_match_char ('(') != MATCH_YES)
3904 m = match_forall_iterator (&new_iter);
3905 if (m == MATCH_ERROR)
3910 head = tail = new_iter;
3914 if (gfc_match_char (',') != MATCH_YES)
3917 m = match_forall_iterator (&new_iter);
3918 if (m == MATCH_ERROR)
3923 tail->next = new_iter;
3928 /* Have to have a mask expression. */
3930 m = gfc_match_expr (&msk);
3933 if (m == MATCH_ERROR)
3939 if (gfc_match_char (')') == MATCH_NO)
3947 gfc_syntax_error (ST_FORALL);
3950 gfc_free_expr (msk);
3951 gfc_free_forall_iterator (head);
3956 /* Match the rest of a simple FORALL statement that follows an
3960 match_simple_forall (void)
3962 gfc_forall_iterator *head;
3971 m = match_forall_header (&head, &mask);
3978 m = gfc_match_assignment ();
3980 if (m == MATCH_ERROR)
3984 m = gfc_match_pointer_assignment ();
3985 if (m == MATCH_ERROR)
3991 c = gfc_get_code ();
3993 c->loc = gfc_current_locus;
3995 if (gfc_match_eos () != MATCH_YES)
3998 gfc_clear_new_st ();
3999 new_st.op = EXEC_FORALL;
4001 new_st.ext.forall_iterator = head;
4002 new_st.block = gfc_get_code ();
4004 new_st.block->op = EXEC_FORALL;
4005 new_st.block->next = c;
4010 gfc_syntax_error (ST_FORALL);
4013 gfc_free_forall_iterator (head);
4014 gfc_free_expr (mask);
4020 /* Match a FORALL statement. */
4023 gfc_match_forall (gfc_statement *st)
4025 gfc_forall_iterator *head;
4034 m0 = gfc_match_label ();
4035 if (m0 == MATCH_ERROR)
4038 m = gfc_match (" forall");
4042 m = match_forall_header (&head, &mask);
4043 if (m == MATCH_ERROR)
4048 if (gfc_match_eos () == MATCH_YES)
4050 *st = ST_FORALL_BLOCK;
4051 new_st.op = EXEC_FORALL;
4053 new_st.ext.forall_iterator = head;
4057 m = gfc_match_assignment ();
4058 if (m == MATCH_ERROR)
4062 m = gfc_match_pointer_assignment ();
4063 if (m == MATCH_ERROR)
4069 c = gfc_get_code ();
4071 c->loc = gfc_current_locus;
4073 gfc_clear_new_st ();
4074 new_st.op = EXEC_FORALL;
4076 new_st.ext.forall_iterator = head;
4077 new_st.block = gfc_get_code ();
4078 new_st.block->op = EXEC_FORALL;
4079 new_st.block->next = c;
4085 gfc_syntax_error (ST_FORALL);
4088 gfc_free_forall_iterator (head);
4089 gfc_free_expr (mask);
4090 gfc_free_statements (c);