1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
30 /* For matching and debugging purposes. Order matters here! The
31 unary operators /must/ precede the binary plus and minus, or
32 the expression parser breaks. */
34 mstring intrinsic_operators[] = {
35 minit ("+", INTRINSIC_UPLUS),
36 minit ("-", INTRINSIC_UMINUS),
37 minit ("+", INTRINSIC_PLUS),
38 minit ("-", INTRINSIC_MINUS),
39 minit ("**", INTRINSIC_POWER),
40 minit ("//", INTRINSIC_CONCAT),
41 minit ("*", INTRINSIC_TIMES),
42 minit ("/", INTRINSIC_DIVIDE),
43 minit (".and.", INTRINSIC_AND),
44 minit (".or.", INTRINSIC_OR),
45 minit (".eqv.", INTRINSIC_EQV),
46 minit (".neqv.", INTRINSIC_NEQV),
47 minit (".eq.", INTRINSIC_EQ),
48 minit ("==", INTRINSIC_EQ),
49 minit (".ne.", INTRINSIC_NE),
50 minit ("/=", INTRINSIC_NE),
51 minit (".ge.", INTRINSIC_GE),
52 minit (">=", INTRINSIC_GE),
53 minit (".le.", INTRINSIC_LE),
54 minit ("<=", INTRINSIC_LE),
55 minit (".lt.", INTRINSIC_LT),
56 minit ("<", INTRINSIC_LT),
57 minit (".gt.", INTRINSIC_GT),
58 minit (">", INTRINSIC_GT),
59 minit (".not.", INTRINSIC_NOT),
60 minit ("parens", INTRINSIC_PARENTHESES),
61 minit (NULL, INTRINSIC_NONE)
65 /******************** Generic matching subroutines ************************/
67 /* In free form, match at least one space. Always matches in fixed
71 gfc_match_space (void)
76 if (gfc_current_form == FORM_FIXED)
79 old_loc = gfc_current_locus;
82 if (!gfc_is_whitespace (c))
84 gfc_current_locus = old_loc;
88 gfc_gobble_whitespace ();
94 /* Match an end of statement. End of statement is optional
95 whitespace, followed by a ';' or '\n' or comment '!'. If a
96 semicolon is found, we continue to eat whitespace and semicolons. */
108 old_loc = gfc_current_locus;
109 gfc_gobble_whitespace ();
111 c = gfc_next_char ();
117 c = gfc_next_char ();
134 gfc_current_locus = old_loc;
135 return (flag) ? MATCH_YES : MATCH_NO;
139 /* Match a literal integer on the input, setting the value on
140 MATCH_YES. Literal ints occur in kind-parameters as well as
141 old-style character length specifications. If cnt is non-NULL it
142 will be set to the number of digits. */
145 gfc_match_small_literal_int (int *value, int *cnt)
151 old_loc = gfc_current_locus;
153 gfc_gobble_whitespace ();
154 c = gfc_next_char ();
160 gfc_current_locus = old_loc;
169 old_loc = gfc_current_locus;
170 c = gfc_next_char ();
175 i = 10 * i + c - '0';
180 gfc_error ("Integer too large at %C");
185 gfc_current_locus = old_loc;
194 /* Match a small, constant integer expression, like in a kind
195 statement. On MATCH_YES, 'value' is set. */
198 gfc_match_small_int (int *value)
205 m = gfc_match_expr (&expr);
209 p = gfc_extract_int (expr, &i);
210 gfc_free_expr (expr);
223 /* Matches a statement label. Uses gfc_match_small_literal_int() to
224 do most of the work. */
227 gfc_match_st_label (gfc_st_label **label)
233 old_loc = gfc_current_locus;
235 m = gfc_match_small_literal_int (&i, &cnt);
241 gfc_error ("Too many digits in statement label at %C");
247 gfc_error ("Statement label at %C is zero");
251 *label = gfc_get_st_label (i);
256 gfc_current_locus = old_loc;
261 /* Match and validate a label associated with a named IF, DO or SELECT
262 statement. If the symbol does not have the label attribute, we add
263 it. We also make sure the symbol does not refer to another
264 (active) block. A matched label is pointed to by gfc_new_block. */
267 gfc_match_label (void)
269 char name[GFC_MAX_SYMBOL_LEN + 1];
272 gfc_new_block = NULL;
274 m = gfc_match (" %n :", name);
278 if (gfc_get_symbol (name, NULL, &gfc_new_block))
280 gfc_error ("Label name '%s' at %C is ambiguous", name);
284 if (gfc_new_block->attr.flavor == FL_LABEL)
286 gfc_error ("Duplicate construct label '%s' at %C", name);
290 if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
291 gfc_new_block->name, NULL) == FAILURE)
298 /* Try and match the input against an array of possibilities. If one
299 potential matching string is a substring of another, the longest
300 match takes precedence. Spaces in the target strings are optional
301 spaces that do not necessarily have to be found in the input
302 stream. In fixed mode, spaces never appear. If whitespace is
303 matched, it matches unlimited whitespace in the input. For this
304 reason, the 'mp' member of the mstring structure is used to track
305 the progress of each potential match.
307 If there is no match we return the tag associated with the
308 terminating NULL mstring structure and leave the locus pointer
309 where it started. If there is a match we return the tag member of
310 the matched mstring and leave the locus pointer after the matched
313 A '%' character is a mandatory space. */
316 gfc_match_strings (mstring *a)
318 mstring *p, *best_match;
319 int no_match, c, possibles;
324 for (p = a; p->string != NULL; p++)
333 match_loc = gfc_current_locus;
335 gfc_gobble_whitespace ();
337 while (possibles > 0)
339 c = gfc_next_char ();
341 /* Apply the next character to the current possibilities. */
342 for (p = a; p->string != NULL; p++)
349 /* Space matches 1+ whitespace(s). */
350 if ((gfc_current_form == FORM_FREE) && gfc_is_whitespace (c))
368 match_loc = gfc_current_locus;
376 gfc_current_locus = match_loc;
378 return (best_match == NULL) ? no_match : best_match->tag;
382 /* See if the current input looks like a name of some sort. Modifies
383 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long. */
386 gfc_match_name (char *buffer)
391 old_loc = gfc_current_locus;
392 gfc_gobble_whitespace ();
394 c = gfc_next_char ();
395 if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore)))
397 if (gfc_error_flag_test() == 0)
398 gfc_error ("Invalid character in name at %C");
399 gfc_current_locus = old_loc;
409 if (i > gfc_option.max_identifier_length)
411 gfc_error ("Name at %C is too long");
415 old_loc = gfc_current_locus;
416 c = gfc_next_char ();
418 while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));
421 gfc_current_locus = old_loc;
427 /* Match a symbol on the input. Modifies the pointer to the symbol
428 pointer if successful. */
431 gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
433 char buffer[GFC_MAX_SYMBOL_LEN + 1];
436 m = gfc_match_name (buffer);
441 return (gfc_get_ha_sym_tree (buffer, matched_symbol))
442 ? MATCH_ERROR : MATCH_YES;
444 if (gfc_get_sym_tree (buffer, NULL, matched_symbol))
452 gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
457 m = gfc_match_sym_tree (&st, host_assoc);
462 *matched_symbol = st->n.sym;
464 *matched_symbol = NULL;
467 *matched_symbol = NULL;
472 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
473 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
477 gfc_match_intrinsic_op (gfc_intrinsic_op *result)
481 op = (gfc_intrinsic_op) gfc_match_strings (intrinsic_operators);
483 if (op == INTRINSIC_NONE)
491 /* Match a loop control phrase:
493 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
495 If the final integer expression is not present, a constant unity
496 expression is returned. We don't return MATCH_ERROR until after
497 the equals sign is seen. */
500 gfc_match_iterator (gfc_iterator *iter, int init_flag)
502 char name[GFC_MAX_SYMBOL_LEN + 1];
503 gfc_expr *var, *e1, *e2, *e3;
507 /* Match the start of an iterator without affecting the symbol table. */
509 start = gfc_current_locus;
510 m = gfc_match (" %n =", name);
511 gfc_current_locus = start;
516 m = gfc_match_variable (&var, 0);
520 gfc_match_char ('=');
524 if (var->ref != NULL)
526 gfc_error ("Loop variable at %C cannot be a sub-component");
530 if (var->symtree->n.sym->attr.intent == INTENT_IN)
532 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
533 var->symtree->n.sym->name);
537 if (var->symtree->n.sym->attr.pointer)
539 gfc_error ("Loop variable at %C cannot have the POINTER attribute");
543 m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
546 if (m == MATCH_ERROR)
549 if (gfc_match_char (',') != MATCH_YES)
552 m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
555 if (m == MATCH_ERROR)
558 if (gfc_match_char (',') != MATCH_YES)
560 e3 = gfc_int_expr (1);
564 m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
565 if (m == MATCH_ERROR)
569 gfc_error ("Expected a step value in iterator at %C");
581 gfc_error ("Syntax error in iterator at %C");
592 /* Tries to match the next non-whitespace character on the input.
593 This subroutine does not return MATCH_ERROR. */
596 gfc_match_char (char c)
600 where = gfc_current_locus;
601 gfc_gobble_whitespace ();
603 if (gfc_next_char () == c)
606 gfc_current_locus = where;
611 /* General purpose matching subroutine. The target string is a
612 scanf-like format string in which spaces correspond to arbitrary
613 whitespace (including no whitespace), characters correspond to
614 themselves. The %-codes are:
616 %% Literal percent sign
617 %e Expression, pointer to a pointer is set
618 %s Symbol, pointer to the symbol is set
619 %n Name, character buffer is set to name
620 %t Matches end of statement.
621 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
622 %l Matches a statement label
623 %v Matches a variable expression (an lvalue)
624 % Matches a required space (in free form) and optional spaces. */
627 gfc_match (const char *target, ...)
629 gfc_st_label **label;
638 old_loc = gfc_current_locus;
639 va_start (argp, target);
649 gfc_gobble_whitespace ();
660 vp = va_arg (argp, void **);
661 n = gfc_match_expr ((gfc_expr **) vp);
672 vp = va_arg (argp, void **);
673 n = gfc_match_variable ((gfc_expr **) vp, 0);
684 vp = va_arg (argp, void **);
685 n = gfc_match_symbol ((gfc_symbol **) vp, 0);
696 np = va_arg (argp, char *);
697 n = gfc_match_name (np);
708 label = va_arg (argp, gfc_st_label **);
709 n = gfc_match_st_label (label);
720 ip = va_arg (argp, int *);
721 n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
732 if (gfc_match_eos () != MATCH_YES)
740 if (gfc_match_space () == MATCH_YES)
746 break; /* Fall through to character matcher */
749 gfc_internal_error ("gfc_match(): Bad match code %c", c);
753 if (c == gfc_next_char ())
763 /* Clean up after a failed match. */
764 gfc_current_locus = old_loc;
765 va_start (argp, target);
768 for (; matches > 0; matches--)
778 /* Matches that don't have to be undone */
783 (void) va_arg (argp, void **);
788 vp = va_arg (argp, void **);
802 /*********************** Statement level matching **********************/
804 /* Matches the start of a program unit, which is the program keyword
805 followed by an obligatory symbol. */
808 gfc_match_program (void)
813 m = gfc_match ("% %s%t", &sym);
817 gfc_error ("Invalid form of PROGRAM statement at %C");
821 if (m == MATCH_ERROR)
824 if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
833 /* Match a simple assignment statement. */
836 gfc_match_assignment (void)
838 gfc_expr *lvalue, *rvalue;
842 old_loc = gfc_current_locus;
845 m = gfc_match (" %v =", &lvalue);
848 gfc_current_locus = old_loc;
849 gfc_free_expr (lvalue);
853 if (lvalue->symtree->n.sym->attr.protected
854 && lvalue->symtree->n.sym->attr.use_assoc)
856 gfc_current_locus = old_loc;
857 gfc_free_expr (lvalue);
858 gfc_error ("Setting value of PROTECTED variable at %C");
863 m = gfc_match (" %e%t", &rvalue);
866 gfc_current_locus = old_loc;
867 gfc_free_expr (lvalue);
868 gfc_free_expr (rvalue);
872 gfc_set_sym_referenced (lvalue->symtree->n.sym);
874 new_st.op = EXEC_ASSIGN;
875 new_st.expr = lvalue;
876 new_st.expr2 = rvalue;
878 gfc_check_do_variable (lvalue->symtree);
884 /* Match a pointer assignment statement. */
887 gfc_match_pointer_assignment (void)
889 gfc_expr *lvalue, *rvalue;
893 old_loc = gfc_current_locus;
895 lvalue = rvalue = NULL;
897 m = gfc_match (" %v =>", &lvalue);
904 m = gfc_match (" %e%t", &rvalue);
908 if (lvalue->symtree->n.sym->attr.protected
909 && lvalue->symtree->n.sym->attr.use_assoc)
911 gfc_error ("Assigning to a PROTECTED pointer at %C");
917 new_st.op = EXEC_POINTER_ASSIGN;
918 new_st.expr = lvalue;
919 new_st.expr2 = rvalue;
924 gfc_current_locus = old_loc;
925 gfc_free_expr (lvalue);
926 gfc_free_expr (rvalue);
931 /* We try to match an easy arithmetic IF statement. This only happens
932 when just after having encountered a simple IF statement. This code
933 is really duplicate with parts of the gfc_match_if code, but this is
937 match_arithmetic_if (void)
939 gfc_st_label *l1, *l2, *l3;
943 m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
947 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
948 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
949 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
951 gfc_free_expr (expr);
955 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF statement "
959 new_st.op = EXEC_ARITHMETIC_IF;
969 /* The IF statement is a bit of a pain. First of all, there are three
970 forms of it, the simple IF, the IF that starts a block and the
973 There is a problem with the simple IF and that is the fact that we
974 only have a single level of undo information on symbols. What this
975 means is for a simple IF, we must re-match the whole IF statement
976 multiple times in order to guarantee that the symbol table ends up
977 in the proper state. */
979 static match match_simple_forall (void);
980 static match match_simple_where (void);
983 gfc_match_if (gfc_statement *if_type)
986 gfc_st_label *l1, *l2, *l3;
991 n = gfc_match_label ();
992 if (n == MATCH_ERROR)
995 old_loc = gfc_current_locus;
997 m = gfc_match (" if ( %e", &expr);
1001 if (gfc_match_char (')') != MATCH_YES)
1003 gfc_error ("Syntax error in IF-expression at %C");
1004 gfc_free_expr (expr);
1008 m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
1014 gfc_error ("Block label not appropriate for arithmetic IF "
1016 gfc_free_expr (expr);
1020 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1021 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1022 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1024 gfc_free_expr (expr);
1028 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF "
1029 "statement at %C") == FAILURE)
1032 new_st.op = EXEC_ARITHMETIC_IF;
1038 *if_type = ST_ARITHMETIC_IF;
1042 if (gfc_match (" then%t") == MATCH_YES)
1044 new_st.op = EXEC_IF;
1046 *if_type = ST_IF_BLOCK;
1052 gfc_error ("Block label is not appropriate IF statement at %C");
1053 gfc_free_expr (expr);
1057 /* At this point the only thing left is a simple IF statement. At
1058 this point, n has to be MATCH_NO, so we don't have to worry about
1059 re-matching a block label. From what we've got so far, try
1060 matching an assignment. */
1062 *if_type = ST_SIMPLE_IF;
1064 m = gfc_match_assignment ();
1068 gfc_free_expr (expr);
1069 gfc_undo_symbols ();
1070 gfc_current_locus = old_loc;
1072 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1073 assignment was found. For MATCH_NO, continue to call the various
1075 if (m == MATCH_ERROR)
1078 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */
1080 m = gfc_match_pointer_assignment ();
1084 gfc_free_expr (expr);
1085 gfc_undo_symbols ();
1086 gfc_current_locus = old_loc;
1088 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */
1090 /* Look at the next keyword to see which matcher to call. Matching
1091 the keyword doesn't affect the symbol table, so we don't have to
1092 restore between tries. */
1094 #define match(string, subr, statement) \
1095 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1099 match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1100 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1101 match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1102 match ("call", gfc_match_call, ST_CALL)
1103 match ("close", gfc_match_close, ST_CLOSE)
1104 match ("continue", gfc_match_continue, ST_CONTINUE)
1105 match ("cycle", gfc_match_cycle, ST_CYCLE)
1106 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1107 match ("end file", gfc_match_endfile, ST_END_FILE)
1108 match ("exit", gfc_match_exit, ST_EXIT)
1109 match ("flush", gfc_match_flush, ST_FLUSH)
1110 match ("forall", match_simple_forall, ST_FORALL)
1111 match ("go to", gfc_match_goto, ST_GOTO)
1112 match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1113 match ("inquire", gfc_match_inquire, ST_INQUIRE)
1114 match ("nullify", gfc_match_nullify, ST_NULLIFY)
1115 match ("open", gfc_match_open, ST_OPEN)
1116 match ("pause", gfc_match_pause, ST_NONE)
1117 match ("print", gfc_match_print, ST_WRITE)
1118 match ("read", gfc_match_read, ST_READ)
1119 match ("return", gfc_match_return, ST_RETURN)
1120 match ("rewind", gfc_match_rewind, ST_REWIND)
1121 match ("stop", gfc_match_stop, ST_STOP)
1122 match ("where", match_simple_where, ST_WHERE)
1123 match ("write", gfc_match_write, ST_WRITE)
1125 /* The gfc_match_assignment() above may have returned a MATCH_NO
1126 where the assignment was to a named constant. Check that
1127 special case here. */
1128 m = gfc_match_assignment ();
1131 gfc_error ("Cannot assign to a named constant at %C");
1132 gfc_free_expr (expr);
1133 gfc_undo_symbols ();
1134 gfc_current_locus = old_loc;
1138 /* All else has failed, so give up. See if any of the matchers has
1139 stored an error message of some sort. */
1140 if (gfc_error_check () == 0)
1141 gfc_error ("Unclassifiable statement in IF-clause at %C");
1143 gfc_free_expr (expr);
1148 gfc_error ("Syntax error in IF-clause at %C");
1151 gfc_free_expr (expr);
1155 /* At this point, we've matched the single IF and the action clause
1156 is in new_st. Rearrange things so that the IF statement appears
1159 p = gfc_get_code ();
1160 p->next = gfc_get_code ();
1162 p->next->loc = gfc_current_locus;
1167 gfc_clear_new_st ();
1169 new_st.op = EXEC_IF;
1178 /* Match an ELSE statement. */
1181 gfc_match_else (void)
1183 char name[GFC_MAX_SYMBOL_LEN + 1];
1185 if (gfc_match_eos () == MATCH_YES)
1188 if (gfc_match_name (name) != MATCH_YES
1189 || gfc_current_block () == NULL
1190 || gfc_match_eos () != MATCH_YES)
1192 gfc_error ("Unexpected junk after ELSE statement at %C");
1196 if (strcmp (name, gfc_current_block ()->name) != 0)
1198 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1199 name, gfc_current_block ()->name);
1207 /* Match an ELSE IF statement. */
1210 gfc_match_elseif (void)
1212 char name[GFC_MAX_SYMBOL_LEN + 1];
1216 m = gfc_match (" ( %e ) then", &expr);
1220 if (gfc_match_eos () == MATCH_YES)
1223 if (gfc_match_name (name) != MATCH_YES
1224 || gfc_current_block () == NULL
1225 || gfc_match_eos () != MATCH_YES)
1227 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1231 if (strcmp (name, gfc_current_block ()->name) != 0)
1233 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1234 name, gfc_current_block ()->name);
1239 new_st.op = EXEC_IF;
1244 gfc_free_expr (expr);
1249 /* Free a gfc_iterator structure. */
1252 gfc_free_iterator (gfc_iterator *iter, int flag)
1257 gfc_free_expr (iter->var);
1258 gfc_free_expr (iter->start);
1259 gfc_free_expr (iter->end);
1260 gfc_free_expr (iter->step);
1267 /* Match a DO statement. */
1272 gfc_iterator iter, *ip;
1274 gfc_st_label *label;
1277 old_loc = gfc_current_locus;
1280 iter.var = iter.start = iter.end = iter.step = NULL;
1282 m = gfc_match_label ();
1283 if (m == MATCH_ERROR)
1286 if (gfc_match (" do") != MATCH_YES)
1289 m = gfc_match_st_label (&label);
1290 if (m == MATCH_ERROR)
1293 /* Match an infinite DO, make it like a DO WHILE(.TRUE.) */
1295 if (gfc_match_eos () == MATCH_YES)
1297 iter.end = gfc_logical_expr (1, NULL);
1298 new_st.op = EXEC_DO_WHILE;
1302 /* match an optional comma, if no comma is found a space is obligatory. */
1303 if (gfc_match_char(',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
1306 /* See if we have a DO WHILE. */
1307 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1309 new_st.op = EXEC_DO_WHILE;
1313 /* The abortive DO WHILE may have done something to the symbol
1314 table, so we start over: */
1315 gfc_undo_symbols ();
1316 gfc_current_locus = old_loc;
1318 gfc_match_label (); /* This won't error */
1319 gfc_match (" do "); /* This will work */
1321 gfc_match_st_label (&label); /* Can't error out */
1322 gfc_match_char (','); /* Optional comma */
1324 m = gfc_match_iterator (&iter, 0);
1327 if (m == MATCH_ERROR)
1330 gfc_check_do_variable (iter.var->symtree);
1332 if (gfc_match_eos () != MATCH_YES)
1334 gfc_syntax_error (ST_DO);
1338 new_st.op = EXEC_DO;
1342 && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1345 new_st.label = label;
1347 if (new_st.op == EXEC_DO_WHILE)
1348 new_st.expr = iter.end;
1351 new_st.ext.iterator = ip = gfc_get_iterator ();
1358 gfc_free_iterator (&iter, 0);
1364 /* Match an EXIT or CYCLE statement. */
1367 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1369 gfc_state_data *p, *o;
1373 if (gfc_match_eos () == MATCH_YES)
1377 m = gfc_match ("% %s%t", &sym);
1378 if (m == MATCH_ERROR)
1382 gfc_syntax_error (st);
1386 if (sym->attr.flavor != FL_LABEL)
1388 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1389 sym->name, gfc_ascii_statement (st));
1394 /* Find the loop mentioned specified by the label (or lack of a
1396 for (o = NULL, p = gfc_state_stack; p; p = p->previous)
1397 if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1399 else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
1405 gfc_error ("%s statement at %C is not within a loop",
1406 gfc_ascii_statement (st));
1408 gfc_error ("%s statement at %C is not within loop '%s'",
1409 gfc_ascii_statement (st), sym->name);
1416 gfc_error ("%s statement at %C leaving OpenMP structured block",
1417 gfc_ascii_statement (st));
1420 else if (st == ST_EXIT
1421 && p->previous != NULL
1422 && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
1423 && (p->previous->head->op == EXEC_OMP_DO
1424 || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
1426 gcc_assert (p->previous->head->next != NULL);
1427 gcc_assert (p->previous->head->next->op == EXEC_DO
1428 || p->previous->head->next->op == EXEC_DO_WHILE);
1429 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1433 /* Save the first statement in the loop - needed by the backend. */
1434 new_st.ext.whichloop = p->head;
1437 /* new_st.sym = sym;*/
1443 /* Match the EXIT statement. */
1446 gfc_match_exit (void)
1448 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1452 /* Match the CYCLE statement. */
1455 gfc_match_cycle (void)
1457 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1461 /* Match a number or character constant after a STOP or PAUSE statement. */
1464 gfc_match_stopcode (gfc_statement st)
1474 if (gfc_match_eos () != MATCH_YES)
1476 m = gfc_match_small_literal_int (&stop_code, &cnt);
1477 if (m == MATCH_ERROR)
1480 if (m == MATCH_YES && cnt > 5)
1482 gfc_error ("Too many digits in STOP code at %C");
1488 /* Try a character constant. */
1489 m = gfc_match_expr (&e);
1490 if (m == MATCH_ERROR)
1494 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1498 if (gfc_match_eos () != MATCH_YES)
1502 if (gfc_pure (NULL))
1504 gfc_error ("%s statement not allowed in PURE procedure at %C",
1505 gfc_ascii_statement (st));
1509 new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1511 new_st.ext.stop_code = stop_code;
1516 gfc_syntax_error (st);
1524 /* Match the (deprecated) PAUSE statement. */
1527 gfc_match_pause (void)
1531 m = gfc_match_stopcode (ST_PAUSE);
1534 if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: PAUSE statement at %C")
1542 /* Match the STOP statement. */
1545 gfc_match_stop (void)
1547 return gfc_match_stopcode (ST_STOP);
1551 /* Match a CONTINUE statement. */
1554 gfc_match_continue (void)
1556 if (gfc_match_eos () != MATCH_YES)
1558 gfc_syntax_error (ST_CONTINUE);
1562 new_st.op = EXEC_CONTINUE;
1567 /* Match the (deprecated) ASSIGN statement. */
1570 gfc_match_assign (void)
1573 gfc_st_label *label;
1575 if (gfc_match (" %l", &label) == MATCH_YES)
1577 if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
1579 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
1581 if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: ASSIGN "
1586 expr->symtree->n.sym->attr.assign = 1;
1588 new_st.op = EXEC_LABEL_ASSIGN;
1589 new_st.label = label;
1598 /* Match the GO TO statement. As a computed GOTO statement is
1599 matched, it is transformed into an equivalent SELECT block. No
1600 tree is necessary, and the resulting jumps-to-jumps are
1601 specifically optimized away by the back end. */
1604 gfc_match_goto (void)
1606 gfc_code *head, *tail;
1609 gfc_st_label *label;
1613 if (gfc_match (" %l%t", &label) == MATCH_YES)
1615 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1618 new_st.op = EXEC_GOTO;
1619 new_st.label = label;
1623 /* The assigned GO TO statement. */
1625 if (gfc_match_variable (&expr, 0) == MATCH_YES)
1627 if (gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: Assigned GOTO "
1632 new_st.op = EXEC_GOTO;
1635 if (gfc_match_eos () == MATCH_YES)
1638 /* Match label list. */
1639 gfc_match_char (',');
1640 if (gfc_match_char ('(') != MATCH_YES)
1642 gfc_syntax_error (ST_GOTO);
1649 m = gfc_match_st_label (&label);
1653 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1657 head = tail = gfc_get_code ();
1660 tail->block = gfc_get_code ();
1664 tail->label = label;
1665 tail->op = EXEC_GOTO;
1667 while (gfc_match_char (',') == MATCH_YES);
1669 if (gfc_match (")%t") != MATCH_YES)
1674 gfc_error ("Statement label list in GOTO at %C cannot be empty");
1677 new_st.block = head;
1682 /* Last chance is a computed GO TO statement. */
1683 if (gfc_match_char ('(') != MATCH_YES)
1685 gfc_syntax_error (ST_GOTO);
1694 m = gfc_match_st_label (&label);
1698 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1702 head = tail = gfc_get_code ();
1705 tail->block = gfc_get_code ();
1709 cp = gfc_get_case ();
1710 cp->low = cp->high = gfc_int_expr (i++);
1712 tail->op = EXEC_SELECT;
1713 tail->ext.case_list = cp;
1715 tail->next = gfc_get_code ();
1716 tail->next->op = EXEC_GOTO;
1717 tail->next->label = label;
1719 while (gfc_match_char (',') == MATCH_YES);
1721 if (gfc_match_char (')') != MATCH_YES)
1726 gfc_error ("Statement label list in GOTO at %C cannot be empty");
1730 /* Get the rest of the statement. */
1731 gfc_match_char (',');
1733 if (gfc_match (" %e%t", &expr) != MATCH_YES)
1736 /* At this point, a computed GOTO has been fully matched and an
1737 equivalent SELECT statement constructed. */
1739 new_st.op = EXEC_SELECT;
1742 /* Hack: For a "real" SELECT, the expression is in expr. We put
1743 it in expr2 so we can distinguish then and produce the correct
1745 new_st.expr2 = expr;
1746 new_st.block = head;
1750 gfc_syntax_error (ST_GOTO);
1752 gfc_free_statements (head);
1757 /* Frees a list of gfc_alloc structures. */
1760 gfc_free_alloc_list (gfc_alloc *p)
1767 gfc_free_expr (p->expr);
1773 /* Match an ALLOCATE statement. */
1776 gfc_match_allocate (void)
1778 gfc_alloc *head, *tail;
1785 if (gfc_match_char ('(') != MATCH_YES)
1791 head = tail = gfc_get_alloc ();
1794 tail->next = gfc_get_alloc ();
1798 m = gfc_match_variable (&tail->expr, 0);
1801 if (m == MATCH_ERROR)
1804 if (gfc_check_do_variable (tail->expr->symtree))
1808 && gfc_impure_variable (tail->expr->symtree->n.sym))
1810 gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1815 if (tail->expr->ts.type == BT_DERIVED)
1816 tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
1818 if (gfc_match_char (',') != MATCH_YES)
1821 m = gfc_match (" stat = %v", &stat);
1822 if (m == MATCH_ERROR)
1830 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1832 gfc_error ("STAT variable '%s' of ALLOCATE statement at %C cannot "
1833 "be INTENT(IN)", stat->symtree->n.sym->name);
1837 if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
1839 gfc_error ("Illegal STAT variable in ALLOCATE statement at %C "
1840 "for a PURE procedure");
1844 if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1846 gfc_error ("STAT expression at %C must be a variable");
1850 gfc_check_do_variable(stat->symtree);
1853 if (gfc_match (" )%t") != MATCH_YES)
1856 new_st.op = EXEC_ALLOCATE;
1858 new_st.ext.alloc_list = head;
1863 gfc_syntax_error (ST_ALLOCATE);
1866 gfc_free_expr (stat);
1867 gfc_free_alloc_list (head);
1872 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1873 a set of pointer assignments to intrinsic NULL(). */
1876 gfc_match_nullify (void)
1884 if (gfc_match_char ('(') != MATCH_YES)
1889 m = gfc_match_variable (&p, 0);
1890 if (m == MATCH_ERROR)
1895 if (gfc_check_do_variable(p->symtree))
1898 if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
1900 gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
1904 /* build ' => NULL() ' */
1905 e = gfc_get_expr ();
1906 e->where = gfc_current_locus;
1907 e->expr_type = EXPR_NULL;
1908 e->ts.type = BT_UNKNOWN;
1915 tail->next = gfc_get_code ();
1919 tail->op = EXEC_POINTER_ASSIGN;
1923 if (gfc_match (" )%t") == MATCH_YES)
1925 if (gfc_match_char (',') != MATCH_YES)
1932 gfc_syntax_error (ST_NULLIFY);
1935 gfc_free_statements (new_st.next);
1940 /* Match a DEALLOCATE statement. */
1943 gfc_match_deallocate (void)
1945 gfc_alloc *head, *tail;
1952 if (gfc_match_char ('(') != MATCH_YES)
1958 head = tail = gfc_get_alloc ();
1961 tail->next = gfc_get_alloc ();
1965 m = gfc_match_variable (&tail->expr, 0);
1966 if (m == MATCH_ERROR)
1971 if (gfc_check_do_variable (tail->expr->symtree))
1975 && gfc_impure_variable (tail->expr->symtree->n.sym))
1977 gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
1978 "for a PURE procedure");
1982 if (gfc_match_char (',') != MATCH_YES)
1985 m = gfc_match (" stat = %v", &stat);
1986 if (m == MATCH_ERROR)
1994 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1996 gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
1997 "cannot be INTENT(IN)", stat->symtree->n.sym->name);
2001 if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym))
2003 gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
2004 "for a PURE procedure");
2008 if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
2010 gfc_error ("STAT expression at %C must be a variable");
2014 gfc_check_do_variable(stat->symtree);
2017 if (gfc_match (" )%t") != MATCH_YES)
2020 new_st.op = EXEC_DEALLOCATE;
2022 new_st.ext.alloc_list = head;
2027 gfc_syntax_error (ST_DEALLOCATE);
2030 gfc_free_expr (stat);
2031 gfc_free_alloc_list (head);
2036 /* Match a RETURN statement. */
2039 gfc_match_return (void)
2043 gfc_compile_state s;
2047 if (gfc_match_eos () == MATCH_YES)
2050 if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
2052 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2057 if (gfc_current_form == FORM_FREE)
2059 /* The following are valid, so we can't require a blank after the
2063 c = gfc_peek_char ();
2064 if (ISALPHA (c) || ISDIGIT (c))
2068 m = gfc_match (" %e%t", &e);
2071 if (m == MATCH_ERROR)
2074 gfc_syntax_error (ST_RETURN);
2081 gfc_enclosing_unit (&s);
2082 if (s == COMP_PROGRAM
2083 && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
2084 "main program at %C") == FAILURE)
2087 new_st.op = EXEC_RETURN;
2094 /* Match a CALL statement. The tricky part here are possible
2095 alternate return specifiers. We handle these by having all
2096 "subroutines" actually return an integer via a register that gives
2097 the return number. If the call specifies alternate returns, we
2098 generate code for a SELECT statement whose case clauses contain
2099 GOTOs to the various labels. */
2102 gfc_match_call (void)
2104 char name[GFC_MAX_SYMBOL_LEN + 1];
2105 gfc_actual_arglist *a, *arglist;
2115 m = gfc_match ("% %n", name);
2121 if (gfc_get_ha_sym_tree (name, &st))
2125 gfc_set_sym_referenced (sym);
2127 if (!sym->attr.generic
2128 && !sym->attr.subroutine
2129 && gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2132 if (gfc_match_eos () != MATCH_YES)
2134 m = gfc_match_actual_arglist (1, &arglist);
2137 if (m == MATCH_ERROR)
2140 if (gfc_match_eos () != MATCH_YES)
2144 /* If any alternate return labels were found, construct a SELECT
2145 statement that will jump to the right place. */
2148 for (a = arglist; a; a = a->next)
2149 if (a->expr == NULL)
2154 gfc_symtree *select_st;
2155 gfc_symbol *select_sym;
2156 char name[GFC_MAX_SYMBOL_LEN + 1];
2158 new_st.next = c = gfc_get_code ();
2159 c->op = EXEC_SELECT;
2160 sprintf (name, "_result_%s", sym->name);
2161 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail */
2163 select_sym = select_st->n.sym;
2164 select_sym->ts.type = BT_INTEGER;
2165 select_sym->ts.kind = gfc_default_integer_kind;
2166 gfc_set_sym_referenced (select_sym);
2167 c->expr = gfc_get_expr ();
2168 c->expr->expr_type = EXPR_VARIABLE;
2169 c->expr->symtree = select_st;
2170 c->expr->ts = select_sym->ts;
2171 c->expr->where = gfc_current_locus;
2174 for (a = arglist; a; a = a->next)
2176 if (a->expr != NULL)
2179 if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2184 c->block = gfc_get_code ();
2186 c->op = EXEC_SELECT;
2188 new_case = gfc_get_case ();
2189 new_case->high = new_case->low = gfc_int_expr (i);
2190 c->ext.case_list = new_case;
2192 c->next = gfc_get_code ();
2193 c->next->op = EXEC_GOTO;
2194 c->next->label = a->label;
2198 new_st.op = EXEC_CALL;
2199 new_st.symtree = st;
2200 new_st.ext.actual = arglist;
2205 gfc_syntax_error (ST_CALL);
2208 gfc_free_actual_arglist (arglist);
2213 /* Given a name, return a pointer to the common head structure,
2214 creating it if it does not exist. If FROM_MODULE is nonzero, we
2215 mangle the name so that it doesn't interfere with commons defined
2216 in the using namespace.
2217 TODO: Add to global symbol tree. */
2220 gfc_get_common (const char *name, int from_module)
2223 static int serial = 0;
2224 char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
2228 /* A use associated common block is only needed to correctly layout
2229 the variables it contains. */
2230 snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2231 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2235 st = gfc_find_symtree (gfc_current_ns->common_root, name);
2238 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2241 if (st->n.common == NULL)
2243 st->n.common = gfc_get_common_head ();
2244 st->n.common->where = gfc_current_locus;
2245 strcpy (st->n.common->name, name);
2248 return st->n.common;
2252 /* Match a common block name. */
2255 match_common_name (char *name)
2259 if (gfc_match_char ('/') == MATCH_NO)
2265 if (gfc_match_char ('/') == MATCH_YES)
2271 m = gfc_match_name (name);
2273 if (m == MATCH_ERROR)
2275 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2278 gfc_error ("Syntax error in common block name at %C");
2283 /* Match a COMMON statement. */
2286 gfc_match_common (void)
2288 gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
2289 char name[GFC_MAX_SYMBOL_LEN + 1];
2296 old_blank_common = gfc_current_ns->blank_common.head;
2297 if (old_blank_common)
2299 while (old_blank_common->common_next)
2300 old_blank_common = old_blank_common->common_next;
2307 m = match_common_name (name);
2308 if (m == MATCH_ERROR)
2311 gsym = gfc_get_gsymbol (name);
2312 if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
2314 gfc_error ("Symbol '%s' at %C is already an external symbol that "
2315 "is not COMMON", name);
2319 if (gsym->type == GSYM_UNKNOWN)
2321 gsym->type = GSYM_COMMON;
2322 gsym->where = gfc_current_locus;
2328 if (name[0] == '\0')
2330 if (gfc_current_ns->is_block_data)
2332 gfc_warning ("BLOCK DATA unit cannot contain blank COMMON "
2335 t = &gfc_current_ns->blank_common;
2336 if (t->head == NULL)
2337 t->where = gfc_current_locus;
2341 t = gfc_get_common (name, 0);
2350 while (tail->common_next)
2351 tail = tail->common_next;
2354 /* Grab the list of symbols. */
2357 m = gfc_match_symbol (&sym, 0);
2358 if (m == MATCH_ERROR)
2363 if (sym->attr.in_common)
2365 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2370 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2373 if (sym->value != NULL
2374 && (name[0] == '\0' || !sym->attr.data))
2376 if (name[0] == '\0')
2377 gfc_error ("Previously initialized symbol '%s' in "
2378 "blank COMMON block at %C", sym->name);
2380 gfc_error ("Previously initialized symbol '%s' in "
2381 "COMMON block '%s' at %C", sym->name, name);
2385 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2388 /* Derived type names must have the SEQUENCE attribute. */
2389 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2391 gfc_error ("Derived type variable in COMMON at %C does not "
2392 "have the SEQUENCE attribute");
2397 tail->common_next = sym;
2403 /* Deal with an optional array specification after the
2405 m = gfc_match_array_spec (&as);
2406 if (m == MATCH_ERROR)
2411 if (as->type != AS_EXPLICIT)
2413 gfc_error ("Array specification for symbol '%s' in COMMON "
2414 "at %C must be explicit", sym->name);
2418 if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2421 if (sym->attr.pointer)
2423 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
2424 "POINTER array", sym->name);
2433 sym->common_head = t;
2435 /* Check to see if the symbol is already in an equivalence group.
2436 If it is, set the other members as being in common. */
2437 if (sym->attr.in_equivalence)
2439 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
2441 for (e2 = e1; e2; e2 = e2->eq)
2442 if (e2->expr->symtree->n.sym == sym)
2449 for (e2 = e1; e2; e2 = e2->eq)
2451 other = e2->expr->symtree->n.sym;
2452 if (other->common_head
2453 && other->common_head != sym->common_head)
2455 gfc_error ("Symbol '%s', in COMMON block '%s' at "
2456 "%C is being indirectly equivalenced to "
2457 "another COMMON block '%s'",
2458 sym->name, sym->common_head->name,
2459 other->common_head->name);
2462 other->attr.in_common = 1;
2463 other->common_head = t;
2469 gfc_gobble_whitespace ();
2470 if (gfc_match_eos () == MATCH_YES)
2472 if (gfc_peek_char () == '/')
2474 if (gfc_match_char (',') != MATCH_YES)
2476 gfc_gobble_whitespace ();
2477 if (gfc_peek_char () == '/')
2486 gfc_syntax_error (ST_COMMON);
2489 if (old_blank_common)
2490 old_blank_common->common_next = NULL;
2492 gfc_current_ns->blank_common.head = NULL;
2493 gfc_free_array_spec (as);
2498 /* Match a BLOCK DATA program unit. */
2501 gfc_match_block_data (void)
2503 char name[GFC_MAX_SYMBOL_LEN + 1];
2507 if (gfc_match_eos () == MATCH_YES)
2509 gfc_new_block = NULL;
2513 m = gfc_match ("% %n%t", name);
2517 if (gfc_get_symbol (name, NULL, &sym))
2520 if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
2523 gfc_new_block = sym;
2529 /* Free a namelist structure. */
2532 gfc_free_namelist (gfc_namelist *name)
2536 for (; name; name = n)
2544 /* Match a NAMELIST statement. */
2547 gfc_match_namelist (void)
2549 gfc_symbol *group_name, *sym;
2553 m = gfc_match (" / %s /", &group_name);
2556 if (m == MATCH_ERROR)
2561 if (group_name->ts.type != BT_UNKNOWN)
2563 gfc_error ("Namelist group name '%s' at %C already has a basic "
2564 "type of %s", group_name->name,
2565 gfc_typename (&group_name->ts));
2569 if (group_name->attr.flavor == FL_NAMELIST
2570 && group_name->attr.use_assoc
2571 && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
2572 "at %C already is USE associated and can"
2573 "not be respecified.", group_name->name)
2577 if (group_name->attr.flavor != FL_NAMELIST
2578 && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
2579 group_name->name, NULL) == FAILURE)
2584 m = gfc_match_symbol (&sym, 1);
2587 if (m == MATCH_ERROR)
2590 if (sym->attr.in_namelist == 0
2591 && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
2594 /* Use gfc_error_check here, rather than goto error, so that
2595 these are the only errors for the next two lines. */
2596 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
2598 gfc_error ("Assumed size array '%s' in namelist '%s' at "
2599 "%C is not allowed", sym->name, group_name->name);
2603 if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL)
2605 gfc_error ("Assumed character length '%s' in namelist '%s' at "
2606 "%C is not allowed", sym->name, group_name->name);
2610 if (sym->as && sym->as->type == AS_ASSUMED_SHAPE
2611 && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
2612 "namelist '%s' at %C is an extension.",
2613 sym->name, group_name->name) == FAILURE)
2616 nl = gfc_get_namelist ();
2620 if (group_name->namelist == NULL)
2621 group_name->namelist = group_name->namelist_tail = nl;
2624 group_name->namelist_tail->next = nl;
2625 group_name->namelist_tail = nl;
2628 if (gfc_match_eos () == MATCH_YES)
2631 m = gfc_match_char (',');
2633 if (gfc_match_char ('/') == MATCH_YES)
2635 m2 = gfc_match (" %s /", &group_name);
2636 if (m2 == MATCH_YES)
2638 if (m2 == MATCH_ERROR)
2652 gfc_syntax_error (ST_NAMELIST);
2659 /* Match a MODULE statement. */
2662 gfc_match_module (void)
2666 m = gfc_match (" %s%t", &gfc_new_block);
2670 if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
2671 gfc_new_block->name, NULL) == FAILURE)
2678 /* Free equivalence sets and lists. Recursively is the easiest way to
2682 gfc_free_equiv (gfc_equiv *eq)
2687 gfc_free_equiv (eq->eq);
2688 gfc_free_equiv (eq->next);
2689 gfc_free_expr (eq->expr);
2694 /* Match an EQUIVALENCE statement. */
2697 gfc_match_equivalence (void)
2699 gfc_equiv *eq, *set, *tail;
2703 gfc_common_head *common_head = NULL;
2711 eq = gfc_get_equiv ();
2715 eq->next = gfc_current_ns->equiv;
2716 gfc_current_ns->equiv = eq;
2718 if (gfc_match_char ('(') != MATCH_YES)
2722 common_flag = FALSE;
2727 m = gfc_match_equiv_variable (&set->expr);
2728 if (m == MATCH_ERROR)
2733 /* count the number of objects. */
2736 if (gfc_match_char ('%') == MATCH_YES)
2738 gfc_error ("Derived type component %C is not a "
2739 "permitted EQUIVALENCE member");
2743 for (ref = set->expr->ref; ref; ref = ref->next)
2744 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2746 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
2747 "be an array section");
2751 sym = set->expr->symtree->n.sym;
2753 if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
2756 if (sym->attr.in_common)
2759 common_head = sym->common_head;
2762 if (gfc_match_char (')') == MATCH_YES)
2765 if (gfc_match_char (',') != MATCH_YES)
2768 set->eq = gfc_get_equiv ();
2774 gfc_error ("EQUIVALENCE at %C requires two or more objects");
2778 /* If one of the members of an equivalence is in common, then
2779 mark them all as being in common. Before doing this, check
2780 that members of the equivalence group are not in different
2783 for (set = eq; set; set = set->eq)
2785 sym = set->expr->symtree->n.sym;
2786 if (sym->common_head && sym->common_head != common_head)
2788 gfc_error ("Attempt to indirectly overlap COMMON "
2789 "blocks %s and %s by EQUIVALENCE at %C",
2790 sym->common_head->name, common_head->name);
2793 sym->attr.in_common = 1;
2794 sym->common_head = common_head;
2797 if (gfc_match_eos () == MATCH_YES)
2799 if (gfc_match_char (',') != MATCH_YES)
2806 gfc_syntax_error (ST_EQUIVALENCE);
2812 gfc_free_equiv (gfc_current_ns->equiv);
2813 gfc_current_ns->equiv = eq;
2819 /* Check that a statement function is not recursive. This is done by looking
2820 for the statement function symbol(sym) by looking recursively through its
2821 expression(e). If a reference to sym is found, true is returned.
2822 12.5.4 requires that any variable of function that is implicitly typed
2823 shall have that type confirmed by any subsequent type declaration. The
2824 implicit typing is conveniently done here. */
2827 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
2829 gfc_actual_arglist *arg;
2836 switch (e->expr_type)
2839 for (arg = e->value.function.actual; arg; arg = arg->next)
2841 if (sym->name == arg->name || recursive_stmt_fcn (arg->expr, sym))
2845 if (e->symtree == NULL)
2848 /* Check the name before testing for nested recursion! */
2849 if (sym->name == e->symtree->n.sym->name)
2852 /* Catch recursion via other statement functions. */
2853 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
2854 && e->symtree->n.sym->value
2855 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
2858 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
2859 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
2864 if (e->symtree && sym->name == e->symtree->n.sym->name)
2867 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
2868 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
2872 if (recursive_stmt_fcn (e->value.op.op1, sym)
2873 || recursive_stmt_fcn (e->value.op.op2, sym))
2881 /* Component references do not need to be checked. */
2884 for (ref = e->ref; ref; ref = ref->next)
2889 for (i = 0; i < ref->u.ar.dimen; i++)
2891 if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
2892 || recursive_stmt_fcn (ref->u.ar.end[i], sym)
2893 || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
2899 if (recursive_stmt_fcn (ref->u.ss.start, sym)
2900 || recursive_stmt_fcn (ref->u.ss.end, sym))
2914 /* Match a statement function declaration. It is so easy to match
2915 non-statement function statements with a MATCH_ERROR as opposed to
2916 MATCH_NO that we suppress error message in most cases. */
2919 gfc_match_st_function (void)
2921 gfc_error_buf old_error;
2926 m = gfc_match_symbol (&sym, 0);
2930 gfc_push_error (&old_error);
2932 if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
2933 sym->name, NULL) == FAILURE)
2936 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2939 m = gfc_match (" = %e%t", &expr);
2943 gfc_free_error (&old_error);
2944 if (m == MATCH_ERROR)
2947 if (recursive_stmt_fcn (expr, sym))
2949 gfc_error ("Statement function at %L is recursive", &expr->where);
2958 gfc_pop_error (&old_error);
2963 /***************** SELECT CASE subroutines ******************/
2965 /* Free a single case structure. */
2968 free_case (gfc_case *p)
2970 if (p->low == p->high)
2972 gfc_free_expr (p->low);
2973 gfc_free_expr (p->high);
2978 /* Free a list of case structures. */
2981 gfc_free_case_list (gfc_case *p)
2993 /* Match a single case selector. */
2996 match_case_selector (gfc_case **cp)
3001 c = gfc_get_case ();
3002 c->where = gfc_current_locus;
3004 if (gfc_match_char (':') == MATCH_YES)
3006 m = gfc_match_init_expr (&c->high);
3009 if (m == MATCH_ERROR)
3014 m = gfc_match_init_expr (&c->low);
3015 if (m == MATCH_ERROR)
3020 /* If we're not looking at a ':' now, make a range out of a single
3021 target. Else get the upper bound for the case range. */
3022 if (gfc_match_char (':') != MATCH_YES)
3026 m = gfc_match_init_expr (&c->high);
3027 if (m == MATCH_ERROR)
3029 /* MATCH_NO is fine. It's OK if nothing is there! */
3037 gfc_error ("Expected initialization expression in CASE at %C");
3045 /* Match the end of a case statement. */
3048 match_case_eos (void)
3050 char name[GFC_MAX_SYMBOL_LEN + 1];
3053 if (gfc_match_eos () == MATCH_YES)
3056 /* If the case construct doesn't have a case-construct-name, we
3057 should have matched the EOS. */
3058 if (!gfc_current_block ())
3060 gfc_error ("Expected the name of the select case construct at %C");
3064 gfc_gobble_whitespace ();
3066 m = gfc_match_name (name);
3070 if (strcmp (name, gfc_current_block ()->name) != 0)
3072 gfc_error ("Expected case name of '%s' at %C",
3073 gfc_current_block ()->name);
3077 return gfc_match_eos ();
3081 /* Match a SELECT statement. */
3084 gfc_match_select (void)
3089 m = gfc_match_label ();
3090 if (m == MATCH_ERROR)
3093 m = gfc_match (" select case ( %e )%t", &expr);
3097 new_st.op = EXEC_SELECT;
3104 /* Match a CASE statement. */
3107 gfc_match_case (void)
3109 gfc_case *c, *head, *tail;
3114 if (gfc_current_state () != COMP_SELECT)
3116 gfc_error ("Unexpected CASE statement at %C");
3120 if (gfc_match ("% default") == MATCH_YES)
3122 m = match_case_eos ();
3125 if (m == MATCH_ERROR)
3128 new_st.op = EXEC_SELECT;
3129 c = gfc_get_case ();
3130 c->where = gfc_current_locus;
3131 new_st.ext.case_list = c;
3135 if (gfc_match_char ('(') != MATCH_YES)
3140 if (match_case_selector (&c) == MATCH_ERROR)
3150 if (gfc_match_char (')') == MATCH_YES)
3152 if (gfc_match_char (',') != MATCH_YES)
3156 m = match_case_eos ();
3159 if (m == MATCH_ERROR)
3162 new_st.op = EXEC_SELECT;
3163 new_st.ext.case_list = head;
3168 gfc_error ("Syntax error in CASE-specification at %C");
3171 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
3175 /********************* WHERE subroutines ********************/
3177 /* Match the rest of a simple WHERE statement that follows an IF statement.
3181 match_simple_where (void)
3187 m = gfc_match (" ( %e )", &expr);
3191 m = gfc_match_assignment ();
3194 if (m == MATCH_ERROR)
3197 if (gfc_match_eos () != MATCH_YES)
3200 c = gfc_get_code ();
3204 c->next = gfc_get_code ();
3207 gfc_clear_new_st ();
3209 new_st.op = EXEC_WHERE;
3215 gfc_syntax_error (ST_WHERE);
3218 gfc_free_expr (expr);
3222 /* Match a WHERE statement. */
3225 gfc_match_where (gfc_statement *st)
3231 m0 = gfc_match_label ();
3232 if (m0 == MATCH_ERROR)
3235 m = gfc_match (" where ( %e )", &expr);
3239 if (gfc_match_eos () == MATCH_YES)
3241 *st = ST_WHERE_BLOCK;
3242 new_st.op = EXEC_WHERE;
3247 m = gfc_match_assignment ();
3249 gfc_syntax_error (ST_WHERE);
3253 gfc_free_expr (expr);
3257 /* We've got a simple WHERE statement. */
3259 c = gfc_get_code ();
3263 c->next = gfc_get_code ();
3266 gfc_clear_new_st ();
3268 new_st.op = EXEC_WHERE;
3275 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3276 new_st if successful. */
3279 gfc_match_elsewhere (void)
3281 char name[GFC_MAX_SYMBOL_LEN + 1];
3285 if (gfc_current_state () != COMP_WHERE)
3287 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3293 if (gfc_match_char ('(') == MATCH_YES)
3295 m = gfc_match_expr (&expr);
3298 if (m == MATCH_ERROR)
3301 if (gfc_match_char (')') != MATCH_YES)
3305 if (gfc_match_eos () != MATCH_YES)
3306 { /* Better be a name at this point */
3307 m = gfc_match_name (name);
3310 if (m == MATCH_ERROR)
3313 if (gfc_match_eos () != MATCH_YES)
3316 if (strcmp (name, gfc_current_block ()->name) != 0)
3318 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3319 name, gfc_current_block ()->name);
3324 new_st.op = EXEC_WHERE;
3329 gfc_syntax_error (ST_ELSEWHERE);
3332 gfc_free_expr (expr);
3337 /******************** FORALL subroutines ********************/
3339 /* Free a list of FORALL iterators. */
3342 gfc_free_forall_iterator (gfc_forall_iterator *iter)
3344 gfc_forall_iterator *next;
3349 gfc_free_expr (iter->var);
3350 gfc_free_expr (iter->start);
3351 gfc_free_expr (iter->end);
3352 gfc_free_expr (iter->stride);
3359 /* Match an iterator as part of a FORALL statement. The format is:
3361 <var> = <start>:<end>[:<stride>]
3363 On MATCH_NO, the caller tests for the possibility that there is a
3364 scalar mask expression. */
3367 match_forall_iterator (gfc_forall_iterator **result)
3369 gfc_forall_iterator *iter;
3373 where = gfc_current_locus;
3374 iter = gfc_getmem (sizeof (gfc_forall_iterator));
3376 m = gfc_match_expr (&iter->var);
3380 if (gfc_match_char ('=') != MATCH_YES
3381 || iter->var->expr_type != EXPR_VARIABLE)
3387 m = gfc_match_expr (&iter->start);
3391 if (gfc_match_char (':') != MATCH_YES)
3394 m = gfc_match_expr (&iter->end);
3397 if (m == MATCH_ERROR)
3400 if (gfc_match_char (':') == MATCH_NO)
3401 iter->stride = gfc_int_expr (1);
3404 m = gfc_match_expr (&iter->stride);
3407 if (m == MATCH_ERROR)
3411 /* Mark the iteration variable's symbol as used as a FORALL index. */
3412 iter->var->symtree->n.sym->forall_index = true;
3418 gfc_error ("Syntax error in FORALL iterator at %C");
3423 gfc_current_locus = where;
3424 gfc_free_forall_iterator (iter);
3429 /* Match the header of a FORALL statement. */
3432 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
3434 gfc_forall_iterator *head, *tail, *new;
3438 gfc_gobble_whitespace ();
3443 if (gfc_match_char ('(') != MATCH_YES)
3446 m = match_forall_iterator (&new);
3447 if (m == MATCH_ERROR)
3456 if (gfc_match_char (',') != MATCH_YES)
3459 m = match_forall_iterator (&new);
3460 if (m == MATCH_ERROR)
3470 /* Have to have a mask expression */
3472 m = gfc_match_expr (&msk);
3475 if (m == MATCH_ERROR)
3481 if (gfc_match_char (')') == MATCH_NO)
3489 gfc_syntax_error (ST_FORALL);
3492 gfc_free_expr (msk);
3493 gfc_free_forall_iterator (head);
3498 /* Match the rest of a simple FORALL statement that follows an
3502 match_simple_forall (void)
3504 gfc_forall_iterator *head;
3513 m = match_forall_header (&head, &mask);
3520 m = gfc_match_assignment ();
3522 if (m == MATCH_ERROR)
3526 m = gfc_match_pointer_assignment ();
3527 if (m == MATCH_ERROR)
3533 c = gfc_get_code ();
3535 c->loc = gfc_current_locus;
3537 if (gfc_match_eos () != MATCH_YES)
3540 gfc_clear_new_st ();
3541 new_st.op = EXEC_FORALL;
3543 new_st.ext.forall_iterator = head;
3544 new_st.block = gfc_get_code ();
3546 new_st.block->op = EXEC_FORALL;
3547 new_st.block->next = c;
3552 gfc_syntax_error (ST_FORALL);
3555 gfc_free_forall_iterator (head);
3556 gfc_free_expr (mask);
3562 /* Match a FORALL statement. */
3565 gfc_match_forall (gfc_statement *st)
3567 gfc_forall_iterator *head;
3576 m0 = gfc_match_label ();
3577 if (m0 == MATCH_ERROR)
3580 m = gfc_match (" forall");
3584 m = match_forall_header (&head, &mask);
3585 if (m == MATCH_ERROR)
3590 if (gfc_match_eos () == MATCH_YES)
3592 *st = ST_FORALL_BLOCK;
3593 new_st.op = EXEC_FORALL;
3595 new_st.ext.forall_iterator = head;
3599 m = gfc_match_assignment ();
3600 if (m == MATCH_ERROR)
3604 m = gfc_match_pointer_assignment ();
3605 if (m == MATCH_ERROR)
3611 c = gfc_get_code ();
3613 c->loc = gfc_current_locus;
3615 gfc_clear_new_st ();
3616 new_st.op = EXEC_FORALL;
3618 new_st.ext.forall_iterator = head;
3619 new_st.block = gfc_get_code ();
3620 new_st.block->op = EXEC_FORALL;
3621 new_st.block->next = c;
3627 gfc_syntax_error (ST_FORALL);
3630 gfc_free_forall_iterator (head);
3631 gfc_free_expr (mask);
3632 gfc_free_statements (c);