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 t = &gfc_current_ns->blank_common;
2331 if (t->head == NULL)
2332 t->where = gfc_current_locus;
2337 t = gfc_get_common (name, 0);
2346 while (tail->common_next)
2347 tail = tail->common_next;
2350 /* Grab the list of symbols. */
2353 m = gfc_match_symbol (&sym, 0);
2354 if (m == MATCH_ERROR)
2359 if (sym->attr.in_common)
2361 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2366 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2369 if (sym->value != NULL
2370 && (name[0] == '\0' || !sym->attr.data))
2372 if (name[0] == '\0')
2373 gfc_error ("Previously initialized symbol '%s' in "
2374 "blank COMMON block at %C", sym->name);
2376 gfc_error ("Previously initialized symbol '%s' in "
2377 "COMMON block '%s' at %C", sym->name, name);
2381 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2384 /* Derived type names must have the SEQUENCE attribute. */
2385 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2388 ("Derived type variable in COMMON at %C does not have the "
2389 "SEQUENCE attribute");
2394 tail->common_next = sym;
2400 /* Deal with an optional array specification after the
2402 m = gfc_match_array_spec (&as);
2403 if (m == MATCH_ERROR)
2408 if (as->type != AS_EXPLICIT)
2411 ("Array specification for symbol '%s' in COMMON at %C "
2412 "must be explicit", sym->name);
2416 if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2419 if (sym->attr.pointer)
2422 ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2432 sym->common_head = t;
2434 /* Check to see if the symbol is already in an equivalence group.
2435 If it is, set the other members as being in common. */
2436 if (sym->attr.in_equivalence)
2438 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
2440 for (e2 = e1; e2; e2 = e2->eq)
2441 if (e2->expr->symtree->n.sym == sym)
2448 for (e2 = e1; e2; e2 = e2->eq)
2450 other = e2->expr->symtree->n.sym;
2451 if (other->common_head
2452 && other->common_head != sym->common_head)
2454 gfc_error ("Symbol '%s', in COMMON block '%s' at "
2455 "%C is being indirectly equivalenced to "
2456 "another COMMON block '%s'",
2458 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)
2564 ("Namelist group name '%s' at %C already has a basic type "
2565 "of %s", group_name->name, 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 this
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->as && sym->as->type == AS_ASSUMED_SHAPE
2604 && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
2605 "namelist '%s' at %C is an extension.",
2606 sym->name, group_name->name) == FAILURE)
2609 nl = gfc_get_namelist ();
2613 if (group_name->namelist == NULL)
2614 group_name->namelist = group_name->namelist_tail = nl;
2617 group_name->namelist_tail->next = nl;
2618 group_name->namelist_tail = nl;
2621 if (gfc_match_eos () == MATCH_YES)
2624 m = gfc_match_char (',');
2626 if (gfc_match_char ('/') == MATCH_YES)
2628 m2 = gfc_match (" %s /", &group_name);
2629 if (m2 == MATCH_YES)
2631 if (m2 == MATCH_ERROR)
2645 gfc_syntax_error (ST_NAMELIST);
2652 /* Match a MODULE statement. */
2655 gfc_match_module (void)
2659 m = gfc_match (" %s%t", &gfc_new_block);
2663 if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
2664 gfc_new_block->name, NULL) == FAILURE)
2671 /* Free equivalence sets and lists. Recursively is the easiest way to
2675 gfc_free_equiv (gfc_equiv * eq)
2681 gfc_free_equiv (eq->eq);
2682 gfc_free_equiv (eq->next);
2684 gfc_free_expr (eq->expr);
2689 /* Match an EQUIVALENCE statement. */
2692 gfc_match_equivalence (void)
2694 gfc_equiv *eq, *set, *tail;
2698 gfc_common_head *common_head = NULL;
2706 eq = gfc_get_equiv ();
2710 eq->next = gfc_current_ns->equiv;
2711 gfc_current_ns->equiv = eq;
2713 if (gfc_match_char ('(') != MATCH_YES)
2717 common_flag = FALSE;
2722 m = gfc_match_equiv_variable (&set->expr);
2723 if (m == MATCH_ERROR)
2728 /* count the number of objects. */
2731 if (gfc_match_char ('%') == MATCH_YES)
2733 gfc_error ("Derived type component %C is not a "
2734 "permitted EQUIVALENCE member");
2738 for (ref = set->expr->ref; ref; ref = ref->next)
2739 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2742 ("Array reference in EQUIVALENCE at %C cannot be an "
2747 sym = set->expr->symtree->n.sym;
2749 if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL)
2753 if (sym->attr.in_common)
2756 common_head = sym->common_head;
2759 if (gfc_match_char (')') == MATCH_YES)
2762 if (gfc_match_char (',') != MATCH_YES)
2765 set->eq = gfc_get_equiv ();
2771 gfc_error ("EQUIVALENCE at %C requires two or more objects");
2775 /* If one of the members of an equivalence is in common, then
2776 mark them all as being in common. Before doing this, check
2777 that members of the equivalence group are not in different
2780 for (set = eq; set; set = set->eq)
2782 sym = set->expr->symtree->n.sym;
2783 if (sym->common_head && sym->common_head != common_head)
2785 gfc_error ("Attempt to indirectly overlap COMMON "
2786 "blocks %s and %s by EQUIVALENCE at %C",
2787 sym->common_head->name,
2791 sym->attr.in_common = 1;
2792 sym->common_head = common_head;
2795 if (gfc_match_eos () == MATCH_YES)
2797 if (gfc_match_char (',') != MATCH_YES)
2804 gfc_syntax_error (ST_EQUIVALENCE);
2810 gfc_free_equiv (gfc_current_ns->equiv);
2811 gfc_current_ns->equiv = eq;
2816 /* Check that a statement function is not recursive. This is done by looking
2817 for the statement function symbol(sym) by looking recursively through its
2818 expression(e). If a reference to sym is found, true is returned.
2819 12.5.4 requires that any variable of function that is implicitly typed
2820 shall have that type confirmed by any subsequent type declaration. The
2821 implicit typing is conveniently done here. */
2824 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
2826 gfc_actual_arglist *arg;
2833 switch (e->expr_type)
2836 for (arg = e->value.function.actual; arg; arg = arg->next)
2838 if (sym->name == arg->name
2839 || recursive_stmt_fcn (arg->expr, sym))
2843 if (e->symtree == NULL)
2846 /* Check the name before testing for nested recursion! */
2847 if (sym->name == e->symtree->n.sym->name)
2850 /* Catch recursion via other statement functions. */
2851 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
2852 && e->symtree->n.sym->value
2853 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
2856 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
2857 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
2862 if (e->symtree && sym->name == e->symtree->n.sym->name)
2865 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
2866 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
2870 if (recursive_stmt_fcn (e->value.op.op1, sym)
2871 || recursive_stmt_fcn (e->value.op.op2, sym))
2879 /* Component references do not need to be checked. */
2882 for (ref = e->ref; ref; ref = ref->next)
2887 for (i = 0; i < ref->u.ar.dimen; i++)
2889 if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
2890 || recursive_stmt_fcn (ref->u.ar.end[i], sym)
2891 || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
2897 if (recursive_stmt_fcn (ref->u.ss.start, sym)
2898 || recursive_stmt_fcn (ref->u.ss.end, sym))
2912 /* Match a statement function declaration. It is so easy to match
2913 non-statement function statements with a MATCH_ERROR as opposed to
2914 MATCH_NO that we suppress error message in most cases. */
2917 gfc_match_st_function (void)
2919 gfc_error_buf old_error;
2924 m = gfc_match_symbol (&sym, 0);
2928 gfc_push_error (&old_error);
2930 if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
2931 sym->name, NULL) == FAILURE)
2934 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2937 m = gfc_match (" = %e%t", &expr);
2941 gfc_free_error (&old_error);
2942 if (m == MATCH_ERROR)
2945 if (recursive_stmt_fcn (expr, sym))
2947 gfc_error ("Statement function at %L is recursive",
2957 gfc_pop_error (&old_error);
2962 /***************** SELECT CASE subroutines ******************/
2964 /* Free a single case structure. */
2967 free_case (gfc_case * p)
2969 if (p->low == p->high)
2971 gfc_free_expr (p->low);
2972 gfc_free_expr (p->high);
2977 /* Free a list of case structures. */
2980 gfc_free_case_list (gfc_case * p)
2992 /* Match a single case selector. */
2995 match_case_selector (gfc_case ** cp)
3000 c = gfc_get_case ();
3001 c->where = gfc_current_locus;
3003 if (gfc_match_char (':') == MATCH_YES)
3005 m = gfc_match_init_expr (&c->high);
3008 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 ())
3061 gfc_gobble_whitespace ();
3063 m = gfc_match_name (name);
3067 if (strcmp (name, gfc_current_block ()->name) != 0)
3069 gfc_error ("Expected case name of '%s' at %C",
3070 gfc_current_block ()->name);
3074 return gfc_match_eos ();
3078 /* Match a SELECT statement. */
3081 gfc_match_select (void)
3086 m = gfc_match_label ();
3087 if (m == MATCH_ERROR)
3090 m = gfc_match (" select case ( %e )%t", &expr);
3094 new_st.op = EXEC_SELECT;
3101 /* Match a CASE statement. */
3104 gfc_match_case (void)
3106 gfc_case *c, *head, *tail;
3111 if (gfc_current_state () != COMP_SELECT)
3113 gfc_error ("Unexpected CASE statement at %C");
3117 if (gfc_match ("% default") == MATCH_YES)
3119 m = match_case_eos ();
3122 if (m == MATCH_ERROR)
3125 new_st.op = EXEC_SELECT;
3126 c = gfc_get_case ();
3127 c->where = gfc_current_locus;
3128 new_st.ext.case_list = c;
3132 if (gfc_match_char ('(') != MATCH_YES)
3137 if (match_case_selector (&c) == MATCH_ERROR)
3147 if (gfc_match_char (')') == MATCH_YES)
3149 if (gfc_match_char (',') != MATCH_YES)
3153 m = match_case_eos ();
3156 if (m == MATCH_ERROR)
3159 new_st.op = EXEC_SELECT;
3160 new_st.ext.case_list = head;
3165 gfc_error ("Syntax error in CASE-specification at %C");
3168 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
3172 /********************* WHERE subroutines ********************/
3174 /* Match the rest of a simple WHERE statement that follows an IF statement.
3178 match_simple_where (void)
3184 m = gfc_match (" ( %e )", &expr);
3188 m = gfc_match_assignment ();
3191 if (m == MATCH_ERROR)
3194 if (gfc_match_eos () != MATCH_YES)
3197 c = gfc_get_code ();
3201 c->next = gfc_get_code ();
3204 gfc_clear_new_st ();
3206 new_st.op = EXEC_WHERE;
3212 gfc_syntax_error (ST_WHERE);
3215 gfc_free_expr (expr);
3219 /* Match a WHERE statement. */
3222 gfc_match_where (gfc_statement * st)
3228 m0 = gfc_match_label ();
3229 if (m0 == MATCH_ERROR)
3232 m = gfc_match (" where ( %e )", &expr);
3236 if (gfc_match_eos () == MATCH_YES)
3238 *st = ST_WHERE_BLOCK;
3240 new_st.op = EXEC_WHERE;
3245 m = gfc_match_assignment ();
3247 gfc_syntax_error (ST_WHERE);
3251 gfc_free_expr (expr);
3255 /* We've got a simple WHERE statement. */
3257 c = gfc_get_code ();
3261 c->next = gfc_get_code ();
3264 gfc_clear_new_st ();
3266 new_st.op = EXEC_WHERE;
3273 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3274 new_st if successful. */
3277 gfc_match_elsewhere (void)
3279 char name[GFC_MAX_SYMBOL_LEN + 1];
3283 if (gfc_current_state () != COMP_WHERE)
3285 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3291 if (gfc_match_char ('(') == MATCH_YES)
3293 m = gfc_match_expr (&expr);
3296 if (m == MATCH_ERROR)
3299 if (gfc_match_char (')') != MATCH_YES)
3303 if (gfc_match_eos () != MATCH_YES)
3304 { /* Better be a name at this point */
3305 m = gfc_match_name (name);
3308 if (m == MATCH_ERROR)
3311 if (gfc_match_eos () != MATCH_YES)
3314 if (strcmp (name, gfc_current_block ()->name) != 0)
3316 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3317 name, gfc_current_block ()->name);
3322 new_st.op = EXEC_WHERE;
3327 gfc_syntax_error (ST_ELSEWHERE);
3330 gfc_free_expr (expr);
3335 /******************** FORALL subroutines ********************/
3337 /* Free a list of FORALL iterators. */
3340 gfc_free_forall_iterator (gfc_forall_iterator * iter)
3342 gfc_forall_iterator *next;
3348 gfc_free_expr (iter->var);
3349 gfc_free_expr (iter->start);
3350 gfc_free_expr (iter->end);
3351 gfc_free_expr (iter->stride);
3359 /* Match an iterator as part of a FORALL statement. The format is:
3361 <var> = <start>:<end>[:<stride>][, <scalar mask>] */
3364 match_forall_iterator (gfc_forall_iterator ** result)
3366 gfc_forall_iterator *iter;
3370 where = gfc_current_locus;
3371 iter = gfc_getmem (sizeof (gfc_forall_iterator));
3373 m = gfc_match_variable (&iter->var, 0);
3377 if (gfc_match_char ('=') != MATCH_YES)
3383 m = gfc_match_expr (&iter->start);
3387 if (gfc_match_char (':') != MATCH_YES)
3390 m = gfc_match_expr (&iter->end);
3393 if (m == MATCH_ERROR)
3396 if (gfc_match_char (':') == MATCH_NO)
3397 iter->stride = gfc_int_expr (1);
3400 m = gfc_match_expr (&iter->stride);
3403 if (m == MATCH_ERROR)
3407 /* Mark the iteration variable's symbol as used as a FORALL index. */
3408 iter->var->symtree->n.sym->forall_index = true;
3414 gfc_error ("Syntax error in FORALL iterator at %C");
3418 /* Make sure that potential internal function references in the
3419 mask do not get messed up. */
3421 && iter->var->expr_type == EXPR_VARIABLE
3422 && iter->var->symtree->n.sym->refs == 1)
3423 iter->var->symtree->n.sym->attr.flavor = FL_UNKNOWN;
3425 gfc_current_locus = where;
3426 gfc_free_forall_iterator (iter);
3431 /* Match the header of a FORALL statement. */
3434 match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask)
3436 gfc_forall_iterator *head, *tail, *new;
3440 gfc_gobble_whitespace ();
3445 if (gfc_match_char ('(') != MATCH_YES)
3448 m = match_forall_iterator (&new);
3449 if (m == MATCH_ERROR)
3458 if (gfc_match_char (',') != MATCH_YES)
3461 m = match_forall_iterator (&new);
3462 if (m == MATCH_ERROR)
3472 /* Have to have a mask expression */
3474 m = gfc_match_expr (&msk);
3477 if (m == MATCH_ERROR)
3483 if (gfc_match_char (')') == MATCH_NO)
3491 gfc_syntax_error (ST_FORALL);
3494 gfc_free_expr (msk);
3495 gfc_free_forall_iterator (head);
3500 /* Match the rest of a simple FORALL statement that follows an IF statement.
3504 match_simple_forall (void)
3506 gfc_forall_iterator *head;
3515 m = match_forall_header (&head, &mask);
3522 m = gfc_match_assignment ();
3524 if (m == MATCH_ERROR)
3528 m = gfc_match_pointer_assignment ();
3529 if (m == MATCH_ERROR)
3535 c = gfc_get_code ();
3537 c->loc = gfc_current_locus;
3539 if (gfc_match_eos () != MATCH_YES)
3542 gfc_clear_new_st ();
3543 new_st.op = EXEC_FORALL;
3545 new_st.ext.forall_iterator = head;
3546 new_st.block = gfc_get_code ();
3548 new_st.block->op = EXEC_FORALL;
3549 new_st.block->next = c;
3554 gfc_syntax_error (ST_FORALL);
3557 gfc_free_forall_iterator (head);
3558 gfc_free_expr (mask);
3564 /* Match a FORALL statement. */
3567 gfc_match_forall (gfc_statement * st)
3569 gfc_forall_iterator *head;
3578 m0 = gfc_match_label ();
3579 if (m0 == MATCH_ERROR)
3582 m = gfc_match (" forall");
3586 m = match_forall_header (&head, &mask);
3587 if (m == MATCH_ERROR)
3592 if (gfc_match_eos () == MATCH_YES)
3594 *st = ST_FORALL_BLOCK;
3596 new_st.op = EXEC_FORALL;
3598 new_st.ext.forall_iterator = head;
3603 m = gfc_match_assignment ();
3604 if (m == MATCH_ERROR)
3608 m = gfc_match_pointer_assignment ();
3609 if (m == MATCH_ERROR)
3615 c = gfc_get_code ();
3617 c->loc = gfc_current_locus;
3619 gfc_clear_new_st ();
3620 new_st.op = EXEC_FORALL;
3622 new_st.ext.forall_iterator = head;
3623 new_st.block = gfc_get_code ();
3625 new_st.block->op = EXEC_FORALL;
3626 new_st.block->next = c;
3632 gfc_syntax_error (ST_FORALL);
3635 gfc_free_forall_iterator (head);
3636 gfc_free_expr (mask);
3637 gfc_free_statements (c);