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))
2174 if (sym->ns != gfc_current_ns
2175 && !sym->attr.generic
2176 && !sym->attr.subroutine
2177 && gfc_get_sym_tree (name, NULL, &st) == 1)
2182 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2185 gfc_set_sym_referenced (sym);
2187 if (gfc_match_eos () != MATCH_YES)
2189 m = gfc_match_actual_arglist (1, &arglist);
2192 if (m == MATCH_ERROR)
2195 if (gfc_match_eos () != MATCH_YES)
2199 /* If any alternate return labels were found, construct a SELECT
2200 statement that will jump to the right place. */
2203 for (a = arglist; a; a = a->next)
2204 if (a->expr == NULL)
2209 gfc_symtree *select_st;
2210 gfc_symbol *select_sym;
2211 char name[GFC_MAX_SYMBOL_LEN + 1];
2213 new_st.next = c = gfc_get_code ();
2214 c->op = EXEC_SELECT;
2215 sprintf (name, "_result_%s", sym->name);
2216 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
2218 select_sym = select_st->n.sym;
2219 select_sym->ts.type = BT_INTEGER;
2220 select_sym->ts.kind = gfc_default_integer_kind;
2221 gfc_set_sym_referenced (select_sym);
2222 c->expr = gfc_get_expr ();
2223 c->expr->expr_type = EXPR_VARIABLE;
2224 c->expr->symtree = select_st;
2225 c->expr->ts = select_sym->ts;
2226 c->expr->where = gfc_current_locus;
2229 for (a = arglist; a; a = a->next)
2231 if (a->expr != NULL)
2234 if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2239 c->block = gfc_get_code ();
2241 c->op = EXEC_SELECT;
2243 new_case = gfc_get_case ();
2244 new_case->high = new_case->low = gfc_int_expr (i);
2245 c->ext.case_list = new_case;
2247 c->next = gfc_get_code ();
2248 c->next->op = EXEC_GOTO;
2249 c->next->label = a->label;
2253 new_st.op = EXEC_CALL;
2254 new_st.symtree = st;
2255 new_st.ext.actual = arglist;
2260 gfc_syntax_error (ST_CALL);
2263 gfc_free_actual_arglist (arglist);
2268 /* Given a name, return a pointer to the common head structure,
2269 creating it if it does not exist. If FROM_MODULE is nonzero, we
2270 mangle the name so that it doesn't interfere with commons defined
2271 in the using namespace.
2272 TODO: Add to global symbol tree. */
2275 gfc_get_common (const char *name, int from_module)
2278 static int serial = 0;
2279 char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
2283 /* A use associated common block is only needed to correctly layout
2284 the variables it contains. */
2285 snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2286 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2290 st = gfc_find_symtree (gfc_current_ns->common_root, name);
2293 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2296 if (st->n.common == NULL)
2298 st->n.common = gfc_get_common_head ();
2299 st->n.common->where = gfc_current_locus;
2300 strcpy (st->n.common->name, name);
2303 return st->n.common;
2307 /* Match a common block name. */
2310 match_common_name (char *name)
2314 if (gfc_match_char ('/') == MATCH_NO)
2320 if (gfc_match_char ('/') == MATCH_YES)
2326 m = gfc_match_name (name);
2328 if (m == MATCH_ERROR)
2330 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2333 gfc_error ("Syntax error in common block name at %C");
2338 /* Match a COMMON statement. */
2341 gfc_match_common (void)
2343 gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
2344 char name[GFC_MAX_SYMBOL_LEN + 1];
2351 old_blank_common = gfc_current_ns->blank_common.head;
2352 if (old_blank_common)
2354 while (old_blank_common->common_next)
2355 old_blank_common = old_blank_common->common_next;
2362 m = match_common_name (name);
2363 if (m == MATCH_ERROR)
2366 gsym = gfc_get_gsymbol (name);
2367 if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
2369 gfc_error ("Symbol '%s' at %C is already an external symbol that "
2370 "is not COMMON", name);
2374 if (gsym->type == GSYM_UNKNOWN)
2376 gsym->type = GSYM_COMMON;
2377 gsym->where = gfc_current_locus;
2383 if (name[0] == '\0')
2385 if (gfc_current_ns->is_block_data)
2387 gfc_warning ("BLOCK DATA unit cannot contain blank COMMON "
2390 t = &gfc_current_ns->blank_common;
2391 if (t->head == NULL)
2392 t->where = gfc_current_locus;
2396 t = gfc_get_common (name, 0);
2405 while (tail->common_next)
2406 tail = tail->common_next;
2409 /* Grab the list of symbols. */
2412 m = gfc_match_symbol (&sym, 0);
2413 if (m == MATCH_ERROR)
2418 if (sym->attr.in_common)
2420 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2425 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2428 if (sym->value != NULL && sym->value->expr_type != EXPR_NULL
2429 && (name[0] == '\0' || !sym->attr.data))
2431 if (name[0] == '\0')
2432 gfc_error ("Previously initialized symbol '%s' in "
2433 "blank COMMON block at %C", sym->name);
2435 gfc_error ("Previously initialized symbol '%s' in "
2436 "COMMON block '%s' at %C", sym->name, name);
2440 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2443 /* Derived type names must have the SEQUENCE attribute. */
2444 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2446 gfc_error ("Derived type variable in COMMON at %C does not "
2447 "have the SEQUENCE attribute");
2452 tail->common_next = sym;
2458 /* Deal with an optional array specification after the
2460 m = gfc_match_array_spec (&as);
2461 if (m == MATCH_ERROR)
2466 if (as->type != AS_EXPLICIT)
2468 gfc_error ("Array specification for symbol '%s' in COMMON "
2469 "at %C must be explicit", sym->name);
2473 if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2476 if (sym->attr.pointer)
2478 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
2479 "POINTER array", sym->name);
2488 sym->common_head = t;
2490 /* Check to see if the symbol is already in an equivalence group.
2491 If it is, set the other members as being in common. */
2492 if (sym->attr.in_equivalence)
2494 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
2496 for (e2 = e1; e2; e2 = e2->eq)
2497 if (e2->expr->symtree->n.sym == sym)
2504 for (e2 = e1; e2; e2 = e2->eq)
2506 other = e2->expr->symtree->n.sym;
2507 if (other->common_head
2508 && other->common_head != sym->common_head)
2510 gfc_error ("Symbol '%s', in COMMON block '%s' at "
2511 "%C is being indirectly equivalenced to "
2512 "another COMMON block '%s'",
2513 sym->name, sym->common_head->name,
2514 other->common_head->name);
2517 other->attr.in_common = 1;
2518 other->common_head = t;
2524 gfc_gobble_whitespace ();
2525 if (gfc_match_eos () == MATCH_YES)
2527 if (gfc_peek_char () == '/')
2529 if (gfc_match_char (',') != MATCH_YES)
2531 gfc_gobble_whitespace ();
2532 if (gfc_peek_char () == '/')
2541 gfc_syntax_error (ST_COMMON);
2544 if (old_blank_common)
2545 old_blank_common->common_next = NULL;
2547 gfc_current_ns->blank_common.head = NULL;
2548 gfc_free_array_spec (as);
2553 /* Match a BLOCK DATA program unit. */
2556 gfc_match_block_data (void)
2558 char name[GFC_MAX_SYMBOL_LEN + 1];
2562 if (gfc_match_eos () == MATCH_YES)
2564 gfc_new_block = NULL;
2568 m = gfc_match ("% %n%t", name);
2572 if (gfc_get_symbol (name, NULL, &sym))
2575 if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
2578 gfc_new_block = sym;
2584 /* Free a namelist structure. */
2587 gfc_free_namelist (gfc_namelist *name)
2591 for (; name; name = n)
2599 /* Match a NAMELIST statement. */
2602 gfc_match_namelist (void)
2604 gfc_symbol *group_name, *sym;
2608 m = gfc_match (" / %s /", &group_name);
2611 if (m == MATCH_ERROR)
2616 if (group_name->ts.type != BT_UNKNOWN)
2618 gfc_error ("Namelist group name '%s' at %C already has a basic "
2619 "type of %s", group_name->name,
2620 gfc_typename (&group_name->ts));
2624 if (group_name->attr.flavor == FL_NAMELIST
2625 && group_name->attr.use_assoc
2626 && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
2627 "at %C already is USE associated and can"
2628 "not be respecified.", group_name->name)
2632 if (group_name->attr.flavor != FL_NAMELIST
2633 && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
2634 group_name->name, NULL) == FAILURE)
2639 m = gfc_match_symbol (&sym, 1);
2642 if (m == MATCH_ERROR)
2645 if (sym->attr.in_namelist == 0
2646 && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
2649 /* Use gfc_error_check here, rather than goto error, so that
2650 these are the only errors for the next two lines. */
2651 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
2653 gfc_error ("Assumed size array '%s' in namelist '%s' at "
2654 "%C is not allowed", sym->name, group_name->name);
2658 if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL)
2660 gfc_error ("Assumed character length '%s' in namelist '%s' at "
2661 "%C is not allowed", sym->name, group_name->name);
2665 if (sym->as && sym->as->type == AS_ASSUMED_SHAPE
2666 && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
2667 "namelist '%s' at %C is an extension.",
2668 sym->name, group_name->name) == FAILURE)
2671 nl = gfc_get_namelist ();
2675 if (group_name->namelist == NULL)
2676 group_name->namelist = group_name->namelist_tail = nl;
2679 group_name->namelist_tail->next = nl;
2680 group_name->namelist_tail = nl;
2683 if (gfc_match_eos () == MATCH_YES)
2686 m = gfc_match_char (',');
2688 if (gfc_match_char ('/') == MATCH_YES)
2690 m2 = gfc_match (" %s /", &group_name);
2691 if (m2 == MATCH_YES)
2693 if (m2 == MATCH_ERROR)
2707 gfc_syntax_error (ST_NAMELIST);
2714 /* Match a MODULE statement. */
2717 gfc_match_module (void)
2721 m = gfc_match (" %s%t", &gfc_new_block);
2725 if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
2726 gfc_new_block->name, NULL) == FAILURE)
2733 /* Free equivalence sets and lists. Recursively is the easiest way to
2737 gfc_free_equiv (gfc_equiv *eq)
2742 gfc_free_equiv (eq->eq);
2743 gfc_free_equiv (eq->next);
2744 gfc_free_expr (eq->expr);
2749 /* Match an EQUIVALENCE statement. */
2752 gfc_match_equivalence (void)
2754 gfc_equiv *eq, *set, *tail;
2758 gfc_common_head *common_head = NULL;
2766 eq = gfc_get_equiv ();
2770 eq->next = gfc_current_ns->equiv;
2771 gfc_current_ns->equiv = eq;
2773 if (gfc_match_char ('(') != MATCH_YES)
2777 common_flag = FALSE;
2782 m = gfc_match_equiv_variable (&set->expr);
2783 if (m == MATCH_ERROR)
2788 /* count the number of objects. */
2791 if (gfc_match_char ('%') == MATCH_YES)
2793 gfc_error ("Derived type component %C is not a "
2794 "permitted EQUIVALENCE member");
2798 for (ref = set->expr->ref; ref; ref = ref->next)
2799 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2801 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
2802 "be an array section");
2806 sym = set->expr->symtree->n.sym;
2808 if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
2811 if (sym->attr.in_common)
2814 common_head = sym->common_head;
2817 if (gfc_match_char (')') == MATCH_YES)
2820 if (gfc_match_char (',') != MATCH_YES)
2823 set->eq = gfc_get_equiv ();
2829 gfc_error ("EQUIVALENCE at %C requires two or more objects");
2833 /* If one of the members of an equivalence is in common, then
2834 mark them all as being in common. Before doing this, check
2835 that members of the equivalence group are not in different
2838 for (set = eq; set; set = set->eq)
2840 sym = set->expr->symtree->n.sym;
2841 if (sym->common_head && sym->common_head != common_head)
2843 gfc_error ("Attempt to indirectly overlap COMMON "
2844 "blocks %s and %s by EQUIVALENCE at %C",
2845 sym->common_head->name, common_head->name);
2848 sym->attr.in_common = 1;
2849 sym->common_head = common_head;
2852 if (gfc_match_eos () == MATCH_YES)
2854 if (gfc_match_char (',') != MATCH_YES)
2861 gfc_syntax_error (ST_EQUIVALENCE);
2867 gfc_free_equiv (gfc_current_ns->equiv);
2868 gfc_current_ns->equiv = eq;
2874 /* Check that a statement function is not recursive. This is done by looking
2875 for the statement function symbol(sym) by looking recursively through its
2876 expression(e). If a reference to sym is found, true is returned.
2877 12.5.4 requires that any variable of function that is implicitly typed
2878 shall have that type confirmed by any subsequent type declaration. The
2879 implicit typing is conveniently done here. */
2882 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
2884 gfc_actual_arglist *arg;
2891 switch (e->expr_type)
2894 for (arg = e->value.function.actual; arg; arg = arg->next)
2896 if (sym->name == arg->name || recursive_stmt_fcn (arg->expr, sym))
2900 if (e->symtree == NULL)
2903 /* Check the name before testing for nested recursion! */
2904 if (sym->name == e->symtree->n.sym->name)
2907 /* Catch recursion via other statement functions. */
2908 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
2909 && e->symtree->n.sym->value
2910 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
2913 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
2914 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
2919 if (e->symtree && sym->name == e->symtree->n.sym->name)
2922 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
2923 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
2927 if (recursive_stmt_fcn (e->value.op.op1, sym)
2928 || recursive_stmt_fcn (e->value.op.op2, sym))
2936 /* Component references do not need to be checked. */
2939 for (ref = e->ref; ref; ref = ref->next)
2944 for (i = 0; i < ref->u.ar.dimen; i++)
2946 if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
2947 || recursive_stmt_fcn (ref->u.ar.end[i], sym)
2948 || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
2954 if (recursive_stmt_fcn (ref->u.ss.start, sym)
2955 || recursive_stmt_fcn (ref->u.ss.end, sym))
2969 /* Match a statement function declaration. It is so easy to match
2970 non-statement function statements with a MATCH_ERROR as opposed to
2971 MATCH_NO that we suppress error message in most cases. */
2974 gfc_match_st_function (void)
2976 gfc_error_buf old_error;
2981 m = gfc_match_symbol (&sym, 0);
2985 gfc_push_error (&old_error);
2987 if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
2988 sym->name, NULL) == FAILURE)
2991 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2994 m = gfc_match (" = %e%t", &expr);
2998 gfc_free_error (&old_error);
2999 if (m == MATCH_ERROR)
3002 if (recursive_stmt_fcn (expr, sym))
3004 gfc_error ("Statement function at %L is recursive", &expr->where);
3013 gfc_pop_error (&old_error);
3018 /***************** SELECT CASE subroutines ******************/
3020 /* Free a single case structure. */
3023 free_case (gfc_case *p)
3025 if (p->low == p->high)
3027 gfc_free_expr (p->low);
3028 gfc_free_expr (p->high);
3033 /* Free a list of case structures. */
3036 gfc_free_case_list (gfc_case *p)
3048 /* Match a single case selector. */
3051 match_case_selector (gfc_case **cp)
3056 c = gfc_get_case ();
3057 c->where = gfc_current_locus;
3059 if (gfc_match_char (':') == MATCH_YES)
3061 m = gfc_match_init_expr (&c->high);
3064 if (m == MATCH_ERROR)
3069 m = gfc_match_init_expr (&c->low);
3070 if (m == MATCH_ERROR)
3075 /* If we're not looking at a ':' now, make a range out of a single
3076 target. Else get the upper bound for the case range. */
3077 if (gfc_match_char (':') != MATCH_YES)
3081 m = gfc_match_init_expr (&c->high);
3082 if (m == MATCH_ERROR)
3084 /* MATCH_NO is fine. It's OK if nothing is there! */
3092 gfc_error ("Expected initialization expression in CASE at %C");
3100 /* Match the end of a case statement. */
3103 match_case_eos (void)
3105 char name[GFC_MAX_SYMBOL_LEN + 1];
3108 if (gfc_match_eos () == MATCH_YES)
3111 /* If the case construct doesn't have a case-construct-name, we
3112 should have matched the EOS. */
3113 if (!gfc_current_block ())
3115 gfc_error ("Expected the name of the SELECT CASE construct at %C");
3119 gfc_gobble_whitespace ();
3121 m = gfc_match_name (name);
3125 if (strcmp (name, gfc_current_block ()->name) != 0)
3127 gfc_error ("Expected case name of '%s' at %C",
3128 gfc_current_block ()->name);
3132 return gfc_match_eos ();
3136 /* Match a SELECT statement. */
3139 gfc_match_select (void)
3144 m = gfc_match_label ();
3145 if (m == MATCH_ERROR)
3148 m = gfc_match (" select case ( %e )%t", &expr);
3152 new_st.op = EXEC_SELECT;
3159 /* Match a CASE statement. */
3162 gfc_match_case (void)
3164 gfc_case *c, *head, *tail;
3169 if (gfc_current_state () != COMP_SELECT)
3171 gfc_error ("Unexpected CASE statement at %C");
3175 if (gfc_match ("% default") == MATCH_YES)
3177 m = match_case_eos ();
3180 if (m == MATCH_ERROR)
3183 new_st.op = EXEC_SELECT;
3184 c = gfc_get_case ();
3185 c->where = gfc_current_locus;
3186 new_st.ext.case_list = c;
3190 if (gfc_match_char ('(') != MATCH_YES)
3195 if (match_case_selector (&c) == MATCH_ERROR)
3205 if (gfc_match_char (')') == MATCH_YES)
3207 if (gfc_match_char (',') != MATCH_YES)
3211 m = match_case_eos ();
3214 if (m == MATCH_ERROR)
3217 new_st.op = EXEC_SELECT;
3218 new_st.ext.case_list = head;
3223 gfc_error ("Syntax error in CASE-specification at %C");
3226 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
3230 /********************* WHERE subroutines ********************/
3232 /* Match the rest of a simple WHERE statement that follows an IF statement.
3236 match_simple_where (void)
3242 m = gfc_match (" ( %e )", &expr);
3246 m = gfc_match_assignment ();
3249 if (m == MATCH_ERROR)
3252 if (gfc_match_eos () != MATCH_YES)
3255 c = gfc_get_code ();
3259 c->next = gfc_get_code ();
3262 gfc_clear_new_st ();
3264 new_st.op = EXEC_WHERE;
3270 gfc_syntax_error (ST_WHERE);
3273 gfc_free_expr (expr);
3278 /* Match a WHERE statement. */
3281 gfc_match_where (gfc_statement *st)
3287 m0 = gfc_match_label ();
3288 if (m0 == MATCH_ERROR)
3291 m = gfc_match (" where ( %e )", &expr);
3295 if (gfc_match_eos () == MATCH_YES)
3297 *st = ST_WHERE_BLOCK;
3298 new_st.op = EXEC_WHERE;
3303 m = gfc_match_assignment ();
3305 gfc_syntax_error (ST_WHERE);
3309 gfc_free_expr (expr);
3313 /* We've got a simple WHERE statement. */
3315 c = gfc_get_code ();
3319 c->next = gfc_get_code ();
3322 gfc_clear_new_st ();
3324 new_st.op = EXEC_WHERE;
3331 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3332 new_st if successful. */
3335 gfc_match_elsewhere (void)
3337 char name[GFC_MAX_SYMBOL_LEN + 1];
3341 if (gfc_current_state () != COMP_WHERE)
3343 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3349 if (gfc_match_char ('(') == MATCH_YES)
3351 m = gfc_match_expr (&expr);
3354 if (m == MATCH_ERROR)
3357 if (gfc_match_char (')') != MATCH_YES)
3361 if (gfc_match_eos () != MATCH_YES)
3363 /* Only makes sense if we have a where-construct-name. */
3364 if (!gfc_current_block ())
3369 /* Better be a name at this point. */
3370 m = gfc_match_name (name);
3373 if (m == MATCH_ERROR)
3376 if (gfc_match_eos () != MATCH_YES)
3379 if (strcmp (name, gfc_current_block ()->name) != 0)
3381 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3382 name, gfc_current_block ()->name);
3387 new_st.op = EXEC_WHERE;
3392 gfc_syntax_error (ST_ELSEWHERE);
3395 gfc_free_expr (expr);
3400 /******************** FORALL subroutines ********************/
3402 /* Free a list of FORALL iterators. */
3405 gfc_free_forall_iterator (gfc_forall_iterator *iter)
3407 gfc_forall_iterator *next;
3412 gfc_free_expr (iter->var);
3413 gfc_free_expr (iter->start);
3414 gfc_free_expr (iter->end);
3415 gfc_free_expr (iter->stride);
3422 /* Match an iterator as part of a FORALL statement. The format is:
3424 <var> = <start>:<end>[:<stride>]
3426 On MATCH_NO, the caller tests for the possibility that there is a
3427 scalar mask expression. */
3430 match_forall_iterator (gfc_forall_iterator **result)
3432 gfc_forall_iterator *iter;
3436 where = gfc_current_locus;
3437 iter = gfc_getmem (sizeof (gfc_forall_iterator));
3439 m = gfc_match_expr (&iter->var);
3443 if (gfc_match_char ('=') != MATCH_YES
3444 || iter->var->expr_type != EXPR_VARIABLE)
3450 m = gfc_match_expr (&iter->start);
3454 if (gfc_match_char (':') != MATCH_YES)
3457 m = gfc_match_expr (&iter->end);
3460 if (m == MATCH_ERROR)
3463 if (gfc_match_char (':') == MATCH_NO)
3464 iter->stride = gfc_int_expr (1);
3467 m = gfc_match_expr (&iter->stride);
3470 if (m == MATCH_ERROR)
3474 /* Mark the iteration variable's symbol as used as a FORALL index. */
3475 iter->var->symtree->n.sym->forall_index = true;
3481 gfc_error ("Syntax error in FORALL iterator at %C");
3486 gfc_current_locus = where;
3487 gfc_free_forall_iterator (iter);
3492 /* Match the header of a FORALL statement. */
3495 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
3497 gfc_forall_iterator *head, *tail, *new;
3501 gfc_gobble_whitespace ();
3506 if (gfc_match_char ('(') != MATCH_YES)
3509 m = match_forall_iterator (&new);
3510 if (m == MATCH_ERROR)
3519 if (gfc_match_char (',') != MATCH_YES)
3522 m = match_forall_iterator (&new);
3523 if (m == MATCH_ERROR)
3533 /* Have to have a mask expression. */
3535 m = gfc_match_expr (&msk);
3538 if (m == MATCH_ERROR)
3544 if (gfc_match_char (')') == MATCH_NO)
3552 gfc_syntax_error (ST_FORALL);
3555 gfc_free_expr (msk);
3556 gfc_free_forall_iterator (head);
3561 /* Match the rest of a simple FORALL statement that follows an
3565 match_simple_forall (void)
3567 gfc_forall_iterator *head;
3576 m = match_forall_header (&head, &mask);
3583 m = gfc_match_assignment ();
3585 if (m == MATCH_ERROR)
3589 m = gfc_match_pointer_assignment ();
3590 if (m == MATCH_ERROR)
3596 c = gfc_get_code ();
3598 c->loc = gfc_current_locus;
3600 if (gfc_match_eos () != MATCH_YES)
3603 gfc_clear_new_st ();
3604 new_st.op = EXEC_FORALL;
3606 new_st.ext.forall_iterator = head;
3607 new_st.block = gfc_get_code ();
3609 new_st.block->op = EXEC_FORALL;
3610 new_st.block->next = c;
3615 gfc_syntax_error (ST_FORALL);
3618 gfc_free_forall_iterator (head);
3619 gfc_free_expr (mask);
3625 /* Match a FORALL statement. */
3628 gfc_match_forall (gfc_statement *st)
3630 gfc_forall_iterator *head;
3639 m0 = gfc_match_label ();
3640 if (m0 == MATCH_ERROR)
3643 m = gfc_match (" forall");
3647 m = match_forall_header (&head, &mask);
3648 if (m == MATCH_ERROR)
3653 if (gfc_match_eos () == MATCH_YES)
3655 *st = ST_FORALL_BLOCK;
3656 new_st.op = EXEC_FORALL;
3658 new_st.ext.forall_iterator = head;
3662 m = gfc_match_assignment ();
3663 if (m == MATCH_ERROR)
3667 m = gfc_match_pointer_assignment ();
3668 if (m == MATCH_ERROR)
3674 c = gfc_get_code ();
3676 c->loc = gfc_current_locus;
3678 gfc_clear_new_st ();
3679 new_st.op = EXEC_FORALL;
3681 new_st.ext.forall_iterator = head;
3682 new_st.block = gfc_get_code ();
3683 new_st.block->op = EXEC_FORALL;
3684 new_st.block->next = c;
3690 gfc_syntax_error (ST_FORALL);
3693 gfc_free_forall_iterator (head);
3694 gfc_free_expr (mask);
3695 gfc_free_statements (c);