1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
30 int gfc_matching_ptr_assignment = 0;
31 int gfc_matching_procptr_assignment = 0;
32 bool gfc_matching_prefix = false;
34 /* Stack of SELECT TYPE statements. */
35 gfc_select_type_stack *select_type_stack = NULL;
37 /* For debugging and diagnostic purposes. Return the textual representation
38 of the intrinsic operator OP. */
40 gfc_op2string (gfc_intrinsic_op op)
48 case INTRINSIC_UMINUS:
54 case INTRINSIC_CONCAT:
58 case INTRINSIC_DIVIDE:
97 case INTRINSIC_ASSIGN:
100 case INTRINSIC_PARENTHESES:
107 gfc_internal_error ("gfc_op2string(): Bad code");
112 /******************** Generic matching subroutines ************************/
114 /* This function scans the current statement counting the opened and closed
115 parenthesis to make sure they are balanced. */
118 gfc_match_parens (void)
120 locus old_loc, where;
122 gfc_instring instring;
125 old_loc = gfc_current_locus;
127 instring = NONSTRING;
132 c = gfc_next_char_literal (instring);
135 if (quote == ' ' && ((c == '\'') || (c == '"')))
138 instring = INSTRING_WARN;
141 if (quote != ' ' && c == quote)
144 instring = NONSTRING;
148 if (c == '(' && quote == ' ')
151 where = gfc_current_locus;
153 if (c == ')' && quote == ' ')
156 where = gfc_current_locus;
160 gfc_current_locus = old_loc;
164 gfc_error ("Missing ')' in statement at or before %L", &where);
169 gfc_error ("Missing '(' in statement at or before %L", &where);
177 /* See if the next character is a special character that has
178 escaped by a \ via the -fbackslash option. */
181 gfc_match_special_char (gfc_char_t *res)
189 switch ((c = gfc_next_char_literal (INSTRING_WARN)))
222 /* Hexadecimal form of wide characters. */
223 len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8));
225 for (i = 0; i < len; i++)
227 char buf[2] = { '\0', '\0' };
229 c = gfc_next_char_literal (INSTRING_WARN);
230 if (!gfc_wide_fits_in_byte (c)
231 || !gfc_check_digit ((unsigned char) c, 16))
234 buf[0] = (unsigned char) c;
236 n += strtol (buf, NULL, 16);
242 /* Unknown backslash codes are simply not expanded. */
251 /* In free form, match at least one space. Always matches in fixed
255 gfc_match_space (void)
260 if (gfc_current_form == FORM_FIXED)
263 old_loc = gfc_current_locus;
265 c = gfc_next_ascii_char ();
266 if (!gfc_is_whitespace (c))
268 gfc_current_locus = old_loc;
272 gfc_gobble_whitespace ();
278 /* Match an end of statement. End of statement is optional
279 whitespace, followed by a ';' or '\n' or comment '!'. If a
280 semicolon is found, we continue to eat whitespace and semicolons. */
293 old_loc = gfc_current_locus;
294 gfc_gobble_whitespace ();
296 c = gfc_next_ascii_char ();
302 c = gfc_next_ascii_char ();
319 gfc_current_locus = old_loc;
320 return (flag) ? MATCH_YES : MATCH_NO;
324 /* Match a literal integer on the input, setting the value on
325 MATCH_YES. Literal ints occur in kind-parameters as well as
326 old-style character length specifications. If cnt is non-NULL it
327 will be set to the number of digits. */
330 gfc_match_small_literal_int (int *value, int *cnt)
336 old_loc = gfc_current_locus;
339 gfc_gobble_whitespace ();
340 c = gfc_next_ascii_char ();
346 gfc_current_locus = old_loc;
355 old_loc = gfc_current_locus;
356 c = gfc_next_ascii_char ();
361 i = 10 * i + c - '0';
366 gfc_error ("Integer too large at %C");
371 gfc_current_locus = old_loc;
380 /* Match a small, constant integer expression, like in a kind
381 statement. On MATCH_YES, 'value' is set. */
384 gfc_match_small_int (int *value)
391 m = gfc_match_expr (&expr);
395 p = gfc_extract_int (expr, &i);
396 gfc_free_expr (expr);
409 /* This function is the same as the gfc_match_small_int, except that
410 we're keeping the pointer to the expr. This function could just be
411 removed and the previously mentioned one modified, though all calls
412 to it would have to be modified then (and there were a number of
413 them). Return MATCH_ERROR if fail to extract the int; otherwise,
414 return the result of gfc_match_expr(). The expr (if any) that was
415 matched is returned in the parameter expr. */
418 gfc_match_small_int_expr (int *value, gfc_expr **expr)
424 m = gfc_match_expr (expr);
428 p = gfc_extract_int (*expr, &i);
441 /* Matches a statement label. Uses gfc_match_small_literal_int() to
442 do most of the work. */
445 gfc_match_st_label (gfc_st_label **label)
451 old_loc = gfc_current_locus;
453 m = gfc_match_small_literal_int (&i, &cnt);
459 gfc_error ("Too many digits in statement label at %C");
465 gfc_error ("Statement label at %C is zero");
469 *label = gfc_get_st_label (i);
474 gfc_current_locus = old_loc;
479 /* Match and validate a label associated with a named IF, DO or SELECT
480 statement. If the symbol does not have the label attribute, we add
481 it. We also make sure the symbol does not refer to another
482 (active) block. A matched label is pointed to by gfc_new_block. */
485 gfc_match_label (void)
487 char name[GFC_MAX_SYMBOL_LEN + 1];
490 gfc_new_block = NULL;
492 m = gfc_match (" %n :", name);
496 if (gfc_get_symbol (name, NULL, &gfc_new_block))
498 gfc_error ("Label name '%s' at %C is ambiguous", name);
502 if (gfc_new_block->attr.flavor == FL_LABEL)
504 gfc_error ("Duplicate construct label '%s' at %C", name);
508 if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
509 gfc_new_block->name, NULL) == FAILURE)
516 /* See if the current input looks like a name of some sort. Modifies
517 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
518 Note that options.c restricts max_identifier_length to not more
519 than GFC_MAX_SYMBOL_LEN. */
522 gfc_match_name (char *buffer)
528 old_loc = gfc_current_locus;
529 gfc_gobble_whitespace ();
531 c = gfc_next_ascii_char ();
532 if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore)))
534 if (gfc_error_flag_test() == 0 && c != '(')
535 gfc_error ("Invalid character in name at %C");
536 gfc_current_locus = old_loc;
546 if (i > gfc_option.max_identifier_length)
548 gfc_error ("Name at %C is too long");
552 old_loc = gfc_current_locus;
553 c = gfc_next_ascii_char ();
555 while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));
557 if (c == '$' && !gfc_option.flag_dollar_ok)
559 gfc_error ("Invalid character '$' at %C. Use -fdollar-ok to allow it "
565 gfc_current_locus = old_loc;
571 /* Match a valid name for C, which is almost the same as for Fortran,
572 except that you can start with an underscore, etc.. It could have
573 been done by modifying the gfc_match_name, but this way other
574 things C allows can be added, such as no limits on the length.
575 Right now, the length is limited to the same thing as Fortran..
576 Also, by rewriting it, we use the gfc_next_char_C() to prevent the
577 input characters from being automatically lower cased, since C is
578 case sensitive. The parameter, buffer, is used to return the name
579 that is matched. Return MATCH_ERROR if the name is too long
580 (though this is a self-imposed limit), MATCH_NO if what we're
581 seeing isn't a name, and MATCH_YES if we successfully match a C
585 gfc_match_name_C (char *buffer)
591 old_loc = gfc_current_locus;
592 gfc_gobble_whitespace ();
594 /* Get the next char (first possible char of name) and see if
595 it's valid for C (either a letter or an underscore). */
596 c = gfc_next_char_literal (INSTRING_WARN);
598 /* If the user put nothing expect spaces between the quotes, it is valid
599 and simply means there is no name= specifier and the name is the fortran
600 symbol name, all lowercase. */
601 if (c == '"' || c == '\'')
604 gfc_current_locus = old_loc;
608 if (!ISALPHA (c) && c != '_')
610 gfc_error ("Invalid C name in NAME= specifier at %C");
614 /* Continue to read valid variable name characters. */
617 gcc_assert (gfc_wide_fits_in_byte (c));
619 buffer[i++] = (unsigned char) c;
621 /* C does not define a maximum length of variable names, to my
622 knowledge, but the compiler typically places a limit on them.
623 For now, i'll use the same as the fortran limit for simplicity,
624 but this may need to be changed to a dynamic buffer that can
625 be realloc'ed here if necessary, or more likely, a larger
627 if (i > gfc_option.max_identifier_length)
629 gfc_error ("Name at %C is too long");
633 old_loc = gfc_current_locus;
635 /* Get next char; param means we're in a string. */
636 c = gfc_next_char_literal (INSTRING_WARN);
637 } while (ISALNUM (c) || c == '_');
640 gfc_current_locus = old_loc;
642 /* See if we stopped because of whitespace. */
645 gfc_gobble_whitespace ();
646 c = gfc_peek_ascii_char ();
647 if (c != '"' && c != '\'')
649 gfc_error ("Embedded space in NAME= specifier at %C");
654 /* If we stopped because we had an invalid character for a C name, report
655 that to the user by returning MATCH_NO. */
656 if (c != '"' && c != '\'')
658 gfc_error ("Invalid C name in NAME= specifier at %C");
666 /* Match a symbol on the input. Modifies the pointer to the symbol
667 pointer if successful. */
670 gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
672 char buffer[GFC_MAX_SYMBOL_LEN + 1];
675 m = gfc_match_name (buffer);
680 return (gfc_get_ha_sym_tree (buffer, matched_symbol))
681 ? MATCH_ERROR : MATCH_YES;
683 if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false))
691 gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
696 m = gfc_match_sym_tree (&st, host_assoc);
701 *matched_symbol = st->n.sym;
703 *matched_symbol = NULL;
706 *matched_symbol = NULL;
711 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
712 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
716 gfc_match_intrinsic_op (gfc_intrinsic_op *result)
718 locus orig_loc = gfc_current_locus;
721 gfc_gobble_whitespace ();
722 ch = gfc_next_ascii_char ();
727 *result = INTRINSIC_PLUS;
732 *result = INTRINSIC_MINUS;
736 if (gfc_next_ascii_char () == '=')
739 *result = INTRINSIC_EQ;
745 if (gfc_peek_ascii_char () == '=')
748 gfc_next_ascii_char ();
749 *result = INTRINSIC_LE;
753 *result = INTRINSIC_LT;
757 if (gfc_peek_ascii_char () == '=')
760 gfc_next_ascii_char ();
761 *result = INTRINSIC_GE;
765 *result = INTRINSIC_GT;
769 if (gfc_peek_ascii_char () == '*')
772 gfc_next_ascii_char ();
773 *result = INTRINSIC_POWER;
777 *result = INTRINSIC_TIMES;
781 ch = gfc_peek_ascii_char ();
785 gfc_next_ascii_char ();
786 *result = INTRINSIC_NE;
792 gfc_next_ascii_char ();
793 *result = INTRINSIC_CONCAT;
797 *result = INTRINSIC_DIVIDE;
801 ch = gfc_next_ascii_char ();
805 if (gfc_next_ascii_char () == 'n'
806 && gfc_next_ascii_char () == 'd'
807 && gfc_next_ascii_char () == '.')
809 /* Matched ".and.". */
810 *result = INTRINSIC_AND;
816 if (gfc_next_ascii_char () == 'q')
818 ch = gfc_next_ascii_char ();
821 /* Matched ".eq.". */
822 *result = INTRINSIC_EQ_OS;
827 if (gfc_next_ascii_char () == '.')
829 /* Matched ".eqv.". */
830 *result = INTRINSIC_EQV;
838 ch = gfc_next_ascii_char ();
841 if (gfc_next_ascii_char () == '.')
843 /* Matched ".ge.". */
844 *result = INTRINSIC_GE_OS;
850 if (gfc_next_ascii_char () == '.')
852 /* Matched ".gt.". */
853 *result = INTRINSIC_GT_OS;
860 ch = gfc_next_ascii_char ();
863 if (gfc_next_ascii_char () == '.')
865 /* Matched ".le.". */
866 *result = INTRINSIC_LE_OS;
872 if (gfc_next_ascii_char () == '.')
874 /* Matched ".lt.". */
875 *result = INTRINSIC_LT_OS;
882 ch = gfc_next_ascii_char ();
885 ch = gfc_next_ascii_char ();
888 /* Matched ".ne.". */
889 *result = INTRINSIC_NE_OS;
894 if (gfc_next_ascii_char () == 'v'
895 && gfc_next_ascii_char () == '.')
897 /* Matched ".neqv.". */
898 *result = INTRINSIC_NEQV;
905 if (gfc_next_ascii_char () == 't'
906 && gfc_next_ascii_char () == '.')
908 /* Matched ".not.". */
909 *result = INTRINSIC_NOT;
916 if (gfc_next_ascii_char () == 'r'
917 && gfc_next_ascii_char () == '.')
919 /* Matched ".or.". */
920 *result = INTRINSIC_OR;
934 gfc_current_locus = orig_loc;
939 /* Match a loop control phrase:
941 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
943 If the final integer expression is not present, a constant unity
944 expression is returned. We don't return MATCH_ERROR until after
945 the equals sign is seen. */
948 gfc_match_iterator (gfc_iterator *iter, int init_flag)
950 char name[GFC_MAX_SYMBOL_LEN + 1];
951 gfc_expr *var, *e1, *e2, *e3;
957 /* Match the start of an iterator without affecting the symbol table. */
959 start = gfc_current_locus;
960 m = gfc_match (" %n =", name);
961 gfc_current_locus = start;
966 m = gfc_match_variable (&var, 0);
970 /* F2008, C617 & C565. */
971 if (var->symtree->n.sym->attr.codimension)
973 gfc_error ("Loop variable at %C cannot be a coarray");
977 if (var->ref != NULL)
979 gfc_error ("Loop variable at %C cannot be a sub-component");
983 gfc_match_char ('=');
985 var->symtree->n.sym->attr.implied_index = 1;
987 m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
990 if (m == MATCH_ERROR)
993 if (gfc_match_char (',') != MATCH_YES)
996 m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
999 if (m == MATCH_ERROR)
1002 if (gfc_match_char (',') != MATCH_YES)
1004 e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
1008 m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
1009 if (m == MATCH_ERROR)
1013 gfc_error ("Expected a step value in iterator at %C");
1025 gfc_error ("Syntax error in iterator at %C");
1036 /* Tries to match the next non-whitespace character on the input.
1037 This subroutine does not return MATCH_ERROR. */
1040 gfc_match_char (char c)
1044 where = gfc_current_locus;
1045 gfc_gobble_whitespace ();
1047 if (gfc_next_ascii_char () == c)
1050 gfc_current_locus = where;
1055 /* General purpose matching subroutine. The target string is a
1056 scanf-like format string in which spaces correspond to arbitrary
1057 whitespace (including no whitespace), characters correspond to
1058 themselves. The %-codes are:
1060 %% Literal percent sign
1061 %e Expression, pointer to a pointer is set
1062 %s Symbol, pointer to the symbol is set
1063 %n Name, character buffer is set to name
1064 %t Matches end of statement.
1065 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1066 %l Matches a statement label
1067 %v Matches a variable expression (an lvalue)
1068 % Matches a required space (in free form) and optional spaces. */
1071 gfc_match (const char *target, ...)
1073 gfc_st_label **label;
1082 old_loc = gfc_current_locus;
1083 va_start (argp, target);
1093 gfc_gobble_whitespace ();
1104 vp = va_arg (argp, void **);
1105 n = gfc_match_expr ((gfc_expr **) vp);
1116 vp = va_arg (argp, void **);
1117 n = gfc_match_variable ((gfc_expr **) vp, 0);
1128 vp = va_arg (argp, void **);
1129 n = gfc_match_symbol ((gfc_symbol **) vp, 0);
1140 np = va_arg (argp, char *);
1141 n = gfc_match_name (np);
1152 label = va_arg (argp, gfc_st_label **);
1153 n = gfc_match_st_label (label);
1164 ip = va_arg (argp, int *);
1165 n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
1176 if (gfc_match_eos () != MATCH_YES)
1184 if (gfc_match_space () == MATCH_YES)
1190 break; /* Fall through to character matcher. */
1193 gfc_internal_error ("gfc_match(): Bad match code %c", c);
1198 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1199 expect an upper case character here! */
1200 gcc_assert (TOLOWER (c) == c);
1202 if (c == gfc_next_ascii_char ())
1212 /* Clean up after a failed match. */
1213 gfc_current_locus = old_loc;
1214 va_start (argp, target);
1217 for (; matches > 0; matches--)
1219 while (*p++ != '%');
1227 /* Matches that don't have to be undone */
1232 (void) va_arg (argp, void **);
1237 vp = va_arg (argp, void **);
1238 gfc_free_expr ((struct gfc_expr *)*vp);
1251 /*********************** Statement level matching **********************/
1253 /* Matches the start of a program unit, which is the program keyword
1254 followed by an obligatory symbol. */
1257 gfc_match_program (void)
1262 m = gfc_match ("% %s%t", &sym);
1266 gfc_error ("Invalid form of PROGRAM statement at %C");
1270 if (m == MATCH_ERROR)
1273 if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
1276 gfc_new_block = sym;
1282 /* Match a simple assignment statement. */
1285 gfc_match_assignment (void)
1287 gfc_expr *lvalue, *rvalue;
1291 old_loc = gfc_current_locus;
1294 m = gfc_match (" %v =", &lvalue);
1297 gfc_current_locus = old_loc;
1298 gfc_free_expr (lvalue);
1303 m = gfc_match (" %e%t", &rvalue);
1306 gfc_current_locus = old_loc;
1307 gfc_free_expr (lvalue);
1308 gfc_free_expr (rvalue);
1312 gfc_set_sym_referenced (lvalue->symtree->n.sym);
1314 new_st.op = EXEC_ASSIGN;
1315 new_st.expr1 = lvalue;
1316 new_st.expr2 = rvalue;
1318 gfc_check_do_variable (lvalue->symtree);
1324 /* Match a pointer assignment statement. */
1327 gfc_match_pointer_assignment (void)
1329 gfc_expr *lvalue, *rvalue;
1333 old_loc = gfc_current_locus;
1335 lvalue = rvalue = NULL;
1336 gfc_matching_ptr_assignment = 0;
1337 gfc_matching_procptr_assignment = 0;
1339 m = gfc_match (" %v =>", &lvalue);
1346 if (lvalue->symtree->n.sym->attr.proc_pointer
1347 || gfc_is_proc_ptr_comp (lvalue, NULL))
1348 gfc_matching_procptr_assignment = 1;
1350 gfc_matching_ptr_assignment = 1;
1352 m = gfc_match (" %e%t", &rvalue);
1353 gfc_matching_ptr_assignment = 0;
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 ("lock", gfc_match_lock, ST_LOCK)
1565 match ("nullify", gfc_match_nullify, ST_NULLIFY)
1566 match ("open", gfc_match_open, ST_OPEN)
1567 match ("pause", gfc_match_pause, ST_NONE)
1568 match ("print", gfc_match_print, ST_WRITE)
1569 match ("read", gfc_match_read, ST_READ)
1570 match ("return", gfc_match_return, ST_RETURN)
1571 match ("rewind", gfc_match_rewind, ST_REWIND)
1572 match ("stop", gfc_match_stop, ST_STOP)
1573 match ("wait", gfc_match_wait, ST_WAIT)
1574 match ("sync all", gfc_match_sync_all, ST_SYNC_CALL);
1575 match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
1576 match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
1577 match ("unlock", gfc_match_unlock, ST_UNLOCK)
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;
1696 new_st.expr1 = expr;
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 CRITICAL statement. */
1726 gfc_match_critical (void)
1728 gfc_st_label *label = NULL;
1730 if (gfc_match_label () == MATCH_ERROR)
1733 if (gfc_match (" critical") != MATCH_YES)
1736 if (gfc_match_st_label (&label) == MATCH_ERROR)
1739 if (gfc_match_eos () != MATCH_YES)
1741 gfc_syntax_error (ST_CRITICAL);
1745 if (gfc_pure (NULL))
1747 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1751 if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
1753 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1758 if (gfc_implicit_pure (NULL))
1759 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1761 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CRITICAL statement at %C")
1765 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
1767 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
1771 if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
1773 gfc_error ("Nested CRITICAL block at %C");
1777 new_st.op = EXEC_CRITICAL;
1780 && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1787 /* Match a BLOCK statement. */
1790 gfc_match_block (void)
1794 if (gfc_match_label () == MATCH_ERROR)
1797 if (gfc_match (" block") != MATCH_YES)
1800 /* For this to be a correct BLOCK statement, the line must end now. */
1801 m = gfc_match_eos ();
1802 if (m == MATCH_ERROR)
1811 /* Match an ASSOCIATE statement. */
1814 gfc_match_associate (void)
1816 if (gfc_match_label () == MATCH_ERROR)
1819 if (gfc_match (" associate") != MATCH_YES)
1822 /* Match the association list. */
1823 if (gfc_match_char ('(') != MATCH_YES)
1825 gfc_error ("Expected association list at %C");
1828 new_st.ext.block.assoc = NULL;
1831 gfc_association_list* newAssoc = gfc_get_association_list ();
1832 gfc_association_list* a;
1834 /* Match the next association. */
1835 if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
1838 gfc_error ("Expected association at %C");
1839 goto assocListError;
1841 newAssoc->where = gfc_current_locus;
1843 /* Check that the current name is not yet in the list. */
1844 for (a = new_st.ext.block.assoc; a; a = a->next)
1845 if (!strcmp (a->name, newAssoc->name))
1847 gfc_error ("Duplicate name '%s' in association at %C",
1849 goto assocListError;
1852 /* The target expression must not be coindexed. */
1853 if (gfc_is_coindexed (newAssoc->target))
1855 gfc_error ("Association target at %C must not be coindexed");
1856 goto assocListError;
1859 /* The `variable' field is left blank for now; because the target is not
1860 yet resolved, we can't use gfc_has_vector_subscript to determine it
1861 for now. This is set during resolution. */
1863 /* Put it into the list. */
1864 newAssoc->next = new_st.ext.block.assoc;
1865 new_st.ext.block.assoc = newAssoc;
1867 /* Try next one or end if closing parenthesis is found. */
1868 gfc_gobble_whitespace ();
1869 if (gfc_peek_char () == ')')
1871 if (gfc_match_char (',') != MATCH_YES)
1873 gfc_error ("Expected ')' or ',' at %C");
1883 if (gfc_match_char (')') != MATCH_YES)
1885 /* This should never happen as we peek above. */
1889 if (gfc_match_eos () != MATCH_YES)
1891 gfc_error ("Junk after ASSOCIATE statement at %C");
1898 gfc_free_association_list (new_st.ext.block.assoc);
1903 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1904 an accessible derived type. */
1907 match_derived_type_spec (gfc_typespec *ts)
1909 char name[GFC_MAX_SYMBOL_LEN + 1];
1911 gfc_symbol *derived;
1913 old_locus = gfc_current_locus;
1915 if (gfc_match ("%n", name) != MATCH_YES)
1917 gfc_current_locus = old_locus;
1921 gfc_find_symbol (name, NULL, 1, &derived);
1923 if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
1924 derived = gfc_find_dt_in_generic (derived);
1926 if (derived && derived->attr.flavor == FL_DERIVED)
1928 ts->type = BT_DERIVED;
1929 ts->u.derived = derived;
1933 gfc_current_locus = old_locus;
1938 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
1939 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
1940 It only includes the intrinsic types from the Fortran 2003 standard
1941 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
1942 the implicit_flag is not needed, so it was removed. Derived types are
1943 identified by their name alone. */
1946 match_type_spec (gfc_typespec *ts)
1952 gfc_gobble_whitespace ();
1953 old_locus = gfc_current_locus;
1955 if (match_derived_type_spec (ts) == MATCH_YES)
1957 /* Enforce F03:C401. */
1958 if (ts->u.derived->attr.abstract)
1960 gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
1961 ts->u.derived->name, &old_locus);
1967 if (gfc_match ("integer") == MATCH_YES)
1969 ts->type = BT_INTEGER;
1970 ts->kind = gfc_default_integer_kind;
1974 if (gfc_match ("real") == MATCH_YES)
1977 ts->kind = gfc_default_real_kind;
1981 if (gfc_match ("double precision") == MATCH_YES)
1984 ts->kind = gfc_default_double_kind;
1988 if (gfc_match ("complex") == MATCH_YES)
1990 ts->type = BT_COMPLEX;
1991 ts->kind = gfc_default_complex_kind;
1995 if (gfc_match ("character") == MATCH_YES)
1997 ts->type = BT_CHARACTER;
1999 m = gfc_match_char_spec (ts);
2007 if (gfc_match ("logical") == MATCH_YES)
2009 ts->type = BT_LOGICAL;
2010 ts->kind = gfc_default_logical_kind;
2014 /* If a type is not matched, simply return MATCH_NO. */
2015 gfc_current_locus = old_locus;
2020 gfc_gobble_whitespace ();
2021 if (gfc_peek_ascii_char () == '*')
2023 gfc_error ("Invalid type-spec at %C");
2027 m = gfc_match_kind_spec (ts, false);
2030 m = MATCH_YES; /* No kind specifier found. */
2036 /******************** FORALL subroutines ********************/
2038 /* Free a list of FORALL iterators. */
2041 gfc_free_forall_iterator (gfc_forall_iterator *iter)
2043 gfc_forall_iterator *next;
2048 gfc_free_expr (iter->var);
2049 gfc_free_expr (iter->start);
2050 gfc_free_expr (iter->end);
2051 gfc_free_expr (iter->stride);
2058 /* Match an iterator as part of a FORALL statement. The format is:
2060 <var> = <start>:<end>[:<stride>]
2062 On MATCH_NO, the caller tests for the possibility that there is a
2063 scalar mask expression. */
2066 match_forall_iterator (gfc_forall_iterator **result)
2068 gfc_forall_iterator *iter;
2072 where = gfc_current_locus;
2073 iter = XCNEW (gfc_forall_iterator);
2075 m = gfc_match_expr (&iter->var);
2079 if (gfc_match_char ('=') != MATCH_YES
2080 || iter->var->expr_type != EXPR_VARIABLE)
2086 m = gfc_match_expr (&iter->start);
2090 if (gfc_match_char (':') != MATCH_YES)
2093 m = gfc_match_expr (&iter->end);
2096 if (m == MATCH_ERROR)
2099 if (gfc_match_char (':') == MATCH_NO)
2100 iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
2103 m = gfc_match_expr (&iter->stride);
2106 if (m == MATCH_ERROR)
2110 /* Mark the iteration variable's symbol as used as a FORALL index. */
2111 iter->var->symtree->n.sym->forall_index = true;
2117 gfc_error ("Syntax error in FORALL iterator at %C");
2122 gfc_current_locus = where;
2123 gfc_free_forall_iterator (iter);
2128 /* Match the header of a FORALL statement. */
2131 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
2133 gfc_forall_iterator *head, *tail, *new_iter;
2137 gfc_gobble_whitespace ();
2142 if (gfc_match_char ('(') != MATCH_YES)
2145 m = match_forall_iterator (&new_iter);
2146 if (m == MATCH_ERROR)
2151 head = tail = new_iter;
2155 if (gfc_match_char (',') != MATCH_YES)
2158 m = match_forall_iterator (&new_iter);
2159 if (m == MATCH_ERROR)
2164 tail->next = new_iter;
2169 /* Have to have a mask expression. */
2171 m = gfc_match_expr (&msk);
2174 if (m == MATCH_ERROR)
2180 if (gfc_match_char (')') == MATCH_NO)
2188 gfc_syntax_error (ST_FORALL);
2191 gfc_free_expr (msk);
2192 gfc_free_forall_iterator (head);
2197 /* Match the rest of a simple FORALL statement that follows an
2201 match_simple_forall (void)
2203 gfc_forall_iterator *head;
2212 m = match_forall_header (&head, &mask);
2219 m = gfc_match_assignment ();
2221 if (m == MATCH_ERROR)
2225 m = gfc_match_pointer_assignment ();
2226 if (m == MATCH_ERROR)
2232 c = gfc_get_code ();
2234 c->loc = gfc_current_locus;
2236 if (gfc_match_eos () != MATCH_YES)
2239 gfc_clear_new_st ();
2240 new_st.op = EXEC_FORALL;
2241 new_st.expr1 = mask;
2242 new_st.ext.forall_iterator = head;
2243 new_st.block = gfc_get_code ();
2245 new_st.block->op = EXEC_FORALL;
2246 new_st.block->next = c;
2251 gfc_syntax_error (ST_FORALL);
2254 gfc_free_forall_iterator (head);
2255 gfc_free_expr (mask);
2261 /* Match a FORALL statement. */
2264 gfc_match_forall (gfc_statement *st)
2266 gfc_forall_iterator *head;
2275 m0 = gfc_match_label ();
2276 if (m0 == MATCH_ERROR)
2279 m = gfc_match (" forall");
2283 m = match_forall_header (&head, &mask);
2284 if (m == MATCH_ERROR)
2289 if (gfc_match_eos () == MATCH_YES)
2291 *st = ST_FORALL_BLOCK;
2292 new_st.op = EXEC_FORALL;
2293 new_st.expr1 = mask;
2294 new_st.ext.forall_iterator = head;
2298 m = gfc_match_assignment ();
2299 if (m == MATCH_ERROR)
2303 m = gfc_match_pointer_assignment ();
2304 if (m == MATCH_ERROR)
2310 c = gfc_get_code ();
2312 c->loc = gfc_current_locus;
2314 gfc_clear_new_st ();
2315 new_st.op = EXEC_FORALL;
2316 new_st.expr1 = mask;
2317 new_st.ext.forall_iterator = head;
2318 new_st.block = gfc_get_code ();
2319 new_st.block->op = EXEC_FORALL;
2320 new_st.block->next = c;
2326 gfc_syntax_error (ST_FORALL);
2329 gfc_free_forall_iterator (head);
2330 gfc_free_expr (mask);
2331 gfc_free_statements (c);
2336 /* Match a DO statement. */
2341 gfc_iterator iter, *ip;
2343 gfc_st_label *label;
2346 old_loc = gfc_current_locus;
2349 iter.var = iter.start = iter.end = iter.step = NULL;
2351 m = gfc_match_label ();
2352 if (m == MATCH_ERROR)
2355 if (gfc_match (" do") != MATCH_YES)
2358 m = gfc_match_st_label (&label);
2359 if (m == MATCH_ERROR)
2362 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2364 if (gfc_match_eos () == MATCH_YES)
2366 iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
2367 new_st.op = EXEC_DO_WHILE;
2371 /* Match an optional comma, if no comma is found, a space is obligatory. */
2372 if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
2375 /* Check for balanced parens. */
2377 if (gfc_match_parens () == MATCH_ERROR)
2380 if (gfc_match (" concurrent") == MATCH_YES)
2382 gfc_forall_iterator *head;
2385 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: DO CONCURRENT "
2386 "construct at %C") == FAILURE)
2392 m = match_forall_header (&head, &mask);
2396 if (m == MATCH_ERROR)
2397 goto concurr_cleanup;
2399 if (gfc_match_eos () != MATCH_YES)
2400 goto concurr_cleanup;
2403 && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2404 goto concurr_cleanup;
2406 new_st.label1 = label;
2407 new_st.op = EXEC_DO_CONCURRENT;
2408 new_st.expr1 = mask;
2409 new_st.ext.forall_iterator = head;
2414 gfc_syntax_error (ST_DO);
2415 gfc_free_expr (mask);
2416 gfc_free_forall_iterator (head);
2420 /* See if we have a DO WHILE. */
2421 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
2423 new_st.op = EXEC_DO_WHILE;
2427 /* The abortive DO WHILE may have done something to the symbol
2428 table, so we start over. */
2429 gfc_undo_symbols ();
2430 gfc_current_locus = old_loc;
2432 gfc_match_label (); /* This won't error. */
2433 gfc_match (" do "); /* This will work. */
2435 gfc_match_st_label (&label); /* Can't error out. */
2436 gfc_match_char (','); /* Optional comma. */
2438 m = gfc_match_iterator (&iter, 0);
2441 if (m == MATCH_ERROR)
2444 iter.var->symtree->n.sym->attr.implied_index = 0;
2445 gfc_check_do_variable (iter.var->symtree);
2447 if (gfc_match_eos () != MATCH_YES)
2449 gfc_syntax_error (ST_DO);
2453 new_st.op = EXEC_DO;
2457 && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2460 new_st.label1 = label;
2462 if (new_st.op == EXEC_DO_WHILE)
2463 new_st.expr1 = iter.end;
2466 new_st.ext.iterator = ip = gfc_get_iterator ();
2473 gfc_free_iterator (&iter, 0);
2479 /* Match an EXIT or CYCLE statement. */
2482 match_exit_cycle (gfc_statement st, gfc_exec_op op)
2484 gfc_state_data *p, *o;
2489 if (gfc_match_eos () == MATCH_YES)
2493 char name[GFC_MAX_SYMBOL_LEN + 1];
2496 m = gfc_match ("% %n%t", name);
2497 if (m == MATCH_ERROR)
2501 gfc_syntax_error (st);
2505 /* Find the corresponding symbol. If there's a BLOCK statement
2506 between here and the label, it is not in gfc_current_ns but a parent
2508 stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
2511 gfc_error ("Name '%s' in %s statement at %C is unknown",
2512 name, gfc_ascii_statement (st));
2517 if (sym->attr.flavor != FL_LABEL)
2519 gfc_error ("Name '%s' in %s statement at %C is not a construct name",
2520 name, gfc_ascii_statement (st));
2525 /* Find the loop specified by the label (or lack of a label). */
2526 for (o = NULL, p = gfc_state_stack; p; p = p->previous)
2527 if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
2529 else if (p->state == COMP_CRITICAL)
2531 gfc_error("%s statement at %C leaves CRITICAL construct",
2532 gfc_ascii_statement (st));
2535 else if (p->state == COMP_DO_CONCURRENT
2536 && (op == EXEC_EXIT || (sym && sym != p->sym)))
2538 /* F2008, C821 & C845. */
2539 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2540 gfc_ascii_statement (st));
2543 else if ((sym && sym == p->sym)
2544 || (!sym && (p->state == COMP_DO
2545 || p->state == COMP_DO_CONCURRENT)))
2551 gfc_error ("%s statement at %C is not within a construct",
2552 gfc_ascii_statement (st));
2554 gfc_error ("%s statement at %C is not within construct '%s'",
2555 gfc_ascii_statement (st), sym->name);
2560 /* Special checks for EXIT from non-loop constructs. */
2564 case COMP_DO_CONCURRENT:
2568 /* This is already handled above. */
2571 case COMP_ASSOCIATE:
2575 case COMP_SELECT_TYPE:
2577 if (op == EXEC_CYCLE)
2579 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2580 " construct '%s'", sym->name);
2583 gcc_assert (op == EXEC_EXIT);
2584 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: EXIT statement with no"
2585 " do-construct-name at %C") == FAILURE)
2590 gfc_error ("%s statement at %C is not applicable to construct '%s'",
2591 gfc_ascii_statement (st), sym->name);
2597 gfc_error ("%s statement at %C leaving OpenMP structured block",
2598 gfc_ascii_statement (st));
2602 for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++)
2606 && o->state == COMP_OMP_STRUCTURED_BLOCK
2607 && (o->head->op == EXEC_OMP_DO
2608 || o->head->op == EXEC_OMP_PARALLEL_DO))
2611 gcc_assert (o->head->next != NULL
2612 && (o->head->next->op == EXEC_DO
2613 || o->head->next->op == EXEC_DO_WHILE)
2614 && o->previous != NULL
2615 && o->previous->tail->op == o->head->op);
2616 if (o->previous->tail->ext.omp_clauses != NULL
2617 && o->previous->tail->ext.omp_clauses->collapse > 1)
2618 collapse = o->previous->tail->ext.omp_clauses->collapse;
2619 if (st == ST_EXIT && cnt <= collapse)
2621 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2624 if (st == ST_CYCLE && cnt < collapse)
2626 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2632 /* Save the first statement in the construct - needed by the backend. */
2633 new_st.ext.which_construct = p->construct;
2641 /* Match the EXIT statement. */
2644 gfc_match_exit (void)
2646 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
2650 /* Match the CYCLE statement. */
2653 gfc_match_cycle (void)
2655 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
2659 /* Match a number or character constant after an (ALL) STOP or PAUSE statement. */
2662 gfc_match_stopcode (gfc_statement st)
2669 if (gfc_match_eos () != MATCH_YES)
2671 m = gfc_match_init_expr (&e);
2672 if (m == MATCH_ERROR)
2677 if (gfc_match_eos () != MATCH_YES)
2681 if (gfc_pure (NULL))
2683 gfc_error ("%s statement not allowed in PURE procedure at %C",
2684 gfc_ascii_statement (st));
2688 if (gfc_implicit_pure (NULL))
2689 gfc_current_ns->proc_name->attr.implicit_pure = 0;
2691 if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
2693 gfc_error ("Image control statement STOP at %C in CRITICAL block");
2696 if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
2698 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
2704 if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
2706 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2713 gfc_error ("STOP code at %L must be scalar",
2718 if (e->ts.type == BT_CHARACTER
2719 && e->ts.kind != gfc_default_character_kind)
2721 gfc_error ("STOP code at %L must be default character KIND=%d",
2722 &e->where, (int) gfc_default_character_kind);
2726 if (e->ts.type == BT_INTEGER
2727 && e->ts.kind != gfc_default_integer_kind)
2729 gfc_error ("STOP code at %L must be default integer KIND=%d",
2730 &e->where, (int) gfc_default_integer_kind);
2738 new_st.op = EXEC_STOP;
2741 new_st.op = EXEC_ERROR_STOP;
2744 new_st.op = EXEC_PAUSE;
2751 new_st.ext.stop_code = -1;
2756 gfc_syntax_error (st);
2765 /* Match the (deprecated) PAUSE statement. */
2768 gfc_match_pause (void)
2772 m = gfc_match_stopcode (ST_PAUSE);
2775 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
2784 /* Match the STOP statement. */
2787 gfc_match_stop (void)
2789 return gfc_match_stopcode (ST_STOP);
2793 /* Match the ERROR STOP statement. */
2796 gfc_match_error_stop (void)
2798 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: ERROR STOP statement at %C")
2802 return gfc_match_stopcode (ST_ERROR_STOP);
2806 /* Match LOCK/UNLOCK statement. Syntax:
2807 LOCK ( lock-variable [ , lock-stat-list ] )
2808 UNLOCK ( lock-variable [ , sync-stat-list ] )
2809 where lock-stat is ACQUIRED_LOCK or sync-stat
2810 and sync-stat is STAT= or ERRMSG=. */
2813 lock_unlock_statement (gfc_statement st)
2816 gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg;
2817 bool saw_acq_lock, saw_stat, saw_errmsg;
2819 tmp = lockvar = acq_lock = stat = errmsg = NULL;
2820 saw_acq_lock = saw_stat = saw_errmsg = false;
2822 if (gfc_pure (NULL))
2824 gfc_error ("Image control statement %s at %C in PURE procedure",
2825 st == ST_LOCK ? "LOCK" : "UNLOCK");
2829 if (gfc_implicit_pure (NULL))
2830 gfc_current_ns->proc_name->attr.implicit_pure = 0;
2832 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
2834 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2838 if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
2840 gfc_error ("Image control statement %s at %C in CRITICAL block",
2841 st == ST_LOCK ? "LOCK" : "UNLOCK");
2845 if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
2847 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
2848 st == ST_LOCK ? "LOCK" : "UNLOCK");
2852 if (gfc_match_char ('(') != MATCH_YES)
2855 if (gfc_match ("%e", &lockvar) != MATCH_YES)
2857 m = gfc_match_char (',');
2858 if (m == MATCH_ERROR)
2862 m = gfc_match_char (')');
2870 m = gfc_match (" stat = %v", &tmp);
2871 if (m == MATCH_ERROR)
2877 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2883 m = gfc_match_char (',');
2891 m = gfc_match (" errmsg = %v", &tmp);
2892 if (m == MATCH_ERROR)
2898 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2904 m = gfc_match_char (',');
2912 m = gfc_match (" acquired_lock = %v", &tmp);
2913 if (m == MATCH_ERROR || st == ST_UNLOCK)
2919 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
2924 saw_acq_lock = true;
2926 m = gfc_match_char (',');
2937 if (m == MATCH_ERROR)
2940 if (gfc_match (" )%t") != MATCH_YES)
2947 new_st.op = EXEC_LOCK;
2950 new_st.op = EXEC_UNLOCK;
2956 new_st.expr1 = lockvar;
2957 new_st.expr2 = stat;
2958 new_st.expr3 = errmsg;
2959 new_st.expr4 = acq_lock;
2964 gfc_syntax_error (st);
2967 gfc_free_expr (tmp);
2968 gfc_free_expr (lockvar);
2969 gfc_free_expr (acq_lock);
2970 gfc_free_expr (stat);
2971 gfc_free_expr (errmsg);
2978 gfc_match_lock (void)
2980 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: LOCK statement at %C")
2984 return lock_unlock_statement (ST_LOCK);
2989 gfc_match_unlock (void)
2991 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: UNLOCK statement at %C")
2995 return lock_unlock_statement (ST_UNLOCK);
2999 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
3000 SYNC ALL [(sync-stat-list)]
3001 SYNC MEMORY [(sync-stat-list)]
3002 SYNC IMAGES (image-set [, sync-stat-list] )
3003 with sync-stat is int-expr or *. */
3006 sync_statement (gfc_statement st)
3009 gfc_expr *tmp, *imageset, *stat, *errmsg;
3010 bool saw_stat, saw_errmsg;
3012 tmp = imageset = stat = errmsg = NULL;
3013 saw_stat = saw_errmsg = false;
3015 if (gfc_pure (NULL))
3017 gfc_error ("Image control statement SYNC at %C in PURE procedure");
3021 if (gfc_implicit_pure (NULL))
3022 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3024 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C")
3028 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
3030 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3034 if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
3036 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3040 if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
3042 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3046 if (gfc_match_eos () == MATCH_YES)
3048 if (st == ST_SYNC_IMAGES)
3053 if (gfc_match_char ('(') != MATCH_YES)
3056 if (st == ST_SYNC_IMAGES)
3058 /* Denote '*' as imageset == NULL. */
3059 m = gfc_match_char ('*');
3060 if (m == MATCH_ERROR)
3064 if (gfc_match ("%e", &imageset) != MATCH_YES)
3067 m = gfc_match_char (',');
3068 if (m == MATCH_ERROR)
3072 m = gfc_match_char (')');
3081 m = gfc_match (" stat = %v", &tmp);
3082 if (m == MATCH_ERROR)
3088 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3094 if (gfc_match_char (',') == MATCH_YES)
3101 m = gfc_match (" errmsg = %v", &tmp);
3102 if (m == MATCH_ERROR)
3108 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3114 if (gfc_match_char (',') == MATCH_YES)
3124 if (m == MATCH_ERROR)
3127 if (gfc_match (" )%t") != MATCH_YES)
3134 new_st.op = EXEC_SYNC_ALL;
3136 case ST_SYNC_IMAGES:
3137 new_st.op = EXEC_SYNC_IMAGES;
3139 case ST_SYNC_MEMORY:
3140 new_st.op = EXEC_SYNC_MEMORY;
3146 new_st.expr1 = imageset;
3147 new_st.expr2 = stat;
3148 new_st.expr3 = errmsg;
3153 gfc_syntax_error (st);
3156 gfc_free_expr (tmp);
3157 gfc_free_expr (imageset);
3158 gfc_free_expr (stat);
3159 gfc_free_expr (errmsg);
3165 /* Match SYNC ALL statement. */
3168 gfc_match_sync_all (void)
3170 return sync_statement (ST_SYNC_ALL);
3174 /* Match SYNC IMAGES statement. */
3177 gfc_match_sync_images (void)
3179 return sync_statement (ST_SYNC_IMAGES);
3183 /* Match SYNC MEMORY statement. */
3186 gfc_match_sync_memory (void)
3188 return sync_statement (ST_SYNC_MEMORY);
3192 /* Match a CONTINUE statement. */
3195 gfc_match_continue (void)
3197 if (gfc_match_eos () != MATCH_YES)
3199 gfc_syntax_error (ST_CONTINUE);
3203 new_st.op = EXEC_CONTINUE;
3208 /* Match the (deprecated) ASSIGN statement. */
3211 gfc_match_assign (void)
3214 gfc_st_label *label;
3216 if (gfc_match (" %l", &label) == MATCH_YES)
3218 if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
3220 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
3222 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
3227 expr->symtree->n.sym->attr.assign = 1;
3229 new_st.op = EXEC_LABEL_ASSIGN;
3230 new_st.label1 = label;
3231 new_st.expr1 = expr;
3239 /* Match the GO TO statement. As a computed GOTO statement is
3240 matched, it is transformed into an equivalent SELECT block. No
3241 tree is necessary, and the resulting jumps-to-jumps are
3242 specifically optimized away by the back end. */
3245 gfc_match_goto (void)
3247 gfc_code *head, *tail;
3250 gfc_st_label *label;
3254 if (gfc_match (" %l%t", &label) == MATCH_YES)
3256 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
3259 new_st.op = EXEC_GOTO;
3260 new_st.label1 = label;
3264 /* The assigned GO TO statement. */
3266 if (gfc_match_variable (&expr, 0) == MATCH_YES)
3268 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
3273 new_st.op = EXEC_GOTO;
3274 new_st.expr1 = expr;
3276 if (gfc_match_eos () == MATCH_YES)
3279 /* Match label list. */
3280 gfc_match_char (',');
3281 if (gfc_match_char ('(') != MATCH_YES)
3283 gfc_syntax_error (ST_GOTO);
3290 m = gfc_match_st_label (&label);
3294 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
3298 head = tail = gfc_get_code ();
3301 tail->block = gfc_get_code ();
3305 tail->label1 = label;
3306 tail->op = EXEC_GOTO;
3308 while (gfc_match_char (',') == MATCH_YES);
3310 if (gfc_match (")%t") != MATCH_YES)
3315 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3318 new_st.block = head;
3323 /* Last chance is a computed GO TO statement. */
3324 if (gfc_match_char ('(') != MATCH_YES)
3326 gfc_syntax_error (ST_GOTO);
3335 m = gfc_match_st_label (&label);
3339 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
3343 head = tail = gfc_get_code ();
3346 tail->block = gfc_get_code ();
3350 cp = gfc_get_case ();
3351 cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
3354 tail->op = EXEC_SELECT;
3355 tail->ext.block.case_list = cp;
3357 tail->next = gfc_get_code ();
3358 tail->next->op = EXEC_GOTO;
3359 tail->next->label1 = label;
3361 while (gfc_match_char (',') == MATCH_YES);
3363 if (gfc_match_char (')') != MATCH_YES)
3368 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3372 /* Get the rest of the statement. */
3373 gfc_match_char (',');
3375 if (gfc_match (" %e%t", &expr) != MATCH_YES)
3378 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Computed GOTO "
3379 "at %C") == FAILURE)
3382 /* At this point, a computed GOTO has been fully matched and an
3383 equivalent SELECT statement constructed. */
3385 new_st.op = EXEC_SELECT;
3386 new_st.expr1 = NULL;
3388 /* Hack: For a "real" SELECT, the expression is in expr. We put
3389 it in expr2 so we can distinguish then and produce the correct
3391 new_st.expr2 = expr;
3392 new_st.block = head;
3396 gfc_syntax_error (ST_GOTO);
3398 gfc_free_statements (head);
3403 /* Frees a list of gfc_alloc structures. */
3406 gfc_free_alloc_list (gfc_alloc *p)
3413 gfc_free_expr (p->expr);
3419 /* Match an ALLOCATE statement. */
3422 gfc_match_allocate (void)
3424 gfc_alloc *head, *tail;
3425 gfc_expr *stat, *errmsg, *tmp, *source, *mold;
3429 locus old_locus, deferred_locus;
3430 bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
3433 stat = errmsg = source = mold = tmp = NULL;
3434 saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
3436 if (gfc_match_char ('(') != MATCH_YES)
3439 /* Match an optional type-spec. */
3440 old_locus = gfc_current_locus;
3441 m = match_type_spec (&ts);
3442 if (m == MATCH_ERROR)
3444 else if (m == MATCH_NO)
3446 char name[GFC_MAX_SYMBOL_LEN + 3];
3448 if (gfc_match ("%n :: ", name) == MATCH_YES)
3450 gfc_error ("Error in type-spec at %L", &old_locus);
3454 ts.type = BT_UNKNOWN;
3458 if (gfc_match (" :: ") == MATCH_YES)
3460 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
3461 "ALLOCATE at %L", &old_locus) == FAILURE)
3466 gfc_error ("Type-spec at %L cannot contain a deferred "
3467 "type parameter", &old_locus);
3473 ts.type = BT_UNKNOWN;
3474 gfc_current_locus = old_locus;
3481 head = tail = gfc_get_alloc ();
3484 tail->next = gfc_get_alloc ();
3488 m = gfc_match_variable (&tail->expr, 0);
3491 if (m == MATCH_ERROR)
3494 if (gfc_check_do_variable (tail->expr->symtree))
3497 if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
3499 gfc_error ("Bad allocate-object at %C for a PURE procedure");
3503 if (gfc_implicit_pure (NULL)
3504 && gfc_impure_variable (tail->expr->symtree->n.sym))
3505 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3507 if (tail->expr->ts.deferred)
3509 saw_deferred = true;
3510 deferred_locus = tail->expr->where;
3513 if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS
3514 || gfc_find_state (COMP_CRITICAL) == SUCCESS)
3517 bool coarray = tail->expr->symtree->n.sym->attr.codimension;
3518 for (ref = tail->expr->ref; ref; ref = ref->next)
3519 if (ref->type == REF_COMPONENT)
3520 coarray = ref->u.c.component->attr.codimension;
3522 if (coarray && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
3524 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
3527 if (coarray && gfc_find_state (COMP_CRITICAL) == SUCCESS)
3529 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
3534 /* The ALLOCATE statement had an optional typespec. Check the
3536 if (ts.type != BT_UNKNOWN)
3538 /* Enforce F03:C624. */
3539 if (!gfc_type_compatible (&tail->expr->ts, &ts))
3541 gfc_error ("Type of entity at %L is type incompatible with "
3542 "typespec", &tail->expr->where);
3546 /* Enforce F03:C627. */
3547 if (ts.kind != tail->expr->ts.kind)
3549 gfc_error ("Kind type parameter for entity at %L differs from "
3550 "the kind type parameter of the typespec",
3551 &tail->expr->where);
3556 if (tail->expr->ts.type == BT_DERIVED)
3557 tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
3559 /* FIXME: disable the checking on derived types and arrays. */
3560 sym = tail->expr->symtree->n.sym;
3561 b1 = !(tail->expr->ref
3562 && (tail->expr->ref->type == REF_COMPONENT
3563 || tail->expr->ref->type == REF_ARRAY));
3564 if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok)
3565 b2 = !(CLASS_DATA (sym)->attr.allocatable
3566 || CLASS_DATA (sym)->attr.class_pointer);
3568 b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
3569 || sym->attr.proc_pointer);
3570 b3 = sym && sym->ns && sym->ns->proc_name
3571 && (sym->ns->proc_name->attr.allocatable
3572 || sym->ns->proc_name->attr.pointer
3573 || sym->ns->proc_name->attr.proc_pointer);
3574 if (b1 && b2 && !b3)
3576 gfc_error ("Allocate-object at %L is not a nonprocedure pointer "
3577 "or an allocatable variable", &tail->expr->where);
3581 if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
3583 gfc_error ("Shape specification for allocatable scalar at %C");
3587 if (gfc_match_char (',') != MATCH_YES)
3592 m = gfc_match (" stat = %v", &tmp);
3593 if (m == MATCH_ERROR)
3600 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3608 if (gfc_check_do_variable (stat->symtree))
3611 if (gfc_match_char (',') == MATCH_YES)
3612 goto alloc_opt_list;
3615 m = gfc_match (" errmsg = %v", &tmp);
3616 if (m == MATCH_ERROR)
3620 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L",
3621 &tmp->where) == FAILURE)
3627 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3635 if (gfc_match_char (',') == MATCH_YES)
3636 goto alloc_opt_list;
3639 m = gfc_match (" source = %e", &tmp);
3640 if (m == MATCH_ERROR)
3644 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L",
3645 &tmp->where) == FAILURE)
3651 gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
3655 /* The next 2 conditionals check C631. */
3656 if (ts.type != BT_UNKNOWN)
3658 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
3659 &tmp->where, &old_locus);
3665 gfc_error ("SOURCE tag at %L requires only a single entity in "
3666 "the allocation-list", &tmp->where);
3674 if (gfc_match_char (',') == MATCH_YES)
3675 goto alloc_opt_list;
3678 m = gfc_match (" mold = %e", &tmp);
3679 if (m == MATCH_ERROR)
3683 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: MOLD tag at %L",
3684 &tmp->where) == FAILURE)
3687 /* Check F08:C636. */
3690 gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
3694 /* Check F08:C637. */
3695 if (ts.type != BT_UNKNOWN)
3697 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
3698 &tmp->where, &old_locus);
3707 if (gfc_match_char (',') == MATCH_YES)
3708 goto alloc_opt_list;
3711 gfc_gobble_whitespace ();
3713 if (gfc_peek_char () == ')')
3717 if (gfc_match (" )%t") != MATCH_YES)
3720 /* Check F08:C637. */
3723 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
3724 &mold->where, &source->where);
3728 /* Check F03:C623, */
3729 if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold)
3731 gfc_error ("Allocate-object at %L with a deferred type parameter "
3732 "requires either a type-spec or SOURCE tag or a MOLD tag",
3737 new_st.op = EXEC_ALLOCATE;
3738 new_st.expr1 = stat;
3739 new_st.expr2 = errmsg;
3741 new_st.expr3 = source;
3743 new_st.expr3 = mold;
3744 new_st.ext.alloc.list = head;
3745 new_st.ext.alloc.ts = ts;
3750 gfc_syntax_error (ST_ALLOCATE);
3753 gfc_free_expr (errmsg);
3754 gfc_free_expr (source);
3755 gfc_free_expr (stat);
3756 gfc_free_expr (mold);
3757 if (tmp && tmp->expr_type) gfc_free_expr (tmp);
3758 gfc_free_alloc_list (head);
3763 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
3764 a set of pointer assignments to intrinsic NULL(). */
3767 gfc_match_nullify (void)
3775 if (gfc_match_char ('(') != MATCH_YES)
3780 m = gfc_match_variable (&p, 0);
3781 if (m == MATCH_ERROR)
3786 if (gfc_check_do_variable (p->symtree))
3790 if (gfc_is_coindexed (p))
3792 gfc_error ("Pointer object at %C shall not be conindexed");
3796 /* build ' => NULL() '. */
3797 e = gfc_get_null_expr (&gfc_current_locus);
3799 /* Chain to list. */
3804 tail->next = gfc_get_code ();
3808 tail->op = EXEC_POINTER_ASSIGN;
3812 if (gfc_match (" )%t") == MATCH_YES)
3814 if (gfc_match_char (',') != MATCH_YES)
3821 gfc_syntax_error (ST_NULLIFY);
3824 gfc_free_statements (new_st.next);
3826 gfc_free_expr (new_st.expr1);
3827 new_st.expr1 = NULL;
3828 gfc_free_expr (new_st.expr2);
3829 new_st.expr2 = NULL;
3834 /* Match a DEALLOCATE statement. */
3837 gfc_match_deallocate (void)
3839 gfc_alloc *head, *tail;
3840 gfc_expr *stat, *errmsg, *tmp;
3843 bool saw_stat, saw_errmsg, b1, b2;
3846 stat = errmsg = tmp = NULL;
3847 saw_stat = saw_errmsg = false;
3849 if (gfc_match_char ('(') != MATCH_YES)
3855 head = tail = gfc_get_alloc ();
3858 tail->next = gfc_get_alloc ();
3862 m = gfc_match_variable (&tail->expr, 0);
3863 if (m == MATCH_ERROR)
3868 if (gfc_check_do_variable (tail->expr->symtree))
3871 sym = tail->expr->symtree->n.sym;
3873 if (gfc_pure (NULL) && gfc_impure_variable (sym))
3875 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3879 if (gfc_implicit_pure (NULL) && gfc_impure_variable (sym))
3880 gfc_current_ns->proc_name->attr.implicit_pure = 0;
3882 if (gfc_is_coarray (tail->expr)
3883 && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
3885 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
3889 if (gfc_is_coarray (tail->expr)
3890 && gfc_find_state (COMP_CRITICAL) == SUCCESS)
3892 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
3896 /* FIXME: disable the checking on derived types. */
3897 b1 = !(tail->expr->ref
3898 && (tail->expr->ref->type == REF_COMPONENT
3899 || tail->expr->ref->type == REF_ARRAY));
3900 if (sym && sym->ts.type == BT_CLASS)
3901 b2 = !(CLASS_DATA (sym)->attr.allocatable
3902 || CLASS_DATA (sym)->attr.class_pointer);
3904 b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
3905 || sym->attr.proc_pointer);
3908 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3909 "or an allocatable variable");
3913 if (gfc_match_char (',') != MATCH_YES)
3918 m = gfc_match (" stat = %v", &tmp);
3919 if (m == MATCH_ERROR)
3925 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3926 gfc_free_expr (tmp);
3933 if (gfc_check_do_variable (stat->symtree))
3936 if (gfc_match_char (',') == MATCH_YES)
3937 goto dealloc_opt_list;
3940 m = gfc_match (" errmsg = %v", &tmp);
3941 if (m == MATCH_ERROR)
3945 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
3946 &tmp->where) == FAILURE)
3951 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3952 gfc_free_expr (tmp);
3959 if (gfc_match_char (',') == MATCH_YES)
3960 goto dealloc_opt_list;
3963 gfc_gobble_whitespace ();
3965 if (gfc_peek_char () == ')')
3969 if (gfc_match (" )%t") != MATCH_YES)
3972 new_st.op = EXEC_DEALLOCATE;
3973 new_st.expr1 = stat;
3974 new_st.expr2 = errmsg;
3975 new_st.ext.alloc.list = head;
3980 gfc_syntax_error (ST_DEALLOCATE);
3983 gfc_free_expr (errmsg);
3984 gfc_free_expr (stat);
3985 gfc_free_alloc_list (head);
3990 /* Match a RETURN statement. */
3993 gfc_match_return (void)
3997 gfc_compile_state s;
4001 if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
4003 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4007 if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
4009 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4013 if (gfc_match_eos () == MATCH_YES)
4016 if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
4018 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4023 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Alternate RETURN "
4024 "at %C") == FAILURE)
4027 if (gfc_current_form == FORM_FREE)
4029 /* The following are valid, so we can't require a blank after the
4033 char c = gfc_peek_ascii_char ();
4034 if (ISALPHA (c) || ISDIGIT (c))
4038 m = gfc_match (" %e%t", &e);
4041 if (m == MATCH_ERROR)
4044 gfc_syntax_error (ST_RETURN);
4051 gfc_enclosing_unit (&s);
4052 if (s == COMP_PROGRAM
4053 && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
4054 "main program at %C") == FAILURE)
4057 new_st.op = EXEC_RETURN;
4064 /* Match the call of a type-bound procedure, if CALL%var has already been
4065 matched and var found to be a derived-type variable. */
4068 match_typebound_call (gfc_symtree* varst)
4073 base = gfc_get_expr ();
4074 base->expr_type = EXPR_VARIABLE;
4075 base->symtree = varst;
4076 base->where = gfc_current_locus;
4077 gfc_set_sym_referenced (varst->n.sym);
4079 m = gfc_match_varspec (base, 0, true, true);
4081 gfc_error ("Expected component reference at %C");
4085 if (gfc_match_eos () != MATCH_YES)
4087 gfc_error ("Junk after CALL at %C");
4091 if (base->expr_type == EXPR_COMPCALL)
4092 new_st.op = EXEC_COMPCALL;
4093 else if (base->expr_type == EXPR_PPC)
4094 new_st.op = EXEC_CALL_PPC;
4097 gfc_error ("Expected type-bound procedure or procedure pointer component "
4101 new_st.expr1 = base;
4107 /* Match a CALL statement. The tricky part here are possible
4108 alternate return specifiers. We handle these by having all
4109 "subroutines" actually return an integer via a register that gives
4110 the return number. If the call specifies alternate returns, we
4111 generate code for a SELECT statement whose case clauses contain
4112 GOTOs to the various labels. */
4115 gfc_match_call (void)
4117 char name[GFC_MAX_SYMBOL_LEN + 1];
4118 gfc_actual_arglist *a, *arglist;
4128 m = gfc_match ("% %n", name);
4134 if (gfc_get_ha_sym_tree (name, &st))
4139 /* If this is a variable of derived-type, it probably starts a type-bound
4141 if ((sym->attr.flavor != FL_PROCEDURE
4142 || gfc_is_function_return_value (sym, gfc_current_ns))
4143 && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
4144 return match_typebound_call (st);
4146 /* If it does not seem to be callable (include functions so that the
4147 right association is made. They are thrown out in resolution.)
4149 if (!sym->attr.generic
4150 && !sym->attr.subroutine
4151 && !sym->attr.function)
4153 if (!(sym->attr.external && !sym->attr.referenced))
4155 /* ...create a symbol in this scope... */
4156 if (sym->ns != gfc_current_ns
4157 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
4160 if (sym != st->n.sym)
4164 /* ...and then to try to make the symbol into a subroutine. */
4165 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
4169 gfc_set_sym_referenced (sym);
4171 if (gfc_match_eos () != MATCH_YES)
4173 m = gfc_match_actual_arglist (1, &arglist);
4176 if (m == MATCH_ERROR)
4179 if (gfc_match_eos () != MATCH_YES)
4183 /* If any alternate return labels were found, construct a SELECT
4184 statement that will jump to the right place. */
4187 for (a = arglist; a; a = a->next)
4188 if (a->expr == NULL)
4193 gfc_symtree *select_st;
4194 gfc_symbol *select_sym;
4195 char name[GFC_MAX_SYMBOL_LEN + 1];
4197 new_st.next = c = gfc_get_code ();
4198 c->op = EXEC_SELECT;
4199 sprintf (name, "_result_%s", sym->name);
4200 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
4202 select_sym = select_st->n.sym;
4203 select_sym->ts.type = BT_INTEGER;
4204 select_sym->ts.kind = gfc_default_integer_kind;
4205 gfc_set_sym_referenced (select_sym);
4206 c->expr1 = gfc_get_expr ();
4207 c->expr1->expr_type = EXPR_VARIABLE;
4208 c->expr1->symtree = select_st;
4209 c->expr1->ts = select_sym->ts;
4210 c->expr1->where = gfc_current_locus;
4213 for (a = arglist; a; a = a->next)
4215 if (a->expr != NULL)
4218 if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
4223 c->block = gfc_get_code ();
4225 c->op = EXEC_SELECT;
4227 new_case = gfc_get_case ();
4228 new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
4229 new_case->low = new_case->high;
4230 c->ext.block.case_list = new_case;
4232 c->next = gfc_get_code ();
4233 c->next->op = EXEC_GOTO;
4234 c->next->label1 = a->label;
4238 new_st.op = EXEC_CALL;
4239 new_st.symtree = st;
4240 new_st.ext.actual = arglist;
4245 gfc_syntax_error (ST_CALL);
4248 gfc_free_actual_arglist (arglist);
4253 /* Given a name, return a pointer to the common head structure,
4254 creating it if it does not exist. If FROM_MODULE is nonzero, we
4255 mangle the name so that it doesn't interfere with commons defined
4256 in the using namespace.
4257 TODO: Add to global symbol tree. */
4260 gfc_get_common (const char *name, int from_module)
4263 static int serial = 0;
4264 char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
4268 /* A use associated common block is only needed to correctly layout
4269 the variables it contains. */
4270 snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
4271 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
4275 st = gfc_find_symtree (gfc_current_ns->common_root, name);
4278 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
4281 if (st->n.common == NULL)
4283 st->n.common = gfc_get_common_head ();
4284 st->n.common->where = gfc_current_locus;
4285 strcpy (st->n.common->name, name);
4288 return st->n.common;
4292 /* Match a common block name. */
4294 match match_common_name (char *name)
4298 if (gfc_match_char ('/') == MATCH_NO)
4304 if (gfc_match_char ('/') == MATCH_YES)
4310 m = gfc_match_name (name);
4312 if (m == MATCH_ERROR)
4314 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
4317 gfc_error ("Syntax error in common block name at %C");
4322 /* Match a COMMON statement. */
4325 gfc_match_common (void)
4327 gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
4328 char name[GFC_MAX_SYMBOL_LEN + 1];
4335 old_blank_common = gfc_current_ns->blank_common.head;
4336 if (old_blank_common)
4338 while (old_blank_common->common_next)
4339 old_blank_common = old_blank_common->common_next;
4346 m = match_common_name (name);
4347 if (m == MATCH_ERROR)
4350 gsym = gfc_get_gsymbol (name);
4351 if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
4353 gfc_error ("Symbol '%s' at %C is already an external symbol that "
4354 "is not COMMON", name);
4358 if (gsym->type == GSYM_UNKNOWN)
4360 gsym->type = GSYM_COMMON;
4361 gsym->where = gfc_current_locus;
4367 if (name[0] == '\0')
4369 t = &gfc_current_ns->blank_common;
4370 if (t->head == NULL)
4371 t->where = gfc_current_locus;
4375 t = gfc_get_common (name, 0);
4384 while (tail->common_next)
4385 tail = tail->common_next;
4388 /* Grab the list of symbols. */
4391 m = gfc_match_symbol (&sym, 0);
4392 if (m == MATCH_ERROR)
4397 /* Store a ref to the common block for error checking. */
4398 sym->common_block = t;
4400 /* See if we know the current common block is bind(c), and if
4401 so, then see if we can check if the symbol is (which it'll
4402 need to be). This can happen if the bind(c) attr stmt was
4403 applied to the common block, and the variable(s) already
4404 defined, before declaring the common block. */
4405 if (t->is_bind_c == 1)
4407 if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
4409 /* If we find an error, just print it and continue,
4410 cause it's just semantic, and we can see if there
4412 gfc_error_now ("Variable '%s' at %L in common block '%s' "
4413 "at %C must be declared with a C "
4414 "interoperable kind since common block "
4416 sym->name, &(sym->declared_at), t->name,
4420 if (sym->attr.is_bind_c == 1)
4421 gfc_error_now ("Variable '%s' in common block "
4422 "'%s' at %C can not be bind(c) since "
4423 "it is not global", sym->name, t->name);
4426 if (sym->attr.in_common)
4428 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
4433 if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
4434 || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
4436 if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
4437 "can only be COMMON in "
4438 "BLOCK DATA", sym->name)
4443 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
4447 tail->common_next = sym;
4453 /* Deal with an optional array specification after the
4455 m = gfc_match_array_spec (&as, true, true);
4456 if (m == MATCH_ERROR)
4461 if (as->type != AS_EXPLICIT)
4463 gfc_error ("Array specification for symbol '%s' in COMMON "
4464 "at %C must be explicit", sym->name);
4468 if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
4471 if (sym->attr.pointer)
4473 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
4474 "POINTER array", sym->name);
4483 sym->common_head = t;
4485 /* Check to see if the symbol is already in an equivalence group.
4486 If it is, set the other members as being in common. */
4487 if (sym->attr.in_equivalence)
4489 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
4491 for (e2 = e1; e2; e2 = e2->eq)
4492 if (e2->expr->symtree->n.sym == sym)
4499 for (e2 = e1; e2; e2 = e2->eq)
4501 other = e2->expr->symtree->n.sym;
4502 if (other->common_head
4503 && other->common_head != sym->common_head)
4505 gfc_error ("Symbol '%s', in COMMON block '%s' at "
4506 "%C is being indirectly equivalenced to "
4507 "another COMMON block '%s'",
4508 sym->name, sym->common_head->name,
4509 other->common_head->name);
4512 other->attr.in_common = 1;
4513 other->common_head = t;
4519 gfc_gobble_whitespace ();
4520 if (gfc_match_eos () == MATCH_YES)
4522 if (gfc_peek_ascii_char () == '/')
4524 if (gfc_match_char (',') != MATCH_YES)
4526 gfc_gobble_whitespace ();
4527 if (gfc_peek_ascii_char () == '/')
4536 gfc_syntax_error (ST_COMMON);
4539 if (old_blank_common)
4540 old_blank_common->common_next = NULL;
4542 gfc_current_ns->blank_common.head = NULL;
4543 gfc_free_array_spec (as);
4548 /* Match a BLOCK DATA program unit. */
4551 gfc_match_block_data (void)
4553 char name[GFC_MAX_SYMBOL_LEN + 1];
4557 if (gfc_match_eos () == MATCH_YES)
4559 gfc_new_block = NULL;
4563 m = gfc_match ("% %n%t", name);
4567 if (gfc_get_symbol (name, NULL, &sym))
4570 if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
4573 gfc_new_block = sym;
4579 /* Free a namelist structure. */
4582 gfc_free_namelist (gfc_namelist *name)
4586 for (; name; name = n)
4594 /* Match a NAMELIST statement. */
4597 gfc_match_namelist (void)
4599 gfc_symbol *group_name, *sym;
4603 m = gfc_match (" / %s /", &group_name);
4606 if (m == MATCH_ERROR)
4611 if (group_name->ts.type != BT_UNKNOWN)
4613 gfc_error ("Namelist group name '%s' at %C already has a basic "
4614 "type of %s", group_name->name,
4615 gfc_typename (&group_name->ts));
4619 if (group_name->attr.flavor == FL_NAMELIST
4620 && group_name->attr.use_assoc
4621 && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
4622 "at %C already is USE associated and can"
4623 "not be respecified.", group_name->name)
4627 if (group_name->attr.flavor != FL_NAMELIST
4628 && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
4629 group_name->name, NULL) == FAILURE)
4634 m = gfc_match_symbol (&sym, 1);
4637 if (m == MATCH_ERROR)
4640 if (sym->attr.in_namelist == 0
4641 && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
4644 /* Use gfc_error_check here, rather than goto error, so that
4645 these are the only errors for the next two lines. */
4646 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
4648 gfc_error ("Assumed size array '%s' in namelist '%s' at "
4649 "%C is not allowed", sym->name, group_name->name);
4653 nl = gfc_get_namelist ();
4657 if (group_name->namelist == NULL)
4658 group_name->namelist = group_name->namelist_tail = nl;
4661 group_name->namelist_tail->next = nl;
4662 group_name->namelist_tail = nl;
4665 if (gfc_match_eos () == MATCH_YES)
4668 m = gfc_match_char (',');
4670 if (gfc_match_char ('/') == MATCH_YES)
4672 m2 = gfc_match (" %s /", &group_name);
4673 if (m2 == MATCH_YES)
4675 if (m2 == MATCH_ERROR)
4689 gfc_syntax_error (ST_NAMELIST);
4696 /* Match a MODULE statement. */
4699 gfc_match_module (void)
4703 m = gfc_match (" %s%t", &gfc_new_block);
4707 if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
4708 gfc_new_block->name, NULL) == FAILURE)
4715 /* Free equivalence sets and lists. Recursively is the easiest way to
4719 gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop)
4724 gfc_free_equiv (eq->eq);
4725 gfc_free_equiv_until (eq->next, stop);
4726 gfc_free_expr (eq->expr);
4732 gfc_free_equiv (gfc_equiv *eq)
4734 gfc_free_equiv_until (eq, NULL);
4738 /* Match an EQUIVALENCE statement. */
4741 gfc_match_equivalence (void)
4743 gfc_equiv *eq, *set, *tail;
4747 gfc_common_head *common_head = NULL;
4755 eq = gfc_get_equiv ();
4759 eq->next = gfc_current_ns->equiv;
4760 gfc_current_ns->equiv = eq;
4762 if (gfc_match_char ('(') != MATCH_YES)
4766 common_flag = FALSE;
4771 m = gfc_match_equiv_variable (&set->expr);
4772 if (m == MATCH_ERROR)
4777 /* count the number of objects. */
4780 if (gfc_match_char ('%') == MATCH_YES)
4782 gfc_error ("Derived type component %C is not a "
4783 "permitted EQUIVALENCE member");
4787 for (ref = set->expr->ref; ref; ref = ref->next)
4788 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
4790 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
4791 "be an array section");
4795 sym = set->expr->symtree->n.sym;
4797 if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
4800 if (sym->attr.in_common)
4803 common_head = sym->common_head;
4806 if (gfc_match_char (')') == MATCH_YES)
4809 if (gfc_match_char (',') != MATCH_YES)
4812 set->eq = gfc_get_equiv ();
4818 gfc_error ("EQUIVALENCE at %C requires two or more objects");
4822 /* If one of the members of an equivalence is in common, then
4823 mark them all as being in common. Before doing this, check
4824 that members of the equivalence group are not in different
4827 for (set = eq; set; set = set->eq)
4829 sym = set->expr->symtree->n.sym;
4830 if (sym->common_head && sym->common_head != common_head)
4832 gfc_error ("Attempt to indirectly overlap COMMON "
4833 "blocks %s and %s by EQUIVALENCE at %C",
4834 sym->common_head->name, common_head->name);
4837 sym->attr.in_common = 1;
4838 sym->common_head = common_head;
4841 if (gfc_match_eos () == MATCH_YES)
4843 if (gfc_match_char (',') != MATCH_YES)
4845 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
4853 gfc_syntax_error (ST_EQUIVALENCE);
4859 gfc_free_equiv (gfc_current_ns->equiv);
4860 gfc_current_ns->equiv = eq;
4866 /* Check that a statement function is not recursive. This is done by looking
4867 for the statement function symbol(sym) by looking recursively through its
4868 expression(e). If a reference to sym is found, true is returned.
4869 12.5.4 requires that any variable of function that is implicitly typed
4870 shall have that type confirmed by any subsequent type declaration. The
4871 implicit typing is conveniently done here. */
4873 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
4876 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
4882 switch (e->expr_type)
4885 if (e->symtree == NULL)
4888 /* Check the name before testing for nested recursion! */
4889 if (sym->name == e->symtree->n.sym->name)
4892 /* Catch recursion via other statement functions. */
4893 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
4894 && e->symtree->n.sym->value
4895 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
4898 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4899 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4904 if (e->symtree && sym->name == e->symtree->n.sym->name)
4907 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4908 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4920 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
4922 return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
4926 /* Match a statement function declaration. It is so easy to match
4927 non-statement function statements with a MATCH_ERROR as opposed to
4928 MATCH_NO that we suppress error message in most cases. */
4931 gfc_match_st_function (void)
4933 gfc_error_buf old_error;
4938 m = gfc_match_symbol (&sym, 0);
4942 gfc_push_error (&old_error);
4944 if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
4945 sym->name, NULL) == FAILURE)
4948 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
4951 m = gfc_match (" = %e%t", &expr);
4955 gfc_free_error (&old_error);
4956 if (m == MATCH_ERROR)
4959 if (recursive_stmt_fcn (expr, sym))
4961 gfc_error ("Statement function at %L is recursive", &expr->where);
4967 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
4968 "Statement function at %C") == FAILURE)
4974 gfc_pop_error (&old_error);
4979 /***************** SELECT CASE subroutines ******************/
4981 /* Free a single case structure. */
4984 free_case (gfc_case *p)
4986 if (p->low == p->high)
4988 gfc_free_expr (p->low);
4989 gfc_free_expr (p->high);
4994 /* Free a list of case structures. */
4997 gfc_free_case_list (gfc_case *p)
5009 /* Match a single case selector. */
5012 match_case_selector (gfc_case **cp)
5017 c = gfc_get_case ();
5018 c->where = gfc_current_locus;
5020 if (gfc_match_char (':') == MATCH_YES)
5022 m = gfc_match_init_expr (&c->high);
5025 if (m == MATCH_ERROR)
5030 m = gfc_match_init_expr (&c->low);
5031 if (m == MATCH_ERROR)
5036 /* If we're not looking at a ':' now, make a range out of a single
5037 target. Else get the upper bound for the case range. */
5038 if (gfc_match_char (':') != MATCH_YES)
5042 m = gfc_match_init_expr (&c->high);
5043 if (m == MATCH_ERROR)
5045 /* MATCH_NO is fine. It's OK if nothing is there! */
5053 gfc_error ("Expected initialization expression in CASE at %C");
5061 /* Match the end of a case statement. */
5064 match_case_eos (void)
5066 char name[GFC_MAX_SYMBOL_LEN + 1];
5069 if (gfc_match_eos () == MATCH_YES)
5072 /* If the case construct doesn't have a case-construct-name, we
5073 should have matched the EOS. */
5074 if (!gfc_current_block ())
5077 gfc_gobble_whitespace ();
5079 m = gfc_match_name (name);
5083 if (strcmp (name, gfc_current_block ()->name) != 0)
5085 gfc_error ("Expected block name '%s' of SELECT construct at %C",
5086 gfc_current_block ()->name);
5090 return gfc_match_eos ();
5094 /* Match a SELECT statement. */
5097 gfc_match_select (void)
5102 m = gfc_match_label ();
5103 if (m == MATCH_ERROR)
5106 m = gfc_match (" select case ( %e )%t", &expr);
5110 new_st.op = EXEC_SELECT;
5111 new_st.expr1 = expr;
5117 /* Push the current selector onto the SELECT TYPE stack. */
5120 select_type_push (gfc_symbol *sel)
5122 gfc_select_type_stack *top = gfc_get_select_type_stack ();
5123 top->selector = sel;
5125 top->prev = select_type_stack;
5127 select_type_stack = top;
5131 /* Set the temporary for the current SELECT TYPE selector. */
5134 select_type_set_tmp (gfc_typespec *ts)
5136 char name[GFC_MAX_SYMBOL_LEN];
5141 select_type_stack->tmp = NULL;
5145 if (!gfc_type_is_extensible (ts->u.derived))
5148 if (ts->type == BT_CLASS)
5149 sprintf (name, "__tmp_class_%s", ts->u.derived->name);
5151 sprintf (name, "__tmp_type_%s", ts->u.derived->name);
5152 gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
5153 gfc_add_type (tmp->n.sym, ts, NULL);
5154 gfc_set_sym_referenced (tmp->n.sym);
5155 gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
5156 tmp->n.sym->attr.select_type_temporary = 1;
5157 if (ts->type == BT_CLASS)
5158 gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
5159 &tmp->n.sym->as, false);
5161 /* Add an association for it, so the rest of the parser knows it is
5162 an associate-name. The target will be set during resolution. */
5163 tmp->n.sym->assoc = gfc_get_association_list ();
5164 tmp->n.sym->assoc->dangling = 1;
5165 tmp->n.sym->assoc->st = tmp;
5167 select_type_stack->tmp = tmp;
5171 /* Match a SELECT TYPE statement. */
5174 gfc_match_select_type (void)
5176 gfc_expr *expr1, *expr2 = NULL;
5178 char name[GFC_MAX_SYMBOL_LEN];
5180 m = gfc_match_label ();
5181 if (m == MATCH_ERROR)
5184 m = gfc_match (" select type ( ");
5188 gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
5190 m = gfc_match (" %n => %e", name, &expr2);
5193 expr1 = gfc_get_expr();
5194 expr1->expr_type = EXPR_VARIABLE;
5195 if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
5200 if (expr2->ts.type == BT_UNKNOWN)
5201 expr1->symtree->n.sym->attr.untyped = 1;
5203 expr1->symtree->n.sym->ts = expr2->ts;
5204 expr1->symtree->n.sym->attr.flavor = FL_VARIABLE;
5205 expr1->symtree->n.sym->attr.referenced = 1;
5206 expr1->symtree->n.sym->attr.class_ok = 1;
5210 m = gfc_match (" %e ", &expr1);
5215 m = gfc_match (" )%t");
5219 /* Check for F03:C811. */
5220 if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
5222 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
5223 "use associate-name=>");
5228 new_st.op = EXEC_SELECT_TYPE;
5229 new_st.expr1 = expr1;
5230 new_st.expr2 = expr2;
5231 new_st.ext.block.ns = gfc_current_ns;
5233 select_type_push (expr1->symtree->n.sym);
5238 gfc_current_ns = gfc_current_ns->parent;
5243 /* Match a CASE statement. */
5246 gfc_match_case (void)
5248 gfc_case *c, *head, *tail;
5253 if (gfc_current_state () != COMP_SELECT)
5255 gfc_error ("Unexpected CASE statement at %C");
5259 if (gfc_match ("% default") == MATCH_YES)
5261 m = match_case_eos ();
5264 if (m == MATCH_ERROR)
5267 new_st.op = EXEC_SELECT;
5268 c = gfc_get_case ();
5269 c->where = gfc_current_locus;
5270 new_st.ext.block.case_list = c;
5274 if (gfc_match_char ('(') != MATCH_YES)
5279 if (match_case_selector (&c) == MATCH_ERROR)
5289 if (gfc_match_char (')') == MATCH_YES)
5291 if (gfc_match_char (',') != MATCH_YES)
5295 m = match_case_eos ();
5298 if (m == MATCH_ERROR)
5301 new_st.op = EXEC_SELECT;
5302 new_st.ext.block.case_list = head;
5307 gfc_error ("Syntax error in CASE specification at %C");
5310 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
5315 /* Match a TYPE IS statement. */
5318 gfc_match_type_is (void)
5323 if (gfc_current_state () != COMP_SELECT_TYPE)
5325 gfc_error ("Unexpected TYPE IS statement at %C");
5329 if (gfc_match_char ('(') != MATCH_YES)
5332 c = gfc_get_case ();
5333 c->where = gfc_current_locus;
5335 /* TODO: Once unlimited polymorphism is implemented, we will need to call
5336 match_type_spec here. */
5337 if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
5340 if (gfc_match_char (')') != MATCH_YES)
5343 m = match_case_eos ();
5346 if (m == MATCH_ERROR)
5349 new_st.op = EXEC_SELECT_TYPE;
5350 new_st.ext.block.case_list = c;
5352 /* Create temporary variable. */
5353 select_type_set_tmp (&c->ts);
5358 gfc_error ("Syntax error in TYPE IS specification at %C");
5362 gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
5367 /* Match a CLASS IS or CLASS DEFAULT statement. */
5370 gfc_match_class_is (void)
5375 if (gfc_current_state () != COMP_SELECT_TYPE)
5378 if (gfc_match ("% default") == MATCH_YES)
5380 m = match_case_eos ();
5383 if (m == MATCH_ERROR)
5386 new_st.op = EXEC_SELECT_TYPE;
5387 c = gfc_get_case ();
5388 c->where = gfc_current_locus;
5389 c->ts.type = BT_UNKNOWN;
5390 new_st.ext.block.case_list = c;
5391 select_type_set_tmp (NULL);
5395 m = gfc_match ("% is");
5398 if (m == MATCH_ERROR)
5401 if (gfc_match_char ('(') != MATCH_YES)
5404 c = gfc_get_case ();
5405 c->where = gfc_current_locus;
5407 if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
5410 if (c->ts.type == BT_DERIVED)
5411 c->ts.type = BT_CLASS;
5413 if (gfc_match_char (')') != MATCH_YES)
5416 m = match_case_eos ();
5419 if (m == MATCH_ERROR)
5422 new_st.op = EXEC_SELECT_TYPE;
5423 new_st.ext.block.case_list = c;
5425 /* Create temporary variable. */
5426 select_type_set_tmp (&c->ts);
5431 gfc_error ("Syntax error in CLASS IS specification at %C");
5435 gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
5440 /********************* WHERE subroutines ********************/
5442 /* Match the rest of a simple WHERE statement that follows an IF statement.
5446 match_simple_where (void)
5452 m = gfc_match (" ( %e )", &expr);
5456 m = gfc_match_assignment ();
5459 if (m == MATCH_ERROR)
5462 if (gfc_match_eos () != MATCH_YES)
5465 c = gfc_get_code ();
5469 c->next = gfc_get_code ();
5472 gfc_clear_new_st ();
5474 new_st.op = EXEC_WHERE;
5480 gfc_syntax_error (ST_WHERE);
5483 gfc_free_expr (expr);
5488 /* Match a WHERE statement. */
5491 gfc_match_where (gfc_statement *st)
5497 m0 = gfc_match_label ();
5498 if (m0 == MATCH_ERROR)
5501 m = gfc_match (" where ( %e )", &expr);
5505 if (gfc_match_eos () == MATCH_YES)
5507 *st = ST_WHERE_BLOCK;
5508 new_st.op = EXEC_WHERE;
5509 new_st.expr1 = expr;
5513 m = gfc_match_assignment ();
5515 gfc_syntax_error (ST_WHERE);
5519 gfc_free_expr (expr);
5523 /* We've got a simple WHERE statement. */
5525 c = gfc_get_code ();
5529 c->next = gfc_get_code ();
5532 gfc_clear_new_st ();
5534 new_st.op = EXEC_WHERE;
5541 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
5542 new_st if successful. */
5545 gfc_match_elsewhere (void)
5547 char name[GFC_MAX_SYMBOL_LEN + 1];
5551 if (gfc_current_state () != COMP_WHERE)
5553 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
5559 if (gfc_match_char ('(') == MATCH_YES)
5561 m = gfc_match_expr (&expr);
5564 if (m == MATCH_ERROR)
5567 if (gfc_match_char (')') != MATCH_YES)
5571 if (gfc_match_eos () != MATCH_YES)
5573 /* Only makes sense if we have a where-construct-name. */
5574 if (!gfc_current_block ())
5579 /* Better be a name at this point. */
5580 m = gfc_match_name (name);
5583 if (m == MATCH_ERROR)
5586 if (gfc_match_eos () != MATCH_YES)
5589 if (strcmp (name, gfc_current_block ()->name) != 0)
5591 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
5592 name, gfc_current_block ()->name);
5597 new_st.op = EXEC_WHERE;
5598 new_st.expr1 = expr;
5602 gfc_syntax_error (ST_ELSEWHERE);
5605 gfc_free_expr (expr);