1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
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;
846 lvalue = rvalue = NULL;
847 m = gfc_match (" %v =", &lvalue);
851 if (lvalue->symtree->n.sym->attr.flavor == FL_PARAMETER)
853 gfc_error ("Cannot assign to a PARAMETER variable at %C");
858 m = gfc_match (" %e%t", &rvalue);
862 gfc_set_sym_referenced (lvalue->symtree->n.sym);
864 new_st.op = EXEC_ASSIGN;
865 new_st.expr = lvalue;
866 new_st.expr2 = rvalue;
868 gfc_check_do_variable (lvalue->symtree);
873 gfc_current_locus = old_loc;
874 gfc_free_expr (lvalue);
875 gfc_free_expr (rvalue);
880 /* Match a pointer assignment statement. */
883 gfc_match_pointer_assignment (void)
885 gfc_expr *lvalue, *rvalue;
889 old_loc = gfc_current_locus;
891 lvalue = rvalue = NULL;
893 m = gfc_match (" %v =>", &lvalue);
900 m = gfc_match (" %e%t", &rvalue);
904 new_st.op = EXEC_POINTER_ASSIGN;
905 new_st.expr = lvalue;
906 new_st.expr2 = rvalue;
911 gfc_current_locus = old_loc;
912 gfc_free_expr (lvalue);
913 gfc_free_expr (rvalue);
918 /* We try to match an easy arithmetic IF statement. This only happens
919 when just after having encountered a simple IF statement. This code
920 is really duplicate with parts of the gfc_match_if code, but this is
923 match_arithmetic_if (void)
925 gfc_st_label *l1, *l2, *l3;
929 m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
933 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
934 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
935 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
937 gfc_free_expr (expr);
941 if (gfc_notify_std (GFC_STD_F95_DEL,
942 "Obsolete: arithmetic IF statement at %C") == FAILURE)
945 new_st.op = EXEC_ARITHMETIC_IF;
955 /* The IF statement is a bit of a pain. First of all, there are three
956 forms of it, the simple IF, the IF that starts a block and the
959 There is a problem with the simple IF and that is the fact that we
960 only have a single level of undo information on symbols. What this
961 means is for a simple IF, we must re-match the whole IF statement
962 multiple times in order to guarantee that the symbol table ends up
963 in the proper state. */
965 static match match_simple_forall (void);
966 static match match_simple_where (void);
969 gfc_match_if (gfc_statement * if_type)
972 gfc_st_label *l1, *l2, *l3;
977 n = gfc_match_label ();
978 if (n == MATCH_ERROR)
981 old_loc = gfc_current_locus;
983 m = gfc_match (" if ( %e", &expr);
987 if (gfc_match_char (')') != MATCH_YES)
989 gfc_error ("Syntax error in IF-expression at %C");
990 gfc_free_expr (expr);
994 m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
1001 ("Block label not appropriate for arithmetic IF statement "
1004 gfc_free_expr (expr);
1008 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1009 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1010 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1013 gfc_free_expr (expr);
1017 if (gfc_notify_std (GFC_STD_F95_DEL,
1018 "Obsolete: arithmetic IF statement at %C")
1022 new_st.op = EXEC_ARITHMETIC_IF;
1028 *if_type = ST_ARITHMETIC_IF;
1032 if (gfc_match (" then%t") == MATCH_YES)
1034 new_st.op = EXEC_IF;
1037 *if_type = ST_IF_BLOCK;
1043 gfc_error ("Block label is not appropriate IF statement at %C");
1045 gfc_free_expr (expr);
1049 /* At this point the only thing left is a simple IF statement. At
1050 this point, n has to be MATCH_NO, so we don't have to worry about
1051 re-matching a block label. From what we've got so far, try
1052 matching an assignment. */
1054 *if_type = ST_SIMPLE_IF;
1056 m = gfc_match_assignment ();
1060 gfc_free_expr (expr);
1061 gfc_undo_symbols ();
1062 gfc_current_locus = old_loc;
1064 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_NO, continue to
1065 call the various matchers. For MATCH_ERROR, a mangled assignment
1067 if (m == MATCH_ERROR)
1070 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */
1072 m = gfc_match_pointer_assignment ();
1076 gfc_free_expr (expr);
1077 gfc_undo_symbols ();
1078 gfc_current_locus = old_loc;
1080 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */
1082 /* Look at the next keyword to see which matcher to call. Matching
1083 the keyword doesn't affect the symbol table, so we don't have to
1084 restore between tries. */
1086 #define match(string, subr, statement) \
1087 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1091 match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1092 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1093 match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1094 match ("call", gfc_match_call, ST_CALL)
1095 match ("close", gfc_match_close, ST_CLOSE)
1096 match ("continue", gfc_match_continue, ST_CONTINUE)
1097 match ("cycle", gfc_match_cycle, ST_CYCLE)
1098 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1099 match ("end file", gfc_match_endfile, ST_END_FILE)
1100 match ("exit", gfc_match_exit, ST_EXIT)
1101 match ("flush", gfc_match_flush, ST_FLUSH)
1102 match ("forall", match_simple_forall, ST_FORALL)
1103 match ("go to", gfc_match_goto, ST_GOTO)
1104 match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1105 match ("inquire", gfc_match_inquire, ST_INQUIRE)
1106 match ("nullify", gfc_match_nullify, ST_NULLIFY)
1107 match ("open", gfc_match_open, ST_OPEN)
1108 match ("pause", gfc_match_pause, ST_NONE)
1109 match ("print", gfc_match_print, ST_WRITE)
1110 match ("read", gfc_match_read, ST_READ)
1111 match ("return", gfc_match_return, ST_RETURN)
1112 match ("rewind", gfc_match_rewind, ST_REWIND)
1113 match ("stop", gfc_match_stop, ST_STOP)
1114 match ("where", match_simple_where, ST_WHERE)
1115 match ("write", gfc_match_write, ST_WRITE)
1117 /* All else has failed, so give up. See if any of the matchers has
1118 stored an error message of some sort. */
1119 if (gfc_error_check () == 0)
1120 gfc_error ("Unclassifiable statement in IF-clause at %C");
1122 gfc_free_expr (expr);
1127 gfc_error ("Syntax error in IF-clause at %C");
1130 gfc_free_expr (expr);
1134 /* At this point, we've matched the single IF and the action clause
1135 is in new_st. Rearrange things so that the IF statement appears
1138 p = gfc_get_code ();
1139 p->next = gfc_get_code ();
1141 p->next->loc = gfc_current_locus;
1146 gfc_clear_new_st ();
1148 new_st.op = EXEC_IF;
1157 /* Match an ELSE statement. */
1160 gfc_match_else (void)
1162 char name[GFC_MAX_SYMBOL_LEN + 1];
1164 if (gfc_match_eos () == MATCH_YES)
1167 if (gfc_match_name (name) != MATCH_YES
1168 || gfc_current_block () == NULL
1169 || gfc_match_eos () != MATCH_YES)
1171 gfc_error ("Unexpected junk after ELSE statement at %C");
1175 if (strcmp (name, gfc_current_block ()->name) != 0)
1177 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1178 name, gfc_current_block ()->name);
1186 /* Match an ELSE IF statement. */
1189 gfc_match_elseif (void)
1191 char name[GFC_MAX_SYMBOL_LEN + 1];
1195 m = gfc_match (" ( %e ) then", &expr);
1199 if (gfc_match_eos () == MATCH_YES)
1202 if (gfc_match_name (name) != MATCH_YES
1203 || gfc_current_block () == NULL
1204 || gfc_match_eos () != MATCH_YES)
1206 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1210 if (strcmp (name, gfc_current_block ()->name) != 0)
1212 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1213 name, gfc_current_block ()->name);
1218 new_st.op = EXEC_IF;
1223 gfc_free_expr (expr);
1228 /* Free a gfc_iterator structure. */
1231 gfc_free_iterator (gfc_iterator * iter, int flag)
1237 gfc_free_expr (iter->var);
1238 gfc_free_expr (iter->start);
1239 gfc_free_expr (iter->end);
1240 gfc_free_expr (iter->step);
1247 /* Match a DO statement. */
1252 gfc_iterator iter, *ip;
1254 gfc_st_label *label;
1257 old_loc = gfc_current_locus;
1260 iter.var = iter.start = iter.end = iter.step = NULL;
1262 m = gfc_match_label ();
1263 if (m == MATCH_ERROR)
1266 if (gfc_match (" do") != MATCH_YES)
1269 m = gfc_match_st_label (&label);
1270 if (m == MATCH_ERROR)
1273 /* Match an infinite DO, make it like a DO WHILE(.TRUE.) */
1275 if (gfc_match_eos () == MATCH_YES)
1277 iter.end = gfc_logical_expr (1, NULL);
1278 new_st.op = EXEC_DO_WHILE;
1282 /* match an optional comma, if no comma is found a space is obligatory. */
1283 if (gfc_match_char(',') != MATCH_YES
1284 && gfc_match ("% ") != MATCH_YES)
1287 /* See if we have a DO WHILE. */
1288 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1290 new_st.op = EXEC_DO_WHILE;
1294 /* The abortive DO WHILE may have done something to the symbol
1295 table, so we start over: */
1296 gfc_undo_symbols ();
1297 gfc_current_locus = old_loc;
1299 gfc_match_label (); /* This won't error */
1300 gfc_match (" do "); /* This will work */
1302 gfc_match_st_label (&label); /* Can't error out */
1303 gfc_match_char (','); /* Optional comma */
1305 m = gfc_match_iterator (&iter, 0);
1308 if (m == MATCH_ERROR)
1311 gfc_check_do_variable (iter.var->symtree);
1313 if (gfc_match_eos () != MATCH_YES)
1315 gfc_syntax_error (ST_DO);
1319 new_st.op = EXEC_DO;
1323 && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1326 new_st.label = label;
1328 if (new_st.op == EXEC_DO_WHILE)
1329 new_st.expr = iter.end;
1332 new_st.ext.iterator = ip = gfc_get_iterator ();
1339 gfc_free_iterator (&iter, 0);
1345 /* Match an EXIT or CYCLE statement. */
1348 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1350 gfc_state_data *p, *o;
1354 if (gfc_match_eos () == MATCH_YES)
1358 m = gfc_match ("% %s%t", &sym);
1359 if (m == MATCH_ERROR)
1363 gfc_syntax_error (st);
1367 if (sym->attr.flavor != FL_LABEL)
1369 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1370 sym->name, gfc_ascii_statement (st));
1375 /* Find the loop mentioned specified by the label (or lack of a
1377 for (o = NULL, p = gfc_state_stack; p; p = p->previous)
1378 if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1380 else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
1386 gfc_error ("%s statement at %C is not within a loop",
1387 gfc_ascii_statement (st));
1389 gfc_error ("%s statement at %C is not within loop '%s'",
1390 gfc_ascii_statement (st), sym->name);
1397 gfc_error ("%s statement at %C leaving OpenMP structured block",
1398 gfc_ascii_statement (st));
1401 else if (st == ST_EXIT
1402 && p->previous != NULL
1403 && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
1404 && (p->previous->head->op == EXEC_OMP_DO
1405 || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
1407 gcc_assert (p->previous->head->next != NULL);
1408 gcc_assert (p->previous->head->next->op == EXEC_DO
1409 || p->previous->head->next->op == EXEC_DO_WHILE);
1410 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1414 /* Save the first statement in the loop - needed by the backend. */
1415 new_st.ext.whichloop = p->head;
1418 /* new_st.sym = sym;*/
1424 /* Match the EXIT statement. */
1427 gfc_match_exit (void)
1430 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1434 /* Match the CYCLE statement. */
1437 gfc_match_cycle (void)
1440 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1444 /* Match a number or character constant after a STOP or PAUSE statement. */
1447 gfc_match_stopcode (gfc_statement st)
1457 if (gfc_match_eos () != MATCH_YES)
1459 m = gfc_match_small_literal_int (&stop_code, &cnt);
1460 if (m == MATCH_ERROR)
1463 if (m == MATCH_YES && cnt > 5)
1465 gfc_error ("Too many digits in STOP code at %C");
1471 /* Try a character constant. */
1472 m = gfc_match_expr (&e);
1473 if (m == MATCH_ERROR)
1477 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1481 if (gfc_match_eos () != MATCH_YES)
1485 if (gfc_pure (NULL))
1487 gfc_error ("%s statement not allowed in PURE procedure at %C",
1488 gfc_ascii_statement (st));
1492 new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1494 new_st.ext.stop_code = stop_code;
1499 gfc_syntax_error (st);
1507 /* Match the (deprecated) PAUSE statement. */
1510 gfc_match_pause (void)
1514 m = gfc_match_stopcode (ST_PAUSE);
1517 if (gfc_notify_std (GFC_STD_F95_DEL,
1518 "Obsolete: PAUSE statement at %C")
1526 /* Match the STOP statement. */
1529 gfc_match_stop (void)
1531 return gfc_match_stopcode (ST_STOP);
1535 /* Match a CONTINUE statement. */
1538 gfc_match_continue (void)
1541 if (gfc_match_eos () != MATCH_YES)
1543 gfc_syntax_error (ST_CONTINUE);
1547 new_st.op = EXEC_CONTINUE;
1552 /* Match the (deprecated) ASSIGN statement. */
1555 gfc_match_assign (void)
1558 gfc_st_label *label;
1560 if (gfc_match (" %l", &label) == MATCH_YES)
1562 if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
1564 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
1566 if (gfc_notify_std (GFC_STD_F95_DEL,
1567 "Obsolete: ASSIGN statement at %C")
1571 expr->symtree->n.sym->attr.assign = 1;
1573 new_st.op = EXEC_LABEL_ASSIGN;
1574 new_st.label = label;
1583 /* Match the GO TO statement. As a computed GOTO statement is
1584 matched, it is transformed into an equivalent SELECT block. No
1585 tree is necessary, and the resulting jumps-to-jumps are
1586 specifically optimized away by the back end. */
1589 gfc_match_goto (void)
1591 gfc_code *head, *tail;
1594 gfc_st_label *label;
1598 if (gfc_match (" %l%t", &label) == MATCH_YES)
1600 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1603 new_st.op = EXEC_GOTO;
1604 new_st.label = label;
1608 /* The assigned GO TO statement. */
1610 if (gfc_match_variable (&expr, 0) == MATCH_YES)
1612 if (gfc_notify_std (GFC_STD_F95_DEL,
1613 "Obsolete: Assigned GOTO statement at %C")
1617 new_st.op = EXEC_GOTO;
1620 if (gfc_match_eos () == MATCH_YES)
1623 /* Match label list. */
1624 gfc_match_char (',');
1625 if (gfc_match_char ('(') != MATCH_YES)
1627 gfc_syntax_error (ST_GOTO);
1634 m = gfc_match_st_label (&label);
1638 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1642 head = tail = gfc_get_code ();
1645 tail->block = gfc_get_code ();
1649 tail->label = label;
1650 tail->op = EXEC_GOTO;
1652 while (gfc_match_char (',') == MATCH_YES);
1654 if (gfc_match (")%t") != MATCH_YES)
1660 "Statement label list in GOTO at %C cannot be empty");
1663 new_st.block = head;
1668 /* Last chance is a computed GO TO statement. */
1669 if (gfc_match_char ('(') != MATCH_YES)
1671 gfc_syntax_error (ST_GOTO);
1680 m = gfc_match_st_label (&label);
1684 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1688 head = tail = gfc_get_code ();
1691 tail->block = gfc_get_code ();
1695 cp = gfc_get_case ();
1696 cp->low = cp->high = gfc_int_expr (i++);
1698 tail->op = EXEC_SELECT;
1699 tail->ext.case_list = cp;
1701 tail->next = gfc_get_code ();
1702 tail->next->op = EXEC_GOTO;
1703 tail->next->label = label;
1705 while (gfc_match_char (',') == MATCH_YES);
1707 if (gfc_match_char (')') != MATCH_YES)
1712 gfc_error ("Statement label list in GOTO at %C cannot be empty");
1716 /* Get the rest of the statement. */
1717 gfc_match_char (',');
1719 if (gfc_match (" %e%t", &expr) != MATCH_YES)
1722 /* At this point, a computed GOTO has been fully matched and an
1723 equivalent SELECT statement constructed. */
1725 new_st.op = EXEC_SELECT;
1728 /* Hack: For a "real" SELECT, the expression is in expr. We put
1729 it in expr2 so we can distinguish then and produce the correct
1731 new_st.expr2 = expr;
1732 new_st.block = head;
1736 gfc_syntax_error (ST_GOTO);
1738 gfc_free_statements (head);
1743 /* Frees a list of gfc_alloc structures. */
1746 gfc_free_alloc_list (gfc_alloc * p)
1753 gfc_free_expr (p->expr);
1759 /* Match an ALLOCATE statement. */
1762 gfc_match_allocate (void)
1764 gfc_alloc *head, *tail;
1771 if (gfc_match_char ('(') != MATCH_YES)
1777 head = tail = gfc_get_alloc ();
1780 tail->next = gfc_get_alloc ();
1784 m = gfc_match_variable (&tail->expr, 0);
1787 if (m == MATCH_ERROR)
1790 if (gfc_check_do_variable (tail->expr->symtree))
1794 && gfc_impure_variable (tail->expr->symtree->n.sym))
1796 gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1801 if (tail->expr->ts.type == BT_DERIVED)
1802 tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
1804 if (gfc_match_char (',') != MATCH_YES)
1807 m = gfc_match (" stat = %v", &stat);
1808 if (m == MATCH_ERROR)
1816 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1819 ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
1820 "INTENT(IN)", stat->symtree->n.sym->name);
1824 if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
1827 ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
1832 if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1834 gfc_error("STAT expression at %C must be a variable");
1838 gfc_check_do_variable(stat->symtree);
1841 if (gfc_match (" )%t") != MATCH_YES)
1844 new_st.op = EXEC_ALLOCATE;
1846 new_st.ext.alloc_list = head;
1851 gfc_syntax_error (ST_ALLOCATE);
1854 gfc_free_expr (stat);
1855 gfc_free_alloc_list (head);
1860 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1861 a set of pointer assignments to intrinsic NULL(). */
1864 gfc_match_nullify (void)
1872 if (gfc_match_char ('(') != MATCH_YES)
1877 m = gfc_match_variable (&p, 0);
1878 if (m == MATCH_ERROR)
1883 if (gfc_check_do_variable(p->symtree))
1886 if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
1889 ("Illegal variable in NULLIFY at %C for a PURE procedure");
1893 /* build ' => NULL() ' */
1894 e = gfc_get_expr ();
1895 e->where = gfc_current_locus;
1896 e->expr_type = EXPR_NULL;
1897 e->ts.type = BT_UNKNOWN;
1904 tail->next = gfc_get_code ();
1908 tail->op = EXEC_POINTER_ASSIGN;
1912 if (gfc_match (" )%t") == MATCH_YES)
1914 if (gfc_match_char (',') != MATCH_YES)
1921 gfc_syntax_error (ST_NULLIFY);
1924 gfc_free_statements (new_st.next);
1929 /* Match a DEALLOCATE statement. */
1932 gfc_match_deallocate (void)
1934 gfc_alloc *head, *tail;
1941 if (gfc_match_char ('(') != MATCH_YES)
1947 head = tail = gfc_get_alloc ();
1950 tail->next = gfc_get_alloc ();
1954 m = gfc_match_variable (&tail->expr, 0);
1955 if (m == MATCH_ERROR)
1960 if (gfc_check_do_variable (tail->expr->symtree))
1964 && gfc_impure_variable (tail->expr->symtree->n.sym))
1967 ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
1972 if (gfc_match_char (',') != MATCH_YES)
1975 m = gfc_match (" stat = %v", &stat);
1976 if (m == MATCH_ERROR)
1984 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1986 gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
1987 "cannot be INTENT(IN)", stat->symtree->n.sym->name);
1991 if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym))
1993 gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
1994 "for a PURE procedure");
1998 if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
2000 gfc_error("STAT expression at %C must be a variable");
2004 gfc_check_do_variable(stat->symtree);
2007 if (gfc_match (" )%t") != MATCH_YES)
2010 new_st.op = EXEC_DEALLOCATE;
2012 new_st.ext.alloc_list = head;
2017 gfc_syntax_error (ST_DEALLOCATE);
2020 gfc_free_expr (stat);
2021 gfc_free_alloc_list (head);
2026 /* Match a RETURN statement. */
2029 gfc_match_return (void)
2033 gfc_compile_state s;
2037 if (gfc_match_eos () == MATCH_YES)
2040 if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
2042 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2047 if (gfc_current_form == FORM_FREE)
2049 /* The following are valid, so we can't require a blank after the
2053 c = gfc_peek_char ();
2054 if (ISALPHA (c) || ISDIGIT (c))
2058 m = gfc_match (" %e%t", &e);
2061 if (m == MATCH_ERROR)
2064 gfc_syntax_error (ST_RETURN);
2071 gfc_enclosing_unit (&s);
2072 if (s == COMP_PROGRAM
2073 && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
2074 "main program at %C") == FAILURE)
2077 new_st.op = EXEC_RETURN;
2084 /* Match a CALL statement. The tricky part here are possible
2085 alternate return specifiers. We handle these by having all
2086 "subroutines" actually return an integer via a register that gives
2087 the return number. If the call specifies alternate returns, we
2088 generate code for a SELECT statement whose case clauses contain
2089 GOTOs to the various labels. */
2092 gfc_match_call (void)
2094 char name[GFC_MAX_SYMBOL_LEN + 1];
2095 gfc_actual_arglist *a, *arglist;
2105 m = gfc_match ("% %n", name);
2111 if (gfc_get_ha_sym_tree (name, &st))
2115 gfc_set_sym_referenced (sym);
2117 if (!sym->attr.generic
2118 && !sym->attr.subroutine
2119 && gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2122 if (gfc_match_eos () != MATCH_YES)
2124 m = gfc_match_actual_arglist (1, &arglist);
2127 if (m == MATCH_ERROR)
2130 if (gfc_match_eos () != MATCH_YES)
2134 /* If any alternate return labels were found, construct a SELECT
2135 statement that will jump to the right place. */
2138 for (a = arglist; a; a = a->next)
2139 if (a->expr == NULL)
2144 gfc_symtree *select_st;
2145 gfc_symbol *select_sym;
2146 char name[GFC_MAX_SYMBOL_LEN + 1];
2148 new_st.next = c = gfc_get_code ();
2149 c->op = EXEC_SELECT;
2150 sprintf (name, "_result_%s",sym->name);
2151 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail */
2153 select_sym = select_st->n.sym;
2154 select_sym->ts.type = BT_INTEGER;
2155 select_sym->ts.kind = gfc_default_integer_kind;
2156 gfc_set_sym_referenced (select_sym);
2157 c->expr = gfc_get_expr ();
2158 c->expr->expr_type = EXPR_VARIABLE;
2159 c->expr->symtree = select_st;
2160 c->expr->ts = select_sym->ts;
2161 c->expr->where = gfc_current_locus;
2164 for (a = arglist; a; a = a->next)
2166 if (a->expr != NULL)
2169 if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2174 c->block = gfc_get_code ();
2176 c->op = EXEC_SELECT;
2178 new_case = gfc_get_case ();
2179 new_case->high = new_case->low = gfc_int_expr (i);
2180 c->ext.case_list = new_case;
2182 c->next = gfc_get_code ();
2183 c->next->op = EXEC_GOTO;
2184 c->next->label = a->label;
2188 new_st.op = EXEC_CALL;
2189 new_st.symtree = st;
2190 new_st.ext.actual = arglist;
2195 gfc_syntax_error (ST_CALL);
2198 gfc_free_actual_arglist (arglist);
2203 /* Given a name, return a pointer to the common head structure,
2204 creating it if it does not exist. If FROM_MODULE is nonzero, we
2205 mangle the name so that it doesn't interfere with commons defined
2206 in the using namespace.
2207 TODO: Add to global symbol tree. */
2210 gfc_get_common (const char *name, int from_module)
2213 static int serial = 0;
2214 char mangled_name[GFC_MAX_SYMBOL_LEN+1];
2218 /* A use associated common block is only needed to correctly layout
2219 the variables it contains. */
2220 snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2221 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2225 st = gfc_find_symtree (gfc_current_ns->common_root, name);
2228 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2231 if (st->n.common == NULL)
2233 st->n.common = gfc_get_common_head ();
2234 st->n.common->where = gfc_current_locus;
2235 strcpy (st->n.common->name, name);
2238 return st->n.common;
2242 /* Match a common block name. */
2245 match_common_name (char *name)
2249 if (gfc_match_char ('/') == MATCH_NO)
2255 if (gfc_match_char ('/') == MATCH_YES)
2261 m = gfc_match_name (name);
2263 if (m == MATCH_ERROR)
2265 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2268 gfc_error ("Syntax error in common block name at %C");
2273 /* Match a COMMON statement. */
2276 gfc_match_common (void)
2278 gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
2279 char name[GFC_MAX_SYMBOL_LEN+1];
2282 gfc_equiv * e1, * e2;
2286 old_blank_common = gfc_current_ns->blank_common.head;
2287 if (old_blank_common)
2289 while (old_blank_common->common_next)
2290 old_blank_common = old_blank_common->common_next;
2297 m = match_common_name (name);
2298 if (m == MATCH_ERROR)
2301 gsym = gfc_get_gsymbol (name);
2302 if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
2304 gfc_error ("Symbol '%s' at %C is already an external symbol that is not COMMON",
2309 if (gsym->type == GSYM_UNKNOWN)
2311 gsym->type = GSYM_COMMON;
2312 gsym->where = gfc_current_locus;
2318 if (name[0] == '\0')
2320 t = &gfc_current_ns->blank_common;
2321 if (t->head == NULL)
2322 t->where = gfc_current_locus;
2327 t = gfc_get_common (name, 0);
2336 while (tail->common_next)
2337 tail = tail->common_next;
2340 /* Grab the list of symbols. */
2343 m = gfc_match_symbol (&sym, 0);
2344 if (m == MATCH_ERROR)
2349 if (sym->attr.in_common)
2351 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2356 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2359 if (sym->value != NULL
2360 && (name[0] == '\0' || !sym->attr.data))
2362 if (name[0] == '\0')
2363 gfc_error ("Previously initialized symbol '%s' in "
2364 "blank COMMON block at %C", sym->name);
2366 gfc_error ("Previously initialized symbol '%s' in "
2367 "COMMON block '%s' at %C", sym->name, name);
2371 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2374 /* Derived type names must have the SEQUENCE attribute. */
2375 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2378 ("Derived type variable in COMMON at %C does not have the "
2379 "SEQUENCE attribute");
2384 tail->common_next = sym;
2390 /* Deal with an optional array specification after the
2392 m = gfc_match_array_spec (&as);
2393 if (m == MATCH_ERROR)
2398 if (as->type != AS_EXPLICIT)
2401 ("Array specification for symbol '%s' in COMMON at %C "
2402 "must be explicit", sym->name);
2406 if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2409 if (sym->attr.pointer)
2412 ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2422 sym->common_head = t;
2424 /* Check to see if the symbol is already in an equivalence group.
2425 If it is, set the other members as being in common. */
2426 if (sym->attr.in_equivalence)
2428 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
2430 for (e2 = e1; e2; e2 = e2->eq)
2431 if (e2->expr->symtree->n.sym == sym)
2438 for (e2 = e1; e2; e2 = e2->eq)
2440 other = e2->expr->symtree->n.sym;
2441 if (other->common_head
2442 && other->common_head != sym->common_head)
2444 gfc_error ("Symbol '%s', in COMMON block '%s' at "
2445 "%C is being indirectly equivalenced to "
2446 "another COMMON block '%s'",
2448 sym->common_head->name,
2449 other->common_head->name);
2452 other->attr.in_common = 1;
2453 other->common_head = t;
2459 gfc_gobble_whitespace ();
2460 if (gfc_match_eos () == MATCH_YES)
2462 if (gfc_peek_char () == '/')
2464 if (gfc_match_char (',') != MATCH_YES)
2466 gfc_gobble_whitespace ();
2467 if (gfc_peek_char () == '/')
2476 gfc_syntax_error (ST_COMMON);
2479 if (old_blank_common)
2480 old_blank_common->common_next = NULL;
2482 gfc_current_ns->blank_common.head = NULL;
2483 gfc_free_array_spec (as);
2488 /* Match a BLOCK DATA program unit. */
2491 gfc_match_block_data (void)
2493 char name[GFC_MAX_SYMBOL_LEN + 1];
2497 if (gfc_match_eos () == MATCH_YES)
2499 gfc_new_block = NULL;
2503 m = gfc_match ("% %n%t", name);
2507 if (gfc_get_symbol (name, NULL, &sym))
2510 if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
2513 gfc_new_block = sym;
2519 /* Free a namelist structure. */
2522 gfc_free_namelist (gfc_namelist * name)
2526 for (; name; name = n)
2534 /* Match a NAMELIST statement. */
2537 gfc_match_namelist (void)
2539 gfc_symbol *group_name, *sym;
2543 m = gfc_match (" / %s /", &group_name);
2546 if (m == MATCH_ERROR)
2551 if (group_name->ts.type != BT_UNKNOWN)
2554 ("Namelist group name '%s' at %C already has a basic type "
2555 "of %s", group_name->name, gfc_typename (&group_name->ts));
2559 if (group_name->attr.flavor == FL_NAMELIST
2560 && group_name->attr.use_assoc
2561 && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
2562 "at %C already is USE associated and can"
2563 "not be respecified.", group_name->name)
2567 if (group_name->attr.flavor != FL_NAMELIST
2568 && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
2569 group_name->name, NULL) == FAILURE)
2574 m = gfc_match_symbol (&sym, 1);
2577 if (m == MATCH_ERROR)
2580 if (sym->attr.in_namelist == 0
2581 && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
2584 /* Use gfc_error_check here, rather than goto error, so that this
2585 these are the only errors for the next two lines. */
2586 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
2588 gfc_error ("Assumed size array '%s' in namelist '%s'at "
2589 "%C is not allowed.", sym->name, group_name->name);
2593 if (sym->as && sym->as->type == AS_ASSUMED_SHAPE
2594 && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
2595 "namelist '%s' at %C is an extension.",
2596 sym->name, group_name->name) == FAILURE)
2599 nl = gfc_get_namelist ();
2603 if (group_name->namelist == NULL)
2604 group_name->namelist = group_name->namelist_tail = nl;
2607 group_name->namelist_tail->next = nl;
2608 group_name->namelist_tail = nl;
2611 if (gfc_match_eos () == MATCH_YES)
2614 m = gfc_match_char (',');
2616 if (gfc_match_char ('/') == MATCH_YES)
2618 m2 = gfc_match (" %s /", &group_name);
2619 if (m2 == MATCH_YES)
2621 if (m2 == MATCH_ERROR)
2635 gfc_syntax_error (ST_NAMELIST);
2642 /* Match a MODULE statement. */
2645 gfc_match_module (void)
2649 m = gfc_match (" %s%t", &gfc_new_block);
2653 if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
2654 gfc_new_block->name, NULL) == FAILURE)
2661 /* Free equivalence sets and lists. Recursively is the easiest way to
2665 gfc_free_equiv (gfc_equiv * eq)
2671 gfc_free_equiv (eq->eq);
2672 gfc_free_equiv (eq->next);
2674 gfc_free_expr (eq->expr);
2679 /* Match an EQUIVALENCE statement. */
2682 gfc_match_equivalence (void)
2684 gfc_equiv *eq, *set, *tail;
2688 gfc_common_head *common_head = NULL;
2696 eq = gfc_get_equiv ();
2700 eq->next = gfc_current_ns->equiv;
2701 gfc_current_ns->equiv = eq;
2703 if (gfc_match_char ('(') != MATCH_YES)
2707 common_flag = FALSE;
2712 m = gfc_match_equiv_variable (&set->expr);
2713 if (m == MATCH_ERROR)
2718 /* count the number of objects. */
2721 if (gfc_match_char ('%') == MATCH_YES)
2723 gfc_error ("Derived type component %C is not a "
2724 "permitted EQUIVALENCE member");
2728 for (ref = set->expr->ref; ref; ref = ref->next)
2729 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2732 ("Array reference in EQUIVALENCE at %C cannot be an "
2737 sym = set->expr->symtree->n.sym;
2739 if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL)
2743 if (sym->attr.in_common)
2746 common_head = sym->common_head;
2749 if (gfc_match_char (')') == MATCH_YES)
2752 if (gfc_match_char (',') != MATCH_YES)
2755 set->eq = gfc_get_equiv ();
2761 gfc_error ("EQUIVALENCE at %C requires two or more objects");
2765 /* If one of the members of an equivalence is in common, then
2766 mark them all as being in common. Before doing this, check
2767 that members of the equivalence group are not in different
2770 for (set = eq; set; set = set->eq)
2772 sym = set->expr->symtree->n.sym;
2773 if (sym->common_head && sym->common_head != common_head)
2775 gfc_error ("Attempt to indirectly overlap COMMON "
2776 "blocks %s and %s by EQUIVALENCE at %C",
2777 sym->common_head->name,
2781 sym->attr.in_common = 1;
2782 sym->common_head = common_head;
2785 if (gfc_match_eos () == MATCH_YES)
2787 if (gfc_match_char (',') != MATCH_YES)
2794 gfc_syntax_error (ST_EQUIVALENCE);
2800 gfc_free_equiv (gfc_current_ns->equiv);
2801 gfc_current_ns->equiv = eq;
2806 /* Check that a statement function is not recursive. This is done by looking
2807 for the statement function symbol(sym) by looking recursively through its
2808 expression(e). If a reference to sym is found, true is returned.
2809 12.5.4 requires that any variable of function that is implicitly typed
2810 shall have that type confirmed by any subsequent type declaration. The
2811 implicit typing is conveniently done here. */
2814 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
2816 gfc_actual_arglist *arg;
2823 switch (e->expr_type)
2826 for (arg = e->value.function.actual; arg; arg = arg->next)
2828 if (sym->name == arg->name
2829 || recursive_stmt_fcn (arg->expr, sym))
2833 if (e->symtree == NULL)
2836 /* Check the name before testing for nested recursion! */
2837 if (sym->name == e->symtree->n.sym->name)
2840 /* Catch recursion via other statement functions. */
2841 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
2842 && e->symtree->n.sym->value
2843 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
2846 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
2847 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
2852 if (e->symtree && sym->name == e->symtree->n.sym->name)
2855 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
2856 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
2860 if (recursive_stmt_fcn (e->value.op.op1, sym)
2861 || recursive_stmt_fcn (e->value.op.op2, sym))
2869 /* Component references do not need to be checked. */
2872 for (ref = e->ref; ref; ref = ref->next)
2877 for (i = 0; i < ref->u.ar.dimen; i++)
2879 if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
2880 || recursive_stmt_fcn (ref->u.ar.end[i], sym)
2881 || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
2887 if (recursive_stmt_fcn (ref->u.ss.start, sym)
2888 || recursive_stmt_fcn (ref->u.ss.end, sym))
2902 /* Match a statement function declaration. It is so easy to match
2903 non-statement function statements with a MATCH_ERROR as opposed to
2904 MATCH_NO that we suppress error message in most cases. */
2907 gfc_match_st_function (void)
2909 gfc_error_buf old_error;
2914 m = gfc_match_symbol (&sym, 0);
2918 gfc_push_error (&old_error);
2920 if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
2921 sym->name, NULL) == FAILURE)
2924 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2927 m = gfc_match (" = %e%t", &expr);
2931 gfc_free_error (&old_error);
2932 if (m == MATCH_ERROR)
2935 if (recursive_stmt_fcn (expr, sym))
2937 gfc_error ("Statement function at %L is recursive",
2947 gfc_pop_error (&old_error);
2952 /***************** SELECT CASE subroutines ******************/
2954 /* Free a single case structure. */
2957 free_case (gfc_case * p)
2959 if (p->low == p->high)
2961 gfc_free_expr (p->low);
2962 gfc_free_expr (p->high);
2967 /* Free a list of case structures. */
2970 gfc_free_case_list (gfc_case * p)
2982 /* Match a single case selector. */
2985 match_case_selector (gfc_case ** cp)
2990 c = gfc_get_case ();
2991 c->where = gfc_current_locus;
2993 if (gfc_match_char (':') == MATCH_YES)
2995 m = gfc_match_init_expr (&c->high);
2998 if (m == MATCH_ERROR)
3004 m = gfc_match_init_expr (&c->low);
3005 if (m == MATCH_ERROR)
3010 /* If we're not looking at a ':' now, make a range out of a single
3011 target. Else get the upper bound for the case range. */
3012 if (gfc_match_char (':') != MATCH_YES)
3016 m = gfc_match_init_expr (&c->high);
3017 if (m == MATCH_ERROR)
3019 /* MATCH_NO is fine. It's OK if nothing is there! */
3027 gfc_error ("Expected initialization expression in CASE at %C");
3035 /* Match the end of a case statement. */
3038 match_case_eos (void)
3040 char name[GFC_MAX_SYMBOL_LEN + 1];
3043 if (gfc_match_eos () == MATCH_YES)
3046 /* If the case construct doesn't have a case-construct-name, we
3047 should have matched the EOS. */
3048 if (!gfc_current_block ())
3051 gfc_gobble_whitespace ();
3053 m = gfc_match_name (name);
3057 if (strcmp (name, gfc_current_block ()->name) != 0)
3059 gfc_error ("Expected case name of '%s' at %C",
3060 gfc_current_block ()->name);
3064 return gfc_match_eos ();
3068 /* Match a SELECT statement. */
3071 gfc_match_select (void)
3076 m = gfc_match_label ();
3077 if (m == MATCH_ERROR)
3080 m = gfc_match (" select case ( %e )%t", &expr);
3084 new_st.op = EXEC_SELECT;
3091 /* Match a CASE statement. */
3094 gfc_match_case (void)
3096 gfc_case *c, *head, *tail;
3101 if (gfc_current_state () != COMP_SELECT)
3103 gfc_error ("Unexpected CASE statement at %C");
3107 if (gfc_match ("% default") == MATCH_YES)
3109 m = match_case_eos ();
3112 if (m == MATCH_ERROR)
3115 new_st.op = EXEC_SELECT;
3116 c = gfc_get_case ();
3117 c->where = gfc_current_locus;
3118 new_st.ext.case_list = c;
3122 if (gfc_match_char ('(') != MATCH_YES)
3127 if (match_case_selector (&c) == MATCH_ERROR)
3137 if (gfc_match_char (')') == MATCH_YES)
3139 if (gfc_match_char (',') != MATCH_YES)
3143 m = match_case_eos ();
3146 if (m == MATCH_ERROR)
3149 new_st.op = EXEC_SELECT;
3150 new_st.ext.case_list = head;
3155 gfc_error ("Syntax error in CASE-specification at %C");
3158 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
3162 /********************* WHERE subroutines ********************/
3164 /* Match the rest of a simple WHERE statement that follows an IF statement.
3168 match_simple_where (void)
3174 m = gfc_match (" ( %e )", &expr);
3178 m = gfc_match_assignment ();
3181 if (m == MATCH_ERROR)
3184 if (gfc_match_eos () != MATCH_YES)
3187 c = gfc_get_code ();
3191 c->next = gfc_get_code ();
3194 gfc_clear_new_st ();
3196 new_st.op = EXEC_WHERE;
3202 gfc_syntax_error (ST_WHERE);
3205 gfc_free_expr (expr);
3209 /* Match a WHERE statement. */
3212 gfc_match_where (gfc_statement * st)
3218 m0 = gfc_match_label ();
3219 if (m0 == MATCH_ERROR)
3222 m = gfc_match (" where ( %e )", &expr);
3226 if (gfc_match_eos () == MATCH_YES)
3228 *st = ST_WHERE_BLOCK;
3230 new_st.op = EXEC_WHERE;
3235 m = gfc_match_assignment ();
3237 gfc_syntax_error (ST_WHERE);
3241 gfc_free_expr (expr);
3245 /* We've got a simple WHERE statement. */
3247 c = gfc_get_code ();
3251 c->next = gfc_get_code ();
3254 gfc_clear_new_st ();
3256 new_st.op = EXEC_WHERE;
3263 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3264 new_st if successful. */
3267 gfc_match_elsewhere (void)
3269 char name[GFC_MAX_SYMBOL_LEN + 1];
3273 if (gfc_current_state () != COMP_WHERE)
3275 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3281 if (gfc_match_char ('(') == MATCH_YES)
3283 m = gfc_match_expr (&expr);
3286 if (m == MATCH_ERROR)
3289 if (gfc_match_char (')') != MATCH_YES)
3293 if (gfc_match_eos () != MATCH_YES)
3294 { /* Better be a name at this point */
3295 m = gfc_match_name (name);
3298 if (m == MATCH_ERROR)
3301 if (gfc_match_eos () != MATCH_YES)
3304 if (strcmp (name, gfc_current_block ()->name) != 0)
3306 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3307 name, gfc_current_block ()->name);
3312 new_st.op = EXEC_WHERE;
3317 gfc_syntax_error (ST_ELSEWHERE);
3320 gfc_free_expr (expr);
3325 /******************** FORALL subroutines ********************/
3327 /* Free a list of FORALL iterators. */
3330 gfc_free_forall_iterator (gfc_forall_iterator * iter)
3332 gfc_forall_iterator *next;
3338 gfc_free_expr (iter->var);
3339 gfc_free_expr (iter->start);
3340 gfc_free_expr (iter->end);
3341 gfc_free_expr (iter->stride);
3349 /* Match an iterator as part of a FORALL statement. The format is:
3351 <var> = <start>:<end>[:<stride>][, <scalar mask>] */
3354 match_forall_iterator (gfc_forall_iterator ** result)
3356 gfc_forall_iterator *iter;
3360 where = gfc_current_locus;
3361 iter = gfc_getmem (sizeof (gfc_forall_iterator));
3363 m = gfc_match_variable (&iter->var, 0);
3367 if (gfc_match_char ('=') != MATCH_YES)
3373 m = gfc_match_expr (&iter->start);
3377 if (gfc_match_char (':') != MATCH_YES)
3380 m = gfc_match_expr (&iter->end);
3383 if (m == MATCH_ERROR)
3386 if (gfc_match_char (':') == MATCH_NO)
3387 iter->stride = gfc_int_expr (1);
3390 m = gfc_match_expr (&iter->stride);
3393 if (m == MATCH_ERROR)
3397 /* Mark the iteration variable's symbol as used as a FORALL index. */
3398 iter->var->symtree->n.sym->forall_index = true;
3404 gfc_error ("Syntax error in FORALL iterator at %C");
3408 /* Make sure that potential internal function references in the
3409 mask do not get messed up. */
3411 && iter->var->expr_type == EXPR_VARIABLE
3412 && iter->var->symtree->n.sym->refs == 1)
3413 iter->var->symtree->n.sym->attr.flavor = FL_UNKNOWN;
3415 gfc_current_locus = where;
3416 gfc_free_forall_iterator (iter);
3421 /* Match the header of a FORALL statement. */
3424 match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask)
3426 gfc_forall_iterator *head, *tail, *new;
3430 gfc_gobble_whitespace ();
3435 if (gfc_match_char ('(') != MATCH_YES)
3438 m = match_forall_iterator (&new);
3439 if (m == MATCH_ERROR)
3448 if (gfc_match_char (',') != MATCH_YES)
3451 m = match_forall_iterator (&new);
3452 if (m == MATCH_ERROR)
3462 /* Have to have a mask expression */
3464 m = gfc_match_expr (&msk);
3467 if (m == MATCH_ERROR)
3473 if (gfc_match_char (')') == MATCH_NO)
3481 gfc_syntax_error (ST_FORALL);
3484 gfc_free_expr (msk);
3485 gfc_free_forall_iterator (head);
3490 /* Match the rest of a simple FORALL statement that follows an IF statement.
3494 match_simple_forall (void)
3496 gfc_forall_iterator *head;
3505 m = match_forall_header (&head, &mask);
3512 m = gfc_match_assignment ();
3514 if (m == MATCH_ERROR)
3518 m = gfc_match_pointer_assignment ();
3519 if (m == MATCH_ERROR)
3525 c = gfc_get_code ();
3527 c->loc = gfc_current_locus;
3529 if (gfc_match_eos () != MATCH_YES)
3532 gfc_clear_new_st ();
3533 new_st.op = EXEC_FORALL;
3535 new_st.ext.forall_iterator = head;
3536 new_st.block = gfc_get_code ();
3538 new_st.block->op = EXEC_FORALL;
3539 new_st.block->next = c;
3544 gfc_syntax_error (ST_FORALL);
3547 gfc_free_forall_iterator (head);
3548 gfc_free_expr (mask);
3554 /* Match a FORALL statement. */
3557 gfc_match_forall (gfc_statement * st)
3559 gfc_forall_iterator *head;
3568 m0 = gfc_match_label ();
3569 if (m0 == MATCH_ERROR)
3572 m = gfc_match (" forall");
3576 m = match_forall_header (&head, &mask);
3577 if (m == MATCH_ERROR)
3582 if (gfc_match_eos () == MATCH_YES)
3584 *st = ST_FORALL_BLOCK;
3586 new_st.op = EXEC_FORALL;
3588 new_st.ext.forall_iterator = head;
3593 m = gfc_match_assignment ();
3594 if (m == MATCH_ERROR)
3598 m = gfc_match_pointer_assignment ();
3599 if (m == MATCH_ERROR)
3605 c = gfc_get_code ();
3607 c->loc = gfc_current_locus;
3609 gfc_clear_new_st ();
3610 new_st.op = EXEC_FORALL;
3612 new_st.ext.forall_iterator = head;
3613 new_st.block = gfc_get_code ();
3615 new_st.block->op = EXEC_FORALL;
3616 new_st.block->next = c;
3622 gfc_syntax_error (ST_FORALL);
3625 gfc_free_forall_iterator (head);
3626 gfc_free_expr (mask);
3627 gfc_free_statements (c);