1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
30 /* For matching and debugging purposes. Order matters here! The
31 unary operators /must/ precede the binary plus and minus, or
32 the expression parser breaks. */
34 mstring intrinsic_operators[] = {
35 minit ("+", INTRINSIC_UPLUS),
36 minit ("-", INTRINSIC_UMINUS),
37 minit ("+", INTRINSIC_PLUS),
38 minit ("-", INTRINSIC_MINUS),
39 minit ("**", INTRINSIC_POWER),
40 minit ("//", INTRINSIC_CONCAT),
41 minit ("*", INTRINSIC_TIMES),
42 minit ("/", INTRINSIC_DIVIDE),
43 minit (".and.", INTRINSIC_AND),
44 minit (".or.", INTRINSIC_OR),
45 minit (".eqv.", INTRINSIC_EQV),
46 minit (".neqv.", INTRINSIC_NEQV),
47 minit (".eq.", INTRINSIC_EQ),
48 minit ("==", INTRINSIC_EQ),
49 minit (".ne.", INTRINSIC_NE),
50 minit ("/=", INTRINSIC_NE),
51 minit (".ge.", INTRINSIC_GE),
52 minit (">=", INTRINSIC_GE),
53 minit (".le.", INTRINSIC_LE),
54 minit ("<=", INTRINSIC_LE),
55 minit (".lt.", INTRINSIC_LT),
56 minit ("<", INTRINSIC_LT),
57 minit (".gt.", INTRINSIC_GT),
58 minit (">", INTRINSIC_GT),
59 minit (".not.", INTRINSIC_NOT),
60 minit ("parens", INTRINSIC_PARENTHESES),
61 minit (NULL, INTRINSIC_NONE)
65 /******************** Generic matching subroutines ************************/
67 /* See if the next character is a special character that has
68 escaped by a \ via the -fbackslash option. */
71 gfc_match_special_char (int *c)
78 switch (gfc_next_char_literal (1))
108 /* Unknown backslash codes are simply not expanded. */
117 /* In free form, match at least one space. Always matches in fixed
121 gfc_match_space (void)
126 if (gfc_current_form == FORM_FIXED)
129 old_loc = gfc_current_locus;
131 c = gfc_next_char ();
132 if (!gfc_is_whitespace (c))
134 gfc_current_locus = old_loc;
138 gfc_gobble_whitespace ();
144 /* Match an end of statement. End of statement is optional
145 whitespace, followed by a ';' or '\n' or comment '!'. If a
146 semicolon is found, we continue to eat whitespace and semicolons. */
158 old_loc = gfc_current_locus;
159 gfc_gobble_whitespace ();
161 c = gfc_next_char ();
167 c = gfc_next_char ();
184 gfc_current_locus = old_loc;
185 return (flag) ? MATCH_YES : MATCH_NO;
189 /* Match a literal integer on the input, setting the value on
190 MATCH_YES. Literal ints occur in kind-parameters as well as
191 old-style character length specifications. If cnt is non-NULL it
192 will be set to the number of digits. */
195 gfc_match_small_literal_int (int *value, int *cnt)
201 old_loc = gfc_current_locus;
203 gfc_gobble_whitespace ();
204 c = gfc_next_char ();
210 gfc_current_locus = old_loc;
219 old_loc = gfc_current_locus;
220 c = gfc_next_char ();
225 i = 10 * i + c - '0';
230 gfc_error ("Integer too large at %C");
235 gfc_current_locus = old_loc;
244 /* Match a small, constant integer expression, like in a kind
245 statement. On MATCH_YES, 'value' is set. */
248 gfc_match_small_int (int *value)
255 m = gfc_match_expr (&expr);
259 p = gfc_extract_int (expr, &i);
260 gfc_free_expr (expr);
273 /* Matches a statement label. Uses gfc_match_small_literal_int() to
274 do most of the work. */
277 gfc_match_st_label (gfc_st_label **label)
283 old_loc = gfc_current_locus;
285 m = gfc_match_small_literal_int (&i, &cnt);
291 gfc_error ("Too many digits in statement label at %C");
297 gfc_error ("Statement label at %C is zero");
301 *label = gfc_get_st_label (i);
306 gfc_current_locus = old_loc;
311 /* Match and validate a label associated with a named IF, DO or SELECT
312 statement. If the symbol does not have the label attribute, we add
313 it. We also make sure the symbol does not refer to another
314 (active) block. A matched label is pointed to by gfc_new_block. */
317 gfc_match_label (void)
319 char name[GFC_MAX_SYMBOL_LEN + 1];
322 gfc_new_block = NULL;
324 m = gfc_match (" %n :", name);
328 if (gfc_get_symbol (name, NULL, &gfc_new_block))
330 gfc_error ("Label name '%s' at %C is ambiguous", name);
334 if (gfc_new_block->attr.flavor == FL_LABEL)
336 gfc_error ("Duplicate construct label '%s' at %C", name);
340 if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
341 gfc_new_block->name, NULL) == FAILURE)
348 /* Try and match the input against an array of possibilities. If one
349 potential matching string is a substring of another, the longest
350 match takes precedence. Spaces in the target strings are optional
351 spaces that do not necessarily have to be found in the input
352 stream. In fixed mode, spaces never appear. If whitespace is
353 matched, it matches unlimited whitespace in the input. For this
354 reason, the 'mp' member of the mstring structure is used to track
355 the progress of each potential match.
357 If there is no match we return the tag associated with the
358 terminating NULL mstring structure and leave the locus pointer
359 where it started. If there is a match we return the tag member of
360 the matched mstring and leave the locus pointer after the matched
363 A '%' character is a mandatory space. */
366 gfc_match_strings (mstring *a)
368 mstring *p, *best_match;
369 int no_match, c, possibles;
374 for (p = a; p->string != NULL; p++)
383 match_loc = gfc_current_locus;
385 gfc_gobble_whitespace ();
387 while (possibles > 0)
389 c = gfc_next_char ();
391 /* Apply the next character to the current possibilities. */
392 for (p = a; p->string != NULL; p++)
399 /* Space matches 1+ whitespace(s). */
400 if ((gfc_current_form == FORM_FREE) && gfc_is_whitespace (c))
418 match_loc = gfc_current_locus;
426 gfc_current_locus = match_loc;
428 return (best_match == NULL) ? no_match : best_match->tag;
432 /* See if the current input looks like a name of some sort. Modifies
433 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
434 Note that options.c restricts max_identifier_length to not more
435 than GFC_MAX_SYMBOL_LEN. */
438 gfc_match_name (char *buffer)
443 old_loc = gfc_current_locus;
444 gfc_gobble_whitespace ();
446 c = gfc_next_char ();
447 if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore)))
449 if (gfc_error_flag_test() == 0)
450 gfc_error ("Invalid character in name at %C");
451 gfc_current_locus = old_loc;
461 if (i > gfc_option.max_identifier_length)
463 gfc_error ("Name at %C is too long");
467 old_loc = gfc_current_locus;
468 c = gfc_next_char ();
470 while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));
473 gfc_current_locus = old_loc;
479 /* Match a symbol on the input. Modifies the pointer to the symbol
480 pointer if successful. */
483 gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
485 char buffer[GFC_MAX_SYMBOL_LEN + 1];
488 m = gfc_match_name (buffer);
493 return (gfc_get_ha_sym_tree (buffer, matched_symbol))
494 ? MATCH_ERROR : MATCH_YES;
496 if (gfc_get_sym_tree (buffer, NULL, matched_symbol))
504 gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
509 m = gfc_match_sym_tree (&st, host_assoc);
514 *matched_symbol = st->n.sym;
516 *matched_symbol = NULL;
519 *matched_symbol = NULL;
524 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
525 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
529 gfc_match_intrinsic_op (gfc_intrinsic_op *result)
533 op = (gfc_intrinsic_op) gfc_match_strings (intrinsic_operators);
535 if (op == INTRINSIC_NONE)
543 /* Match a loop control phrase:
545 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
547 If the final integer expression is not present, a constant unity
548 expression is returned. We don't return MATCH_ERROR until after
549 the equals sign is seen. */
552 gfc_match_iterator (gfc_iterator *iter, int init_flag)
554 char name[GFC_MAX_SYMBOL_LEN + 1];
555 gfc_expr *var, *e1, *e2, *e3;
559 /* Match the start of an iterator without affecting the symbol table. */
561 start = gfc_current_locus;
562 m = gfc_match (" %n =", name);
563 gfc_current_locus = start;
568 m = gfc_match_variable (&var, 0);
572 gfc_match_char ('=');
576 if (var->ref != NULL)
578 gfc_error ("Loop variable at %C cannot be a sub-component");
582 if (var->symtree->n.sym->attr.intent == INTENT_IN)
584 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
585 var->symtree->n.sym->name);
589 var->symtree->n.sym->attr.implied_index = 1;
591 m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
594 if (m == MATCH_ERROR)
597 if (gfc_match_char (',') != MATCH_YES)
600 m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
603 if (m == MATCH_ERROR)
606 if (gfc_match_char (',') != MATCH_YES)
608 e3 = gfc_int_expr (1);
612 m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
613 if (m == MATCH_ERROR)
617 gfc_error ("Expected a step value in iterator at %C");
629 gfc_error ("Syntax error in iterator at %C");
640 /* Tries to match the next non-whitespace character on the input.
641 This subroutine does not return MATCH_ERROR. */
644 gfc_match_char (char c)
648 where = gfc_current_locus;
649 gfc_gobble_whitespace ();
651 if (gfc_next_char () == c)
654 gfc_current_locus = where;
659 /* General purpose matching subroutine. The target string is a
660 scanf-like format string in which spaces correspond to arbitrary
661 whitespace (including no whitespace), characters correspond to
662 themselves. The %-codes are:
664 %% Literal percent sign
665 %e Expression, pointer to a pointer is set
666 %s Symbol, pointer to the symbol is set
667 %n Name, character buffer is set to name
668 %t Matches end of statement.
669 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
670 %l Matches a statement label
671 %v Matches a variable expression (an lvalue)
672 % Matches a required space (in free form) and optional spaces. */
675 gfc_match (const char *target, ...)
677 gfc_st_label **label;
686 old_loc = gfc_current_locus;
687 va_start (argp, target);
697 gfc_gobble_whitespace ();
708 vp = va_arg (argp, void **);
709 n = gfc_match_expr ((gfc_expr **) vp);
720 vp = va_arg (argp, void **);
721 n = gfc_match_variable ((gfc_expr **) vp, 0);
732 vp = va_arg (argp, void **);
733 n = gfc_match_symbol ((gfc_symbol **) vp, 0);
744 np = va_arg (argp, char *);
745 n = gfc_match_name (np);
756 label = va_arg (argp, gfc_st_label **);
757 n = gfc_match_st_label (label);
768 ip = va_arg (argp, int *);
769 n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
780 if (gfc_match_eos () != MATCH_YES)
788 if (gfc_match_space () == MATCH_YES)
794 break; /* Fall through to character matcher. */
797 gfc_internal_error ("gfc_match(): Bad match code %c", c);
801 if (c == gfc_next_char ())
811 /* Clean up after a failed match. */
812 gfc_current_locus = old_loc;
813 va_start (argp, target);
816 for (; matches > 0; matches--)
826 /* Matches that don't have to be undone */
831 (void) va_arg (argp, void **);
836 vp = va_arg (argp, void **);
850 /*********************** Statement level matching **********************/
852 /* Matches the start of a program unit, which is the program keyword
853 followed by an obligatory symbol. */
856 gfc_match_program (void)
861 m = gfc_match ("% %s%t", &sym);
865 gfc_error ("Invalid form of PROGRAM statement at %C");
869 if (m == MATCH_ERROR)
872 if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
881 /* Match a simple assignment statement. */
884 gfc_match_assignment (void)
886 gfc_expr *lvalue, *rvalue;
890 old_loc = gfc_current_locus;
893 m = gfc_match (" %v =", &lvalue);
896 gfc_current_locus = old_loc;
897 gfc_free_expr (lvalue);
901 if (lvalue->symtree->n.sym->attr.protected
902 && lvalue->symtree->n.sym->attr.use_assoc)
904 gfc_current_locus = old_loc;
905 gfc_free_expr (lvalue);
906 gfc_error ("Setting value of PROTECTED variable at %C");
911 m = gfc_match (" %e%t", &rvalue);
914 gfc_current_locus = old_loc;
915 gfc_free_expr (lvalue);
916 gfc_free_expr (rvalue);
920 gfc_set_sym_referenced (lvalue->symtree->n.sym);
922 new_st.op = EXEC_ASSIGN;
923 new_st.expr = lvalue;
924 new_st.expr2 = rvalue;
926 gfc_check_do_variable (lvalue->symtree);
932 /* Match a pointer assignment statement. */
935 gfc_match_pointer_assignment (void)
937 gfc_expr *lvalue, *rvalue;
941 old_loc = gfc_current_locus;
943 lvalue = rvalue = NULL;
945 m = gfc_match (" %v =>", &lvalue);
952 m = gfc_match (" %e%t", &rvalue);
956 if (lvalue->symtree->n.sym->attr.protected
957 && lvalue->symtree->n.sym->attr.use_assoc)
959 gfc_error ("Assigning to a PROTECTED pointer at %C");
964 new_st.op = EXEC_POINTER_ASSIGN;
965 new_st.expr = lvalue;
966 new_st.expr2 = rvalue;
971 gfc_current_locus = old_loc;
972 gfc_free_expr (lvalue);
973 gfc_free_expr (rvalue);
978 /* We try to match an easy arithmetic IF statement. This only happens
979 when just after having encountered a simple IF statement. This code
980 is really duplicate with parts of the gfc_match_if code, but this is
984 match_arithmetic_if (void)
986 gfc_st_label *l1, *l2, *l3;
990 m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
994 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
995 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
996 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
998 gfc_free_expr (expr);
1002 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF statement "
1003 "at %C") == FAILURE)
1006 new_st.op = EXEC_ARITHMETIC_IF;
1016 /* The IF statement is a bit of a pain. First of all, there are three
1017 forms of it, the simple IF, the IF that starts a block and the
1020 There is a problem with the simple IF and that is the fact that we
1021 only have a single level of undo information on symbols. What this
1022 means is for a simple IF, we must re-match the whole IF statement
1023 multiple times in order to guarantee that the symbol table ends up
1024 in the proper state. */
1026 static match match_simple_forall (void);
1027 static match match_simple_where (void);
1030 gfc_match_if (gfc_statement *if_type)
1033 gfc_st_label *l1, *l2, *l3;
1038 n = gfc_match_label ();
1039 if (n == MATCH_ERROR)
1042 old_loc = gfc_current_locus;
1044 m = gfc_match (" if ( %e", &expr);
1048 if (gfc_match_char (')') != MATCH_YES)
1050 gfc_error ("Syntax error in IF-expression at %C");
1051 gfc_free_expr (expr);
1055 m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
1061 gfc_error ("Block label not appropriate for arithmetic IF "
1063 gfc_free_expr (expr);
1067 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1068 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1069 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1071 gfc_free_expr (expr);
1075 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF "
1076 "statement at %C") == FAILURE)
1079 new_st.op = EXEC_ARITHMETIC_IF;
1085 *if_type = ST_ARITHMETIC_IF;
1089 if (gfc_match (" then%t") == MATCH_YES)
1091 new_st.op = EXEC_IF;
1093 *if_type = ST_IF_BLOCK;
1099 gfc_error ("Block label is not appropriate IF statement at %C");
1100 gfc_free_expr (expr);
1104 /* At this point the only thing left is a simple IF statement. At
1105 this point, n has to be MATCH_NO, so we don't have to worry about
1106 re-matching a block label. From what we've got so far, try
1107 matching an assignment. */
1109 *if_type = ST_SIMPLE_IF;
1111 m = gfc_match_assignment ();
1115 gfc_free_expr (expr);
1116 gfc_undo_symbols ();
1117 gfc_current_locus = old_loc;
1119 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1120 assignment was found. For MATCH_NO, continue to call the various
1122 if (m == MATCH_ERROR)
1125 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
1127 m = gfc_match_pointer_assignment ();
1131 gfc_free_expr (expr);
1132 gfc_undo_symbols ();
1133 gfc_current_locus = old_loc;
1135 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
1137 /* Look at the next keyword to see which matcher to call. Matching
1138 the keyword doesn't affect the symbol table, so we don't have to
1139 restore between tries. */
1141 #define match(string, subr, statement) \
1142 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1146 match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1147 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1148 match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1149 match ("call", gfc_match_call, ST_CALL)
1150 match ("close", gfc_match_close, ST_CLOSE)
1151 match ("continue", gfc_match_continue, ST_CONTINUE)
1152 match ("cycle", gfc_match_cycle, ST_CYCLE)
1153 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1154 match ("end file", gfc_match_endfile, ST_END_FILE)
1155 match ("exit", gfc_match_exit, ST_EXIT)
1156 match ("flush", gfc_match_flush, ST_FLUSH)
1157 match ("forall", match_simple_forall, ST_FORALL)
1158 match ("go to", gfc_match_goto, ST_GOTO)
1159 match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1160 match ("inquire", gfc_match_inquire, ST_INQUIRE)
1161 match ("nullify", gfc_match_nullify, ST_NULLIFY)
1162 match ("open", gfc_match_open, ST_OPEN)
1163 match ("pause", gfc_match_pause, ST_NONE)
1164 match ("print", gfc_match_print, ST_WRITE)
1165 match ("read", gfc_match_read, ST_READ)
1166 match ("return", gfc_match_return, ST_RETURN)
1167 match ("rewind", gfc_match_rewind, ST_REWIND)
1168 match ("stop", gfc_match_stop, ST_STOP)
1169 match ("where", match_simple_where, ST_WHERE)
1170 match ("write", gfc_match_write, ST_WRITE)
1172 /* The gfc_match_assignment() above may have returned a MATCH_NO
1173 where the assignment was to a named constant. Check that
1174 special case here. */
1175 m = gfc_match_assignment ();
1178 gfc_error ("Cannot assign to a named constant at %C");
1179 gfc_free_expr (expr);
1180 gfc_undo_symbols ();
1181 gfc_current_locus = old_loc;
1185 /* All else has failed, so give up. See if any of the matchers has
1186 stored an error message of some sort. */
1187 if (gfc_error_check () == 0)
1188 gfc_error ("Unclassifiable statement in IF-clause at %C");
1190 gfc_free_expr (expr);
1195 gfc_error ("Syntax error in IF-clause at %C");
1198 gfc_free_expr (expr);
1202 /* At this point, we've matched the single IF and the action clause
1203 is in new_st. Rearrange things so that the IF statement appears
1206 p = gfc_get_code ();
1207 p->next = gfc_get_code ();
1209 p->next->loc = gfc_current_locus;
1214 gfc_clear_new_st ();
1216 new_st.op = EXEC_IF;
1225 /* Match an ELSE statement. */
1228 gfc_match_else (void)
1230 char name[GFC_MAX_SYMBOL_LEN + 1];
1232 if (gfc_match_eos () == MATCH_YES)
1235 if (gfc_match_name (name) != MATCH_YES
1236 || gfc_current_block () == NULL
1237 || gfc_match_eos () != MATCH_YES)
1239 gfc_error ("Unexpected junk after ELSE statement at %C");
1243 if (strcmp (name, gfc_current_block ()->name) != 0)
1245 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1246 name, gfc_current_block ()->name);
1254 /* Match an ELSE IF statement. */
1257 gfc_match_elseif (void)
1259 char name[GFC_MAX_SYMBOL_LEN + 1];
1263 m = gfc_match (" ( %e ) then", &expr);
1267 if (gfc_match_eos () == MATCH_YES)
1270 if (gfc_match_name (name) != MATCH_YES
1271 || gfc_current_block () == NULL
1272 || gfc_match_eos () != MATCH_YES)
1274 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1278 if (strcmp (name, gfc_current_block ()->name) != 0)
1280 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1281 name, gfc_current_block ()->name);
1286 new_st.op = EXEC_IF;
1291 gfc_free_expr (expr);
1296 /* Free a gfc_iterator structure. */
1299 gfc_free_iterator (gfc_iterator *iter, int flag)
1305 gfc_free_expr (iter->var);
1306 gfc_free_expr (iter->start);
1307 gfc_free_expr (iter->end);
1308 gfc_free_expr (iter->step);
1315 /* Match a DO statement. */
1320 gfc_iterator iter, *ip;
1322 gfc_st_label *label;
1325 old_loc = gfc_current_locus;
1328 iter.var = iter.start = iter.end = iter.step = NULL;
1330 m = gfc_match_label ();
1331 if (m == MATCH_ERROR)
1334 if (gfc_match (" do") != MATCH_YES)
1337 m = gfc_match_st_label (&label);
1338 if (m == MATCH_ERROR)
1341 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
1343 if (gfc_match_eos () == MATCH_YES)
1345 iter.end = gfc_logical_expr (1, NULL);
1346 new_st.op = EXEC_DO_WHILE;
1350 /* Match an optional comma, if no comma is found, a space is obligatory. */
1351 if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
1354 /* See if we have a DO WHILE. */
1355 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1357 new_st.op = EXEC_DO_WHILE;
1361 /* The abortive DO WHILE may have done something to the symbol
1362 table, so we start over. */
1363 gfc_undo_symbols ();
1364 gfc_current_locus = old_loc;
1366 gfc_match_label (); /* This won't error. */
1367 gfc_match (" do "); /* This will work. */
1369 gfc_match_st_label (&label); /* Can't error out. */
1370 gfc_match_char (','); /* Optional comma. */
1372 m = gfc_match_iterator (&iter, 0);
1375 if (m == MATCH_ERROR)
1378 gfc_check_do_variable (iter.var->symtree);
1380 if (gfc_match_eos () != MATCH_YES)
1382 gfc_syntax_error (ST_DO);
1386 new_st.op = EXEC_DO;
1390 && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1393 new_st.label = label;
1395 if (new_st.op == EXEC_DO_WHILE)
1396 new_st.expr = iter.end;
1399 new_st.ext.iterator = ip = gfc_get_iterator ();
1406 gfc_free_iterator (&iter, 0);
1412 /* Match an EXIT or CYCLE statement. */
1415 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1417 gfc_state_data *p, *o;
1421 if (gfc_match_eos () == MATCH_YES)
1425 m = gfc_match ("% %s%t", &sym);
1426 if (m == MATCH_ERROR)
1430 gfc_syntax_error (st);
1434 if (sym->attr.flavor != FL_LABEL)
1436 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1437 sym->name, gfc_ascii_statement (st));
1442 /* Find the loop mentioned specified by the label (or lack of a label). */
1443 for (o = NULL, p = gfc_state_stack; p; p = p->previous)
1444 if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1446 else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
1452 gfc_error ("%s statement at %C is not within a loop",
1453 gfc_ascii_statement (st));
1455 gfc_error ("%s statement at %C is not within loop '%s'",
1456 gfc_ascii_statement (st), sym->name);
1463 gfc_error ("%s statement at %C leaving OpenMP structured block",
1464 gfc_ascii_statement (st));
1467 else if (st == ST_EXIT
1468 && p->previous != NULL
1469 && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
1470 && (p->previous->head->op == EXEC_OMP_DO
1471 || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
1473 gcc_assert (p->previous->head->next != NULL);
1474 gcc_assert (p->previous->head->next->op == EXEC_DO
1475 || p->previous->head->next->op == EXEC_DO_WHILE);
1476 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1480 /* Save the first statement in the loop - needed by the backend. */
1481 new_st.ext.whichloop = p->head;
1489 /* Match the EXIT statement. */
1492 gfc_match_exit (void)
1494 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1498 /* Match the CYCLE statement. */
1501 gfc_match_cycle (void)
1503 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1507 /* Match a number or character constant after a STOP or PAUSE statement. */
1510 gfc_match_stopcode (gfc_statement st)
1520 if (gfc_match_eos () != MATCH_YES)
1522 m = gfc_match_small_literal_int (&stop_code, &cnt);
1523 if (m == MATCH_ERROR)
1526 if (m == MATCH_YES && cnt > 5)
1528 gfc_error ("Too many digits in STOP code at %C");
1534 /* Try a character constant. */
1535 m = gfc_match_expr (&e);
1536 if (m == MATCH_ERROR)
1540 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1544 if (gfc_match_eos () != MATCH_YES)
1548 if (gfc_pure (NULL))
1550 gfc_error ("%s statement not allowed in PURE procedure at %C",
1551 gfc_ascii_statement (st));
1555 new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1557 new_st.ext.stop_code = stop_code;
1562 gfc_syntax_error (st);
1571 /* Match the (deprecated) PAUSE statement. */
1574 gfc_match_pause (void)
1578 m = gfc_match_stopcode (ST_PAUSE);
1581 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
1590 /* Match the STOP statement. */
1593 gfc_match_stop (void)
1595 return gfc_match_stopcode (ST_STOP);
1599 /* Match a CONTINUE statement. */
1602 gfc_match_continue (void)
1604 if (gfc_match_eos () != MATCH_YES)
1606 gfc_syntax_error (ST_CONTINUE);
1610 new_st.op = EXEC_CONTINUE;
1615 /* Match the (deprecated) ASSIGN statement. */
1618 gfc_match_assign (void)
1621 gfc_st_label *label;
1623 if (gfc_match (" %l", &label) == MATCH_YES)
1625 if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
1627 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
1629 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
1634 expr->symtree->n.sym->attr.assign = 1;
1636 new_st.op = EXEC_LABEL_ASSIGN;
1637 new_st.label = label;
1646 /* Match the GO TO statement. As a computed GOTO statement is
1647 matched, it is transformed into an equivalent SELECT block. No
1648 tree is necessary, and the resulting jumps-to-jumps are
1649 specifically optimized away by the back end. */
1652 gfc_match_goto (void)
1654 gfc_code *head, *tail;
1657 gfc_st_label *label;
1661 if (gfc_match (" %l%t", &label) == MATCH_YES)
1663 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1666 new_st.op = EXEC_GOTO;
1667 new_st.label = label;
1671 /* The assigned GO TO statement. */
1673 if (gfc_match_variable (&expr, 0) == MATCH_YES)
1675 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
1680 new_st.op = EXEC_GOTO;
1683 if (gfc_match_eos () == MATCH_YES)
1686 /* Match label list. */
1687 gfc_match_char (',');
1688 if (gfc_match_char ('(') != MATCH_YES)
1690 gfc_syntax_error (ST_GOTO);
1697 m = gfc_match_st_label (&label);
1701 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1705 head = tail = gfc_get_code ();
1708 tail->block = gfc_get_code ();
1712 tail->label = label;
1713 tail->op = EXEC_GOTO;
1715 while (gfc_match_char (',') == MATCH_YES);
1717 if (gfc_match (")%t") != MATCH_YES)
1722 gfc_error ("Statement label list in GOTO at %C cannot be empty");
1725 new_st.block = head;
1730 /* Last chance is a computed GO TO statement. */
1731 if (gfc_match_char ('(') != MATCH_YES)
1733 gfc_syntax_error (ST_GOTO);
1742 m = gfc_match_st_label (&label);
1746 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1750 head = tail = gfc_get_code ();
1753 tail->block = gfc_get_code ();
1757 cp = gfc_get_case ();
1758 cp->low = cp->high = gfc_int_expr (i++);
1760 tail->op = EXEC_SELECT;
1761 tail->ext.case_list = cp;
1763 tail->next = gfc_get_code ();
1764 tail->next->op = EXEC_GOTO;
1765 tail->next->label = label;
1767 while (gfc_match_char (',') == MATCH_YES);
1769 if (gfc_match_char (')') != MATCH_YES)
1774 gfc_error ("Statement label list in GOTO at %C cannot be empty");
1778 /* Get the rest of the statement. */
1779 gfc_match_char (',');
1781 if (gfc_match (" %e%t", &expr) != MATCH_YES)
1784 /* At this point, a computed GOTO has been fully matched and an
1785 equivalent SELECT statement constructed. */
1787 new_st.op = EXEC_SELECT;
1790 /* Hack: For a "real" SELECT, the expression is in expr. We put
1791 it in expr2 so we can distinguish then and produce the correct
1793 new_st.expr2 = expr;
1794 new_st.block = head;
1798 gfc_syntax_error (ST_GOTO);
1800 gfc_free_statements (head);
1805 /* Frees a list of gfc_alloc structures. */
1808 gfc_free_alloc_list (gfc_alloc *p)
1815 gfc_free_expr (p->expr);
1821 /* Match an ALLOCATE statement. */
1824 gfc_match_allocate (void)
1826 gfc_alloc *head, *tail;
1833 if (gfc_match_char ('(') != MATCH_YES)
1839 head = tail = gfc_get_alloc ();
1842 tail->next = gfc_get_alloc ();
1846 m = gfc_match_variable (&tail->expr, 0);
1849 if (m == MATCH_ERROR)
1852 if (gfc_check_do_variable (tail->expr->symtree))
1856 && gfc_impure_variable (tail->expr->symtree->n.sym))
1858 gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1863 if (tail->expr->ts.type == BT_DERIVED)
1864 tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
1866 if (gfc_match_char (',') != MATCH_YES)
1869 m = gfc_match (" stat = %v", &stat);
1870 if (m == MATCH_ERROR)
1878 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1880 gfc_error ("STAT variable '%s' of ALLOCATE statement at %C cannot "
1881 "be INTENT(IN)", stat->symtree->n.sym->name);
1885 if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
1887 gfc_error ("Illegal STAT variable in ALLOCATE statement at %C "
1888 "for a PURE procedure");
1892 if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1894 gfc_error ("STAT expression at %C must be a variable");
1898 gfc_check_do_variable(stat->symtree);
1901 if (gfc_match (" )%t") != MATCH_YES)
1904 new_st.op = EXEC_ALLOCATE;
1906 new_st.ext.alloc_list = head;
1911 gfc_syntax_error (ST_ALLOCATE);
1914 gfc_free_expr (stat);
1915 gfc_free_alloc_list (head);
1920 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1921 a set of pointer assignments to intrinsic NULL(). */
1924 gfc_match_nullify (void)
1932 if (gfc_match_char ('(') != MATCH_YES)
1937 m = gfc_match_variable (&p, 0);
1938 if (m == MATCH_ERROR)
1943 if (gfc_check_do_variable (p->symtree))
1946 if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
1948 gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
1952 /* build ' => NULL() '. */
1953 e = gfc_get_expr ();
1954 e->where = gfc_current_locus;
1955 e->expr_type = EXPR_NULL;
1956 e->ts.type = BT_UNKNOWN;
1958 /* Chain to list. */
1963 tail->next = gfc_get_code ();
1967 tail->op = EXEC_POINTER_ASSIGN;
1971 if (gfc_match (" )%t") == MATCH_YES)
1973 if (gfc_match_char (',') != MATCH_YES)
1980 gfc_syntax_error (ST_NULLIFY);
1983 gfc_free_statements (new_st.next);
1988 /* Match a DEALLOCATE statement. */
1991 gfc_match_deallocate (void)
1993 gfc_alloc *head, *tail;
2000 if (gfc_match_char ('(') != MATCH_YES)
2006 head = tail = gfc_get_alloc ();
2009 tail->next = gfc_get_alloc ();
2013 m = gfc_match_variable (&tail->expr, 0);
2014 if (m == MATCH_ERROR)
2019 if (gfc_check_do_variable (tail->expr->symtree))
2023 && gfc_impure_variable (tail->expr->symtree->n.sym))
2025 gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
2026 "for a PURE procedure");
2030 if (gfc_match_char (',') != MATCH_YES)
2033 m = gfc_match (" stat = %v", &stat);
2034 if (m == MATCH_ERROR)
2042 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
2044 gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
2045 "cannot be INTENT(IN)", stat->symtree->n.sym->name);
2049 if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym))
2051 gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
2052 "for a PURE procedure");
2056 if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
2058 gfc_error ("STAT expression at %C must be a variable");
2062 gfc_check_do_variable(stat->symtree);
2065 if (gfc_match (" )%t") != MATCH_YES)
2068 new_st.op = EXEC_DEALLOCATE;
2070 new_st.ext.alloc_list = head;
2075 gfc_syntax_error (ST_DEALLOCATE);
2078 gfc_free_expr (stat);
2079 gfc_free_alloc_list (head);
2084 /* Match a RETURN statement. */
2087 gfc_match_return (void)
2091 gfc_compile_state s;
2095 if (gfc_match_eos () == MATCH_YES)
2098 if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
2100 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2105 if (gfc_current_form == FORM_FREE)
2107 /* The following are valid, so we can't require a blank after the
2111 c = gfc_peek_char ();
2112 if (ISALPHA (c) || ISDIGIT (c))
2116 m = gfc_match (" %e%t", &e);
2119 if (m == MATCH_ERROR)
2122 gfc_syntax_error (ST_RETURN);
2129 gfc_enclosing_unit (&s);
2130 if (s == COMP_PROGRAM
2131 && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
2132 "main program at %C") == FAILURE)
2135 new_st.op = EXEC_RETURN;
2142 /* Match a CALL statement. The tricky part here are possible
2143 alternate return specifiers. We handle these by having all
2144 "subroutines" actually return an integer via a register that gives
2145 the return number. If the call specifies alternate returns, we
2146 generate code for a SELECT statement whose case clauses contain
2147 GOTOs to the various labels. */
2150 gfc_match_call (void)
2152 char name[GFC_MAX_SYMBOL_LEN + 1];
2153 gfc_actual_arglist *a, *arglist;
2163 m = gfc_match ("% %n", name);
2169 if (gfc_get_ha_sym_tree (name, &st))
2173 gfc_set_sym_referenced (sym);
2175 if (!sym->attr.generic
2176 && !sym->attr.subroutine
2177 && gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2180 if (gfc_match_eos () != MATCH_YES)
2182 m = gfc_match_actual_arglist (1, &arglist);
2185 if (m == MATCH_ERROR)
2188 if (gfc_match_eos () != MATCH_YES)
2192 /* If any alternate return labels were found, construct a SELECT
2193 statement that will jump to the right place. */
2196 for (a = arglist; a; a = a->next)
2197 if (a->expr == NULL)
2202 gfc_symtree *select_st;
2203 gfc_symbol *select_sym;
2204 char name[GFC_MAX_SYMBOL_LEN + 1];
2206 new_st.next = c = gfc_get_code ();
2207 c->op = EXEC_SELECT;
2208 sprintf (name, "_result_%s", sym->name);
2209 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
2211 select_sym = select_st->n.sym;
2212 select_sym->ts.type = BT_INTEGER;
2213 select_sym->ts.kind = gfc_default_integer_kind;
2214 gfc_set_sym_referenced (select_sym);
2215 c->expr = gfc_get_expr ();
2216 c->expr->expr_type = EXPR_VARIABLE;
2217 c->expr->symtree = select_st;
2218 c->expr->ts = select_sym->ts;
2219 c->expr->where = gfc_current_locus;
2222 for (a = arglist; a; a = a->next)
2224 if (a->expr != NULL)
2227 if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2232 c->block = gfc_get_code ();
2234 c->op = EXEC_SELECT;
2236 new_case = gfc_get_case ();
2237 new_case->high = new_case->low = gfc_int_expr (i);
2238 c->ext.case_list = new_case;
2240 c->next = gfc_get_code ();
2241 c->next->op = EXEC_GOTO;
2242 c->next->label = a->label;
2246 new_st.op = EXEC_CALL;
2247 new_st.symtree = st;
2248 new_st.ext.actual = arglist;
2253 gfc_syntax_error (ST_CALL);
2256 gfc_free_actual_arglist (arglist);
2261 /* Given a name, return a pointer to the common head structure,
2262 creating it if it does not exist. If FROM_MODULE is nonzero, we
2263 mangle the name so that it doesn't interfere with commons defined
2264 in the using namespace.
2265 TODO: Add to global symbol tree. */
2268 gfc_get_common (const char *name, int from_module)
2271 static int serial = 0;
2272 char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
2276 /* A use associated common block is only needed to correctly layout
2277 the variables it contains. */
2278 snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2279 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2283 st = gfc_find_symtree (gfc_current_ns->common_root, name);
2286 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2289 if (st->n.common == NULL)
2291 st->n.common = gfc_get_common_head ();
2292 st->n.common->where = gfc_current_locus;
2293 strcpy (st->n.common->name, name);
2296 return st->n.common;
2300 /* Match a common block name. */
2303 match_common_name (char *name)
2307 if (gfc_match_char ('/') == MATCH_NO)
2313 if (gfc_match_char ('/') == MATCH_YES)
2319 m = gfc_match_name (name);
2321 if (m == MATCH_ERROR)
2323 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2326 gfc_error ("Syntax error in common block name at %C");
2331 /* Match a COMMON statement. */
2334 gfc_match_common (void)
2336 gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
2337 char name[GFC_MAX_SYMBOL_LEN + 1];
2344 old_blank_common = gfc_current_ns->blank_common.head;
2345 if (old_blank_common)
2347 while (old_blank_common->common_next)
2348 old_blank_common = old_blank_common->common_next;
2355 m = match_common_name (name);
2356 if (m == MATCH_ERROR)
2359 gsym = gfc_get_gsymbol (name);
2360 if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
2362 gfc_error ("Symbol '%s' at %C is already an external symbol that "
2363 "is not COMMON", name);
2367 if (gsym->type == GSYM_UNKNOWN)
2369 gsym->type = GSYM_COMMON;
2370 gsym->where = gfc_current_locus;
2376 if (name[0] == '\0')
2378 if (gfc_current_ns->is_block_data)
2380 gfc_warning ("BLOCK DATA unit cannot contain blank COMMON "
2383 t = &gfc_current_ns->blank_common;
2384 if (t->head == NULL)
2385 t->where = gfc_current_locus;
2389 t = gfc_get_common (name, 0);
2398 while (tail->common_next)
2399 tail = tail->common_next;
2402 /* Grab the list of symbols. */
2405 m = gfc_match_symbol (&sym, 0);
2406 if (m == MATCH_ERROR)
2411 if (sym->attr.in_common)
2413 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2418 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2421 if (sym->value != NULL && sym->value->expr_type != EXPR_NULL
2422 && (name[0] == '\0' || !sym->attr.data))
2424 if (name[0] == '\0')
2425 gfc_error ("Previously initialized symbol '%s' in "
2426 "blank COMMON block at %C", sym->name);
2428 gfc_error ("Previously initialized symbol '%s' in "
2429 "COMMON block '%s' at %C", sym->name, name);
2433 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2436 /* Derived type names must have the SEQUENCE attribute. */
2437 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2439 gfc_error ("Derived type variable in COMMON at %C does not "
2440 "have the SEQUENCE attribute");
2445 tail->common_next = sym;
2451 /* Deal with an optional array specification after the
2453 m = gfc_match_array_spec (&as);
2454 if (m == MATCH_ERROR)
2459 if (as->type != AS_EXPLICIT)
2461 gfc_error ("Array specification for symbol '%s' in COMMON "
2462 "at %C must be explicit", sym->name);
2466 if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2469 if (sym->attr.pointer)
2471 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
2472 "POINTER array", sym->name);
2481 sym->common_head = t;
2483 /* Check to see if the symbol is already in an equivalence group.
2484 If it is, set the other members as being in common. */
2485 if (sym->attr.in_equivalence)
2487 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
2489 for (e2 = e1; e2; e2 = e2->eq)
2490 if (e2->expr->symtree->n.sym == sym)
2497 for (e2 = e1; e2; e2 = e2->eq)
2499 other = e2->expr->symtree->n.sym;
2500 if (other->common_head
2501 && other->common_head != sym->common_head)
2503 gfc_error ("Symbol '%s', in COMMON block '%s' at "
2504 "%C is being indirectly equivalenced to "
2505 "another COMMON block '%s'",
2506 sym->name, sym->common_head->name,
2507 other->common_head->name);
2510 other->attr.in_common = 1;
2511 other->common_head = t;
2517 gfc_gobble_whitespace ();
2518 if (gfc_match_eos () == MATCH_YES)
2520 if (gfc_peek_char () == '/')
2522 if (gfc_match_char (',') != MATCH_YES)
2524 gfc_gobble_whitespace ();
2525 if (gfc_peek_char () == '/')
2534 gfc_syntax_error (ST_COMMON);
2537 if (old_blank_common)
2538 old_blank_common->common_next = NULL;
2540 gfc_current_ns->blank_common.head = NULL;
2541 gfc_free_array_spec (as);
2546 /* Match a BLOCK DATA program unit. */
2549 gfc_match_block_data (void)
2551 char name[GFC_MAX_SYMBOL_LEN + 1];
2555 if (gfc_match_eos () == MATCH_YES)
2557 gfc_new_block = NULL;
2561 m = gfc_match ("% %n%t", name);
2565 if (gfc_get_symbol (name, NULL, &sym))
2568 if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
2571 gfc_new_block = sym;
2577 /* Free a namelist structure. */
2580 gfc_free_namelist (gfc_namelist *name)
2584 for (; name; name = n)
2592 /* Match a NAMELIST statement. */
2595 gfc_match_namelist (void)
2597 gfc_symbol *group_name, *sym;
2601 m = gfc_match (" / %s /", &group_name);
2604 if (m == MATCH_ERROR)
2609 if (group_name->ts.type != BT_UNKNOWN)
2611 gfc_error ("Namelist group name '%s' at %C already has a basic "
2612 "type of %s", group_name->name,
2613 gfc_typename (&group_name->ts));
2617 if (group_name->attr.flavor == FL_NAMELIST
2618 && group_name->attr.use_assoc
2619 && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
2620 "at %C already is USE associated and can"
2621 "not be respecified.", group_name->name)
2625 if (group_name->attr.flavor != FL_NAMELIST
2626 && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
2627 group_name->name, NULL) == FAILURE)
2632 m = gfc_match_symbol (&sym, 1);
2635 if (m == MATCH_ERROR)
2638 if (sym->attr.in_namelist == 0
2639 && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
2642 /* Use gfc_error_check here, rather than goto error, so that
2643 these are the only errors for the next two lines. */
2644 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
2646 gfc_error ("Assumed size array '%s' in namelist '%s' at "
2647 "%C is not allowed", sym->name, group_name->name);
2651 if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL)
2653 gfc_error ("Assumed character length '%s' in namelist '%s' at "
2654 "%C is not allowed", sym->name, group_name->name);
2658 if (sym->as && sym->as->type == AS_ASSUMED_SHAPE
2659 && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
2660 "namelist '%s' at %C is an extension.",
2661 sym->name, group_name->name) == FAILURE)
2664 nl = gfc_get_namelist ();
2668 if (group_name->namelist == NULL)
2669 group_name->namelist = group_name->namelist_tail = nl;
2672 group_name->namelist_tail->next = nl;
2673 group_name->namelist_tail = nl;
2676 if (gfc_match_eos () == MATCH_YES)
2679 m = gfc_match_char (',');
2681 if (gfc_match_char ('/') == MATCH_YES)
2683 m2 = gfc_match (" %s /", &group_name);
2684 if (m2 == MATCH_YES)
2686 if (m2 == MATCH_ERROR)
2700 gfc_syntax_error (ST_NAMELIST);
2707 /* Match a MODULE statement. */
2710 gfc_match_module (void)
2714 m = gfc_match (" %s%t", &gfc_new_block);
2718 if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
2719 gfc_new_block->name, NULL) == FAILURE)
2726 /* Free equivalence sets and lists. Recursively is the easiest way to
2730 gfc_free_equiv (gfc_equiv *eq)
2735 gfc_free_equiv (eq->eq);
2736 gfc_free_equiv (eq->next);
2737 gfc_free_expr (eq->expr);
2742 /* Match an EQUIVALENCE statement. */
2745 gfc_match_equivalence (void)
2747 gfc_equiv *eq, *set, *tail;
2751 gfc_common_head *common_head = NULL;
2759 eq = gfc_get_equiv ();
2763 eq->next = gfc_current_ns->equiv;
2764 gfc_current_ns->equiv = eq;
2766 if (gfc_match_char ('(') != MATCH_YES)
2770 common_flag = FALSE;
2775 m = gfc_match_equiv_variable (&set->expr);
2776 if (m == MATCH_ERROR)
2781 /* count the number of objects. */
2784 if (gfc_match_char ('%') == MATCH_YES)
2786 gfc_error ("Derived type component %C is not a "
2787 "permitted EQUIVALENCE member");
2791 for (ref = set->expr->ref; ref; ref = ref->next)
2792 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2794 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
2795 "be an array section");
2799 sym = set->expr->symtree->n.sym;
2801 if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
2804 if (sym->attr.in_common)
2807 common_head = sym->common_head;
2810 if (gfc_match_char (')') == MATCH_YES)
2813 if (gfc_match_char (',') != MATCH_YES)
2816 set->eq = gfc_get_equiv ();
2822 gfc_error ("EQUIVALENCE at %C requires two or more objects");
2826 /* If one of the members of an equivalence is in common, then
2827 mark them all as being in common. Before doing this, check
2828 that members of the equivalence group are not in different
2831 for (set = eq; set; set = set->eq)
2833 sym = set->expr->symtree->n.sym;
2834 if (sym->common_head && sym->common_head != common_head)
2836 gfc_error ("Attempt to indirectly overlap COMMON "
2837 "blocks %s and %s by EQUIVALENCE at %C",
2838 sym->common_head->name, common_head->name);
2841 sym->attr.in_common = 1;
2842 sym->common_head = common_head;
2845 if (gfc_match_eos () == MATCH_YES)
2847 if (gfc_match_char (',') != MATCH_YES)
2854 gfc_syntax_error (ST_EQUIVALENCE);
2860 gfc_free_equiv (gfc_current_ns->equiv);
2861 gfc_current_ns->equiv = eq;
2867 /* Check that a statement function is not recursive. This is done by looking
2868 for the statement function symbol(sym) by looking recursively through its
2869 expression(e). If a reference to sym is found, true is returned.
2870 12.5.4 requires that any variable of function that is implicitly typed
2871 shall have that type confirmed by any subsequent type declaration. The
2872 implicit typing is conveniently done here. */
2875 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
2877 gfc_actual_arglist *arg;
2884 switch (e->expr_type)
2887 for (arg = e->value.function.actual; arg; arg = arg->next)
2889 if (sym->name == arg->name || recursive_stmt_fcn (arg->expr, sym))
2893 if (e->symtree == NULL)
2896 /* Check the name before testing for nested recursion! */
2897 if (sym->name == e->symtree->n.sym->name)
2900 /* Catch recursion via other statement functions. */
2901 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
2902 && e->symtree->n.sym->value
2903 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
2906 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
2907 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
2912 if (e->symtree && sym->name == e->symtree->n.sym->name)
2915 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
2916 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
2920 if (recursive_stmt_fcn (e->value.op.op1, sym)
2921 || recursive_stmt_fcn (e->value.op.op2, sym))
2929 /* Component references do not need to be checked. */
2932 for (ref = e->ref; ref; ref = ref->next)
2937 for (i = 0; i < ref->u.ar.dimen; i++)
2939 if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
2940 || recursive_stmt_fcn (ref->u.ar.end[i], sym)
2941 || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
2947 if (recursive_stmt_fcn (ref->u.ss.start, sym)
2948 || recursive_stmt_fcn (ref->u.ss.end, sym))
2962 /* Match a statement function declaration. It is so easy to match
2963 non-statement function statements with a MATCH_ERROR as opposed to
2964 MATCH_NO that we suppress error message in most cases. */
2967 gfc_match_st_function (void)
2969 gfc_error_buf old_error;
2974 m = gfc_match_symbol (&sym, 0);
2978 gfc_push_error (&old_error);
2980 if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
2981 sym->name, NULL) == FAILURE)
2984 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2987 m = gfc_match (" = %e%t", &expr);
2991 gfc_free_error (&old_error);
2992 if (m == MATCH_ERROR)
2995 if (recursive_stmt_fcn (expr, sym))
2997 gfc_error ("Statement function at %L is recursive", &expr->where);
3006 gfc_pop_error (&old_error);
3011 /***************** SELECT CASE subroutines ******************/
3013 /* Free a single case structure. */
3016 free_case (gfc_case *p)
3018 if (p->low == p->high)
3020 gfc_free_expr (p->low);
3021 gfc_free_expr (p->high);
3026 /* Free a list of case structures. */
3029 gfc_free_case_list (gfc_case *p)
3041 /* Match a single case selector. */
3044 match_case_selector (gfc_case **cp)
3049 c = gfc_get_case ();
3050 c->where = gfc_current_locus;
3052 if (gfc_match_char (':') == MATCH_YES)
3054 m = gfc_match_init_expr (&c->high);
3057 if (m == MATCH_ERROR)
3062 m = gfc_match_init_expr (&c->low);
3063 if (m == MATCH_ERROR)
3068 /* If we're not looking at a ':' now, make a range out of a single
3069 target. Else get the upper bound for the case range. */
3070 if (gfc_match_char (':') != MATCH_YES)
3074 m = gfc_match_init_expr (&c->high);
3075 if (m == MATCH_ERROR)
3077 /* MATCH_NO is fine. It's OK if nothing is there! */
3085 gfc_error ("Expected initialization expression in CASE at %C");
3093 /* Match the end of a case statement. */
3096 match_case_eos (void)
3098 char name[GFC_MAX_SYMBOL_LEN + 1];
3101 if (gfc_match_eos () == MATCH_YES)
3104 /* If the case construct doesn't have a case-construct-name, we
3105 should have matched the EOS. */
3106 if (!gfc_current_block ())
3108 gfc_error ("Expected the name of the SELECT CASE construct at %C");
3112 gfc_gobble_whitespace ();
3114 m = gfc_match_name (name);
3118 if (strcmp (name, gfc_current_block ()->name) != 0)
3120 gfc_error ("Expected case name of '%s' at %C",
3121 gfc_current_block ()->name);
3125 return gfc_match_eos ();
3129 /* Match a SELECT statement. */
3132 gfc_match_select (void)
3137 m = gfc_match_label ();
3138 if (m == MATCH_ERROR)
3141 m = gfc_match (" select case ( %e )%t", &expr);
3145 new_st.op = EXEC_SELECT;
3152 /* Match a CASE statement. */
3155 gfc_match_case (void)
3157 gfc_case *c, *head, *tail;
3162 if (gfc_current_state () != COMP_SELECT)
3164 gfc_error ("Unexpected CASE statement at %C");
3168 if (gfc_match ("% default") == MATCH_YES)
3170 m = match_case_eos ();
3173 if (m == MATCH_ERROR)
3176 new_st.op = EXEC_SELECT;
3177 c = gfc_get_case ();
3178 c->where = gfc_current_locus;
3179 new_st.ext.case_list = c;
3183 if (gfc_match_char ('(') != MATCH_YES)
3188 if (match_case_selector (&c) == MATCH_ERROR)
3198 if (gfc_match_char (')') == MATCH_YES)
3200 if (gfc_match_char (',') != MATCH_YES)
3204 m = match_case_eos ();
3207 if (m == MATCH_ERROR)
3210 new_st.op = EXEC_SELECT;
3211 new_st.ext.case_list = head;
3216 gfc_error ("Syntax error in CASE-specification at %C");
3219 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
3223 /********************* WHERE subroutines ********************/
3225 /* Match the rest of a simple WHERE statement that follows an IF statement.
3229 match_simple_where (void)
3235 m = gfc_match (" ( %e )", &expr);
3239 m = gfc_match_assignment ();
3242 if (m == MATCH_ERROR)
3245 if (gfc_match_eos () != MATCH_YES)
3248 c = gfc_get_code ();
3252 c->next = gfc_get_code ();
3255 gfc_clear_new_st ();
3257 new_st.op = EXEC_WHERE;
3263 gfc_syntax_error (ST_WHERE);
3266 gfc_free_expr (expr);
3271 /* Match a WHERE statement. */
3274 gfc_match_where (gfc_statement *st)
3280 m0 = gfc_match_label ();
3281 if (m0 == MATCH_ERROR)
3284 m = gfc_match (" where ( %e )", &expr);
3288 if (gfc_match_eos () == MATCH_YES)
3290 *st = ST_WHERE_BLOCK;
3291 new_st.op = EXEC_WHERE;
3296 m = gfc_match_assignment ();
3298 gfc_syntax_error (ST_WHERE);
3302 gfc_free_expr (expr);
3306 /* We've got a simple WHERE statement. */
3308 c = gfc_get_code ();
3312 c->next = gfc_get_code ();
3315 gfc_clear_new_st ();
3317 new_st.op = EXEC_WHERE;
3324 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3325 new_st if successful. */
3328 gfc_match_elsewhere (void)
3330 char name[GFC_MAX_SYMBOL_LEN + 1];
3334 if (gfc_current_state () != COMP_WHERE)
3336 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3342 if (gfc_match_char ('(') == MATCH_YES)
3344 m = gfc_match_expr (&expr);
3347 if (m == MATCH_ERROR)
3350 if (gfc_match_char (')') != MATCH_YES)
3354 if (gfc_match_eos () != MATCH_YES)
3356 /* Only makes sense if we have a where-construct-name. */
3357 if (!gfc_current_block ())
3362 /* Better be a name at this point. */
3363 m = gfc_match_name (name);
3366 if (m == MATCH_ERROR)
3369 if (gfc_match_eos () != MATCH_YES)
3372 if (strcmp (name, gfc_current_block ()->name) != 0)
3374 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3375 name, gfc_current_block ()->name);
3380 new_st.op = EXEC_WHERE;
3385 gfc_syntax_error (ST_ELSEWHERE);
3388 gfc_free_expr (expr);
3393 /******************** FORALL subroutines ********************/
3395 /* Free a list of FORALL iterators. */
3398 gfc_free_forall_iterator (gfc_forall_iterator *iter)
3400 gfc_forall_iterator *next;
3405 gfc_free_expr (iter->var);
3406 gfc_free_expr (iter->start);
3407 gfc_free_expr (iter->end);
3408 gfc_free_expr (iter->stride);
3415 /* Match an iterator as part of a FORALL statement. The format is:
3417 <var> = <start>:<end>[:<stride>]
3419 On MATCH_NO, the caller tests for the possibility that there is a
3420 scalar mask expression. */
3423 match_forall_iterator (gfc_forall_iterator **result)
3425 gfc_forall_iterator *iter;
3429 where = gfc_current_locus;
3430 iter = gfc_getmem (sizeof (gfc_forall_iterator));
3432 m = gfc_match_expr (&iter->var);
3436 if (gfc_match_char ('=') != MATCH_YES
3437 || iter->var->expr_type != EXPR_VARIABLE)
3443 m = gfc_match_expr (&iter->start);
3447 if (gfc_match_char (':') != MATCH_YES)
3450 m = gfc_match_expr (&iter->end);
3453 if (m == MATCH_ERROR)
3456 if (gfc_match_char (':') == MATCH_NO)
3457 iter->stride = gfc_int_expr (1);
3460 m = gfc_match_expr (&iter->stride);
3463 if (m == MATCH_ERROR)
3467 /* Mark the iteration variable's symbol as used as a FORALL index. */
3468 iter->var->symtree->n.sym->forall_index = true;
3474 gfc_error ("Syntax error in FORALL iterator at %C");
3479 gfc_current_locus = where;
3480 gfc_free_forall_iterator (iter);
3485 /* Match the header of a FORALL statement. */
3488 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
3490 gfc_forall_iterator *head, *tail, *new;
3494 gfc_gobble_whitespace ();
3499 if (gfc_match_char ('(') != MATCH_YES)
3502 m = match_forall_iterator (&new);
3503 if (m == MATCH_ERROR)
3512 if (gfc_match_char (',') != MATCH_YES)
3515 m = match_forall_iterator (&new);
3516 if (m == MATCH_ERROR)
3526 /* Have to have a mask expression. */
3528 m = gfc_match_expr (&msk);
3531 if (m == MATCH_ERROR)
3537 if (gfc_match_char (')') == MATCH_NO)
3545 gfc_syntax_error (ST_FORALL);
3548 gfc_free_expr (msk);
3549 gfc_free_forall_iterator (head);
3554 /* Match the rest of a simple FORALL statement that follows an
3558 match_simple_forall (void)
3560 gfc_forall_iterator *head;
3569 m = match_forall_header (&head, &mask);
3576 m = gfc_match_assignment ();
3578 if (m == MATCH_ERROR)
3582 m = gfc_match_pointer_assignment ();
3583 if (m == MATCH_ERROR)
3589 c = gfc_get_code ();
3591 c->loc = gfc_current_locus;
3593 if (gfc_match_eos () != MATCH_YES)
3596 gfc_clear_new_st ();
3597 new_st.op = EXEC_FORALL;
3599 new_st.ext.forall_iterator = head;
3600 new_st.block = gfc_get_code ();
3602 new_st.block->op = EXEC_FORALL;
3603 new_st.block->next = c;
3608 gfc_syntax_error (ST_FORALL);
3611 gfc_free_forall_iterator (head);
3612 gfc_free_expr (mask);
3618 /* Match a FORALL statement. */
3621 gfc_match_forall (gfc_statement *st)
3623 gfc_forall_iterator *head;
3632 m0 = gfc_match_label ();
3633 if (m0 == MATCH_ERROR)
3636 m = gfc_match (" forall");
3640 m = match_forall_header (&head, &mask);
3641 if (m == MATCH_ERROR)
3646 if (gfc_match_eos () == MATCH_YES)
3648 *st = ST_FORALL_BLOCK;
3649 new_st.op = EXEC_FORALL;
3651 new_st.ext.forall_iterator = head;
3655 m = gfc_match_assignment ();
3656 if (m == MATCH_ERROR)
3660 m = gfc_match_pointer_assignment ();
3661 if (m == MATCH_ERROR)
3667 c = gfc_get_code ();
3669 c->loc = gfc_current_locus;
3671 gfc_clear_new_st ();
3672 new_st.op = EXEC_FORALL;
3674 new_st.ext.forall_iterator = head;
3675 new_st.block = gfc_get_code ();
3676 new_st.block->op = EXEC_FORALL;
3677 new_st.block->next = c;
3683 gfc_syntax_error (ST_FORALL);
3686 gfc_free_forall_iterator (head);
3687 gfc_free_expr (mask);
3688 gfc_free_statements (c);