1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
3 2010 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 /* Stack of SELECT TYPE statements. */
33 gfc_select_type_stack *select_type_stack = NULL;
35 /* For debugging and diagnostic purposes. Return the textual representation
36 of the intrinsic operator OP. */
38 gfc_op2string (gfc_intrinsic_op op)
46 case INTRINSIC_UMINUS:
52 case INTRINSIC_CONCAT:
56 case INTRINSIC_DIVIDE:
95 case INTRINSIC_ASSIGN:
98 case INTRINSIC_PARENTHESES:
105 gfc_internal_error ("gfc_op2string(): Bad code");
110 /******************** Generic matching subroutines ************************/
112 /* This function scans the current statement counting the opened and closed
113 parenthesis to make sure they are balanced. */
116 gfc_match_parens (void)
118 locus old_loc, where;
122 old_loc = gfc_current_locus;
129 c = gfc_next_char_literal (instring);
132 if (quote == ' ' && ((c == '\'') || (c == '"')))
138 if (quote != ' ' && c == quote)
145 if (c == '(' && quote == ' ')
148 where = gfc_current_locus;
150 if (c == ')' && quote == ' ')
153 where = gfc_current_locus;
157 gfc_current_locus = old_loc;
161 gfc_error ("Missing ')' in statement at or before %L", &where);
166 gfc_error ("Missing '(' in statement at or before %L", &where);
174 /* See if the next character is a special character that has
175 escaped by a \ via the -fbackslash option. */
178 gfc_match_special_char (gfc_char_t *res)
186 switch ((c = gfc_next_char_literal (1)))
219 /* Hexadecimal form of wide characters. */
220 len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8));
222 for (i = 0; i < len; i++)
224 char buf[2] = { '\0', '\0' };
226 c = gfc_next_char_literal (1);
227 if (!gfc_wide_fits_in_byte (c)
228 || !gfc_check_digit ((unsigned char) c, 16))
231 buf[0] = (unsigned char) c;
233 n += strtol (buf, NULL, 16);
239 /* Unknown backslash codes are simply not expanded. */
248 /* In free form, match at least one space. Always matches in fixed
252 gfc_match_space (void)
257 if (gfc_current_form == FORM_FIXED)
260 old_loc = gfc_current_locus;
262 c = gfc_next_ascii_char ();
263 if (!gfc_is_whitespace (c))
265 gfc_current_locus = old_loc;
269 gfc_gobble_whitespace ();
275 /* Match an end of statement. End of statement is optional
276 whitespace, followed by a ';' or '\n' or comment '!'. If a
277 semicolon is found, we continue to eat whitespace and semicolons. */
290 old_loc = gfc_current_locus;
291 gfc_gobble_whitespace ();
293 c = gfc_next_ascii_char ();
299 c = gfc_next_ascii_char ();
316 gfc_current_locus = old_loc;
317 return (flag) ? MATCH_YES : MATCH_NO;
321 /* Match a literal integer on the input, setting the value on
322 MATCH_YES. Literal ints occur in kind-parameters as well as
323 old-style character length specifications. If cnt is non-NULL it
324 will be set to the number of digits. */
327 gfc_match_small_literal_int (int *value, int *cnt)
333 old_loc = gfc_current_locus;
336 gfc_gobble_whitespace ();
337 c = gfc_next_ascii_char ();
343 gfc_current_locus = old_loc;
352 old_loc = gfc_current_locus;
353 c = gfc_next_ascii_char ();
358 i = 10 * i + c - '0';
363 gfc_error ("Integer too large at %C");
368 gfc_current_locus = old_loc;
377 /* Match a small, constant integer expression, like in a kind
378 statement. On MATCH_YES, 'value' is set. */
381 gfc_match_small_int (int *value)
388 m = gfc_match_expr (&expr);
392 p = gfc_extract_int (expr, &i);
393 gfc_free_expr (expr);
406 /* This function is the same as the gfc_match_small_int, except that
407 we're keeping the pointer to the expr. This function could just be
408 removed and the previously mentioned one modified, though all calls
409 to it would have to be modified then (and there were a number of
410 them). Return MATCH_ERROR if fail to extract the int; otherwise,
411 return the result of gfc_match_expr(). The expr (if any) that was
412 matched is returned in the parameter expr. */
415 gfc_match_small_int_expr (int *value, gfc_expr **expr)
421 m = gfc_match_expr (expr);
425 p = gfc_extract_int (*expr, &i);
438 /* Matches a statement label. Uses gfc_match_small_literal_int() to
439 do most of the work. */
442 gfc_match_st_label (gfc_st_label **label)
448 old_loc = gfc_current_locus;
450 m = gfc_match_small_literal_int (&i, &cnt);
456 gfc_error ("Too many digits in statement label at %C");
462 gfc_error ("Statement label at %C is zero");
466 *label = gfc_get_st_label (i);
471 gfc_current_locus = old_loc;
476 /* Match and validate a label associated with a named IF, DO or SELECT
477 statement. If the symbol does not have the label attribute, we add
478 it. We also make sure the symbol does not refer to another
479 (active) block. A matched label is pointed to by gfc_new_block. */
482 gfc_match_label (void)
484 char name[GFC_MAX_SYMBOL_LEN + 1];
487 gfc_new_block = NULL;
489 m = gfc_match (" %n :", name);
493 if (gfc_get_symbol (name, NULL, &gfc_new_block))
495 gfc_error ("Label name '%s' at %C is ambiguous", name);
499 if (gfc_new_block->attr.flavor == FL_LABEL)
501 gfc_error ("Duplicate construct label '%s' at %C", name);
505 if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
506 gfc_new_block->name, NULL) == FAILURE)
513 /* See if the current input looks like a name of some sort. Modifies
514 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
515 Note that options.c restricts max_identifier_length to not more
516 than GFC_MAX_SYMBOL_LEN. */
519 gfc_match_name (char *buffer)
525 old_loc = gfc_current_locus;
526 gfc_gobble_whitespace ();
528 c = gfc_next_ascii_char ();
529 if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore)))
531 if (gfc_error_flag_test() == 0 && c != '(')
532 gfc_error ("Invalid character in name at %C");
533 gfc_current_locus = old_loc;
543 if (i > gfc_option.max_identifier_length)
545 gfc_error ("Name at %C is too long");
549 old_loc = gfc_current_locus;
550 c = gfc_next_ascii_char ();
552 while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));
554 if (c == '$' && !gfc_option.flag_dollar_ok)
556 gfc_error ("Invalid character '$' at %C. Use -fdollar-ok to allow it "
562 gfc_current_locus = old_loc;
568 /* Match a valid name for C, which is almost the same as for Fortran,
569 except that you can start with an underscore, etc.. It could have
570 been done by modifying the gfc_match_name, but this way other
571 things C allows can be added, such as no limits on the length.
572 Right now, the length is limited to the same thing as Fortran..
573 Also, by rewriting it, we use the gfc_next_char_C() to prevent the
574 input characters from being automatically lower cased, since C is
575 case sensitive. The parameter, buffer, is used to return the name
576 that is matched. Return MATCH_ERROR if the name is too long
577 (though this is a self-imposed limit), MATCH_NO if what we're
578 seeing isn't a name, and MATCH_YES if we successfully match a C
582 gfc_match_name_C (char *buffer)
588 old_loc = gfc_current_locus;
589 gfc_gobble_whitespace ();
591 /* Get the next char (first possible char of name) and see if
592 it's valid for C (either a letter or an underscore). */
593 c = gfc_next_char_literal (1);
595 /* If the user put nothing expect spaces between the quotes, it is valid
596 and simply means there is no name= specifier and the name is the fortran
597 symbol name, all lowercase. */
598 if (c == '"' || c == '\'')
601 gfc_current_locus = old_loc;
605 if (!ISALPHA (c) && c != '_')
607 gfc_error ("Invalid C name in NAME= specifier at %C");
611 /* Continue to read valid variable name characters. */
614 gcc_assert (gfc_wide_fits_in_byte (c));
616 buffer[i++] = (unsigned char) c;
618 /* C does not define a maximum length of variable names, to my
619 knowledge, but the compiler typically places a limit on them.
620 For now, i'll use the same as the fortran limit for simplicity,
621 but this may need to be changed to a dynamic buffer that can
622 be realloc'ed here if necessary, or more likely, a larger
624 if (i > gfc_option.max_identifier_length)
626 gfc_error ("Name at %C is too long");
630 old_loc = gfc_current_locus;
632 /* Get next char; param means we're in a string. */
633 c = gfc_next_char_literal (1);
634 } while (ISALNUM (c) || c == '_');
637 gfc_current_locus = old_loc;
639 /* See if we stopped because of whitespace. */
642 gfc_gobble_whitespace ();
643 c = gfc_peek_ascii_char ();
644 if (c != '"' && c != '\'')
646 gfc_error ("Embedded space in NAME= specifier at %C");
651 /* If we stopped because we had an invalid character for a C name, report
652 that to the user by returning MATCH_NO. */
653 if (c != '"' && c != '\'')
655 gfc_error ("Invalid C name in NAME= specifier at %C");
663 /* Match a symbol on the input. Modifies the pointer to the symbol
664 pointer if successful. */
667 gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
669 char buffer[GFC_MAX_SYMBOL_LEN + 1];
672 m = gfc_match_name (buffer);
677 return (gfc_get_ha_sym_tree (buffer, matched_symbol))
678 ? MATCH_ERROR : MATCH_YES;
680 if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false))
688 gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
693 m = gfc_match_sym_tree (&st, host_assoc);
698 *matched_symbol = st->n.sym;
700 *matched_symbol = NULL;
703 *matched_symbol = NULL;
708 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
709 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
713 gfc_match_intrinsic_op (gfc_intrinsic_op *result)
715 locus orig_loc = gfc_current_locus;
718 gfc_gobble_whitespace ();
719 ch = gfc_next_ascii_char ();
724 *result = INTRINSIC_PLUS;
729 *result = INTRINSIC_MINUS;
733 if (gfc_next_ascii_char () == '=')
736 *result = INTRINSIC_EQ;
742 if (gfc_peek_ascii_char () == '=')
745 gfc_next_ascii_char ();
746 *result = INTRINSIC_LE;
750 *result = INTRINSIC_LT;
754 if (gfc_peek_ascii_char () == '=')
757 gfc_next_ascii_char ();
758 *result = INTRINSIC_GE;
762 *result = INTRINSIC_GT;
766 if (gfc_peek_ascii_char () == '*')
769 gfc_next_ascii_char ();
770 *result = INTRINSIC_POWER;
774 *result = INTRINSIC_TIMES;
778 ch = gfc_peek_ascii_char ();
782 gfc_next_ascii_char ();
783 *result = INTRINSIC_NE;
789 gfc_next_ascii_char ();
790 *result = INTRINSIC_CONCAT;
794 *result = INTRINSIC_DIVIDE;
798 ch = gfc_next_ascii_char ();
802 if (gfc_next_ascii_char () == 'n'
803 && gfc_next_ascii_char () == 'd'
804 && gfc_next_ascii_char () == '.')
806 /* Matched ".and.". */
807 *result = INTRINSIC_AND;
813 if (gfc_next_ascii_char () == 'q')
815 ch = gfc_next_ascii_char ();
818 /* Matched ".eq.". */
819 *result = INTRINSIC_EQ_OS;
824 if (gfc_next_ascii_char () == '.')
826 /* Matched ".eqv.". */
827 *result = INTRINSIC_EQV;
835 ch = gfc_next_ascii_char ();
838 if (gfc_next_ascii_char () == '.')
840 /* Matched ".ge.". */
841 *result = INTRINSIC_GE_OS;
847 if (gfc_next_ascii_char () == '.')
849 /* Matched ".gt.". */
850 *result = INTRINSIC_GT_OS;
857 ch = gfc_next_ascii_char ();
860 if (gfc_next_ascii_char () == '.')
862 /* Matched ".le.". */
863 *result = INTRINSIC_LE_OS;
869 if (gfc_next_ascii_char () == '.')
871 /* Matched ".lt.". */
872 *result = INTRINSIC_LT_OS;
879 ch = gfc_next_ascii_char ();
882 ch = gfc_next_ascii_char ();
885 /* Matched ".ne.". */
886 *result = INTRINSIC_NE_OS;
891 if (gfc_next_ascii_char () == 'v'
892 && gfc_next_ascii_char () == '.')
894 /* Matched ".neqv.". */
895 *result = INTRINSIC_NEQV;
902 if (gfc_next_ascii_char () == 't'
903 && gfc_next_ascii_char () == '.')
905 /* Matched ".not.". */
906 *result = INTRINSIC_NOT;
913 if (gfc_next_ascii_char () == 'r'
914 && gfc_next_ascii_char () == '.')
916 /* Matched ".or.". */
917 *result = INTRINSIC_OR;
931 gfc_current_locus = orig_loc;
936 /* Match a loop control phrase:
938 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
940 If the final integer expression is not present, a constant unity
941 expression is returned. We don't return MATCH_ERROR until after
942 the equals sign is seen. */
945 gfc_match_iterator (gfc_iterator *iter, int init_flag)
947 char name[GFC_MAX_SYMBOL_LEN + 1];
948 gfc_expr *var, *e1, *e2, *e3;
954 /* Match the start of an iterator without affecting the symbol table. */
956 start = gfc_current_locus;
957 m = gfc_match (" %n =", name);
958 gfc_current_locus = start;
963 m = gfc_match_variable (&var, 0);
967 /* F2008, C617 & C565. */
968 if (var->symtree->n.sym->attr.codimension)
970 gfc_error ("Loop variable at %C cannot be a coarray");
974 if (var->ref != NULL)
976 gfc_error ("Loop variable at %C cannot be a sub-component");
980 if (var->symtree->n.sym->attr.intent == INTENT_IN)
982 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
983 var->symtree->n.sym->name);
987 gfc_match_char ('=');
989 var->symtree->n.sym->attr.implied_index = 1;
991 m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
994 if (m == MATCH_ERROR)
997 if (gfc_match_char (',') != MATCH_YES)
1000 m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
1003 if (m == MATCH_ERROR)
1006 if (gfc_match_char (',') != MATCH_YES)
1008 e3 = gfc_int_expr (1);
1012 m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
1013 if (m == MATCH_ERROR)
1017 gfc_error ("Expected a step value in iterator at %C");
1029 gfc_error ("Syntax error in iterator at %C");
1040 /* Tries to match the next non-whitespace character on the input.
1041 This subroutine does not return MATCH_ERROR. */
1044 gfc_match_char (char c)
1048 where = gfc_current_locus;
1049 gfc_gobble_whitespace ();
1051 if (gfc_next_ascii_char () == c)
1054 gfc_current_locus = where;
1059 /* General purpose matching subroutine. The target string is a
1060 scanf-like format string in which spaces correspond to arbitrary
1061 whitespace (including no whitespace), characters correspond to
1062 themselves. The %-codes are:
1064 %% Literal percent sign
1065 %e Expression, pointer to a pointer is set
1066 %s Symbol, pointer to the symbol is set
1067 %n Name, character buffer is set to name
1068 %t Matches end of statement.
1069 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1070 %l Matches a statement label
1071 %v Matches a variable expression (an lvalue)
1072 % Matches a required space (in free form) and optional spaces. */
1075 gfc_match (const char *target, ...)
1077 gfc_st_label **label;
1086 old_loc = gfc_current_locus;
1087 va_start (argp, target);
1097 gfc_gobble_whitespace ();
1108 vp = va_arg (argp, void **);
1109 n = gfc_match_expr ((gfc_expr **) vp);
1120 vp = va_arg (argp, void **);
1121 n = gfc_match_variable ((gfc_expr **) vp, 0);
1132 vp = va_arg (argp, void **);
1133 n = gfc_match_symbol ((gfc_symbol **) vp, 0);
1144 np = va_arg (argp, char *);
1145 n = gfc_match_name (np);
1156 label = va_arg (argp, gfc_st_label **);
1157 n = gfc_match_st_label (label);
1168 ip = va_arg (argp, int *);
1169 n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
1180 if (gfc_match_eos () != MATCH_YES)
1188 if (gfc_match_space () == MATCH_YES)
1194 break; /* Fall through to character matcher. */
1197 gfc_internal_error ("gfc_match(): Bad match code %c", c);
1202 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1203 expect an upper case character here! */
1204 gcc_assert (TOLOWER (c) == c);
1206 if (c == gfc_next_ascii_char ())
1216 /* Clean up after a failed match. */
1217 gfc_current_locus = old_loc;
1218 va_start (argp, target);
1221 for (; matches > 0; matches--)
1223 while (*p++ != '%');
1231 /* Matches that don't have to be undone */
1236 (void) va_arg (argp, void **);
1241 vp = va_arg (argp, void **);
1242 gfc_free_expr ((struct gfc_expr *)*vp);
1255 /*********************** Statement level matching **********************/
1257 /* Matches the start of a program unit, which is the program keyword
1258 followed by an obligatory symbol. */
1261 gfc_match_program (void)
1266 m = gfc_match ("% %s%t", &sym);
1270 gfc_error ("Invalid form of PROGRAM statement at %C");
1274 if (m == MATCH_ERROR)
1277 if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
1280 gfc_new_block = sym;
1286 /* Match a simple assignment statement. */
1289 gfc_match_assignment (void)
1291 gfc_expr *lvalue, *rvalue;
1295 old_loc = gfc_current_locus;
1298 m = gfc_match (" %v =", &lvalue);
1301 gfc_current_locus = old_loc;
1302 gfc_free_expr (lvalue);
1307 m = gfc_match (" %e%t", &rvalue);
1310 gfc_current_locus = old_loc;
1311 gfc_free_expr (lvalue);
1312 gfc_free_expr (rvalue);
1316 gfc_set_sym_referenced (lvalue->symtree->n.sym);
1318 new_st.op = EXEC_ASSIGN;
1319 new_st.expr1 = lvalue;
1320 new_st.expr2 = rvalue;
1322 gfc_check_do_variable (lvalue->symtree);
1328 /* Match a pointer assignment statement. */
1331 gfc_match_pointer_assignment (void)
1333 gfc_expr *lvalue, *rvalue;
1337 old_loc = gfc_current_locus;
1339 lvalue = rvalue = NULL;
1340 gfc_matching_procptr_assignment = 0;
1342 m = gfc_match (" %v =>", &lvalue);
1349 if (lvalue->symtree->n.sym->attr.proc_pointer
1350 || gfc_is_proc_ptr_comp (lvalue, NULL))
1351 gfc_matching_procptr_assignment = 1;
1353 m = gfc_match (" %e%t", &rvalue);
1354 gfc_matching_procptr_assignment = 0;
1358 new_st.op = EXEC_POINTER_ASSIGN;
1359 new_st.expr1 = lvalue;
1360 new_st.expr2 = rvalue;
1365 gfc_current_locus = old_loc;
1366 gfc_free_expr (lvalue);
1367 gfc_free_expr (rvalue);
1372 /* We try to match an easy arithmetic IF statement. This only happens
1373 when just after having encountered a simple IF statement. This code
1374 is really duplicate with parts of the gfc_match_if code, but this is
1378 match_arithmetic_if (void)
1380 gfc_st_label *l1, *l2, *l3;
1384 m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
1388 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1389 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1390 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1392 gfc_free_expr (expr);
1396 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF "
1397 "statement at %C") == FAILURE)
1400 new_st.op = EXEC_ARITHMETIC_IF;
1401 new_st.expr1 = expr;
1410 /* The IF statement is a bit of a pain. First of all, there are three
1411 forms of it, the simple IF, the IF that starts a block and the
1414 There is a problem with the simple IF and that is the fact that we
1415 only have a single level of undo information on symbols. What this
1416 means is for a simple IF, we must re-match the whole IF statement
1417 multiple times in order to guarantee that the symbol table ends up
1418 in the proper state. */
1420 static match match_simple_forall (void);
1421 static match match_simple_where (void);
1424 gfc_match_if (gfc_statement *if_type)
1427 gfc_st_label *l1, *l2, *l3;
1428 locus old_loc, old_loc2;
1432 n = gfc_match_label ();
1433 if (n == MATCH_ERROR)
1436 old_loc = gfc_current_locus;
1438 m = gfc_match (" if ( %e", &expr);
1442 old_loc2 = gfc_current_locus;
1443 gfc_current_locus = old_loc;
1445 if (gfc_match_parens () == MATCH_ERROR)
1448 gfc_current_locus = old_loc2;
1450 if (gfc_match_char (')') != MATCH_YES)
1452 gfc_error ("Syntax error in IF-expression at %C");
1453 gfc_free_expr (expr);
1457 m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
1463 gfc_error ("Block label not appropriate for arithmetic IF "
1465 gfc_free_expr (expr);
1469 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1470 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1471 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1473 gfc_free_expr (expr);
1477 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF "
1478 "statement at %C") == FAILURE)
1481 new_st.op = EXEC_ARITHMETIC_IF;
1482 new_st.expr1 = expr;
1487 *if_type = ST_ARITHMETIC_IF;
1491 if (gfc_match (" then%t") == MATCH_YES)
1493 new_st.op = EXEC_IF;
1494 new_st.expr1 = expr;
1495 *if_type = ST_IF_BLOCK;
1501 gfc_error ("Block label is not appropriate for IF statement at %C");
1502 gfc_free_expr (expr);
1506 /* At this point the only thing left is a simple IF statement. At
1507 this point, n has to be MATCH_NO, so we don't have to worry about
1508 re-matching a block label. From what we've got so far, try
1509 matching an assignment. */
1511 *if_type = ST_SIMPLE_IF;
1513 m = gfc_match_assignment ();
1517 gfc_free_expr (expr);
1518 gfc_undo_symbols ();
1519 gfc_current_locus = old_loc;
1521 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1522 assignment was found. For MATCH_NO, continue to call the various
1524 if (m == MATCH_ERROR)
1527 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
1529 m = gfc_match_pointer_assignment ();
1533 gfc_free_expr (expr);
1534 gfc_undo_symbols ();
1535 gfc_current_locus = old_loc;
1537 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
1539 /* Look at the next keyword to see which matcher to call. Matching
1540 the keyword doesn't affect the symbol table, so we don't have to
1541 restore between tries. */
1543 #define match(string, subr, statement) \
1544 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1548 match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1549 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1550 match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1551 match ("call", gfc_match_call, ST_CALL)
1552 match ("close", gfc_match_close, ST_CLOSE)
1553 match ("continue", gfc_match_continue, ST_CONTINUE)
1554 match ("cycle", gfc_match_cycle, ST_CYCLE)
1555 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1556 match ("end file", gfc_match_endfile, ST_END_FILE)
1557 match ("error stop", gfc_match_error_stop, ST_ERROR_STOP)
1558 match ("exit", gfc_match_exit, ST_EXIT)
1559 match ("flush", gfc_match_flush, ST_FLUSH)
1560 match ("forall", match_simple_forall, ST_FORALL)
1561 match ("go to", gfc_match_goto, ST_GOTO)
1562 match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1563 match ("inquire", gfc_match_inquire, ST_INQUIRE)
1564 match ("nullify", gfc_match_nullify, ST_NULLIFY)
1565 match ("open", gfc_match_open, ST_OPEN)
1566 match ("pause", gfc_match_pause, ST_NONE)
1567 match ("print", gfc_match_print, ST_WRITE)
1568 match ("read", gfc_match_read, ST_READ)
1569 match ("return", gfc_match_return, ST_RETURN)
1570 match ("rewind", gfc_match_rewind, ST_REWIND)
1571 match ("stop", gfc_match_stop, ST_STOP)
1572 match ("wait", gfc_match_wait, ST_WAIT)
1573 match ("sync all", gfc_match_sync_all, ST_SYNC_CALL);
1574 match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
1575 match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
1576 match ("where", match_simple_where, ST_WHERE)
1577 match ("write", gfc_match_write, ST_WRITE)
1579 /* The gfc_match_assignment() above may have returned a MATCH_NO
1580 where the assignment was to a named constant. Check that
1581 special case here. */
1582 m = gfc_match_assignment ();
1585 gfc_error ("Cannot assign to a named constant at %C");
1586 gfc_free_expr (expr);
1587 gfc_undo_symbols ();
1588 gfc_current_locus = old_loc;
1592 /* All else has failed, so give up. See if any of the matchers has
1593 stored an error message of some sort. */
1594 if (gfc_error_check () == 0)
1595 gfc_error ("Unclassifiable statement in IF-clause at %C");
1597 gfc_free_expr (expr);
1602 gfc_error ("Syntax error in IF-clause at %C");
1605 gfc_free_expr (expr);
1609 /* At this point, we've matched the single IF and the action clause
1610 is in new_st. Rearrange things so that the IF statement appears
1613 p = gfc_get_code ();
1614 p->next = gfc_get_code ();
1616 p->next->loc = gfc_current_locus;
1621 gfc_clear_new_st ();
1623 new_st.op = EXEC_IF;
1632 /* Match an ELSE statement. */
1635 gfc_match_else (void)
1637 char name[GFC_MAX_SYMBOL_LEN + 1];
1639 if (gfc_match_eos () == MATCH_YES)
1642 if (gfc_match_name (name) != MATCH_YES
1643 || gfc_current_block () == NULL
1644 || gfc_match_eos () != MATCH_YES)
1646 gfc_error ("Unexpected junk after ELSE statement at %C");
1650 if (strcmp (name, gfc_current_block ()->name) != 0)
1652 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1653 name, gfc_current_block ()->name);
1661 /* Match an ELSE IF statement. */
1664 gfc_match_elseif (void)
1666 char name[GFC_MAX_SYMBOL_LEN + 1];
1670 m = gfc_match (" ( %e ) then", &expr);
1674 if (gfc_match_eos () == MATCH_YES)
1677 if (gfc_match_name (name) != MATCH_YES
1678 || gfc_current_block () == NULL
1679 || gfc_match_eos () != MATCH_YES)
1681 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1685 if (strcmp (name, gfc_current_block ()->name) != 0)
1687 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1688 name, gfc_current_block ()->name);
1693 new_st.op = EXEC_IF;
1694 new_st.expr1 = expr;
1698 gfc_free_expr (expr);
1703 /* Free a gfc_iterator structure. */
1706 gfc_free_iterator (gfc_iterator *iter, int flag)
1712 gfc_free_expr (iter->var);
1713 gfc_free_expr (iter->start);
1714 gfc_free_expr (iter->end);
1715 gfc_free_expr (iter->step);
1722 /* Match a CRITICAL statement. */
1724 gfc_match_critical (void)
1726 gfc_st_label *label = NULL;
1728 if (gfc_match_label () == MATCH_ERROR)
1731 if (gfc_match (" critical") != MATCH_YES)
1734 if (gfc_match_st_label (&label) == MATCH_ERROR)
1737 if (gfc_match_eos () != MATCH_YES)
1739 gfc_syntax_error (ST_CRITICAL);
1743 if (gfc_pure (NULL))
1745 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1749 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CRITICAL statement at %C")
1753 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
1755 gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
1759 if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
1761 gfc_error ("Nested CRITICAL block at %C");
1765 new_st.op = EXEC_CRITICAL;
1768 && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1775 /* Match a BLOCK statement. */
1778 gfc_match_block (void)
1782 if (gfc_match_label () == MATCH_ERROR)
1785 if (gfc_match (" block") != MATCH_YES)
1788 /* For this to be a correct BLOCK statement, the line must end now. */
1789 m = gfc_match_eos ();
1790 if (m == MATCH_ERROR)
1799 /* Match a DO statement. */
1804 gfc_iterator iter, *ip;
1806 gfc_st_label *label;
1809 old_loc = gfc_current_locus;
1812 iter.var = iter.start = iter.end = iter.step = NULL;
1814 m = gfc_match_label ();
1815 if (m == MATCH_ERROR)
1818 if (gfc_match (" do") != MATCH_YES)
1821 m = gfc_match_st_label (&label);
1822 if (m == MATCH_ERROR)
1825 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
1827 if (gfc_match_eos () == MATCH_YES)
1829 iter.end = gfc_logical_expr (1, NULL);
1830 new_st.op = EXEC_DO_WHILE;
1834 /* Match an optional comma, if no comma is found, a space is obligatory. */
1835 if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
1838 /* Check for balanced parens. */
1840 if (gfc_match_parens () == MATCH_ERROR)
1843 /* See if we have a DO WHILE. */
1844 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1846 new_st.op = EXEC_DO_WHILE;
1850 /* The abortive DO WHILE may have done something to the symbol
1851 table, so we start over. */
1852 gfc_undo_symbols ();
1853 gfc_current_locus = old_loc;
1855 gfc_match_label (); /* This won't error. */
1856 gfc_match (" do "); /* This will work. */
1858 gfc_match_st_label (&label); /* Can't error out. */
1859 gfc_match_char (','); /* Optional comma. */
1861 m = gfc_match_iterator (&iter, 0);
1864 if (m == MATCH_ERROR)
1867 iter.var->symtree->n.sym->attr.implied_index = 0;
1868 gfc_check_do_variable (iter.var->symtree);
1870 if (gfc_match_eos () != MATCH_YES)
1872 gfc_syntax_error (ST_DO);
1876 new_st.op = EXEC_DO;
1880 && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1883 new_st.label1 = label;
1885 if (new_st.op == EXEC_DO_WHILE)
1886 new_st.expr1 = iter.end;
1889 new_st.ext.iterator = ip = gfc_get_iterator ();
1896 gfc_free_iterator (&iter, 0);
1902 /* Match an EXIT or CYCLE statement. */
1905 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1907 gfc_state_data *p, *o;
1911 if (gfc_match_eos () == MATCH_YES)
1915 m = gfc_match ("% %s%t", &sym);
1916 if (m == MATCH_ERROR)
1920 gfc_syntax_error (st);
1924 if (sym->attr.flavor != FL_LABEL)
1926 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1927 sym->name, gfc_ascii_statement (st));
1932 /* Find the loop mentioned specified by the label (or lack of a label). */
1933 for (o = NULL, p = gfc_state_stack; p; p = p->previous)
1934 if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1936 else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
1938 else if (p->state == COMP_CRITICAL)
1940 gfc_error("%s statement at %C leaves CRITICAL construct",
1941 gfc_ascii_statement (st));
1948 gfc_error ("%s statement at %C is not within a loop",
1949 gfc_ascii_statement (st));
1951 gfc_error ("%s statement at %C is not within loop '%s'",
1952 gfc_ascii_statement (st), sym->name);
1959 gfc_error ("%s statement at %C leaving OpenMP structured block",
1960 gfc_ascii_statement (st));
1963 else if (st == ST_EXIT
1964 && p->previous != NULL
1965 && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
1966 && (p->previous->head->op == EXEC_OMP_DO
1967 || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
1969 gcc_assert (p->previous->head->next != NULL);
1970 gcc_assert (p->previous->head->next->op == EXEC_DO
1971 || p->previous->head->next->op == EXEC_DO_WHILE);
1972 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1976 /* Save the first statement in the loop - needed by the backend. */
1977 new_st.ext.whichloop = p->head;
1985 /* Match the EXIT statement. */
1988 gfc_match_exit (void)
1990 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1994 /* Match the CYCLE statement. */
1997 gfc_match_cycle (void)
1999 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
2003 /* Match a number or character constant after an (ALL) STOP or PAUSE statement. */
2006 gfc_match_stopcode (gfc_statement st)
2016 if (gfc_match_eos () != MATCH_YES)
2018 m = gfc_match_small_literal_int (&stop_code, &cnt);
2019 if (m == MATCH_ERROR)
2022 if (m == MATCH_YES && cnt > 5)
2024 gfc_error ("Too many digits in STOP code at %C");
2030 /* Try a character constant. */
2031 m = gfc_match_expr (&e);
2032 if (m == MATCH_ERROR)
2036 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
2040 if (gfc_match_eos () != MATCH_YES)
2044 if (gfc_pure (NULL))
2046 gfc_error ("%s statement not allowed in PURE procedure at %C",
2047 gfc_ascii_statement (st));
2051 if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
2053 gfc_error ("Image control statement STOP at %C in CRITICAL block");
2060 new_st.op = EXEC_STOP;
2063 new_st.op = EXEC_ERROR_STOP;
2066 new_st.op = EXEC_PAUSE;
2073 new_st.ext.stop_code = stop_code;
2078 gfc_syntax_error (st);
2087 /* Match the (deprecated) PAUSE statement. */
2090 gfc_match_pause (void)
2094 m = gfc_match_stopcode (ST_PAUSE);
2097 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
2106 /* Match the STOP statement. */
2109 gfc_match_stop (void)
2111 return gfc_match_stopcode (ST_STOP);
2115 /* Match the ERROR STOP statement. */
2118 gfc_match_error_stop (void)
2120 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: ERROR STOP statement at %C")
2124 return gfc_match_stopcode (ST_ERROR_STOP);
2128 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
2129 SYNC ALL [(sync-stat-list)]
2130 SYNC MEMORY [(sync-stat-list)]
2131 SYNC IMAGES (image-set [, sync-stat-list] )
2132 with sync-stat is int-expr or *. */
2135 sync_statement (gfc_statement st)
2138 gfc_expr *tmp, *imageset, *stat, *errmsg;
2139 bool saw_stat, saw_errmsg;
2141 tmp = imageset = stat = errmsg = NULL;
2142 saw_stat = saw_errmsg = false;
2144 if (gfc_pure (NULL))
2146 gfc_error ("Image control statement SYNC at %C in PURE procedure");
2150 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C")
2154 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
2156 gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2160 if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
2162 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
2166 if (gfc_match_eos () == MATCH_YES)
2168 if (st == ST_SYNC_IMAGES)
2173 if (gfc_match_char ('(') != MATCH_YES)
2176 if (st == ST_SYNC_IMAGES)
2178 /* Denote '*' as imageset == NULL. */
2179 m = gfc_match_char ('*');
2180 if (m == MATCH_ERROR)
2184 if (gfc_match ("%e", &imageset) != MATCH_YES)
2187 m = gfc_match_char (',');
2188 if (m == MATCH_ERROR)
2192 m = gfc_match_char (')');
2201 m = gfc_match (" stat = %v", &tmp);
2202 if (m == MATCH_ERROR)
2208 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2214 if (gfc_match_char (',') == MATCH_YES)
2218 m = gfc_match (" errmsg = %v", &tmp);
2219 if (m == MATCH_ERROR)
2225 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2231 if (gfc_match_char (',') == MATCH_YES)
2235 gfc_gobble_whitespace ();
2237 if (gfc_peek_char () == ')')
2243 if (gfc_match (" )%t") != MATCH_YES)
2250 new_st.op = EXEC_SYNC_ALL;
2252 case ST_SYNC_IMAGES:
2253 new_st.op = EXEC_SYNC_IMAGES;
2255 case ST_SYNC_MEMORY:
2256 new_st.op = EXEC_SYNC_MEMORY;
2262 new_st.expr1 = imageset;
2263 new_st.expr2 = stat;
2264 new_st.expr3 = errmsg;
2269 gfc_syntax_error (st);
2272 gfc_free_expr (tmp);
2273 gfc_free_expr (imageset);
2274 gfc_free_expr (stat);
2275 gfc_free_expr (errmsg);
2281 /* Match SYNC ALL statement. */
2284 gfc_match_sync_all (void)
2286 return sync_statement (ST_SYNC_ALL);
2290 /* Match SYNC IMAGES statement. */
2293 gfc_match_sync_images (void)
2295 return sync_statement (ST_SYNC_IMAGES);
2299 /* Match SYNC MEMORY statement. */
2302 gfc_match_sync_memory (void)
2304 return sync_statement (ST_SYNC_MEMORY);
2308 /* Match a CONTINUE statement. */
2311 gfc_match_continue (void)
2313 if (gfc_match_eos () != MATCH_YES)
2315 gfc_syntax_error (ST_CONTINUE);
2319 new_st.op = EXEC_CONTINUE;
2324 /* Match the (deprecated) ASSIGN statement. */
2327 gfc_match_assign (void)
2330 gfc_st_label *label;
2332 if (gfc_match (" %l", &label) == MATCH_YES)
2334 if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
2336 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
2338 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
2343 expr->symtree->n.sym->attr.assign = 1;
2345 new_st.op = EXEC_LABEL_ASSIGN;
2346 new_st.label1 = label;
2347 new_st.expr1 = expr;
2355 /* Match the GO TO statement. As a computed GOTO statement is
2356 matched, it is transformed into an equivalent SELECT block. No
2357 tree is necessary, and the resulting jumps-to-jumps are
2358 specifically optimized away by the back end. */
2361 gfc_match_goto (void)
2363 gfc_code *head, *tail;
2366 gfc_st_label *label;
2370 if (gfc_match (" %l%t", &label) == MATCH_YES)
2372 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2375 new_st.op = EXEC_GOTO;
2376 new_st.label1 = label;
2380 /* The assigned GO TO statement. */
2382 if (gfc_match_variable (&expr, 0) == MATCH_YES)
2384 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
2389 new_st.op = EXEC_GOTO;
2390 new_st.expr1 = expr;
2392 if (gfc_match_eos () == MATCH_YES)
2395 /* Match label list. */
2396 gfc_match_char (',');
2397 if (gfc_match_char ('(') != MATCH_YES)
2399 gfc_syntax_error (ST_GOTO);
2406 m = gfc_match_st_label (&label);
2410 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2414 head = tail = gfc_get_code ();
2417 tail->block = gfc_get_code ();
2421 tail->label1 = label;
2422 tail->op = EXEC_GOTO;
2424 while (gfc_match_char (',') == MATCH_YES);
2426 if (gfc_match (")%t") != MATCH_YES)
2431 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2434 new_st.block = head;
2439 /* Last chance is a computed GO TO statement. */
2440 if (gfc_match_char ('(') != MATCH_YES)
2442 gfc_syntax_error (ST_GOTO);
2451 m = gfc_match_st_label (&label);
2455 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2459 head = tail = gfc_get_code ();
2462 tail->block = gfc_get_code ();
2466 cp = gfc_get_case ();
2467 cp->low = cp->high = gfc_int_expr (i++);
2469 tail->op = EXEC_SELECT;
2470 tail->ext.case_list = cp;
2472 tail->next = gfc_get_code ();
2473 tail->next->op = EXEC_GOTO;
2474 tail->next->label1 = label;
2476 while (gfc_match_char (',') == MATCH_YES);
2478 if (gfc_match_char (')') != MATCH_YES)
2483 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2487 /* Get the rest of the statement. */
2488 gfc_match_char (',');
2490 if (gfc_match (" %e%t", &expr) != MATCH_YES)
2493 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Computed GOTO "
2494 "at %C") == FAILURE)
2497 /* At this point, a computed GOTO has been fully matched and an
2498 equivalent SELECT statement constructed. */
2500 new_st.op = EXEC_SELECT;
2501 new_st.expr1 = NULL;
2503 /* Hack: For a "real" SELECT, the expression is in expr. We put
2504 it in expr2 so we can distinguish then and produce the correct
2506 new_st.expr2 = expr;
2507 new_st.block = head;
2511 gfc_syntax_error (ST_GOTO);
2513 gfc_free_statements (head);
2518 /* Frees a list of gfc_alloc structures. */
2521 gfc_free_alloc_list (gfc_alloc *p)
2528 gfc_free_expr (p->expr);
2534 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
2535 an accessible derived type. */
2538 match_derived_type_spec (gfc_typespec *ts)
2541 gfc_symbol *derived;
2543 old_locus = gfc_current_locus;
2545 if (gfc_match_symbol (&derived, 1) == MATCH_YES)
2547 if (derived->attr.flavor == FL_DERIVED)
2549 ts->type = BT_DERIVED;
2550 ts->u.derived = derived;
2555 /* Enforce F03:C476. */
2556 gfc_error ("'%s' at %L is not an accessible derived type",
2557 derived->name, &gfc_current_locus);
2562 gfc_current_locus = old_locus;
2567 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2568 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2569 It only includes the intrinsic types from the Fortran 2003 standard
2570 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2571 the implicit_flag is not needed, so it was removed. Derived types are
2572 identified by their name alone. */
2575 match_type_spec (gfc_typespec *ts)
2581 old_locus = gfc_current_locus;
2583 if (gfc_match ("integer") == MATCH_YES)
2585 ts->type = BT_INTEGER;
2586 ts->kind = gfc_default_integer_kind;
2590 if (gfc_match ("real") == MATCH_YES)
2593 ts->kind = gfc_default_real_kind;
2597 if (gfc_match ("double precision") == MATCH_YES)
2600 ts->kind = gfc_default_double_kind;
2604 if (gfc_match ("complex") == MATCH_YES)
2606 ts->type = BT_COMPLEX;
2607 ts->kind = gfc_default_complex_kind;
2611 if (gfc_match ("character") == MATCH_YES)
2613 ts->type = BT_CHARACTER;
2617 if (gfc_match ("logical") == MATCH_YES)
2619 ts->type = BT_LOGICAL;
2620 ts->kind = gfc_default_logical_kind;
2624 m = match_derived_type_spec (ts);
2627 old_locus = gfc_current_locus;
2628 if (gfc_match (" :: ") != MATCH_YES)
2630 gfc_current_locus = old_locus;
2631 /* Enfore F03:C401. */
2632 if (ts->u.derived->attr.abstract)
2634 gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
2635 ts->u.derived->name, &old_locus);
2640 else if (m == MATCH_ERROR && gfc_match (" :: ") == MATCH_YES)
2643 /* If a type is not matched, simply return MATCH_NO. */
2644 gfc_current_locus = old_locus;
2649 gfc_gobble_whitespace ();
2650 if (gfc_peek_ascii_char () == '*')
2652 gfc_error ("Invalid type-spec at %C");
2656 m = gfc_match_kind_spec (ts, false);
2659 m = MATCH_YES; /* No kind specifier found. */
2665 m = gfc_match_char_spec (ts);
2668 m = MATCH_YES; /* No kind specifier found. */
2674 /* Match an ALLOCATE statement. */
2677 gfc_match_allocate (void)
2679 gfc_alloc *head, *tail;
2680 gfc_expr *stat, *errmsg, *tmp, *source;
2685 bool saw_stat, saw_errmsg, saw_source, b1, b2, b3;
2688 stat = errmsg = source = tmp = NULL;
2689 saw_stat = saw_errmsg = saw_source = false;
2691 if (gfc_match_char ('(') != MATCH_YES)
2694 /* Match an optional type-spec. */
2695 old_locus = gfc_current_locus;
2696 m = match_type_spec (&ts);
2697 if (m == MATCH_ERROR)
2699 else if (m == MATCH_NO)
2700 ts.type = BT_UNKNOWN;
2703 if (gfc_match (" :: ") == MATCH_YES)
2705 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
2706 "ALLOCATE at %L", &old_locus) == FAILURE)
2711 ts.type = BT_UNKNOWN;
2712 gfc_current_locus = old_locus;
2719 head = tail = gfc_get_alloc ();
2722 tail->next = gfc_get_alloc ();
2726 m = gfc_match_variable (&tail->expr, 0);
2729 if (m == MATCH_ERROR)
2732 if (gfc_check_do_variable (tail->expr->symtree))
2735 if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
2737 gfc_error ("Bad allocate-object at %C for a PURE procedure");
2741 /* The ALLOCATE statement had an optional typespec. Check the
2743 if (ts.type != BT_UNKNOWN)
2745 /* Enforce F03:C624. */
2746 if (!gfc_type_compatible (&tail->expr->ts, &ts))
2748 gfc_error ("Type of entity at %L is type incompatible with "
2749 "typespec", &tail->expr->where);
2753 /* Enforce F03:C627. */
2754 if (ts.kind != tail->expr->ts.kind)
2756 gfc_error ("Kind type parameter for entity at %L differs from "
2757 "the kind type parameter of the typespec",
2758 &tail->expr->where);
2763 if (tail->expr->ts.type == BT_DERIVED)
2764 tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
2766 /* FIXME: disable the checking on derived types and arrays. */
2767 sym = tail->expr->symtree->n.sym;
2768 b1 = !(tail->expr->ref
2769 && (tail->expr->ref->type == REF_COMPONENT
2770 || tail->expr->ref->type == REF_ARRAY));
2771 if (sym && sym->ts.type == BT_CLASS)
2772 b2 = !(sym->ts.u.derived->components->attr.allocatable
2773 || sym->ts.u.derived->components->attr.pointer);
2775 b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
2776 || sym->attr.proc_pointer);
2777 b3 = sym && sym->ns && sym->ns->proc_name
2778 && (sym->ns->proc_name->attr.allocatable
2779 || sym->ns->proc_name->attr.pointer
2780 || sym->ns->proc_name->attr.proc_pointer);
2781 if (b1 && b2 && !b3)
2783 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2784 "or an allocatable variable");
2788 if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
2790 gfc_error ("Shape specification for allocatable scalar at %C");
2794 if (gfc_match_char (',') != MATCH_YES)
2799 m = gfc_match (" stat = %v", &tmp);
2800 if (m == MATCH_ERROR)
2807 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2814 if (gfc_check_do_variable (stat->symtree))
2817 if (gfc_match_char (',') == MATCH_YES)
2818 goto alloc_opt_list;
2821 m = gfc_match (" errmsg = %v", &tmp);
2822 if (m == MATCH_ERROR)
2826 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L",
2827 &tmp->where) == FAILURE)
2833 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2840 if (gfc_match_char (',') == MATCH_YES)
2841 goto alloc_opt_list;
2844 m = gfc_match (" source = %e", &tmp);
2845 if (m == MATCH_ERROR)
2849 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L",
2850 &tmp->where) == FAILURE)
2856 gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
2860 /* The next 2 conditionals check C631. */
2861 if (ts.type != BT_UNKNOWN)
2863 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
2864 &tmp->where, &old_locus);
2870 gfc_error ("SOURCE tag at %L requires only a single entity in "
2871 "the allocation-list", &tmp->where);
2878 if (gfc_match_char (',') == MATCH_YES)
2879 goto alloc_opt_list;
2882 gfc_gobble_whitespace ();
2884 if (gfc_peek_char () == ')')
2889 if (gfc_match (" )%t") != MATCH_YES)
2892 new_st.op = EXEC_ALLOCATE;
2893 new_st.expr1 = stat;
2894 new_st.expr2 = errmsg;
2895 new_st.expr3 = source;
2896 new_st.ext.alloc.list = head;
2897 new_st.ext.alloc.ts = ts;
2902 gfc_syntax_error (ST_ALLOCATE);
2905 gfc_free_expr (errmsg);
2906 gfc_free_expr (source);
2907 gfc_free_expr (stat);
2908 gfc_free_expr (tmp);
2909 gfc_free_alloc_list (head);
2914 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
2915 a set of pointer assignments to intrinsic NULL(). */
2918 gfc_match_nullify (void)
2926 if (gfc_match_char ('(') != MATCH_YES)
2931 m = gfc_match_variable (&p, 0);
2932 if (m == MATCH_ERROR)
2937 if (gfc_check_do_variable (p->symtree))
2940 if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
2942 gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
2946 /* build ' => NULL() '. */
2947 e = gfc_get_expr ();
2948 e->where = gfc_current_locus;
2949 e->expr_type = EXPR_NULL;
2950 e->ts.type = BT_UNKNOWN;
2952 /* Chain to list. */
2957 tail->next = gfc_get_code ();
2961 tail->op = EXEC_POINTER_ASSIGN;
2965 if (gfc_match (" )%t") == MATCH_YES)
2967 if (gfc_match_char (',') != MATCH_YES)
2974 gfc_syntax_error (ST_NULLIFY);
2977 gfc_free_statements (new_st.next);
2979 gfc_free_expr (new_st.expr1);
2980 new_st.expr1 = NULL;
2981 gfc_free_expr (new_st.expr2);
2982 new_st.expr2 = NULL;
2987 /* Match a DEALLOCATE statement. */
2990 gfc_match_deallocate (void)
2992 gfc_alloc *head, *tail;
2993 gfc_expr *stat, *errmsg, *tmp;
2996 bool saw_stat, saw_errmsg, b1, b2;
2999 stat = errmsg = tmp = NULL;
3000 saw_stat = saw_errmsg = false;
3002 if (gfc_match_char ('(') != MATCH_YES)
3008 head = tail = gfc_get_alloc ();
3011 tail->next = gfc_get_alloc ();
3015 m = gfc_match_variable (&tail->expr, 0);
3016 if (m == MATCH_ERROR)
3021 if (gfc_check_do_variable (tail->expr->symtree))
3024 sym = tail->expr->symtree->n.sym;
3026 if (gfc_pure (NULL) && gfc_impure_variable (sym))
3028 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3032 /* FIXME: disable the checking on derived types. */
3033 b1 = !(tail->expr->ref
3034 && (tail->expr->ref->type == REF_COMPONENT
3035 || tail->expr->ref->type == REF_ARRAY));
3036 if (sym && sym->ts.type == BT_CLASS)
3037 b2 = !(sym->ts.u.derived->components->attr.allocatable
3038 || sym->ts.u.derived->components->attr.pointer);
3040 b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
3041 || sym->attr.proc_pointer);
3044 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3045 "or an allocatable variable");
3049 if (gfc_match_char (',') != MATCH_YES)
3054 m = gfc_match (" stat = %v", &tmp);
3055 if (m == MATCH_ERROR)
3061 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3062 gfc_free_expr (tmp);
3069 if (gfc_check_do_variable (stat->symtree))
3072 if (gfc_match_char (',') == MATCH_YES)
3073 goto dealloc_opt_list;
3076 m = gfc_match (" errmsg = %v", &tmp);
3077 if (m == MATCH_ERROR)
3081 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
3082 &tmp->where) == FAILURE)
3087 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3088 gfc_free_expr (tmp);
3095 if (gfc_match_char (',') == MATCH_YES)
3096 goto dealloc_opt_list;
3099 gfc_gobble_whitespace ();
3101 if (gfc_peek_char () == ')')
3105 if (gfc_match (" )%t") != MATCH_YES)
3108 new_st.op = EXEC_DEALLOCATE;
3109 new_st.expr1 = stat;
3110 new_st.expr2 = errmsg;
3111 new_st.ext.alloc.list = head;
3116 gfc_syntax_error (ST_DEALLOCATE);
3119 gfc_free_expr (errmsg);
3120 gfc_free_expr (stat);
3121 gfc_free_alloc_list (head);
3126 /* Match a RETURN statement. */
3129 gfc_match_return (void)
3133 gfc_compile_state s;
3137 if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
3139 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
3143 if (gfc_match_eos () == MATCH_YES)
3146 if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
3148 gfc_error ("Alternate RETURN statement at %C is only allowed within "
3153 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Alternate RETURN "
3154 "at %C") == FAILURE)
3157 if (gfc_current_form == FORM_FREE)
3159 /* The following are valid, so we can't require a blank after the
3163 char c = gfc_peek_ascii_char ();
3164 if (ISALPHA (c) || ISDIGIT (c))
3168 m = gfc_match (" %e%t", &e);
3171 if (m == MATCH_ERROR)
3174 gfc_syntax_error (ST_RETURN);
3181 gfc_enclosing_unit (&s);
3182 if (s == COMP_PROGRAM
3183 && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
3184 "main program at %C") == FAILURE)
3187 new_st.op = EXEC_RETURN;
3194 /* Match the call of a type-bound procedure, if CALL%var has already been
3195 matched and var found to be a derived-type variable. */
3198 match_typebound_call (gfc_symtree* varst)
3203 base = gfc_get_expr ();
3204 base->expr_type = EXPR_VARIABLE;
3205 base->symtree = varst;
3206 base->where = gfc_current_locus;
3207 gfc_set_sym_referenced (varst->n.sym);
3209 m = gfc_match_varspec (base, 0, true, true);
3211 gfc_error ("Expected component reference at %C");
3215 if (gfc_match_eos () != MATCH_YES)
3217 gfc_error ("Junk after CALL at %C");
3221 if (base->expr_type == EXPR_COMPCALL)
3222 new_st.op = EXEC_COMPCALL;
3223 else if (base->expr_type == EXPR_PPC)
3224 new_st.op = EXEC_CALL_PPC;
3227 gfc_error ("Expected type-bound procedure or procedure pointer component "
3231 new_st.expr1 = base;
3237 /* Match a CALL statement. The tricky part here are possible
3238 alternate return specifiers. We handle these by having all
3239 "subroutines" actually return an integer via a register that gives
3240 the return number. If the call specifies alternate returns, we
3241 generate code for a SELECT statement whose case clauses contain
3242 GOTOs to the various labels. */
3245 gfc_match_call (void)
3247 char name[GFC_MAX_SYMBOL_LEN + 1];
3248 gfc_actual_arglist *a, *arglist;
3258 m = gfc_match ("% %n", name);
3264 if (gfc_get_ha_sym_tree (name, &st))
3269 /* If this is a variable of derived-type, it probably starts a type-bound
3271 if ((sym->attr.flavor != FL_PROCEDURE
3272 || gfc_is_function_return_value (sym, gfc_current_ns))
3273 && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
3274 return match_typebound_call (st);
3276 /* If it does not seem to be callable (include functions so that the
3277 right association is made. They are thrown out in resolution.)
3279 if (!sym->attr.generic
3280 && !sym->attr.subroutine
3281 && !sym->attr.function)
3283 if (!(sym->attr.external && !sym->attr.referenced))
3285 /* ...create a symbol in this scope... */
3286 if (sym->ns != gfc_current_ns
3287 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
3290 if (sym != st->n.sym)
3294 /* ...and then to try to make the symbol into a subroutine. */
3295 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
3299 gfc_set_sym_referenced (sym);
3301 if (gfc_match_eos () != MATCH_YES)
3303 m = gfc_match_actual_arglist (1, &arglist);
3306 if (m == MATCH_ERROR)
3309 if (gfc_match_eos () != MATCH_YES)
3313 /* If any alternate return labels were found, construct a SELECT
3314 statement that will jump to the right place. */
3317 for (a = arglist; a; a = a->next)
3318 if (a->expr == NULL)
3323 gfc_symtree *select_st;
3324 gfc_symbol *select_sym;
3325 char name[GFC_MAX_SYMBOL_LEN + 1];
3327 new_st.next = c = gfc_get_code ();
3328 c->op = EXEC_SELECT;
3329 sprintf (name, "_result_%s", sym->name);
3330 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
3332 select_sym = select_st->n.sym;
3333 select_sym->ts.type = BT_INTEGER;
3334 select_sym->ts.kind = gfc_default_integer_kind;
3335 gfc_set_sym_referenced (select_sym);
3336 c->expr1 = gfc_get_expr ();
3337 c->expr1->expr_type = EXPR_VARIABLE;
3338 c->expr1->symtree = select_st;
3339 c->expr1->ts = select_sym->ts;
3340 c->expr1->where = gfc_current_locus;
3343 for (a = arglist; a; a = a->next)
3345 if (a->expr != NULL)
3348 if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
3353 c->block = gfc_get_code ();
3355 c->op = EXEC_SELECT;
3357 new_case = gfc_get_case ();
3358 new_case->high = new_case->low = gfc_int_expr (i);
3359 c->ext.case_list = new_case;
3361 c->next = gfc_get_code ();
3362 c->next->op = EXEC_GOTO;
3363 c->next->label1 = a->label;
3367 new_st.op = EXEC_CALL;
3368 new_st.symtree = st;
3369 new_st.ext.actual = arglist;
3374 gfc_syntax_error (ST_CALL);
3377 gfc_free_actual_arglist (arglist);
3382 /* Given a name, return a pointer to the common head structure,
3383 creating it if it does not exist. If FROM_MODULE is nonzero, we
3384 mangle the name so that it doesn't interfere with commons defined
3385 in the using namespace.
3386 TODO: Add to global symbol tree. */
3389 gfc_get_common (const char *name, int from_module)
3392 static int serial = 0;
3393 char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
3397 /* A use associated common block is only needed to correctly layout
3398 the variables it contains. */
3399 snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
3400 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
3404 st = gfc_find_symtree (gfc_current_ns->common_root, name);
3407 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
3410 if (st->n.common == NULL)
3412 st->n.common = gfc_get_common_head ();
3413 st->n.common->where = gfc_current_locus;
3414 strcpy (st->n.common->name, name);
3417 return st->n.common;
3421 /* Match a common block name. */
3423 match match_common_name (char *name)
3427 if (gfc_match_char ('/') == MATCH_NO)
3433 if (gfc_match_char ('/') == MATCH_YES)
3439 m = gfc_match_name (name);
3441 if (m == MATCH_ERROR)
3443 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
3446 gfc_error ("Syntax error in common block name at %C");
3451 /* Match a COMMON statement. */
3454 gfc_match_common (void)
3456 gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
3457 char name[GFC_MAX_SYMBOL_LEN + 1];
3464 old_blank_common = gfc_current_ns->blank_common.head;
3465 if (old_blank_common)
3467 while (old_blank_common->common_next)
3468 old_blank_common = old_blank_common->common_next;
3475 m = match_common_name (name);
3476 if (m == MATCH_ERROR)
3479 gsym = gfc_get_gsymbol (name);
3480 if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
3482 gfc_error ("Symbol '%s' at %C is already an external symbol that "
3483 "is not COMMON", name);
3487 if (gsym->type == GSYM_UNKNOWN)
3489 gsym->type = GSYM_COMMON;
3490 gsym->where = gfc_current_locus;
3496 if (name[0] == '\0')
3498 t = &gfc_current_ns->blank_common;
3499 if (t->head == NULL)
3500 t->where = gfc_current_locus;
3504 t = gfc_get_common (name, 0);
3513 while (tail->common_next)
3514 tail = tail->common_next;
3517 /* Grab the list of symbols. */
3520 m = gfc_match_symbol (&sym, 0);
3521 if (m == MATCH_ERROR)
3526 /* Store a ref to the common block for error checking. */
3527 sym->common_block = t;
3529 /* See if we know the current common block is bind(c), and if
3530 so, then see if we can check if the symbol is (which it'll
3531 need to be). This can happen if the bind(c) attr stmt was
3532 applied to the common block, and the variable(s) already
3533 defined, before declaring the common block. */
3534 if (t->is_bind_c == 1)
3536 if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
3538 /* If we find an error, just print it and continue,
3539 cause it's just semantic, and we can see if there
3541 gfc_error_now ("Variable '%s' at %L in common block '%s' "
3542 "at %C must be declared with a C "
3543 "interoperable kind since common block "
3545 sym->name, &(sym->declared_at), t->name,
3549 if (sym->attr.is_bind_c == 1)
3550 gfc_error_now ("Variable '%s' in common block "
3551 "'%s' at %C can not be bind(c) since "
3552 "it is not global", sym->name, t->name);
3555 if (sym->attr.in_common)
3557 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
3562 if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
3563 || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
3565 if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
3566 "can only be COMMON in "
3567 "BLOCK DATA", sym->name)
3572 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
3576 tail->common_next = sym;
3582 /* Deal with an optional array specification after the
3584 m = gfc_match_array_spec (&as, true, true);
3585 if (m == MATCH_ERROR)
3590 if (as->type != AS_EXPLICIT)
3592 gfc_error ("Array specification for symbol '%s' in COMMON "
3593 "at %C must be explicit", sym->name);
3597 if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
3600 if (sym->attr.pointer)
3602 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
3603 "POINTER array", sym->name);
3612 sym->common_head = t;
3614 /* Check to see if the symbol is already in an equivalence group.
3615 If it is, set the other members as being in common. */
3616 if (sym->attr.in_equivalence)
3618 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
3620 for (e2 = e1; e2; e2 = e2->eq)
3621 if (e2->expr->symtree->n.sym == sym)
3628 for (e2 = e1; e2; e2 = e2->eq)
3630 other = e2->expr->symtree->n.sym;
3631 if (other->common_head
3632 && other->common_head != sym->common_head)
3634 gfc_error ("Symbol '%s', in COMMON block '%s' at "
3635 "%C is being indirectly equivalenced to "
3636 "another COMMON block '%s'",
3637 sym->name, sym->common_head->name,
3638 other->common_head->name);
3641 other->attr.in_common = 1;
3642 other->common_head = t;
3648 gfc_gobble_whitespace ();
3649 if (gfc_match_eos () == MATCH_YES)
3651 if (gfc_peek_ascii_char () == '/')
3653 if (gfc_match_char (',') != MATCH_YES)
3655 gfc_gobble_whitespace ();
3656 if (gfc_peek_ascii_char () == '/')
3665 gfc_syntax_error (ST_COMMON);
3668 if (old_blank_common)
3669 old_blank_common->common_next = NULL;
3671 gfc_current_ns->blank_common.head = NULL;
3672 gfc_free_array_spec (as);
3677 /* Match a BLOCK DATA program unit. */
3680 gfc_match_block_data (void)
3682 char name[GFC_MAX_SYMBOL_LEN + 1];
3686 if (gfc_match_eos () == MATCH_YES)
3688 gfc_new_block = NULL;
3692 m = gfc_match ("% %n%t", name);
3696 if (gfc_get_symbol (name, NULL, &sym))
3699 if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
3702 gfc_new_block = sym;
3708 /* Free a namelist structure. */
3711 gfc_free_namelist (gfc_namelist *name)
3715 for (; name; name = n)
3723 /* Match a NAMELIST statement. */
3726 gfc_match_namelist (void)
3728 gfc_symbol *group_name, *sym;
3732 m = gfc_match (" / %s /", &group_name);
3735 if (m == MATCH_ERROR)
3740 if (group_name->ts.type != BT_UNKNOWN)
3742 gfc_error ("Namelist group name '%s' at %C already has a basic "
3743 "type of %s", group_name->name,
3744 gfc_typename (&group_name->ts));
3748 if (group_name->attr.flavor == FL_NAMELIST
3749 && group_name->attr.use_assoc
3750 && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
3751 "at %C already is USE associated and can"
3752 "not be respecified.", group_name->name)
3756 if (group_name->attr.flavor != FL_NAMELIST
3757 && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
3758 group_name->name, NULL) == FAILURE)
3763 m = gfc_match_symbol (&sym, 1);
3766 if (m == MATCH_ERROR)
3769 if (sym->attr.in_namelist == 0
3770 && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
3773 /* Use gfc_error_check here, rather than goto error, so that
3774 these are the only errors for the next two lines. */
3775 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
3777 gfc_error ("Assumed size array '%s' in namelist '%s' at "
3778 "%C is not allowed", sym->name, group_name->name);
3782 if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl->length == NULL)
3784 gfc_error ("Assumed character length '%s' in namelist '%s' at "
3785 "%C is not allowed", sym->name, group_name->name);
3789 nl = gfc_get_namelist ();
3793 if (group_name->namelist == NULL)
3794 group_name->namelist = group_name->namelist_tail = nl;
3797 group_name->namelist_tail->next = nl;
3798 group_name->namelist_tail = nl;
3801 if (gfc_match_eos () == MATCH_YES)
3804 m = gfc_match_char (',');
3806 if (gfc_match_char ('/') == MATCH_YES)
3808 m2 = gfc_match (" %s /", &group_name);
3809 if (m2 == MATCH_YES)
3811 if (m2 == MATCH_ERROR)
3825 gfc_syntax_error (ST_NAMELIST);
3832 /* Match a MODULE statement. */
3835 gfc_match_module (void)
3839 m = gfc_match (" %s%t", &gfc_new_block);
3843 if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
3844 gfc_new_block->name, NULL) == FAILURE)
3851 /* Free equivalence sets and lists. Recursively is the easiest way to
3855 gfc_free_equiv (gfc_equiv *eq)
3860 gfc_free_equiv (eq->eq);
3861 gfc_free_equiv (eq->next);
3862 gfc_free_expr (eq->expr);
3867 /* Match an EQUIVALENCE statement. */
3870 gfc_match_equivalence (void)
3872 gfc_equiv *eq, *set, *tail;
3876 gfc_common_head *common_head = NULL;
3884 eq = gfc_get_equiv ();
3888 eq->next = gfc_current_ns->equiv;
3889 gfc_current_ns->equiv = eq;
3891 if (gfc_match_char ('(') != MATCH_YES)
3895 common_flag = FALSE;
3900 m = gfc_match_equiv_variable (&set->expr);
3901 if (m == MATCH_ERROR)
3906 /* count the number of objects. */
3909 if (gfc_match_char ('%') == MATCH_YES)
3911 gfc_error ("Derived type component %C is not a "
3912 "permitted EQUIVALENCE member");
3916 for (ref = set->expr->ref; ref; ref = ref->next)
3917 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3919 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
3920 "be an array section");
3924 sym = set->expr->symtree->n.sym;
3926 if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
3929 if (sym->attr.in_common)
3932 common_head = sym->common_head;
3935 if (gfc_match_char (')') == MATCH_YES)
3938 if (gfc_match_char (',') != MATCH_YES)
3941 set->eq = gfc_get_equiv ();
3947 gfc_error ("EQUIVALENCE at %C requires two or more objects");
3951 /* If one of the members of an equivalence is in common, then
3952 mark them all as being in common. Before doing this, check
3953 that members of the equivalence group are not in different
3956 for (set = eq; set; set = set->eq)
3958 sym = set->expr->symtree->n.sym;
3959 if (sym->common_head && sym->common_head != common_head)
3961 gfc_error ("Attempt to indirectly overlap COMMON "
3962 "blocks %s and %s by EQUIVALENCE at %C",
3963 sym->common_head->name, common_head->name);
3966 sym->attr.in_common = 1;
3967 sym->common_head = common_head;
3970 if (gfc_match_eos () == MATCH_YES)
3972 if (gfc_match_char (',') != MATCH_YES)
3974 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
3982 gfc_syntax_error (ST_EQUIVALENCE);
3988 gfc_free_equiv (gfc_current_ns->equiv);
3989 gfc_current_ns->equiv = eq;
3995 /* Check that a statement function is not recursive. This is done by looking
3996 for the statement function symbol(sym) by looking recursively through its
3997 expression(e). If a reference to sym is found, true is returned.
3998 12.5.4 requires that any variable of function that is implicitly typed
3999 shall have that type confirmed by any subsequent type declaration. The
4000 implicit typing is conveniently done here. */
4002 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
4005 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
4011 switch (e->expr_type)
4014 if (e->symtree == NULL)
4017 /* Check the name before testing for nested recursion! */
4018 if (sym->name == e->symtree->n.sym->name)
4021 /* Catch recursion via other statement functions. */
4022 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
4023 && e->symtree->n.sym->value
4024 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
4027 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4028 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4033 if (e->symtree && sym->name == e->symtree->n.sym->name)
4036 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4037 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4049 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
4051 return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
4055 /* Match a statement function declaration. It is so easy to match
4056 non-statement function statements with a MATCH_ERROR as opposed to
4057 MATCH_NO that we suppress error message in most cases. */
4060 gfc_match_st_function (void)
4062 gfc_error_buf old_error;
4067 m = gfc_match_symbol (&sym, 0);
4071 gfc_push_error (&old_error);
4073 if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
4074 sym->name, NULL) == FAILURE)
4077 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
4080 m = gfc_match (" = %e%t", &expr);
4084 gfc_free_error (&old_error);
4085 if (m == MATCH_ERROR)
4088 if (recursive_stmt_fcn (expr, sym))
4090 gfc_error ("Statement function at %L is recursive", &expr->where);
4096 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
4097 "Statement function at %C") == FAILURE)
4103 gfc_pop_error (&old_error);
4108 /***************** SELECT CASE subroutines ******************/
4110 /* Free a single case structure. */
4113 free_case (gfc_case *p)
4115 if (p->low == p->high)
4117 gfc_free_expr (p->low);
4118 gfc_free_expr (p->high);
4123 /* Free a list of case structures. */
4126 gfc_free_case_list (gfc_case *p)
4138 /* Match a single case selector. */
4141 match_case_selector (gfc_case **cp)
4146 c = gfc_get_case ();
4147 c->where = gfc_current_locus;
4149 if (gfc_match_char (':') == MATCH_YES)
4151 m = gfc_match_init_expr (&c->high);
4154 if (m == MATCH_ERROR)
4159 m = gfc_match_init_expr (&c->low);
4160 if (m == MATCH_ERROR)
4165 /* If we're not looking at a ':' now, make a range out of a single
4166 target. Else get the upper bound for the case range. */
4167 if (gfc_match_char (':') != MATCH_YES)
4171 m = gfc_match_init_expr (&c->high);
4172 if (m == MATCH_ERROR)
4174 /* MATCH_NO is fine. It's OK if nothing is there! */
4182 gfc_error ("Expected initialization expression in CASE at %C");
4190 /* Match the end of a case statement. */
4193 match_case_eos (void)
4195 char name[GFC_MAX_SYMBOL_LEN + 1];
4198 if (gfc_match_eos () == MATCH_YES)
4201 /* If the case construct doesn't have a case-construct-name, we
4202 should have matched the EOS. */
4203 if (!gfc_current_block ())
4206 gfc_gobble_whitespace ();
4208 m = gfc_match_name (name);
4212 if (strcmp (name, gfc_current_block ()->name) != 0)
4214 gfc_error ("Expected block name '%s' of SELECT construct at %C",
4215 gfc_current_block ()->name);
4219 return gfc_match_eos ();
4223 /* Match a SELECT statement. */
4226 gfc_match_select (void)
4231 m = gfc_match_label ();
4232 if (m == MATCH_ERROR)
4235 m = gfc_match (" select case ( %e )%t", &expr);
4239 new_st.op = EXEC_SELECT;
4240 new_st.expr1 = expr;
4246 /* Push the current selector onto the SELECT TYPE stack. */
4249 select_type_push (gfc_symbol *sel)
4251 gfc_select_type_stack *top = gfc_get_select_type_stack ();
4252 top->selector = sel;
4254 top->prev = select_type_stack;
4256 select_type_stack = top;
4260 /* Set the temporary for the current SELECT TYPE selector. */
4263 select_type_set_tmp (gfc_typespec *ts)
4265 char name[GFC_MAX_SYMBOL_LEN];
4268 if (!gfc_type_is_extensible (ts->u.derived))
4271 if (ts->type == BT_CLASS)
4272 sprintf (name, "tmp$class$%s", ts->u.derived->name);
4274 sprintf (name, "tmp$type$%s", ts->u.derived->name);
4275 gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
4276 gfc_add_type (tmp->n.sym, ts, NULL);
4277 gfc_set_sym_referenced (tmp->n.sym);
4278 gfc_add_pointer (&tmp->n.sym->attr, NULL);
4279 gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
4280 if (ts->type == BT_CLASS)
4282 gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
4284 tmp->n.sym->attr.class_ok = 1;
4287 select_type_stack->tmp = tmp;
4291 /* Match a SELECT TYPE statement. */
4294 gfc_match_select_type (void)
4296 gfc_expr *expr1, *expr2 = NULL;
4298 char name[GFC_MAX_SYMBOL_LEN];
4300 m = gfc_match_label ();
4301 if (m == MATCH_ERROR)
4304 m = gfc_match (" select type ( ");
4308 gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
4310 m = gfc_match (" %n => %e", name, &expr2);
4313 expr1 = gfc_get_expr();
4314 expr1->expr_type = EXPR_VARIABLE;
4315 if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
4317 expr1->symtree->n.sym->ts = expr2->ts;
4318 expr1->symtree->n.sym->attr.referenced = 1;
4319 expr1->symtree->n.sym->attr.class_ok = 1;
4323 m = gfc_match (" %e ", &expr1);
4328 m = gfc_match (" )%t");
4332 /* Check for F03:C811. */
4333 if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
4335 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
4336 "use associate-name=>");
4340 /* Check for F03:C813. */
4341 if (expr1->ts.type != BT_CLASS && !(expr2 && expr2->ts.type == BT_CLASS))
4343 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
4348 new_st.op = EXEC_SELECT_TYPE;
4349 new_st.expr1 = expr1;
4350 new_st.expr2 = expr2;
4351 new_st.ext.ns = gfc_current_ns;
4353 select_type_push (expr1->symtree->n.sym);
4359 /* Match a CASE statement. */
4362 gfc_match_case (void)
4364 gfc_case *c, *head, *tail;
4369 if (gfc_current_state () != COMP_SELECT)
4371 gfc_error ("Unexpected CASE statement at %C");
4375 if (gfc_match ("% default") == MATCH_YES)
4377 m = match_case_eos ();
4380 if (m == MATCH_ERROR)
4383 new_st.op = EXEC_SELECT;
4384 c = gfc_get_case ();
4385 c->where = gfc_current_locus;
4386 new_st.ext.case_list = c;
4390 if (gfc_match_char ('(') != MATCH_YES)
4395 if (match_case_selector (&c) == MATCH_ERROR)
4405 if (gfc_match_char (')') == MATCH_YES)
4407 if (gfc_match_char (',') != MATCH_YES)
4411 m = match_case_eos ();
4414 if (m == MATCH_ERROR)
4417 new_st.op = EXEC_SELECT;
4418 new_st.ext.case_list = head;
4423 gfc_error ("Syntax error in CASE specification at %C");
4426 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
4431 /* Match a TYPE IS statement. */
4434 gfc_match_type_is (void)
4439 if (gfc_current_state () != COMP_SELECT_TYPE)
4441 gfc_error ("Unexpected TYPE IS statement at %C");
4445 if (gfc_match_char ('(') != MATCH_YES)
4448 c = gfc_get_case ();
4449 c->where = gfc_current_locus;
4451 /* TODO: Once unlimited polymorphism is implemented, we will need to call
4452 match_type_spec here. */
4453 if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
4456 if (gfc_match_char (')') != MATCH_YES)
4459 m = match_case_eos ();
4462 if (m == MATCH_ERROR)
4465 new_st.op = EXEC_SELECT_TYPE;
4466 new_st.ext.case_list = c;
4468 /* Create temporary variable. */
4469 select_type_set_tmp (&c->ts);
4474 gfc_error ("Syntax error in TYPE IS specification at %C");
4478 gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
4483 /* Match a CLASS IS or CLASS DEFAULT statement. */
4486 gfc_match_class_is (void)
4491 if (gfc_current_state () != COMP_SELECT_TYPE)
4494 if (gfc_match ("% default") == MATCH_YES)
4496 m = match_case_eos ();
4499 if (m == MATCH_ERROR)
4502 new_st.op = EXEC_SELECT_TYPE;
4503 c = gfc_get_case ();
4504 c->where = gfc_current_locus;
4505 c->ts.type = BT_UNKNOWN;
4506 new_st.ext.case_list = c;
4510 m = gfc_match ("% is");
4513 if (m == MATCH_ERROR)
4516 if (gfc_match_char ('(') != MATCH_YES)
4519 c = gfc_get_case ();
4520 c->where = gfc_current_locus;
4522 if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
4525 if (c->ts.type == BT_DERIVED)
4526 c->ts.type = BT_CLASS;
4528 if (gfc_match_char (')') != MATCH_YES)
4531 m = match_case_eos ();
4534 if (m == MATCH_ERROR)
4537 new_st.op = EXEC_SELECT_TYPE;
4538 new_st.ext.case_list = c;
4540 /* Create temporary variable. */
4541 select_type_set_tmp (&c->ts);
4546 gfc_error ("Syntax error in CLASS IS specification at %C");
4550 gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
4555 /********************* WHERE subroutines ********************/
4557 /* Match the rest of a simple WHERE statement that follows an IF statement.
4561 match_simple_where (void)
4567 m = gfc_match (" ( %e )", &expr);
4571 m = gfc_match_assignment ();
4574 if (m == MATCH_ERROR)
4577 if (gfc_match_eos () != MATCH_YES)
4580 c = gfc_get_code ();
4584 c->next = gfc_get_code ();
4587 gfc_clear_new_st ();
4589 new_st.op = EXEC_WHERE;
4595 gfc_syntax_error (ST_WHERE);
4598 gfc_free_expr (expr);
4603 /* Match a WHERE statement. */
4606 gfc_match_where (gfc_statement *st)
4612 m0 = gfc_match_label ();
4613 if (m0 == MATCH_ERROR)
4616 m = gfc_match (" where ( %e )", &expr);
4620 if (gfc_match_eos () == MATCH_YES)
4622 *st = ST_WHERE_BLOCK;
4623 new_st.op = EXEC_WHERE;
4624 new_st.expr1 = expr;
4628 m = gfc_match_assignment ();
4630 gfc_syntax_error (ST_WHERE);
4634 gfc_free_expr (expr);
4638 /* We've got a simple WHERE statement. */
4640 c = gfc_get_code ();
4644 c->next = gfc_get_code ();
4647 gfc_clear_new_st ();
4649 new_st.op = EXEC_WHERE;
4656 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
4657 new_st if successful. */
4660 gfc_match_elsewhere (void)
4662 char name[GFC_MAX_SYMBOL_LEN + 1];
4666 if (gfc_current_state () != COMP_WHERE)
4668 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
4674 if (gfc_match_char ('(') == MATCH_YES)
4676 m = gfc_match_expr (&expr);
4679 if (m == MATCH_ERROR)
4682 if (gfc_match_char (')') != MATCH_YES)
4686 if (gfc_match_eos () != MATCH_YES)
4688 /* Only makes sense if we have a where-construct-name. */
4689 if (!gfc_current_block ())
4694 /* Better be a name at this point. */
4695 m = gfc_match_name (name);
4698 if (m == MATCH_ERROR)
4701 if (gfc_match_eos () != MATCH_YES)
4704 if (strcmp (name, gfc_current_block ()->name) != 0)
4706 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
4707 name, gfc_current_block ()->name);
4712 new_st.op = EXEC_WHERE;
4713 new_st.expr1 = expr;
4717 gfc_syntax_error (ST_ELSEWHERE);
4720 gfc_free_expr (expr);
4725 /******************** FORALL subroutines ********************/
4727 /* Free a list of FORALL iterators. */
4730 gfc_free_forall_iterator (gfc_forall_iterator *iter)
4732 gfc_forall_iterator *next;
4737 gfc_free_expr (iter->var);
4738 gfc_free_expr (iter->start);
4739 gfc_free_expr (iter->end);
4740 gfc_free_expr (iter->stride);
4747 /* Match an iterator as part of a FORALL statement. The format is:
4749 <var> = <start>:<end>[:<stride>]
4751 On MATCH_NO, the caller tests for the possibility that there is a
4752 scalar mask expression. */
4755 match_forall_iterator (gfc_forall_iterator **result)
4757 gfc_forall_iterator *iter;
4761 where = gfc_current_locus;
4762 iter = XCNEW (gfc_forall_iterator);
4764 m = gfc_match_expr (&iter->var);
4768 if (gfc_match_char ('=') != MATCH_YES
4769 || iter->var->expr_type != EXPR_VARIABLE)
4775 m = gfc_match_expr (&iter->start);
4779 if (gfc_match_char (':') != MATCH_YES)
4782 m = gfc_match_expr (&iter->end);
4785 if (m == MATCH_ERROR)
4788 if (gfc_match_char (':') == MATCH_NO)
4789 iter->stride = gfc_int_expr (1);
4792 m = gfc_match_expr (&iter->stride);
4795 if (m == MATCH_ERROR)
4799 /* Mark the iteration variable's symbol as used as a FORALL index. */
4800 iter->var->symtree->n.sym->forall_index = true;
4806 gfc_error ("Syntax error in FORALL iterator at %C");
4811 gfc_current_locus = where;
4812 gfc_free_forall_iterator (iter);
4817 /* Match the header of a FORALL statement. */
4820 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
4822 gfc_forall_iterator *head, *tail, *new_iter;
4826 gfc_gobble_whitespace ();
4831 if (gfc_match_char ('(') != MATCH_YES)
4834 m = match_forall_iterator (&new_iter);
4835 if (m == MATCH_ERROR)
4840 head = tail = new_iter;
4844 if (gfc_match_char (',') != MATCH_YES)
4847 m = match_forall_iterator (&new_iter);
4848 if (m == MATCH_ERROR)
4853 tail->next = new_iter;
4858 /* Have to have a mask expression. */
4860 m = gfc_match_expr (&msk);
4863 if (m == MATCH_ERROR)
4869 if (gfc_match_char (')') == MATCH_NO)
4877 gfc_syntax_error (ST_FORALL);
4880 gfc_free_expr (msk);
4881 gfc_free_forall_iterator (head);
4886 /* Match the rest of a simple FORALL statement that follows an
4890 match_simple_forall (void)
4892 gfc_forall_iterator *head;
4901 m = match_forall_header (&head, &mask);
4908 m = gfc_match_assignment ();
4910 if (m == MATCH_ERROR)
4914 m = gfc_match_pointer_assignment ();
4915 if (m == MATCH_ERROR)
4921 c = gfc_get_code ();
4923 c->loc = gfc_current_locus;
4925 if (gfc_match_eos () != MATCH_YES)
4928 gfc_clear_new_st ();
4929 new_st.op = EXEC_FORALL;
4930 new_st.expr1 = mask;
4931 new_st.ext.forall_iterator = head;
4932 new_st.block = gfc_get_code ();
4934 new_st.block->op = EXEC_FORALL;
4935 new_st.block->next = c;
4940 gfc_syntax_error (ST_FORALL);
4943 gfc_free_forall_iterator (head);
4944 gfc_free_expr (mask);
4950 /* Match a FORALL statement. */
4953 gfc_match_forall (gfc_statement *st)
4955 gfc_forall_iterator *head;
4964 m0 = gfc_match_label ();
4965 if (m0 == MATCH_ERROR)
4968 m = gfc_match (" forall");
4972 m = match_forall_header (&head, &mask);
4973 if (m == MATCH_ERROR)
4978 if (gfc_match_eos () == MATCH_YES)
4980 *st = ST_FORALL_BLOCK;
4981 new_st.op = EXEC_FORALL;
4982 new_st.expr1 = mask;
4983 new_st.ext.forall_iterator = head;
4987 m = gfc_match_assignment ();
4988 if (m == MATCH_ERROR)
4992 m = gfc_match_pointer_assignment ();
4993 if (m == MATCH_ERROR)
4999 c = gfc_get_code ();
5001 c->loc = gfc_current_locus;
5003 gfc_clear_new_st ();
5004 new_st.op = EXEC_FORALL;
5005 new_st.expr1 = mask;
5006 new_st.ext.forall_iterator = head;
5007 new_st.block = gfc_get_code ();
5008 new_st.block->op = EXEC_FORALL;
5009 new_st.block->next = c;
5015 gfc_syntax_error (ST_FORALL);
5018 gfc_free_forall_iterator (head);
5019 gfc_free_expr (mask);
5020 gfc_free_statements (c);