1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
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
31 /* For matching and debugging purposes. Order matters here! The
32 unary operators /must/ precede the binary plus and minus, or
33 the expression parser breaks. */
35 mstring intrinsic_operators[] = {
36 minit ("+", INTRINSIC_UPLUS),
37 minit ("-", INTRINSIC_UMINUS),
38 minit ("+", INTRINSIC_PLUS),
39 minit ("-", INTRINSIC_MINUS),
40 minit ("**", INTRINSIC_POWER),
41 minit ("//", INTRINSIC_CONCAT),
42 minit ("*", INTRINSIC_TIMES),
43 minit ("/", INTRINSIC_DIVIDE),
44 minit (".and.", INTRINSIC_AND),
45 minit (".or.", INTRINSIC_OR),
46 minit (".eqv.", INTRINSIC_EQV),
47 minit (".neqv.", INTRINSIC_NEQV),
48 minit (".eq.", INTRINSIC_EQ),
49 minit ("==", INTRINSIC_EQ),
50 minit (".ne.", INTRINSIC_NE),
51 minit ("/=", INTRINSIC_NE),
52 minit (".ge.", INTRINSIC_GE),
53 minit (">=", INTRINSIC_GE),
54 minit (".le.", INTRINSIC_LE),
55 minit ("<=", INTRINSIC_LE),
56 minit (".lt.", INTRINSIC_LT),
57 minit ("<", INTRINSIC_LT),
58 minit (".gt.", INTRINSIC_GT),
59 minit (">", INTRINSIC_GT),
60 minit (".not.", INTRINSIC_NOT),
61 minit ("parens", INTRINSIC_PARENTHESES),
62 minit (NULL, INTRINSIC_NONE)
66 /******************** Generic matching subroutines ************************/
68 /* In free form, match at least one space. Always matches in fixed
72 gfc_match_space (void)
77 if (gfc_current_form == FORM_FIXED)
80 old_loc = gfc_current_locus;
83 if (!gfc_is_whitespace (c))
85 gfc_current_locus = old_loc;
89 gfc_gobble_whitespace ();
95 /* Match an end of statement. End of statement is optional
96 whitespace, followed by a ';' or '\n' or comment '!'. If a
97 semicolon is found, we continue to eat whitespace and semicolons. */
109 old_loc = gfc_current_locus;
110 gfc_gobble_whitespace ();
112 c = gfc_next_char ();
118 c = gfc_next_char ();
135 gfc_current_locus = old_loc;
136 return (flag) ? MATCH_YES : MATCH_NO;
140 /* Match a literal integer on the input, setting the value on
141 MATCH_YES. Literal ints occur in kind-parameters as well as
142 old-style character length specifications. If cnt is non-NULL it
143 will be set to the number of digits. */
146 gfc_match_small_literal_int (int *value, int *cnt)
152 old_loc = gfc_current_locus;
154 gfc_gobble_whitespace ();
155 c = gfc_next_char ();
161 gfc_current_locus = old_loc;
170 old_loc = gfc_current_locus;
171 c = gfc_next_char ();
176 i = 10 * i + c - '0';
181 gfc_error ("Integer too large at %C");
186 gfc_current_locus = old_loc;
195 /* Match a small, constant integer expression, like in a kind
196 statement. On MATCH_YES, 'value' is set. */
199 gfc_match_small_int (int *value)
206 m = gfc_match_expr (&expr);
210 p = gfc_extract_int (expr, &i);
211 gfc_free_expr (expr);
224 /* Matches a statement label. Uses gfc_match_small_literal_int() to
225 do most of the work. */
228 gfc_match_st_label (gfc_st_label ** label)
234 old_loc = gfc_current_locus;
236 m = gfc_match_small_literal_int (&i, &cnt);
242 gfc_error ("Too many digits in statement label at %C");
248 gfc_error ("Statement label at %C is zero");
252 *label = gfc_get_st_label (i);
257 gfc_current_locus = old_loc;
262 /* Match and validate a label associated with a named IF, DO or SELECT
263 statement. If the symbol does not have the label attribute, we add
264 it. We also make sure the symbol does not refer to another
265 (active) block. A matched label is pointed to by gfc_new_block. */
268 gfc_match_label (void)
270 char name[GFC_MAX_SYMBOL_LEN + 1];
273 gfc_new_block = NULL;
275 m = gfc_match (" %n :", name);
279 if (gfc_get_symbol (name, NULL, &gfc_new_block))
281 gfc_error ("Label name '%s' at %C is ambiguous", name);
285 if (gfc_new_block->attr.flavor == FL_LABEL)
287 gfc_error ("Duplicate construct label '%s' at %C", name);
291 if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
292 gfc_new_block->name, NULL) == FAILURE)
299 /* Try and match the input against an array of possibilities. If one
300 potential matching string is a substring of another, the longest
301 match takes precedence. Spaces in the target strings are optional
302 spaces that do not necessarily have to be found in the input
303 stream. In fixed mode, spaces never appear. If whitespace is
304 matched, it matches unlimited whitespace in the input. For this
305 reason, the 'mp' member of the mstring structure is used to track
306 the progress of each potential match.
308 If there is no match we return the tag associated with the
309 terminating NULL mstring structure and leave the locus pointer
310 where it started. If there is a match we return the tag member of
311 the matched mstring and leave the locus pointer after the matched
314 A '%' character is a mandatory space. */
317 gfc_match_strings (mstring * a)
319 mstring *p, *best_match;
320 int no_match, c, possibles;
325 for (p = a; p->string != NULL; p++)
334 match_loc = gfc_current_locus;
336 gfc_gobble_whitespace ();
338 while (possibles > 0)
340 c = gfc_next_char ();
342 /* Apply the next character to the current possibilities. */
343 for (p = a; p->string != NULL; p++)
350 /* Space matches 1+ whitespace(s). */
351 if ((gfc_current_form == FORM_FREE)
352 && gfc_is_whitespace (c))
370 match_loc = gfc_current_locus;
378 gfc_current_locus = match_loc;
380 return (best_match == NULL) ? no_match : best_match->tag;
384 /* See if the current input looks like a name of some sort. Modifies
385 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long. */
388 gfc_match_name (char *buffer)
393 old_loc = gfc_current_locus;
394 gfc_gobble_whitespace ();
396 c = gfc_next_char ();
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 ();
420 || (gfc_option.flag_dollar_ok && c == '$'));
423 gfc_current_locus = old_loc;
429 /* Match a symbol on the input. Modifies the pointer to the symbol
430 pointer if successful. */
433 gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc)
435 char buffer[GFC_MAX_SYMBOL_LEN + 1];
438 m = gfc_match_name (buffer);
443 return (gfc_get_ha_sym_tree (buffer, matched_symbol))
444 ? MATCH_ERROR : MATCH_YES;
446 if (gfc_get_sym_tree (buffer, NULL, matched_symbol))
454 gfc_match_symbol (gfc_symbol ** matched_symbol, int host_assoc)
459 m = gfc_match_sym_tree (&st, host_assoc);
464 *matched_symbol = st->n.sym;
466 *matched_symbol = NULL;
469 *matched_symbol = NULL;
473 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
474 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
478 gfc_match_intrinsic_op (gfc_intrinsic_op * result)
482 op = (gfc_intrinsic_op) gfc_match_strings (intrinsic_operators);
484 if (op == INTRINSIC_NONE)
492 /* Match a loop control phrase:
494 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
496 If the final integer expression is not present, a constant unity
497 expression is returned. We don't return MATCH_ERROR until after
498 the equals sign is seen. */
501 gfc_match_iterator (gfc_iterator * iter, int init_flag)
503 char name[GFC_MAX_SYMBOL_LEN + 1];
504 gfc_expr *var, *e1, *e2, *e3;
508 /* Match the start of an iterator without affecting the symbol
511 start = gfc_current_locus;
512 m = gfc_match (" %n =", name);
513 gfc_current_locus = start;
518 m = gfc_match_variable (&var, 0);
522 gfc_match_char ('=');
526 if (var->ref != NULL)
528 gfc_error ("Loop variable at %C cannot be a sub-component");
532 if (var->symtree->n.sym->attr.intent == INTENT_IN)
534 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
535 var->symtree->n.sym->name);
539 if (var->symtree->n.sym->attr.pointer)
541 gfc_error ("Loop variable at %C cannot have the POINTER attribute");
545 m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
548 if (m == MATCH_ERROR)
551 if (gfc_match_char (',') != MATCH_YES)
554 m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
557 if (m == MATCH_ERROR)
560 if (gfc_match_char (',') != MATCH_YES)
562 e3 = gfc_int_expr (1);
566 m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
567 if (m == MATCH_ERROR)
571 gfc_error ("Expected a step value in iterator at %C");
583 gfc_error ("Syntax error in iterator at %C");
594 /* Tries to match the next non-whitespace character on the input.
595 This subroutine does not return MATCH_ERROR. */
598 gfc_match_char (char c)
602 where = gfc_current_locus;
603 gfc_gobble_whitespace ();
605 if (gfc_next_char () == c)
608 gfc_current_locus = where;
613 /* General purpose matching subroutine. The target string is a
614 scanf-like format string in which spaces correspond to arbitrary
615 whitespace (including no whitespace), characters correspond to
616 themselves. The %-codes are:
618 %% Literal percent sign
619 %e Expression, pointer to a pointer is set
620 %s Symbol, pointer to the symbol is set
621 %n Name, character buffer is set to name
622 %t Matches end of statement.
623 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
624 %l Matches a statement label
625 %v Matches a variable expression (an lvalue)
626 % Matches a required space (in free form) and optional spaces. */
629 gfc_match (const char *target, ...)
631 gfc_st_label **label;
640 old_loc = gfc_current_locus;
641 va_start (argp, target);
651 gfc_gobble_whitespace ();
662 vp = va_arg (argp, void **);
663 n = gfc_match_expr ((gfc_expr **) vp);
674 vp = va_arg (argp, void **);
675 n = gfc_match_variable ((gfc_expr **) vp, 0);
686 vp = va_arg (argp, void **);
687 n = gfc_match_symbol ((gfc_symbol **) vp, 0);
698 np = va_arg (argp, char *);
699 n = gfc_match_name (np);
710 label = va_arg (argp, gfc_st_label **);
711 n = gfc_match_st_label (label);
722 ip = va_arg (argp, int *);
723 n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
734 if (gfc_match_eos () != MATCH_YES)
742 if (gfc_match_space () == MATCH_YES)
748 break; /* Fall through to character matcher */
751 gfc_internal_error ("gfc_match(): Bad match code %c", c);
755 if (c == gfc_next_char ())
765 /* Clean up after a failed match. */
766 gfc_current_locus = old_loc;
767 va_start (argp, target);
770 for (; matches > 0; matches--)
780 /* Matches that don't have to be undone */
785 (void)va_arg (argp, void **);
790 vp = va_arg (argp, void **);
804 /*********************** Statement level matching **********************/
806 /* Matches the start of a program unit, which is the program keyword
807 followed by an obligatory symbol. */
810 gfc_match_program (void)
815 m = gfc_match ("% %s%t", &sym);
819 gfc_error ("Invalid form of PROGRAM statement at %C");
823 if (m == MATCH_ERROR)
826 if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
835 /* Match a simple assignment statement. */
838 gfc_match_assignment (void)
840 gfc_expr *lvalue, *rvalue;
844 old_loc = gfc_current_locus;
847 m = gfc_match (" %v =", &lvalue);
850 gfc_current_locus = old_loc;
851 gfc_free_expr (lvalue);
856 m = gfc_match (" %e%t", &rvalue);
859 gfc_current_locus = old_loc;
860 gfc_free_expr (lvalue);
861 gfc_free_expr (rvalue);
865 gfc_set_sym_referenced (lvalue->symtree->n.sym);
867 new_st.op = EXEC_ASSIGN;
868 new_st.expr = lvalue;
869 new_st.expr2 = rvalue;
871 gfc_check_do_variable (lvalue->symtree);
877 /* Match a pointer assignment statement. */
880 gfc_match_pointer_assignment (void)
882 gfc_expr *lvalue, *rvalue;
886 old_loc = gfc_current_locus;
888 lvalue = rvalue = NULL;
890 m = gfc_match (" %v =>", &lvalue);
897 m = gfc_match (" %e%t", &rvalue);
901 new_st.op = EXEC_POINTER_ASSIGN;
902 new_st.expr = lvalue;
903 new_st.expr2 = rvalue;
908 gfc_current_locus = old_loc;
909 gfc_free_expr (lvalue);
910 gfc_free_expr (rvalue);
915 /* We try to match an easy arithmetic IF statement. This only happens
916 when just after having encountered a simple IF statement. This code
917 is really duplicate with parts of the gfc_match_if code, but this is
920 match_arithmetic_if (void)
922 gfc_st_label *l1, *l2, *l3;
926 m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
930 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
931 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
932 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
934 gfc_free_expr (expr);
938 if (gfc_notify_std (GFC_STD_F95_DEL,
939 "Obsolete: arithmetic IF statement at %C") == FAILURE)
942 new_st.op = EXEC_ARITHMETIC_IF;
952 /* The IF statement is a bit of a pain. First of all, there are three
953 forms of it, the simple IF, the IF that starts a block and the
956 There is a problem with the simple IF and that is the fact that we
957 only have a single level of undo information on symbols. What this
958 means is for a simple IF, we must re-match the whole IF statement
959 multiple times in order to guarantee that the symbol table ends up
960 in the proper state. */
962 static match match_simple_forall (void);
963 static match match_simple_where (void);
966 gfc_match_if (gfc_statement * if_type)
969 gfc_st_label *l1, *l2, *l3;
974 n = gfc_match_label ();
975 if (n == MATCH_ERROR)
978 old_loc = gfc_current_locus;
980 m = gfc_match (" if ( %e", &expr);
984 if (gfc_match_char (')') != MATCH_YES)
986 gfc_error ("Syntax error in IF-expression at %C");
987 gfc_free_expr (expr);
991 m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
998 ("Block label not appropriate for arithmetic IF statement "
1001 gfc_free_expr (expr);
1005 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1006 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1007 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1010 gfc_free_expr (expr);
1014 if (gfc_notify_std (GFC_STD_F95_DEL,
1015 "Obsolete: arithmetic IF statement at %C")
1019 new_st.op = EXEC_ARITHMETIC_IF;
1025 *if_type = ST_ARITHMETIC_IF;
1029 if (gfc_match (" then%t") == MATCH_YES)
1031 new_st.op = EXEC_IF;
1034 *if_type = ST_IF_BLOCK;
1040 gfc_error ("Block label is not appropriate IF statement at %C");
1042 gfc_free_expr (expr);
1046 /* At this point the only thing left is a simple IF statement. At
1047 this point, n has to be MATCH_NO, so we don't have to worry about
1048 re-matching a block label. From what we've got so far, try
1049 matching an assignment. */
1051 *if_type = ST_SIMPLE_IF;
1053 m = gfc_match_assignment ();
1057 gfc_free_expr (expr);
1058 gfc_undo_symbols ();
1059 gfc_current_locus = old_loc;
1061 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1062 assignment was found. For MATCH_NO, continue to call the various
1064 if (m == MATCH_ERROR)
1067 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */
1069 m = gfc_match_pointer_assignment ();
1073 gfc_free_expr (expr);
1074 gfc_undo_symbols ();
1075 gfc_current_locus = old_loc;
1077 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */
1079 /* Look at the next keyword to see which matcher to call. Matching
1080 the keyword doesn't affect the symbol table, so we don't have to
1081 restore between tries. */
1083 #define match(string, subr, statement) \
1084 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1088 match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1089 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1090 match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1091 match ("call", gfc_match_call, ST_CALL)
1092 match ("close", gfc_match_close, ST_CLOSE)
1093 match ("continue", gfc_match_continue, ST_CONTINUE)
1094 match ("cycle", gfc_match_cycle, ST_CYCLE)
1095 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1096 match ("end file", gfc_match_endfile, ST_END_FILE)
1097 match ("exit", gfc_match_exit, ST_EXIT)
1098 match ("flush", gfc_match_flush, ST_FLUSH)
1099 match ("forall", match_simple_forall, ST_FORALL)
1100 match ("go to", gfc_match_goto, ST_GOTO)
1101 match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1102 match ("inquire", gfc_match_inquire, ST_INQUIRE)
1103 match ("nullify", gfc_match_nullify, ST_NULLIFY)
1104 match ("open", gfc_match_open, ST_OPEN)
1105 match ("pause", gfc_match_pause, ST_NONE)
1106 match ("print", gfc_match_print, ST_WRITE)
1107 match ("read", gfc_match_read, ST_READ)
1108 match ("return", gfc_match_return, ST_RETURN)
1109 match ("rewind", gfc_match_rewind, ST_REWIND)
1110 match ("stop", gfc_match_stop, ST_STOP)
1111 match ("where", match_simple_where, ST_WHERE)
1112 match ("write", gfc_match_write, ST_WRITE)
1114 /* The gfc_match_assignment() above may have returned a MATCH_NO
1115 where the assignment was to a named constant. Check that
1116 special case here. */
1117 m = gfc_match_assignment ();
1120 gfc_error ("Cannot assign to a named constant at %C");
1121 gfc_free_expr (expr);
1122 gfc_undo_symbols ();
1123 gfc_current_locus = old_loc;
1127 /* All else has failed, so give up. See if any of the matchers has
1128 stored an error message of some sort. */
1129 if (gfc_error_check () == 0)
1130 gfc_error ("Unclassifiable statement in IF-clause at %C");
1132 gfc_free_expr (expr);
1137 gfc_error ("Syntax error in IF-clause at %C");
1140 gfc_free_expr (expr);
1144 /* At this point, we've matched the single IF and the action clause
1145 is in new_st. Rearrange things so that the IF statement appears
1148 p = gfc_get_code ();
1149 p->next = gfc_get_code ();
1151 p->next->loc = gfc_current_locus;
1156 gfc_clear_new_st ();
1158 new_st.op = EXEC_IF;
1167 /* Match an ELSE statement. */
1170 gfc_match_else (void)
1172 char name[GFC_MAX_SYMBOL_LEN + 1];
1174 if (gfc_match_eos () == MATCH_YES)
1177 if (gfc_match_name (name) != MATCH_YES
1178 || gfc_current_block () == NULL
1179 || gfc_match_eos () != MATCH_YES)
1181 gfc_error ("Unexpected junk after ELSE statement at %C");
1185 if (strcmp (name, gfc_current_block ()->name) != 0)
1187 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1188 name, gfc_current_block ()->name);
1196 /* Match an ELSE IF statement. */
1199 gfc_match_elseif (void)
1201 char name[GFC_MAX_SYMBOL_LEN + 1];
1205 m = gfc_match (" ( %e ) then", &expr);
1209 if (gfc_match_eos () == MATCH_YES)
1212 if (gfc_match_name (name) != MATCH_YES
1213 || gfc_current_block () == NULL
1214 || gfc_match_eos () != MATCH_YES)
1216 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1220 if (strcmp (name, gfc_current_block ()->name) != 0)
1222 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1223 name, gfc_current_block ()->name);
1228 new_st.op = EXEC_IF;
1233 gfc_free_expr (expr);
1238 /* Free a gfc_iterator structure. */
1241 gfc_free_iterator (gfc_iterator * iter, int flag)
1247 gfc_free_expr (iter->var);
1248 gfc_free_expr (iter->start);
1249 gfc_free_expr (iter->end);
1250 gfc_free_expr (iter->step);
1257 /* Match a DO statement. */
1262 gfc_iterator iter, *ip;
1264 gfc_st_label *label;
1267 old_loc = gfc_current_locus;
1270 iter.var = iter.start = iter.end = iter.step = NULL;
1272 m = gfc_match_label ();
1273 if (m == MATCH_ERROR)
1276 if (gfc_match (" do") != MATCH_YES)
1279 m = gfc_match_st_label (&label);
1280 if (m == MATCH_ERROR)
1283 /* Match an infinite DO, make it like a DO WHILE(.TRUE.) */
1285 if (gfc_match_eos () == MATCH_YES)
1287 iter.end = gfc_logical_expr (1, NULL);
1288 new_st.op = EXEC_DO_WHILE;
1292 /* match an optional comma, if no comma is found a space is obligatory. */
1293 if (gfc_match_char(',') != MATCH_YES
1294 && gfc_match ("% ") != MATCH_YES)
1297 /* See if we have a DO WHILE. */
1298 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1300 new_st.op = EXEC_DO_WHILE;
1304 /* The abortive DO WHILE may have done something to the symbol
1305 table, so we start over: */
1306 gfc_undo_symbols ();
1307 gfc_current_locus = old_loc;
1309 gfc_match_label (); /* This won't error */
1310 gfc_match (" do "); /* This will work */
1312 gfc_match_st_label (&label); /* Can't error out */
1313 gfc_match_char (','); /* Optional comma */
1315 m = gfc_match_iterator (&iter, 0);
1318 if (m == MATCH_ERROR)
1321 gfc_check_do_variable (iter.var->symtree);
1323 if (gfc_match_eos () != MATCH_YES)
1325 gfc_syntax_error (ST_DO);
1329 new_st.op = EXEC_DO;
1333 && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1336 new_st.label = label;
1338 if (new_st.op == EXEC_DO_WHILE)
1339 new_st.expr = iter.end;
1342 new_st.ext.iterator = ip = gfc_get_iterator ();
1349 gfc_free_iterator (&iter, 0);
1355 /* Match an EXIT or CYCLE statement. */
1358 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1360 gfc_state_data *p, *o;
1364 if (gfc_match_eos () == MATCH_YES)
1368 m = gfc_match ("% %s%t", &sym);
1369 if (m == MATCH_ERROR)
1373 gfc_syntax_error (st);
1377 if (sym->attr.flavor != FL_LABEL)
1379 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1380 sym->name, gfc_ascii_statement (st));
1385 /* Find the loop mentioned specified by the label (or lack of a
1387 for (o = NULL, p = gfc_state_stack; p; p = p->previous)
1388 if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1390 else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
1396 gfc_error ("%s statement at %C is not within a loop",
1397 gfc_ascii_statement (st));
1399 gfc_error ("%s statement at %C is not within loop '%s'",
1400 gfc_ascii_statement (st), sym->name);
1407 gfc_error ("%s statement at %C leaving OpenMP structured block",
1408 gfc_ascii_statement (st));
1411 else if (st == ST_EXIT
1412 && p->previous != NULL
1413 && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
1414 && (p->previous->head->op == EXEC_OMP_DO
1415 || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
1417 gcc_assert (p->previous->head->next != NULL);
1418 gcc_assert (p->previous->head->next->op == EXEC_DO
1419 || p->previous->head->next->op == EXEC_DO_WHILE);
1420 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1424 /* Save the first statement in the loop - needed by the backend. */
1425 new_st.ext.whichloop = p->head;
1428 /* new_st.sym = sym;*/
1434 /* Match the EXIT statement. */
1437 gfc_match_exit (void)
1440 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1444 /* Match the CYCLE statement. */
1447 gfc_match_cycle (void)
1450 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1454 /* Match a number or character constant after a STOP or PAUSE statement. */
1457 gfc_match_stopcode (gfc_statement st)
1467 if (gfc_match_eos () != MATCH_YES)
1469 m = gfc_match_small_literal_int (&stop_code, &cnt);
1470 if (m == MATCH_ERROR)
1473 if (m == MATCH_YES && cnt > 5)
1475 gfc_error ("Too many digits in STOP code at %C");
1481 /* Try a character constant. */
1482 m = gfc_match_expr (&e);
1483 if (m == MATCH_ERROR)
1487 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1491 if (gfc_match_eos () != MATCH_YES)
1495 if (gfc_pure (NULL))
1497 gfc_error ("%s statement not allowed in PURE procedure at %C",
1498 gfc_ascii_statement (st));
1502 new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1504 new_st.ext.stop_code = stop_code;
1509 gfc_syntax_error (st);
1517 /* Match the (deprecated) PAUSE statement. */
1520 gfc_match_pause (void)
1524 m = gfc_match_stopcode (ST_PAUSE);
1527 if (gfc_notify_std (GFC_STD_F95_DEL,
1528 "Obsolete: PAUSE statement at %C")
1536 /* Match the STOP statement. */
1539 gfc_match_stop (void)
1541 return gfc_match_stopcode (ST_STOP);
1545 /* Match a CONTINUE statement. */
1548 gfc_match_continue (void)
1551 if (gfc_match_eos () != MATCH_YES)
1553 gfc_syntax_error (ST_CONTINUE);
1557 new_st.op = EXEC_CONTINUE;
1562 /* Match the (deprecated) ASSIGN statement. */
1565 gfc_match_assign (void)
1568 gfc_st_label *label;
1570 if (gfc_match (" %l", &label) == MATCH_YES)
1572 if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
1574 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
1576 if (gfc_notify_std (GFC_STD_F95_DEL,
1577 "Obsolete: ASSIGN statement at %C")
1581 expr->symtree->n.sym->attr.assign = 1;
1583 new_st.op = EXEC_LABEL_ASSIGN;
1584 new_st.label = label;
1593 /* Match the GO TO statement. As a computed GOTO statement is
1594 matched, it is transformed into an equivalent SELECT block. No
1595 tree is necessary, and the resulting jumps-to-jumps are
1596 specifically optimized away by the back end. */
1599 gfc_match_goto (void)
1601 gfc_code *head, *tail;
1604 gfc_st_label *label;
1608 if (gfc_match (" %l%t", &label) == MATCH_YES)
1610 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1613 new_st.op = EXEC_GOTO;
1614 new_st.label = label;
1618 /* The assigned GO TO statement. */
1620 if (gfc_match_variable (&expr, 0) == MATCH_YES)
1622 if (gfc_notify_std (GFC_STD_F95_DEL,
1623 "Obsolete: Assigned GOTO statement at %C")
1627 new_st.op = EXEC_GOTO;
1630 if (gfc_match_eos () == MATCH_YES)
1633 /* Match label list. */
1634 gfc_match_char (',');
1635 if (gfc_match_char ('(') != MATCH_YES)
1637 gfc_syntax_error (ST_GOTO);
1644 m = gfc_match_st_label (&label);
1648 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1652 head = tail = gfc_get_code ();
1655 tail->block = gfc_get_code ();
1659 tail->label = label;
1660 tail->op = EXEC_GOTO;
1662 while (gfc_match_char (',') == MATCH_YES);
1664 if (gfc_match (")%t") != MATCH_YES)
1670 "Statement label list in GOTO at %C cannot be empty");
1673 new_st.block = head;
1678 /* Last chance is a computed GO TO statement. */
1679 if (gfc_match_char ('(') != MATCH_YES)
1681 gfc_syntax_error (ST_GOTO);
1690 m = gfc_match_st_label (&label);
1694 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1698 head = tail = gfc_get_code ();
1701 tail->block = gfc_get_code ();
1705 cp = gfc_get_case ();
1706 cp->low = cp->high = gfc_int_expr (i++);
1708 tail->op = EXEC_SELECT;
1709 tail->ext.case_list = cp;
1711 tail->next = gfc_get_code ();
1712 tail->next->op = EXEC_GOTO;
1713 tail->next->label = label;
1715 while (gfc_match_char (',') == MATCH_YES);
1717 if (gfc_match_char (')') != MATCH_YES)
1722 gfc_error ("Statement label list in GOTO at %C cannot be empty");
1726 /* Get the rest of the statement. */
1727 gfc_match_char (',');
1729 if (gfc_match (" %e%t", &expr) != MATCH_YES)
1732 /* At this point, a computed GOTO has been fully matched and an
1733 equivalent SELECT statement constructed. */
1735 new_st.op = EXEC_SELECT;
1738 /* Hack: For a "real" SELECT, the expression is in expr. We put
1739 it in expr2 so we can distinguish then and produce the correct
1741 new_st.expr2 = expr;
1742 new_st.block = head;
1746 gfc_syntax_error (ST_GOTO);
1748 gfc_free_statements (head);
1753 /* Frees a list of gfc_alloc structures. */
1756 gfc_free_alloc_list (gfc_alloc * p)
1763 gfc_free_expr (p->expr);
1769 /* Match an ALLOCATE statement. */
1772 gfc_match_allocate (void)
1774 gfc_alloc *head, *tail;
1781 if (gfc_match_char ('(') != MATCH_YES)
1787 head = tail = gfc_get_alloc ();
1790 tail->next = gfc_get_alloc ();
1794 m = gfc_match_variable (&tail->expr, 0);
1797 if (m == MATCH_ERROR)
1800 if (gfc_check_do_variable (tail->expr->symtree))
1804 && gfc_impure_variable (tail->expr->symtree->n.sym))
1806 gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1811 if (tail->expr->ts.type == BT_DERIVED)
1812 tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
1814 if (gfc_match_char (',') != MATCH_YES)
1817 m = gfc_match (" stat = %v", &stat);
1818 if (m == MATCH_ERROR)
1826 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1829 ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
1830 "INTENT(IN)", stat->symtree->n.sym->name);
1834 if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
1837 ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
1842 if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1844 gfc_error("STAT expression at %C must be a variable");
1848 gfc_check_do_variable(stat->symtree);
1851 if (gfc_match (" )%t") != MATCH_YES)
1854 new_st.op = EXEC_ALLOCATE;
1856 new_st.ext.alloc_list = head;
1861 gfc_syntax_error (ST_ALLOCATE);
1864 gfc_free_expr (stat);
1865 gfc_free_alloc_list (head);
1870 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1871 a set of pointer assignments to intrinsic NULL(). */
1874 gfc_match_nullify (void)
1882 if (gfc_match_char ('(') != MATCH_YES)
1887 m = gfc_match_variable (&p, 0);
1888 if (m == MATCH_ERROR)
1893 if (gfc_check_do_variable(p->symtree))
1896 if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
1899 ("Illegal variable in NULLIFY at %C for a PURE procedure");
1903 /* build ' => NULL() ' */
1904 e = gfc_get_expr ();
1905 e->where = gfc_current_locus;
1906 e->expr_type = EXPR_NULL;
1907 e->ts.type = BT_UNKNOWN;
1914 tail->next = gfc_get_code ();
1918 tail->op = EXEC_POINTER_ASSIGN;
1922 if (gfc_match (" )%t") == MATCH_YES)
1924 if (gfc_match_char (',') != MATCH_YES)
1931 gfc_syntax_error (ST_NULLIFY);
1934 gfc_free_statements (new_st.next);
1939 /* Match a DEALLOCATE statement. */
1942 gfc_match_deallocate (void)
1944 gfc_alloc *head, *tail;
1951 if (gfc_match_char ('(') != MATCH_YES)
1957 head = tail = gfc_get_alloc ();
1960 tail->next = gfc_get_alloc ();
1964 m = gfc_match_variable (&tail->expr, 0);
1965 if (m == MATCH_ERROR)
1970 if (gfc_check_do_variable (tail->expr->symtree))
1974 && gfc_impure_variable (tail->expr->symtree->n.sym))
1977 ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
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];
2292 gfc_equiv * e1, * e2;
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 is not COMMON",
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 at %C");
2334 t = &gfc_current_ns->blank_common;
2335 if (t->head == NULL)
2336 t->where = gfc_current_locus;
2340 t = gfc_get_common (name, 0);
2349 while (tail->common_next)
2350 tail = tail->common_next;
2353 /* Grab the list of symbols. */
2356 m = gfc_match_symbol (&sym, 0);
2357 if (m == MATCH_ERROR)
2362 if (sym->attr.in_common)
2364 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2369 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2372 if (sym->value != NULL
2373 && (name[0] == '\0' || !sym->attr.data))
2375 if (name[0] == '\0')
2376 gfc_error ("Previously initialized symbol '%s' in "
2377 "blank COMMON block at %C", sym->name);
2379 gfc_error ("Previously initialized symbol '%s' in "
2380 "COMMON block '%s' at %C", sym->name, name);
2384 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2387 /* Derived type names must have the SEQUENCE attribute. */
2388 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2391 ("Derived type variable in COMMON at %C does not have the "
2392 "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)
2414 ("Array specification for symbol '%s' in COMMON at %C "
2415 "must be explicit", sym->name);
2419 if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2422 if (sym->attr.pointer)
2425 ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2435 sym->common_head = t;
2437 /* Check to see if the symbol is already in an equivalence group.
2438 If it is, set the other members as being in common. */
2439 if (sym->attr.in_equivalence)
2441 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
2443 for (e2 = e1; e2; e2 = e2->eq)
2444 if (e2->expr->symtree->n.sym == sym)
2451 for (e2 = e1; e2; e2 = e2->eq)
2453 other = e2->expr->symtree->n.sym;
2454 if (other->common_head
2455 && other->common_head != sym->common_head)
2457 gfc_error ("Symbol '%s', in COMMON block '%s' at "
2458 "%C is being indirectly equivalenced to "
2459 "another COMMON block '%s'",
2461 sym->common_head->name,
2462 other->common_head->name);
2465 other->attr.in_common = 1;
2466 other->common_head = t;
2472 gfc_gobble_whitespace ();
2473 if (gfc_match_eos () == MATCH_YES)
2475 if (gfc_peek_char () == '/')
2477 if (gfc_match_char (',') != MATCH_YES)
2479 gfc_gobble_whitespace ();
2480 if (gfc_peek_char () == '/')
2489 gfc_syntax_error (ST_COMMON);
2492 if (old_blank_common)
2493 old_blank_common->common_next = NULL;
2495 gfc_current_ns->blank_common.head = NULL;
2496 gfc_free_array_spec (as);
2501 /* Match a BLOCK DATA program unit. */
2504 gfc_match_block_data (void)
2506 char name[GFC_MAX_SYMBOL_LEN + 1];
2510 if (gfc_match_eos () == MATCH_YES)
2512 gfc_new_block = NULL;
2516 m = gfc_match ("% %n%t", name);
2520 if (gfc_get_symbol (name, NULL, &sym))
2523 if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
2526 gfc_new_block = sym;
2532 /* Free a namelist structure. */
2535 gfc_free_namelist (gfc_namelist * name)
2539 for (; name; name = n)
2547 /* Match a NAMELIST statement. */
2550 gfc_match_namelist (void)
2552 gfc_symbol *group_name, *sym;
2556 m = gfc_match (" / %s /", &group_name);
2559 if (m == MATCH_ERROR)
2564 if (group_name->ts.type != BT_UNKNOWN)
2567 ("Namelist group name '%s' at %C already has a basic type "
2568 "of %s", group_name->name, gfc_typename (&group_name->ts));
2572 if (group_name->attr.flavor == FL_NAMELIST
2573 && group_name->attr.use_assoc
2574 && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
2575 "at %C already is USE associated and can"
2576 "not be respecified.", group_name->name)
2580 if (group_name->attr.flavor != FL_NAMELIST
2581 && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
2582 group_name->name, NULL) == FAILURE)
2587 m = gfc_match_symbol (&sym, 1);
2590 if (m == MATCH_ERROR)
2593 if (sym->attr.in_namelist == 0
2594 && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
2597 /* Use gfc_error_check here, rather than goto error, so that this
2598 these are the only errors for the next two lines. */
2599 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
2601 gfc_error ("Assumed size array '%s' in namelist '%s' at "
2602 "%C is not allowed.", sym->name, group_name->name);
2606 if (sym->as && sym->as->type == AS_ASSUMED_SHAPE
2607 && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
2608 "namelist '%s' at %C is an extension.",
2609 sym->name, group_name->name) == FAILURE)
2612 nl = gfc_get_namelist ();
2616 if (group_name->namelist == NULL)
2617 group_name->namelist = group_name->namelist_tail = nl;
2620 group_name->namelist_tail->next = nl;
2621 group_name->namelist_tail = nl;
2624 if (gfc_match_eos () == MATCH_YES)
2627 m = gfc_match_char (',');
2629 if (gfc_match_char ('/') == MATCH_YES)
2631 m2 = gfc_match (" %s /", &group_name);
2632 if (m2 == MATCH_YES)
2634 if (m2 == MATCH_ERROR)
2648 gfc_syntax_error (ST_NAMELIST);
2655 /* Match a MODULE statement. */
2658 gfc_match_module (void)
2662 m = gfc_match (" %s%t", &gfc_new_block);
2666 if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
2667 gfc_new_block->name, NULL) == FAILURE)
2674 /* Free equivalence sets and lists. Recursively is the easiest way to
2678 gfc_free_equiv (gfc_equiv * eq)
2684 gfc_free_equiv (eq->eq);
2685 gfc_free_equiv (eq->next);
2687 gfc_free_expr (eq->expr);
2692 /* Match an EQUIVALENCE statement. */
2695 gfc_match_equivalence (void)
2697 gfc_equiv *eq, *set, *tail;
2701 gfc_common_head *common_head = NULL;
2709 eq = gfc_get_equiv ();
2713 eq->next = gfc_current_ns->equiv;
2714 gfc_current_ns->equiv = eq;
2716 if (gfc_match_char ('(') != MATCH_YES)
2720 common_flag = FALSE;
2725 m = gfc_match_equiv_variable (&set->expr);
2726 if (m == MATCH_ERROR)
2731 /* count the number of objects. */
2734 if (gfc_match_char ('%') == MATCH_YES)
2736 gfc_error ("Derived type component %C is not a "
2737 "permitted EQUIVALENCE member");
2741 for (ref = set->expr->ref; ref; ref = ref->next)
2742 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2745 ("Array reference in EQUIVALENCE at %C cannot be an "
2750 sym = set->expr->symtree->n.sym;
2752 if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL)
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,
2794 sym->attr.in_common = 1;
2795 sym->common_head = common_head;
2798 if (gfc_match_eos () == MATCH_YES)
2800 if (gfc_match_char (',') != MATCH_YES)
2807 gfc_syntax_error (ST_EQUIVALENCE);
2813 gfc_free_equiv (gfc_current_ns->equiv);
2814 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
2842 || recursive_stmt_fcn (arg->expr, sym))
2846 if (e->symtree == NULL)
2849 /* Check the name before testing for nested recursion! */
2850 if (sym->name == e->symtree->n.sym->name)
2853 /* Catch recursion via other statement functions. */
2854 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
2855 && e->symtree->n.sym->value
2856 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
2859 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
2860 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
2865 if (e->symtree && sym->name == e->symtree->n.sym->name)
2868 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
2869 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
2873 if (recursive_stmt_fcn (e->value.op.op1, sym)
2874 || recursive_stmt_fcn (e->value.op.op2, sym))
2882 /* Component references do not need to be checked. */
2885 for (ref = e->ref; ref; ref = ref->next)
2890 for (i = 0; i < ref->u.ar.dimen; i++)
2892 if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
2893 || recursive_stmt_fcn (ref->u.ar.end[i], sym)
2894 || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
2900 if (recursive_stmt_fcn (ref->u.ss.start, sym)
2901 || recursive_stmt_fcn (ref->u.ss.end, sym))
2915 /* Match a statement function declaration. It is so easy to match
2916 non-statement function statements with a MATCH_ERROR as opposed to
2917 MATCH_NO that we suppress error message in most cases. */
2920 gfc_match_st_function (void)
2922 gfc_error_buf old_error;
2927 m = gfc_match_symbol (&sym, 0);
2931 gfc_push_error (&old_error);
2933 if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
2934 sym->name, NULL) == FAILURE)
2937 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2940 m = gfc_match (" = %e%t", &expr);
2944 gfc_free_error (&old_error);
2945 if (m == MATCH_ERROR)
2948 if (recursive_stmt_fcn (expr, sym))
2950 gfc_error ("Statement function at %L is recursive",
2960 gfc_pop_error (&old_error);
2965 /***************** SELECT CASE subroutines ******************/
2967 /* Free a single case structure. */
2970 free_case (gfc_case * p)
2972 if (p->low == p->high)
2974 gfc_free_expr (p->low);
2975 gfc_free_expr (p->high);
2980 /* Free a list of case structures. */
2983 gfc_free_case_list (gfc_case * p)
2995 /* Match a single case selector. */
2998 match_case_selector (gfc_case ** cp)
3003 c = gfc_get_case ();
3004 c->where = gfc_current_locus;
3006 if (gfc_match_char (':') == MATCH_YES)
3008 m = gfc_match_init_expr (&c->high);
3011 if (m == MATCH_ERROR)
3017 m = gfc_match_init_expr (&c->low);
3018 if (m == MATCH_ERROR)
3023 /* If we're not looking at a ':' now, make a range out of a single
3024 target. Else get the upper bound for the case range. */
3025 if (gfc_match_char (':') != MATCH_YES)
3029 m = gfc_match_init_expr (&c->high);
3030 if (m == MATCH_ERROR)
3032 /* MATCH_NO is fine. It's OK if nothing is there! */
3040 gfc_error ("Expected initialization expression in CASE at %C");
3048 /* Match the end of a case statement. */
3051 match_case_eos (void)
3053 char name[GFC_MAX_SYMBOL_LEN + 1];
3056 if (gfc_match_eos () == MATCH_YES)
3059 /* If the case construct doesn't have a case-construct-name, we
3060 should have matched the EOS. */
3061 if (!gfc_current_block ())
3063 gfc_error ("Expected the name of the select case construct at %C");
3067 gfc_gobble_whitespace ();
3069 m = gfc_match_name (name);
3073 if (strcmp (name, gfc_current_block ()->name) != 0)
3075 gfc_error ("Expected case name of '%s' at %C",
3076 gfc_current_block ()->name);
3080 return gfc_match_eos ();
3084 /* Match a SELECT statement. */
3087 gfc_match_select (void)
3092 m = gfc_match_label ();
3093 if (m == MATCH_ERROR)
3096 m = gfc_match (" select case ( %e )%t", &expr);
3100 new_st.op = EXEC_SELECT;
3107 /* Match a CASE statement. */
3110 gfc_match_case (void)
3112 gfc_case *c, *head, *tail;
3117 if (gfc_current_state () != COMP_SELECT)
3119 gfc_error ("Unexpected CASE statement at %C");
3123 if (gfc_match ("% default") == MATCH_YES)
3125 m = match_case_eos ();
3128 if (m == MATCH_ERROR)
3131 new_st.op = EXEC_SELECT;
3132 c = gfc_get_case ();
3133 c->where = gfc_current_locus;
3134 new_st.ext.case_list = c;
3138 if (gfc_match_char ('(') != MATCH_YES)
3143 if (match_case_selector (&c) == MATCH_ERROR)
3153 if (gfc_match_char (')') == MATCH_YES)
3155 if (gfc_match_char (',') != MATCH_YES)
3159 m = match_case_eos ();
3162 if (m == MATCH_ERROR)
3165 new_st.op = EXEC_SELECT;
3166 new_st.ext.case_list = head;
3171 gfc_error ("Syntax error in CASE-specification at %C");
3174 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
3178 /********************* WHERE subroutines ********************/
3180 /* Match the rest of a simple WHERE statement that follows an IF statement.
3184 match_simple_where (void)
3190 m = gfc_match (" ( %e )", &expr);
3194 m = gfc_match_assignment ();
3197 if (m == MATCH_ERROR)
3200 if (gfc_match_eos () != MATCH_YES)
3203 c = gfc_get_code ();
3207 c->next = gfc_get_code ();
3210 gfc_clear_new_st ();
3212 new_st.op = EXEC_WHERE;
3218 gfc_syntax_error (ST_WHERE);
3221 gfc_free_expr (expr);
3225 /* Match a WHERE statement. */
3228 gfc_match_where (gfc_statement * st)
3234 m0 = gfc_match_label ();
3235 if (m0 == MATCH_ERROR)
3238 m = gfc_match (" where ( %e )", &expr);
3242 if (gfc_match_eos () == MATCH_YES)
3244 *st = ST_WHERE_BLOCK;
3246 new_st.op = EXEC_WHERE;
3251 m = gfc_match_assignment ();
3253 gfc_syntax_error (ST_WHERE);
3257 gfc_free_expr (expr);
3261 /* We've got a simple WHERE statement. */
3263 c = gfc_get_code ();
3267 c->next = gfc_get_code ();
3270 gfc_clear_new_st ();
3272 new_st.op = EXEC_WHERE;
3279 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3280 new_st if successful. */
3283 gfc_match_elsewhere (void)
3285 char name[GFC_MAX_SYMBOL_LEN + 1];
3289 if (gfc_current_state () != COMP_WHERE)
3291 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3297 if (gfc_match_char ('(') == MATCH_YES)
3299 m = gfc_match_expr (&expr);
3302 if (m == MATCH_ERROR)
3305 if (gfc_match_char (')') != MATCH_YES)
3309 if (gfc_match_eos () != MATCH_YES)
3310 { /* Better be a name at this point */
3311 m = gfc_match_name (name);
3314 if (m == MATCH_ERROR)
3317 if (gfc_match_eos () != MATCH_YES)
3320 if (strcmp (name, gfc_current_block ()->name) != 0)
3322 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3323 name, gfc_current_block ()->name);
3328 new_st.op = EXEC_WHERE;
3333 gfc_syntax_error (ST_ELSEWHERE);
3336 gfc_free_expr (expr);
3341 /******************** FORALL subroutines ********************/
3343 /* Free a list of FORALL iterators. */
3346 gfc_free_forall_iterator (gfc_forall_iterator * iter)
3348 gfc_forall_iterator *next;
3354 gfc_free_expr (iter->var);
3355 gfc_free_expr (iter->start);
3356 gfc_free_expr (iter->end);
3357 gfc_free_expr (iter->stride);
3365 /* Match an iterator as part of a FORALL statement. The format is:
3367 <var> = <start>:<end>[:<stride>][, <scalar mask>] */
3370 match_forall_iterator (gfc_forall_iterator ** result)
3372 gfc_forall_iterator *iter;
3376 where = gfc_current_locus;
3377 iter = gfc_getmem (sizeof (gfc_forall_iterator));
3379 m = gfc_match_variable (&iter->var, 0);
3383 if (gfc_match_char ('=') != MATCH_YES)
3389 m = gfc_match_expr (&iter->start);
3393 if (gfc_match_char (':') != MATCH_YES)
3396 m = gfc_match_expr (&iter->end);
3399 if (m == MATCH_ERROR)
3402 if (gfc_match_char (':') == MATCH_NO)
3403 iter->stride = gfc_int_expr (1);
3406 m = gfc_match_expr (&iter->stride);
3409 if (m == MATCH_ERROR)
3413 /* Mark the iteration variable's symbol as used as a FORALL index. */
3414 iter->var->symtree->n.sym->forall_index = true;
3420 gfc_error ("Syntax error in FORALL iterator at %C");
3424 /* Make sure that potential internal function references in the
3425 mask do not get messed up. */
3427 && iter->var->expr_type == EXPR_VARIABLE
3428 && iter->var->symtree->n.sym->refs == 1)
3429 iter->var->symtree->n.sym->attr.flavor = FL_UNKNOWN;
3431 gfc_current_locus = where;
3432 gfc_free_forall_iterator (iter);
3437 /* Match the header of a FORALL statement. */
3440 match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask)
3442 gfc_forall_iterator *head, *tail, *new;
3446 gfc_gobble_whitespace ();
3451 if (gfc_match_char ('(') != MATCH_YES)
3454 m = match_forall_iterator (&new);
3455 if (m == MATCH_ERROR)
3464 if (gfc_match_char (',') != MATCH_YES)
3467 m = match_forall_iterator (&new);
3468 if (m == MATCH_ERROR)
3478 /* Have to have a mask expression */
3480 m = gfc_match_expr (&msk);
3483 if (m == MATCH_ERROR)
3489 if (gfc_match_char (')') == MATCH_NO)
3497 gfc_syntax_error (ST_FORALL);
3500 gfc_free_expr (msk);
3501 gfc_free_forall_iterator (head);
3506 /* Match the rest of a simple FORALL statement that follows an IF statement.
3510 match_simple_forall (void)
3512 gfc_forall_iterator *head;
3521 m = match_forall_header (&head, &mask);
3528 m = gfc_match_assignment ();
3530 if (m == MATCH_ERROR)
3534 m = gfc_match_pointer_assignment ();
3535 if (m == MATCH_ERROR)
3541 c = gfc_get_code ();
3543 c->loc = gfc_current_locus;
3545 if (gfc_match_eos () != MATCH_YES)
3548 gfc_clear_new_st ();
3549 new_st.op = EXEC_FORALL;
3551 new_st.ext.forall_iterator = head;
3552 new_st.block = gfc_get_code ();
3554 new_st.block->op = EXEC_FORALL;
3555 new_st.block->next = c;
3560 gfc_syntax_error (ST_FORALL);
3563 gfc_free_forall_iterator (head);
3564 gfc_free_expr (mask);
3570 /* Match a FORALL statement. */
3573 gfc_match_forall (gfc_statement * st)
3575 gfc_forall_iterator *head;
3584 m0 = gfc_match_label ();
3585 if (m0 == MATCH_ERROR)
3588 m = gfc_match (" forall");
3592 m = match_forall_header (&head, &mask);
3593 if (m == MATCH_ERROR)
3598 if (gfc_match_eos () == MATCH_YES)
3600 *st = ST_FORALL_BLOCK;
3602 new_st.op = EXEC_FORALL;
3604 new_st.ext.forall_iterator = head;
3609 m = gfc_match_assignment ();
3610 if (m == MATCH_ERROR)
3614 m = gfc_match_pointer_assignment ();
3615 if (m == MATCH_ERROR)
3621 c = gfc_get_code ();
3623 c->loc = gfc_current_locus;
3625 gfc_clear_new_st ();
3626 new_st.op = EXEC_FORALL;
3628 new_st.ext.forall_iterator = head;
3629 new_st.block = gfc_get_code ();
3631 new_st.block->op = EXEC_FORALL;
3632 new_st.block->next = c;
3638 gfc_syntax_error (ST_FORALL);
3641 gfc_free_forall_iterator (head);
3642 gfc_free_expr (mask);
3643 gfc_free_statements (c);