1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
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, 59 Temple Place - Suite 330, Boston, MA
35 /* For matching and debugging purposes. Order matters here! The
36 unary operators /must/ precede the binary plus and minus, or
37 the expression parser breaks. */
39 mstring intrinsic_operators[] = {
40 minit ("+", INTRINSIC_UPLUS),
41 minit ("-", INTRINSIC_UMINUS),
42 minit ("+", INTRINSIC_PLUS),
43 minit ("-", INTRINSIC_MINUS),
44 minit ("**", INTRINSIC_POWER),
45 minit ("//", INTRINSIC_CONCAT),
46 minit ("*", INTRINSIC_TIMES),
47 minit ("/", INTRINSIC_DIVIDE),
48 minit (".and.", INTRINSIC_AND),
49 minit (".or.", INTRINSIC_OR),
50 minit (".eqv.", INTRINSIC_EQV),
51 minit (".neqv.", INTRINSIC_NEQV),
52 minit (".eq.", INTRINSIC_EQ),
53 minit ("==", INTRINSIC_EQ),
54 minit (".ne.", INTRINSIC_NE),
55 minit ("/=", INTRINSIC_NE),
56 minit (".ge.", INTRINSIC_GE),
57 minit (">=", INTRINSIC_GE),
58 minit (".le.", INTRINSIC_LE),
59 minit ("<=", INTRINSIC_LE),
60 minit (".lt.", INTRINSIC_LT),
61 minit ("<", INTRINSIC_LT),
62 minit (".gt.", INTRINSIC_GT),
63 minit (">", INTRINSIC_GT),
64 minit (".not.", INTRINSIC_NOT),
65 minit (NULL, INTRINSIC_NONE)
69 /******************** Generic matching subroutines ************************/
71 /* In free form, match at least one space. Always matches in fixed
75 gfc_match_space (void)
80 if (gfc_current_form == FORM_FIXED)
83 old_loc = gfc_current_locus;
86 if (!gfc_is_whitespace (c))
88 gfc_current_locus = old_loc;
92 gfc_gobble_whitespace ();
98 /* Match an end of statement. End of statement is optional
99 whitespace, followed by a ';' or '\n' or comment '!'. If a
100 semicolon is found, we continue to eat whitespace and semicolons. */
112 old_loc = gfc_current_locus;
113 gfc_gobble_whitespace ();
115 c = gfc_next_char ();
121 c = gfc_next_char ();
138 gfc_current_locus = old_loc;
139 return (flag) ? MATCH_YES : MATCH_NO;
143 /* Match a literal integer on the input, setting the value on
144 MATCH_YES. Literal ints occur in kind-parameters as well as
145 old-style character length specifications. */
148 gfc_match_small_literal_int (int *value)
154 old_loc = gfc_current_locus;
156 gfc_gobble_whitespace ();
157 c = gfc_next_char ();
161 gfc_current_locus = old_loc;
169 old_loc = gfc_current_locus;
170 c = gfc_next_char ();
175 i = 10 * i + c - '0';
179 gfc_error ("Integer too large at %C");
184 gfc_current_locus = old_loc;
191 /* Match a small, constant integer expression, like in a kind
192 statement. On MATCH_YES, 'value' is set. */
195 gfc_match_small_int (int *value)
202 m = gfc_match_expr (&expr);
206 p = gfc_extract_int (expr, &i);
207 gfc_free_expr (expr);
220 /* Matches a statement label. Uses gfc_match_small_literal_int() to
221 do most of the work. */
224 gfc_match_st_label (gfc_st_label ** label, int allow_zero)
230 old_loc = gfc_current_locus;
232 m = gfc_match_small_literal_int (&i);
236 if (((i == 0) && allow_zero) || i <= 99999)
238 *label = gfc_get_st_label (i);
242 gfc_error ("Statement label at %C is out of range");
243 gfc_current_locus = old_loc;
248 /* Match and validate a label associated with a named IF, DO or SELECT
249 statement. If the symbol does not have the label attribute, we add
250 it. We also make sure the symbol does not refer to another
251 (active) block. A matched label is pointed to by gfc_new_block. */
254 gfc_match_label (void)
256 char name[GFC_MAX_SYMBOL_LEN + 1];
260 gfc_new_block = NULL;
262 m = gfc_match (" %n :", name);
266 if (gfc_get_symbol (name, NULL, &gfc_new_block))
268 gfc_error ("Label name '%s' at %C is ambiguous", name);
272 if (gfc_new_block->attr.flavor != FL_LABEL
273 && gfc_add_flavor (&gfc_new_block->attr, FL_LABEL, NULL) == FAILURE)
276 for (p = gfc_state_stack; p; p = p->previous)
277 if (p->sym == gfc_new_block)
279 gfc_error ("Label %s at %C already in use by a parent block",
280 gfc_new_block->name);
288 /* Try and match the input against an array of possibilities. If one
289 potential matching string is a substring of another, the longest
290 match takes precedence. Spaces in the target strings are optional
291 spaces that do not necessarily have to be found in the input
292 stream. In fixed mode, spaces never appear. If whitespace is
293 matched, it matches unlimited whitespace in the input. For this
294 reason, the 'mp' member of the mstring structure is used to track
295 the progress of each potential match.
297 If there is no match we return the tag associated with the
298 terminating NULL mstring structure and leave the locus pointer
299 where it started. If there is a match we return the tag member of
300 the matched mstring and leave the locus pointer after the matched
303 A '%' character is a mandatory space. */
306 gfc_match_strings (mstring * a)
308 mstring *p, *best_match;
309 int no_match, c, possibles;
314 for (p = a; p->string != NULL; p++)
323 match_loc = gfc_current_locus;
325 gfc_gobble_whitespace ();
327 while (possibles > 0)
329 c = gfc_next_char ();
331 /* Apply the next character to the current possibilities. */
332 for (p = a; p->string != NULL; p++)
339 /* Space matches 1+ whitespace(s). */
340 if ((gfc_current_form == FORM_FREE)
341 && gfc_is_whitespace (c))
359 match_loc = gfc_current_locus;
367 gfc_current_locus = match_loc;
369 return (best_match == NULL) ? no_match : best_match->tag;
373 /* See if the current input looks like a name of some sort. Modifies
374 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long. */
377 gfc_match_name (char *buffer)
382 old_loc = gfc_current_locus;
383 gfc_gobble_whitespace ();
385 c = gfc_next_char ();
388 gfc_current_locus = old_loc;
398 if (i > gfc_option.max_identifier_length)
400 gfc_error ("Name at %C is too long");
404 old_loc = gfc_current_locus;
405 c = gfc_next_char ();
409 || (gfc_option.flag_dollar_ok && c == '$'));
412 gfc_current_locus = old_loc;
418 /* Match a symbol on the input. Modifies the pointer to the symbol
419 pointer if successful. */
422 gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc)
424 char buffer[GFC_MAX_SYMBOL_LEN + 1];
427 m = gfc_match_name (buffer);
432 return (gfc_get_ha_sym_tree (buffer, matched_symbol))
433 ? MATCH_ERROR : MATCH_YES;
435 if (gfc_get_sym_tree (buffer, NULL, matched_symbol))
443 gfc_match_symbol (gfc_symbol ** matched_symbol, int host_assoc)
448 m = gfc_match_sym_tree (&st, host_assoc);
453 *matched_symbol = st->n.sym;
455 *matched_symbol = NULL;
460 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
461 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
465 gfc_match_intrinsic_op (gfc_intrinsic_op * result)
469 op = (gfc_intrinsic_op) gfc_match_strings (intrinsic_operators);
471 if (op == INTRINSIC_NONE)
479 /* Match a loop control phrase:
481 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
483 If the final integer expression is not present, a constant unity
484 expression is returned. We don't return MATCH_ERROR until after
485 the equals sign is seen. */
488 gfc_match_iterator (gfc_iterator * iter, int init_flag)
490 char name[GFC_MAX_SYMBOL_LEN + 1];
491 gfc_expr *var, *e1, *e2, *e3;
495 /* Match the start of an iterator without affecting the symbol
498 start = gfc_current_locus;
499 m = gfc_match (" %n =", name);
500 gfc_current_locus = start;
505 m = gfc_match_variable (&var, 0);
509 gfc_match_char ('=');
513 if (var->ref != NULL)
515 gfc_error ("Loop variable at %C cannot be a sub-component");
519 if (var->symtree->n.sym->attr.intent == INTENT_IN)
521 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
522 var->symtree->n.sym->name);
526 if (var->symtree->n.sym->attr.pointer)
528 gfc_error ("Loop variable at %C cannot have the POINTER attribute");
532 m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
535 if (m == MATCH_ERROR)
538 if (gfc_match_char (',') != MATCH_YES)
541 m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
544 if (m == MATCH_ERROR)
547 if (gfc_match_char (',') != MATCH_YES)
549 e3 = gfc_int_expr (1);
553 m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
554 if (m == MATCH_ERROR)
558 gfc_error ("Expected a step value in iterator at %C");
570 gfc_error ("Syntax error in iterator at %C");
581 /* Tries to match the next non-whitespace character on the input.
582 This subroutine does not return MATCH_ERROR. */
585 gfc_match_char (char c)
589 where = gfc_current_locus;
590 gfc_gobble_whitespace ();
592 if (gfc_next_char () == c)
595 gfc_current_locus = where;
600 /* General purpose matching subroutine. The target string is a
601 scanf-like format string in which spaces correspond to arbitrary
602 whitespace (including no whitespace), characters correspond to
603 themselves. The %-codes are:
605 %% Literal percent sign
606 %e Expression, pointer to a pointer is set
607 %s Symbol, pointer to the symbol is set
608 %n Name, character buffer is set to name
609 %t Matches end of statement.
610 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
611 %l Matches a statement label
612 %v Matches a variable expression (an lvalue)
613 % Matches a required space (in free form) and optional spaces. */
616 gfc_match (const char *target, ...)
618 gfc_st_label **label;
627 old_loc = gfc_current_locus;
628 va_start (argp, target);
638 gfc_gobble_whitespace ();
649 vp = va_arg (argp, void **);
650 n = gfc_match_expr ((gfc_expr **) vp);
661 vp = va_arg (argp, void **);
662 n = gfc_match_variable ((gfc_expr **) vp, 0);
673 vp = va_arg (argp, void **);
674 n = gfc_match_symbol ((gfc_symbol **) vp, 0);
685 np = va_arg (argp, char *);
686 n = gfc_match_name (np);
697 label = va_arg (argp, gfc_st_label **);
698 n = gfc_match_st_label (label, 0);
709 ip = va_arg (argp, int *);
710 n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
721 if (gfc_match_eos () != MATCH_YES)
729 if (gfc_match_space () == MATCH_YES)
735 break; /* Fall through to character matcher */
738 gfc_internal_error ("gfc_match(): Bad match code %c", c);
742 if (c == gfc_next_char ())
752 /* Clean up after a failed match. */
753 gfc_current_locus = old_loc;
754 va_start (argp, target);
757 for (; matches > 0; matches--)
767 /* Matches that don't have to be undone */
772 (void)va_arg (argp, void **);
777 vp = va_arg (argp, void **);
791 /*********************** Statement level matching **********************/
793 /* Matches the start of a program unit, which is the program keyword
794 followed by an obligatory symbol. */
797 gfc_match_program (void)
802 m = gfc_match ("% %s%t", &sym);
806 gfc_error ("Invalid form of PROGRAM statement at %C");
810 if (m == MATCH_ERROR)
813 if (gfc_add_flavor (&sym->attr, FL_PROGRAM, NULL) == FAILURE)
822 /* Match a simple assignment statement. */
825 gfc_match_assignment (void)
827 gfc_expr *lvalue, *rvalue;
831 old_loc = gfc_current_locus;
833 lvalue = rvalue = NULL;
834 m = gfc_match (" %v =", &lvalue);
838 m = gfc_match (" %e%t", &rvalue);
842 gfc_set_sym_referenced (lvalue->symtree->n.sym);
844 new_st.op = EXEC_ASSIGN;
845 new_st.expr = lvalue;
846 new_st.expr2 = rvalue;
851 gfc_current_locus = old_loc;
852 gfc_free_expr (lvalue);
853 gfc_free_expr (rvalue);
858 /* Match a pointer assignment statement. */
861 gfc_match_pointer_assignment (void)
863 gfc_expr *lvalue, *rvalue;
867 old_loc = gfc_current_locus;
869 lvalue = rvalue = NULL;
871 m = gfc_match (" %v =>", &lvalue);
878 m = gfc_match (" %e%t", &rvalue);
882 new_st.op = EXEC_POINTER_ASSIGN;
883 new_st.expr = lvalue;
884 new_st.expr2 = rvalue;
889 gfc_current_locus = old_loc;
890 gfc_free_expr (lvalue);
891 gfc_free_expr (rvalue);
896 /* The IF statement is a bit of a pain. First of all, there are three
897 forms of it, the simple IF, the IF that starts a block and the
900 There is a problem with the simple IF and that is the fact that we
901 only have a single level of undo information on symbols. What this
902 means is for a simple IF, we must re-match the whole IF statement
903 multiple times in order to guarantee that the symbol table ends up
904 in the proper state. */
907 gfc_match_if (gfc_statement * if_type)
910 gfc_st_label *l1, *l2, *l3;
915 n = gfc_match_label ();
916 if (n == MATCH_ERROR)
919 old_loc = gfc_current_locus;
921 m = gfc_match (" if ( %e", &expr);
925 if (gfc_match_char (')') != MATCH_YES)
927 gfc_error ("Syntax error in IF-expression at %C");
928 gfc_free_expr (expr);
932 m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
939 ("Block label not appropriate for arithmetic IF statement "
942 gfc_free_expr (expr);
946 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
947 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
948 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
951 gfc_free_expr (expr);
955 new_st.op = EXEC_ARITHMETIC_IF;
961 *if_type = ST_ARITHMETIC_IF;
965 if (gfc_match (" then %t") == MATCH_YES)
970 *if_type = ST_IF_BLOCK;
976 gfc_error ("Block label is not appropriate IF statement at %C");
978 gfc_free_expr (expr);
982 /* At this point the only thing left is a simple IF statement. At
983 this point, n has to be MATCH_NO, so we don't have to worry about
984 re-matching a block label. From what we've got so far, try
985 matching an assignment. */
987 *if_type = ST_SIMPLE_IF;
989 m = gfc_match_assignment ();
993 gfc_free_expr (expr);
995 gfc_current_locus = old_loc;
997 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */
999 m = gfc_match_pointer_assignment ();
1003 gfc_free_expr (expr);
1004 gfc_undo_symbols ();
1005 gfc_current_locus = old_loc;
1007 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */
1009 /* Look at the next keyword to see which matcher to call. Matching
1010 the keyword doesn't affect the symbol table, so we don't have to
1011 restore between tries. */
1013 #define match(string, subr, statement) \
1014 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1018 match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1019 match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1020 match ("call", gfc_match_call, ST_CALL)
1021 match ("close", gfc_match_close, ST_CLOSE)
1022 match ("continue", gfc_match_continue, ST_CONTINUE)
1023 match ("cycle", gfc_match_cycle, ST_CYCLE)
1024 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1025 match ("end file", gfc_match_endfile, ST_END_FILE)
1026 match ("exit", gfc_match_exit, ST_EXIT)
1027 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1028 match ("go to", gfc_match_goto, ST_GOTO)
1029 match ("inquire", gfc_match_inquire, ST_INQUIRE)
1030 match ("nullify", gfc_match_nullify, ST_NULLIFY)
1031 match ("open", gfc_match_open, ST_OPEN)
1032 match ("pause", gfc_match_pause, ST_NONE)
1033 match ("print", gfc_match_print, ST_WRITE)
1034 match ("read", gfc_match_read, ST_READ)
1035 match ("return", gfc_match_return, ST_RETURN)
1036 match ("rewind", gfc_match_rewind, ST_REWIND)
1037 match ("pause", gfc_match_stop, ST_PAUSE)
1038 match ("stop", gfc_match_stop, ST_STOP)
1039 match ("write", gfc_match_write, ST_WRITE)
1041 /* All else has failed, so give up. See if any of the matchers has
1042 stored an error message of some sort. */
1043 if (gfc_error_check () == 0)
1044 gfc_error ("Unclassifiable statement in IF-clause at %C");
1046 gfc_free_expr (expr);
1051 gfc_error ("Syntax error in IF-clause at %C");
1054 gfc_free_expr (expr);
1058 /* At this point, we've matched the single IF and the action clause
1059 is in new_st. Rearrange things so that the IF statement appears
1062 p = gfc_get_code ();
1063 p->next = gfc_get_code ();
1065 p->next->loc = gfc_current_locus;
1070 gfc_clear_new_st ();
1072 new_st.op = EXEC_IF;
1081 /* Match an ELSE statement. */
1084 gfc_match_else (void)
1086 char name[GFC_MAX_SYMBOL_LEN + 1];
1088 if (gfc_match_eos () == MATCH_YES)
1091 if (gfc_match_name (name) != MATCH_YES
1092 || gfc_current_block () == NULL
1093 || gfc_match_eos () != MATCH_YES)
1095 gfc_error ("Unexpected junk after ELSE statement at %C");
1099 if (strcmp (name, gfc_current_block ()->name) != 0)
1101 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1102 name, gfc_current_block ()->name);
1110 /* Match an ELSE IF statement. */
1113 gfc_match_elseif (void)
1115 char name[GFC_MAX_SYMBOL_LEN + 1];
1119 m = gfc_match (" ( %e ) then", &expr);
1123 if (gfc_match_eos () == MATCH_YES)
1126 if (gfc_match_name (name) != MATCH_YES
1127 || gfc_current_block () == NULL
1128 || gfc_match_eos () != MATCH_YES)
1130 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1134 if (strcmp (name, gfc_current_block ()->name) != 0)
1136 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1137 name, gfc_current_block ()->name);
1142 new_st.op = EXEC_IF;
1147 gfc_free_expr (expr);
1152 /* Free a gfc_iterator structure. */
1155 gfc_free_iterator (gfc_iterator * iter, int flag)
1161 gfc_free_expr (iter->var);
1162 gfc_free_expr (iter->start);
1163 gfc_free_expr (iter->end);
1164 gfc_free_expr (iter->step);
1171 /* Match a DO statement. */
1176 gfc_iterator iter, *ip;
1178 gfc_st_label *label;
1181 old_loc = gfc_current_locus;
1184 iter.var = iter.start = iter.end = iter.step = NULL;
1186 m = gfc_match_label ();
1187 if (m == MATCH_ERROR)
1190 if (gfc_match (" do") != MATCH_YES)
1193 m = gfc_match_st_label (&label, 0);
1194 if (m == MATCH_ERROR)
1197 /* Match an infinite DO, make it like a DO WHILE(.TRUE.) */
1199 if (gfc_match_eos () == MATCH_YES)
1201 iter.end = gfc_logical_expr (1, NULL);
1202 new_st.op = EXEC_DO_WHILE;
1206 /* match an optional comma, if no comma is found a space is obligatory. */
1207 if (gfc_match_char(',') != MATCH_YES
1208 && gfc_match ("% ") != MATCH_YES)
1211 /* See if we have a DO WHILE. */
1212 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1214 new_st.op = EXEC_DO_WHILE;
1218 /* The abortive DO WHILE may have done something to the symbol
1219 table, so we start over: */
1220 gfc_undo_symbols ();
1221 gfc_current_locus = old_loc;
1223 gfc_match_label (); /* This won't error */
1224 gfc_match (" do "); /* This will work */
1226 gfc_match_st_label (&label, 0); /* Can't error out */
1227 gfc_match_char (','); /* Optional comma */
1229 m = gfc_match_iterator (&iter, 0);
1232 if (m == MATCH_ERROR)
1235 if (gfc_match_eos () != MATCH_YES)
1237 gfc_syntax_error (ST_DO);
1241 new_st.op = EXEC_DO;
1245 && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1248 new_st.label = label;
1250 if (new_st.op == EXEC_DO_WHILE)
1251 new_st.expr = iter.end;
1254 new_st.ext.iterator = ip = gfc_get_iterator ();
1261 gfc_free_iterator (&iter, 0);
1267 /* Match an EXIT or CYCLE statement. */
1270 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1276 if (gfc_match_eos () == MATCH_YES)
1280 m = gfc_match ("% %s%t", &sym);
1281 if (m == MATCH_ERROR)
1285 gfc_syntax_error (st);
1289 if (sym->attr.flavor != FL_LABEL)
1291 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1292 sym->name, gfc_ascii_statement (st));
1297 /* Find the loop mentioned specified by the label (or lack of a
1299 for (p = gfc_state_stack; p; p = p->previous)
1300 if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1306 gfc_error ("%s statement at %C is not within a loop",
1307 gfc_ascii_statement (st));
1309 gfc_error ("%s statement at %C is not within loop '%s'",
1310 gfc_ascii_statement (st), sym->name);
1315 /* Save the first statement in the loop - needed by the backend. */
1316 new_st.ext.whichloop = p->head;
1319 /* new_st.sym = sym;*/
1325 /* Match the EXIT statement. */
1328 gfc_match_exit (void)
1331 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1335 /* Match the CYCLE statement. */
1338 gfc_match_cycle (void)
1341 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1345 /* Match a number or character constant after a STOP or PAUSE statement. */
1348 gfc_match_stopcode (gfc_statement st)
1357 if (gfc_match_eos () != MATCH_YES)
1359 m = gfc_match_small_literal_int (&stop_code);
1360 if (m == MATCH_ERROR)
1363 if (m == MATCH_YES && stop_code > 99999)
1365 gfc_error ("STOP code out of range at %C");
1371 /* Try a character constant. */
1372 m = gfc_match_expr (&e);
1373 if (m == MATCH_ERROR)
1377 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1381 if (gfc_match_eos () != MATCH_YES)
1385 if (gfc_pure (NULL))
1387 gfc_error ("%s statement not allowed in PURE procedure at %C",
1388 gfc_ascii_statement (st));
1392 new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1394 new_st.ext.stop_code = stop_code;
1399 gfc_syntax_error (st);
1407 /* Match the (deprecated) PAUSE statement. */
1410 gfc_match_pause (void)
1414 m = gfc_match_stopcode (ST_PAUSE);
1417 if (gfc_notify_std (GFC_STD_F95_DEL,
1418 "Obsolete: PAUSE statement at %C")
1426 /* Match the STOP statement. */
1429 gfc_match_stop (void)
1431 return gfc_match_stopcode (ST_STOP);
1435 /* Match a CONTINUE statement. */
1438 gfc_match_continue (void)
1441 if (gfc_match_eos () != MATCH_YES)
1443 gfc_syntax_error (ST_CONTINUE);
1447 new_st.op = EXEC_CONTINUE;
1452 /* Match the (deprecated) ASSIGN statement. */
1455 gfc_match_assign (void)
1458 gfc_st_label *label;
1460 if (gfc_match (" %l", &label) == MATCH_YES)
1462 if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
1464 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
1466 if (gfc_notify_std (GFC_STD_F95_DEL,
1467 "Obsolete: ASSIGN statement at %C")
1471 expr->symtree->n.sym->attr.assign = 1;
1473 new_st.op = EXEC_LABEL_ASSIGN;
1474 new_st.label = label;
1483 /* Match the GO TO statement. As a computed GOTO statement is
1484 matched, it is transformed into an equivalent SELECT block. No
1485 tree is necessary, and the resulting jumps-to-jumps are
1486 specifically optimized away by the back end. */
1489 gfc_match_goto (void)
1491 gfc_code *head, *tail;
1494 gfc_st_label *label;
1498 if (gfc_match (" %l%t", &label) == MATCH_YES)
1500 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1503 new_st.op = EXEC_GOTO;
1504 new_st.label = label;
1508 /* The assigned GO TO statement. */
1510 if (gfc_match_variable (&expr, 0) == MATCH_YES)
1512 if (gfc_notify_std (GFC_STD_F95_DEL,
1513 "Obsolete: Assigned GOTO statement at %C")
1517 expr->symtree->n.sym->attr.assign = 1;
1518 new_st.op = EXEC_GOTO;
1521 if (gfc_match_eos () == MATCH_YES)
1524 /* Match label list. */
1525 gfc_match_char (',');
1526 if (gfc_match_char ('(') != MATCH_YES)
1528 gfc_syntax_error (ST_GOTO);
1535 m = gfc_match_st_label (&label, 0);
1539 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1543 head = tail = gfc_get_code ();
1546 tail->block = gfc_get_code ();
1550 tail->label = label;
1551 tail->op = EXEC_GOTO;
1553 while (gfc_match_char (',') == MATCH_YES);
1555 if (gfc_match (")%t") != MATCH_YES)
1561 "Statement label list in GOTO at %C cannot be empty");
1564 new_st.block = head;
1569 /* Last chance is a computed GO TO statement. */
1570 if (gfc_match_char ('(') != MATCH_YES)
1572 gfc_syntax_error (ST_GOTO);
1581 m = gfc_match_st_label (&label, 0);
1585 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1589 head = tail = gfc_get_code ();
1592 tail->block = gfc_get_code ();
1596 cp = gfc_get_case ();
1597 cp->low = cp->high = gfc_int_expr (i++);
1599 tail->op = EXEC_SELECT;
1600 tail->ext.case_list = cp;
1602 tail->next = gfc_get_code ();
1603 tail->next->op = EXEC_GOTO;
1604 tail->next->label = label;
1606 while (gfc_match_char (',') == MATCH_YES);
1608 if (gfc_match_char (')') != MATCH_YES)
1613 gfc_error ("Statement label list in GOTO at %C cannot be empty");
1617 /* Get the rest of the statement. */
1618 gfc_match_char (',');
1620 if (gfc_match (" %e%t", &expr) != MATCH_YES)
1623 /* At this point, a computed GOTO has been fully matched and an
1624 equivalent SELECT statement constructed. */
1626 new_st.op = EXEC_SELECT;
1629 /* Hack: For a "real" SELECT, the expression is in expr. We put
1630 it in expr2 so we can distinguish then and produce the correct
1632 new_st.expr2 = expr;
1633 new_st.block = head;
1637 gfc_syntax_error (ST_GOTO);
1639 gfc_free_statements (head);
1644 /* Frees a list of gfc_alloc structures. */
1647 gfc_free_alloc_list (gfc_alloc * p)
1654 gfc_free_expr (p->expr);
1660 /* Match an ALLOCATE statement. */
1663 gfc_match_allocate (void)
1665 gfc_alloc *head, *tail;
1672 if (gfc_match_char ('(') != MATCH_YES)
1678 head = tail = gfc_get_alloc ();
1681 tail->next = gfc_get_alloc ();
1685 m = gfc_match_variable (&tail->expr, 0);
1688 if (m == MATCH_ERROR)
1692 && gfc_impure_variable (tail->expr->symtree->n.sym))
1694 gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1699 if (gfc_match_char (',') != MATCH_YES)
1702 m = gfc_match (" stat = %v", &stat);
1703 if (m == MATCH_ERROR)
1711 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1714 ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
1715 "INTENT(IN)", stat->symtree->n.sym->name);
1719 if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
1722 ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
1728 if (gfc_match (" )%t") != MATCH_YES)
1731 new_st.op = EXEC_ALLOCATE;
1733 new_st.ext.alloc_list = head;
1738 gfc_syntax_error (ST_ALLOCATE);
1741 gfc_free_expr (stat);
1742 gfc_free_alloc_list (head);
1747 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1748 a set of pointer assignments to intrinsic NULL(). */
1751 gfc_match_nullify (void)
1759 if (gfc_match_char ('(') != MATCH_YES)
1764 m = gfc_match_variable (&p, 0);
1765 if (m == MATCH_ERROR)
1770 if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
1773 ("Illegal variable in NULLIFY at %C for a PURE procedure");
1777 /* build ' => NULL() ' */
1778 e = gfc_get_expr ();
1779 e->where = gfc_current_locus;
1780 e->expr_type = EXPR_NULL;
1781 e->ts.type = BT_UNKNOWN;
1788 tail->next = gfc_get_code ();
1792 tail->op = EXEC_POINTER_ASSIGN;
1796 if (gfc_match_char (')') == MATCH_YES)
1798 if (gfc_match_char (',') != MATCH_YES)
1805 gfc_syntax_error (ST_NULLIFY);
1808 gfc_free_statements (tail);
1813 /* Match a DEALLOCATE statement. */
1816 gfc_match_deallocate (void)
1818 gfc_alloc *head, *tail;
1825 if (gfc_match_char ('(') != MATCH_YES)
1831 head = tail = gfc_get_alloc ();
1834 tail->next = gfc_get_alloc ();
1838 m = gfc_match_variable (&tail->expr, 0);
1839 if (m == MATCH_ERROR)
1845 && gfc_impure_variable (tail->expr->symtree->n.sym))
1848 ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
1853 if (gfc_match_char (',') != MATCH_YES)
1856 m = gfc_match (" stat = %v", &stat);
1857 if (m == MATCH_ERROR)
1863 if (stat != NULL && stat->symtree->n.sym->attr.intent == INTENT_IN)
1865 gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C cannot be "
1866 "INTENT(IN)", stat->symtree->n.sym->name);
1870 if (gfc_match (" )%t") != MATCH_YES)
1873 new_st.op = EXEC_DEALLOCATE;
1875 new_st.ext.alloc_list = head;
1880 gfc_syntax_error (ST_DEALLOCATE);
1883 gfc_free_expr (stat);
1884 gfc_free_alloc_list (head);
1889 /* Match a RETURN statement. */
1892 gfc_match_return (void)
1896 gfc_compile_state s;
1898 gfc_enclosing_unit (&s);
1899 if (s == COMP_PROGRAM
1900 && gfc_notify_std (GFC_STD_GNU, "RETURN statement in a main "
1901 "program at %C is an extension.") == FAILURE)
1905 if (gfc_match_eos () == MATCH_YES)
1908 if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
1910 gfc_error ("Alternate RETURN statement at %C is only allowed within "
1915 m = gfc_match ("% %e%t", &e);
1918 if (m == MATCH_ERROR)
1921 gfc_syntax_error (ST_RETURN);
1928 new_st.op = EXEC_RETURN;
1935 /* Match a CALL statement. The tricky part here are possible
1936 alternate return specifiers. We handle these by having all
1937 "subroutines" actually return an integer via a register that gives
1938 the return number. If the call specifies alternate returns, we
1939 generate code for a SELECT statement whose case clauses contain
1940 GOTOs to the various labels. */
1943 gfc_match_call (void)
1945 char name[GFC_MAX_SYMBOL_LEN + 1];
1946 gfc_actual_arglist *a, *arglist;
1956 m = gfc_match ("% %n", name);
1962 if (gfc_get_ha_sym_tree (name, &st))
1966 gfc_set_sym_referenced (sym);
1968 if (!sym->attr.generic
1969 && !sym->attr.subroutine
1970 && gfc_add_subroutine (&sym->attr, NULL) == FAILURE)
1973 if (gfc_match_eos () != MATCH_YES)
1975 m = gfc_match_actual_arglist (1, &arglist);
1978 if (m == MATCH_ERROR)
1981 if (gfc_match_eos () != MATCH_YES)
1985 /* If any alternate return labels were found, construct a SELECT
1986 statement that will jump to the right place. */
1989 for (a = arglist; a; a = a->next)
1990 if (a->expr == NULL)
1995 gfc_symtree *select_st;
1996 gfc_symbol *select_sym;
1997 char name[GFC_MAX_SYMBOL_LEN + 1];
1999 new_st.next = c = gfc_get_code ();
2000 c->op = EXEC_SELECT;
2001 sprintf (name, "_result_%s",sym->name);
2002 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail */
2004 select_sym = select_st->n.sym;
2005 select_sym->ts.type = BT_INTEGER;
2006 select_sym->ts.kind = gfc_default_integer_kind ();
2007 gfc_set_sym_referenced (select_sym);
2008 c->expr = gfc_get_expr ();
2009 c->expr->expr_type = EXPR_VARIABLE;
2010 c->expr->symtree = select_st;
2011 c->expr->ts = select_sym->ts;
2012 c->expr->where = gfc_current_locus;
2015 for (a = arglist; a; a = a->next)
2017 if (a->expr != NULL)
2020 if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2025 c->block = gfc_get_code ();
2027 c->op = EXEC_SELECT;
2029 new_case = gfc_get_case ();
2030 new_case->high = new_case->low = gfc_int_expr (i);
2031 c->ext.case_list = new_case;
2033 c->next = gfc_get_code ();
2034 c->next->op = EXEC_GOTO;
2035 c->next->label = a->label;
2039 new_st.op = EXEC_CALL;
2040 new_st.symtree = st;
2041 new_st.ext.actual = arglist;
2046 gfc_syntax_error (ST_CALL);
2049 gfc_free_actual_arglist (arglist);
2054 /* Given a name, return a pointer to the common head structure,
2055 creating it if it does not exist. If FROM_MODULE is non-zero, we
2056 mangle the name so that it doesn't interfere with commons defined
2057 in the using namespace.
2058 TODO: Add to global symbol tree. */
2061 gfc_get_common (const char *name, int from_module)
2064 static int serial = 0;
2065 char mangled_name[GFC_MAX_SYMBOL_LEN+1];
2069 /* A use associated common block is only needed to correctly layout
2070 the variables it contains. */
2071 snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2072 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2076 st = gfc_find_symtree (gfc_current_ns->common_root, name);
2079 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2082 if (st->n.common == NULL)
2084 st->n.common = gfc_get_common_head ();
2085 st->n.common->where = gfc_current_locus;
2086 strcpy (st->n.common->name, name);
2089 return st->n.common;
2093 /* Match a common block name. */
2096 match_common_name (char *name)
2100 if (gfc_match_char ('/') == MATCH_NO)
2106 if (gfc_match_char ('/') == MATCH_YES)
2112 m = gfc_match_name (name);
2114 if (m == MATCH_ERROR)
2116 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2119 gfc_error ("Syntax error in common block name at %C");
2124 /* Match a COMMON statement. */
2127 gfc_match_common (void)
2129 gfc_symbol *sym, **head, *tail, *old_blank_common;
2130 char name[GFC_MAX_SYMBOL_LEN+1];
2135 old_blank_common = gfc_current_ns->blank_common.head;
2136 if (old_blank_common)
2138 while (old_blank_common->common_next)
2139 old_blank_common = old_blank_common->common_next;
2144 if (gfc_match_eos () == MATCH_YES)
2149 m = match_common_name (name);
2150 if (m == MATCH_ERROR)
2153 if (name[0] == '\0')
2155 t = &gfc_current_ns->blank_common;
2156 if (t->head == NULL)
2157 t->where = gfc_current_locus;
2162 t = gfc_get_common (name, 0);
2171 while (tail->common_next)
2172 tail = tail->common_next;
2175 /* Grab the list of symbols. */
2176 if (gfc_match_eos () == MATCH_YES)
2181 m = gfc_match_symbol (&sym, 0);
2182 if (m == MATCH_ERROR)
2187 if (sym->attr.in_common)
2189 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2194 if (gfc_add_in_common (&sym->attr, NULL) == FAILURE)
2197 if (sym->value != NULL
2198 && (name[0] == '\0' || !sym->attr.data))
2200 if (name[0] == '\0')
2201 gfc_error ("Previously initialized symbol '%s' in "
2202 "blank COMMON block at %C", sym->name);
2204 gfc_error ("Previously initialized symbol '%s' in "
2205 "COMMON block '%s' at %C", sym->name, name);
2209 if (gfc_add_in_common (&sym->attr, NULL) == FAILURE)
2212 /* Derived type names must have the SEQUENCE attribute. */
2213 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2216 ("Derived type variable in COMMON at %C does not have the "
2217 "SEQUENCE attribute");
2222 tail->common_next = sym;
2228 /* Deal with an optional array specification after the
2230 m = gfc_match_array_spec (&as);
2231 if (m == MATCH_ERROR)
2236 if (as->type != AS_EXPLICIT)
2239 ("Array specification for symbol '%s' in COMMON at %C "
2240 "must be explicit", sym->name);
2244 if (gfc_add_dimension (&sym->attr, NULL) == FAILURE)
2247 if (sym->attr.pointer)
2250 ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2259 if (gfc_match_eos () == MATCH_YES)
2261 if (gfc_peek_char () == '/')
2263 if (gfc_match_char (',') != MATCH_YES)
2265 if (gfc_peek_char () == '/')
2274 gfc_syntax_error (ST_COMMON);
2277 if (old_blank_common)
2278 old_blank_common->common_next = NULL;
2280 gfc_current_ns->blank_common.head = NULL;
2281 gfc_free_array_spec (as);
2286 /* Match a BLOCK DATA program unit. */
2289 gfc_match_block_data (void)
2291 char name[GFC_MAX_SYMBOL_LEN + 1];
2295 if (gfc_match_eos () == MATCH_YES)
2297 gfc_new_block = NULL;
2301 m = gfc_match ("% %n%t", name);
2305 if (gfc_get_symbol (name, NULL, &sym))
2308 if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, NULL) == FAILURE)
2311 gfc_new_block = sym;
2317 /* Free a namelist structure. */
2320 gfc_free_namelist (gfc_namelist * name)
2324 for (; name; name = n)
2332 /* Match a NAMELIST statement. */
2335 gfc_match_namelist (void)
2337 gfc_symbol *group_name, *sym;
2341 m = gfc_match (" / %s /", &group_name);
2344 if (m == MATCH_ERROR)
2349 if (group_name->ts.type != BT_UNKNOWN)
2352 ("Namelist group name '%s' at %C already has a basic type "
2353 "of %s", group_name->name, gfc_typename (&group_name->ts));
2357 if (group_name->attr.flavor != FL_NAMELIST
2358 && gfc_add_flavor (&group_name->attr, FL_NAMELIST, NULL) == FAILURE)
2363 m = gfc_match_symbol (&sym, 1);
2366 if (m == MATCH_ERROR)
2369 if (sym->attr.in_namelist == 0
2370 && gfc_add_in_namelist (&sym->attr, NULL) == FAILURE)
2373 /* TODO: worry about PRIVATE members of a PUBLIC namelist
2376 nl = gfc_get_namelist ();
2379 if (group_name->namelist == NULL)
2380 group_name->namelist = group_name->namelist_tail = nl;
2383 group_name->namelist_tail->next = nl;
2384 group_name->namelist_tail = nl;
2387 if (gfc_match_eos () == MATCH_YES)
2390 m = gfc_match_char (',');
2392 if (gfc_match_char ('/') == MATCH_YES)
2394 m2 = gfc_match (" %s /", &group_name);
2395 if (m2 == MATCH_YES)
2397 if (m2 == MATCH_ERROR)
2411 gfc_syntax_error (ST_NAMELIST);
2418 /* Match a MODULE statement. */
2421 gfc_match_module (void)
2425 m = gfc_match (" %s%t", &gfc_new_block);
2429 if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, NULL) == FAILURE)
2436 /* Free equivalence sets and lists. Recursively is the easiest way to
2440 gfc_free_equiv (gfc_equiv * eq)
2446 gfc_free_equiv (eq->eq);
2447 gfc_free_equiv (eq->next);
2449 gfc_free_expr (eq->expr);
2454 /* Match an EQUIVALENCE statement. */
2457 gfc_match_equivalence (void)
2459 gfc_equiv *eq, *set, *tail;
2467 eq = gfc_get_equiv ();
2471 eq->next = gfc_current_ns->equiv;
2472 gfc_current_ns->equiv = eq;
2474 if (gfc_match_char ('(') != MATCH_YES)
2481 m = gfc_match_variable (&set->expr, 1);
2482 if (m == MATCH_ERROR)
2487 for (ref = set->expr->ref; ref; ref = ref->next)
2488 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2491 ("Array reference in EQUIVALENCE at %C cannot be an "
2496 if (gfc_match_char (')') == MATCH_YES)
2498 if (gfc_match_char (',') != MATCH_YES)
2501 set->eq = gfc_get_equiv ();
2505 if (gfc_match_eos () == MATCH_YES)
2507 if (gfc_match_char (',') != MATCH_YES)
2514 gfc_syntax_error (ST_EQUIVALENCE);
2520 gfc_free_equiv (gfc_current_ns->equiv);
2521 gfc_current_ns->equiv = eq;
2527 /* Match a statement function declaration. It is so easy to match
2528 non-statement function statements with a MATCH_ERROR as opposed to
2529 MATCH_NO that we suppress error message in most cases. */
2532 gfc_match_st_function (void)
2534 gfc_error_buf old_error;
2539 m = gfc_match_symbol (&sym, 0);
2543 gfc_push_error (&old_error);
2545 if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, NULL) == FAILURE)
2548 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2551 m = gfc_match (" = %e%t", &expr);
2554 if (m == MATCH_ERROR)
2562 gfc_pop_error (&old_error);
2567 /********************* DATA statement subroutines *********************/
2569 /* Free a gfc_data_variable structure and everything beneath it. */
2572 free_variable (gfc_data_variable * p)
2574 gfc_data_variable *q;
2579 gfc_free_expr (p->expr);
2580 gfc_free_iterator (&p->iter, 0);
2581 free_variable (p->list);
2588 /* Free a gfc_data_value structure and everything beneath it. */
2591 free_value (gfc_data_value * p)
2598 gfc_free_expr (p->expr);
2604 /* Free a list of gfc_data structures. */
2607 gfc_free_data (gfc_data * p)
2615 free_variable (p->var);
2616 free_value (p->value);
2623 static match var_element (gfc_data_variable *);
2625 /* Match a list of variables terminated by an iterator and a right
2629 var_list (gfc_data_variable * parent)
2631 gfc_data_variable *tail, var;
2634 m = var_element (&var);
2635 if (m == MATCH_ERROR)
2640 tail = gfc_get_data_variable ();
2643 parent->list = tail;
2647 if (gfc_match_char (',') != MATCH_YES)
2650 m = gfc_match_iterator (&parent->iter, 1);
2653 if (m == MATCH_ERROR)
2656 m = var_element (&var);
2657 if (m == MATCH_ERROR)
2662 tail->next = gfc_get_data_variable ();
2668 if (gfc_match_char (')') != MATCH_YES)
2673 gfc_syntax_error (ST_DATA);
2678 /* Match a single element in a data variable list, which can be a
2679 variable-iterator list. */
2682 var_element (gfc_data_variable * new)
2687 memset (new, '\0', sizeof (gfc_data_variable));
2689 if (gfc_match_char ('(') == MATCH_YES)
2690 return var_list (new);
2692 m = gfc_match_variable (&new->expr, 0);
2696 sym = new->expr->symtree->n.sym;
2698 if(sym->value != NULL)
2700 gfc_error ("Variable '%s' at %C already has an initialization",
2705 #if 0 // TODO: Find out where to move this message
2706 if (sym->attr.in_common)
2707 /* See if sym is in the blank common block. */
2708 for (t = &sym->ns->blank_common; t; t = t->common_next)
2711 gfc_error ("DATA statement at %C may not initialize variable "
2712 "'%s' from blank COMMON", sym->name);
2717 if (gfc_add_data (&sym->attr, &new->expr->where) == FAILURE)
2724 /* Match the top-level list of data variables. */
2727 top_var_list (gfc_data * d)
2729 gfc_data_variable var, *tail, *new;
2736 m = var_element (&var);
2739 if (m == MATCH_ERROR)
2742 new = gfc_get_data_variable ();
2752 if (gfc_match_char ('/') == MATCH_YES)
2754 if (gfc_match_char (',') != MATCH_YES)
2761 gfc_syntax_error (ST_DATA);
2767 match_data_constant (gfc_expr ** result)
2769 char name[GFC_MAX_SYMBOL_LEN + 1];
2774 m = gfc_match_literal_constant (&expr, 1);
2781 if (m == MATCH_ERROR)
2784 m = gfc_match_null (result);
2788 m = gfc_match_name (name);
2792 if (gfc_find_symbol (name, NULL, 1, &sym))
2796 || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
2798 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
2802 else if (sym->attr.flavor == FL_DERIVED)
2803 return gfc_match_structure_constructor (sym, result);
2805 *result = gfc_copy_expr (sym->value);
2810 /* Match a list of values in a DATA statement. The leading '/' has
2811 already been seen at this point. */
2814 top_val_list (gfc_data * data)
2816 gfc_data_value *new, *tail;
2825 m = match_data_constant (&expr);
2828 if (m == MATCH_ERROR)
2831 new = gfc_get_data_value ();
2840 if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
2847 msg = gfc_extract_int (expr, &tail->repeat);
2848 gfc_free_expr (expr);
2855 m = match_data_constant (&tail->expr);
2858 if (m == MATCH_ERROR)
2862 if (gfc_match_char ('/') == MATCH_YES)
2864 if (gfc_match_char (',') == MATCH_NO)
2871 gfc_syntax_error (ST_DATA);
2876 /* Match a DATA statement. */
2879 gfc_match_data (void)
2886 new = gfc_get_data ();
2887 new->where = gfc_current_locus;
2889 m = top_var_list (new);
2893 m = top_val_list (new);
2897 new->next = gfc_current_ns->data;
2898 gfc_current_ns->data = new;
2900 if (gfc_match_eos () == MATCH_YES)
2903 gfc_match_char (','); /* Optional comma */
2906 if (gfc_pure (NULL))
2908 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
2915 gfc_free_data (new);
2920 /***************** SELECT CASE subroutines ******************/
2922 /* Free a single case structure. */
2925 free_case (gfc_case * p)
2927 if (p->low == p->high)
2929 gfc_free_expr (p->low);
2930 gfc_free_expr (p->high);
2935 /* Free a list of case structures. */
2938 gfc_free_case_list (gfc_case * p)
2950 /* Match a single case selector. */
2953 match_case_selector (gfc_case ** cp)
2958 c = gfc_get_case ();
2959 c->where = gfc_current_locus;
2961 if (gfc_match_char (':') == MATCH_YES)
2963 m = gfc_match_init_expr (&c->high);
2966 if (m == MATCH_ERROR)
2972 m = gfc_match_init_expr (&c->low);
2973 if (m == MATCH_ERROR)
2978 /* If we're not looking at a ':' now, make a range out of a single
2979 target. Else get the upper bound for the case range. */
2980 if (gfc_match_char (':') != MATCH_YES)
2984 m = gfc_match_init_expr (&c->high);
2985 if (m == MATCH_ERROR)
2987 /* MATCH_NO is fine. It's OK if nothing is there! */
2995 gfc_error ("Expected initialization expression in CASE at %C");
3003 /* Match the end of a case statement. */
3006 match_case_eos (void)
3008 char name[GFC_MAX_SYMBOL_LEN + 1];
3011 if (gfc_match_eos () == MATCH_YES)
3014 gfc_gobble_whitespace ();
3016 m = gfc_match_name (name);
3020 if (strcmp (name, gfc_current_block ()->name) != 0)
3022 gfc_error ("Expected case name of '%s' at %C",
3023 gfc_current_block ()->name);
3027 return gfc_match_eos ();
3031 /* Match a SELECT statement. */
3034 gfc_match_select (void)
3039 m = gfc_match_label ();
3040 if (m == MATCH_ERROR)
3043 m = gfc_match (" select case ( %e )%t", &expr);
3047 new_st.op = EXEC_SELECT;
3054 /* Match a CASE statement. */
3057 gfc_match_case (void)
3059 gfc_case *c, *head, *tail;
3064 if (gfc_current_state () != COMP_SELECT)
3066 gfc_error ("Unexpected CASE statement at %C");
3070 if (gfc_match ("% default") == MATCH_YES)
3072 m = match_case_eos ();
3075 if (m == MATCH_ERROR)
3078 new_st.op = EXEC_SELECT;
3079 c = gfc_get_case ();
3080 c->where = gfc_current_locus;
3081 new_st.ext.case_list = c;
3085 if (gfc_match_char ('(') != MATCH_YES)
3090 if (match_case_selector (&c) == MATCH_ERROR)
3100 if (gfc_match_char (')') == MATCH_YES)
3102 if (gfc_match_char (',') != MATCH_YES)
3106 m = match_case_eos ();
3109 if (m == MATCH_ERROR)
3112 new_st.op = EXEC_SELECT;
3113 new_st.ext.case_list = head;
3118 gfc_error ("Syntax error in CASE-specification at %C");
3121 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
3125 /********************* WHERE subroutines ********************/
3127 /* Match a WHERE statement. */
3130 gfc_match_where (gfc_statement * st)
3136 m0 = gfc_match_label ();
3137 if (m0 == MATCH_ERROR)
3140 m = gfc_match (" where ( %e )", &expr);
3144 if (gfc_match_eos () == MATCH_YES)
3146 *st = ST_WHERE_BLOCK;
3148 new_st.op = EXEC_WHERE;
3153 m = gfc_match_assignment ();
3155 gfc_syntax_error (ST_WHERE);
3159 gfc_free_expr (expr);
3163 /* We've got a simple WHERE statement. */
3165 c = gfc_get_code ();
3169 c->next = gfc_get_code ();
3172 gfc_clear_new_st ();
3174 new_st.op = EXEC_WHERE;
3181 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3182 new_st if successful. */
3185 gfc_match_elsewhere (void)
3187 char name[GFC_MAX_SYMBOL_LEN + 1];
3191 if (gfc_current_state () != COMP_WHERE)
3193 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3199 if (gfc_match_char ('(') == MATCH_YES)
3201 m = gfc_match_expr (&expr);
3204 if (m == MATCH_ERROR)
3207 if (gfc_match_char (')') != MATCH_YES)
3211 if (gfc_match_eos () != MATCH_YES)
3212 { /* Better be a name at this point */
3213 m = gfc_match_name (name);
3216 if (m == MATCH_ERROR)
3219 if (gfc_match_eos () != MATCH_YES)
3222 if (strcmp (name, gfc_current_block ()->name) != 0)
3224 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3225 name, gfc_current_block ()->name);
3230 new_st.op = EXEC_WHERE;
3235 gfc_syntax_error (ST_ELSEWHERE);
3238 gfc_free_expr (expr);
3243 /******************** FORALL subroutines ********************/
3245 /* Free a list of FORALL iterators. */
3248 gfc_free_forall_iterator (gfc_forall_iterator * iter)
3250 gfc_forall_iterator *next;
3256 gfc_free_expr (iter->var);
3257 gfc_free_expr (iter->start);
3258 gfc_free_expr (iter->end);
3259 gfc_free_expr (iter->stride);
3267 /* Match an iterator as part of a FORALL statement. The format is:
3269 <var> = <start>:<end>[:<stride>][, <scalar mask>] */
3272 match_forall_iterator (gfc_forall_iterator ** result)
3274 gfc_forall_iterator *iter;
3278 where = gfc_current_locus;
3279 iter = gfc_getmem (sizeof (gfc_forall_iterator));
3281 m = gfc_match_variable (&iter->var, 0);
3285 if (gfc_match_char ('=') != MATCH_YES)
3291 m = gfc_match_expr (&iter->start);
3294 if (m == MATCH_ERROR)
3297 if (gfc_match_char (':') != MATCH_YES)
3300 m = gfc_match_expr (&iter->end);
3303 if (m == MATCH_ERROR)
3306 if (gfc_match_char (':') == MATCH_NO)
3307 iter->stride = gfc_int_expr (1);
3310 m = gfc_match_expr (&iter->stride);
3313 if (m == MATCH_ERROR)
3321 gfc_error ("Syntax error in FORALL iterator at %C");
3325 gfc_current_locus = where;
3326 gfc_free_forall_iterator (iter);
3331 /* Match a FORALL statement. */
3334 gfc_match_forall (gfc_statement * st)
3336 gfc_forall_iterator *head, *tail, *new;
3345 m0 = gfc_match_label ();
3346 if (m0 == MATCH_ERROR)
3349 m = gfc_match (" forall (");
3353 m = match_forall_iterator (&new);
3354 if (m == MATCH_ERROR)
3363 if (gfc_match_char (',') != MATCH_YES)
3366 m = match_forall_iterator (&new);
3367 if (m == MATCH_ERROR)
3376 /* Have to have a mask expression. */
3377 m = gfc_match_expr (&mask);
3380 if (m == MATCH_ERROR)
3386 if (gfc_match_char (')') == MATCH_NO)
3389 if (gfc_match_eos () == MATCH_YES)
3391 *st = ST_FORALL_BLOCK;
3393 new_st.op = EXEC_FORALL;
3395 new_st.ext.forall_iterator = head;
3400 m = gfc_match_assignment ();
3401 if (m == MATCH_ERROR)
3405 m = gfc_match_pointer_assignment ();
3406 if (m == MATCH_ERROR)
3412 c = gfc_get_code ();
3415 if (gfc_match_eos () != MATCH_YES)
3418 gfc_clear_new_st ();
3419 new_st.op = EXEC_FORALL;
3421 new_st.ext.forall_iterator = head;
3422 new_st.block = gfc_get_code ();
3424 new_st.block->op = EXEC_FORALL;
3425 new_st.block->next = c;
3431 gfc_syntax_error (ST_FORALL);
3434 gfc_free_forall_iterator (head);
3435 gfc_free_expr (mask);
3436 gfc_free_statements (c);