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 if (lvalue->symtree->n.sym->attr.flavor == FL_PARAMETER)
840 gfc_error ("Cannot assign to a PARAMETER variable at %C");
845 m = gfc_match (" %e%t", &rvalue);
849 gfc_set_sym_referenced (lvalue->symtree->n.sym);
851 new_st.op = EXEC_ASSIGN;
852 new_st.expr = lvalue;
853 new_st.expr2 = rvalue;
855 gfc_check_do_variable (lvalue->symtree);
860 gfc_current_locus = old_loc;
861 gfc_free_expr (lvalue);
862 gfc_free_expr (rvalue);
867 /* Match a pointer assignment statement. */
870 gfc_match_pointer_assignment (void)
872 gfc_expr *lvalue, *rvalue;
876 old_loc = gfc_current_locus;
878 lvalue = rvalue = NULL;
880 m = gfc_match (" %v =>", &lvalue);
887 m = gfc_match (" %e%t", &rvalue);
891 new_st.op = EXEC_POINTER_ASSIGN;
892 new_st.expr = lvalue;
893 new_st.expr2 = rvalue;
898 gfc_current_locus = old_loc;
899 gfc_free_expr (lvalue);
900 gfc_free_expr (rvalue);
905 /* The IF statement is a bit of a pain. First of all, there are three
906 forms of it, the simple IF, the IF that starts a block and the
909 There is a problem with the simple IF and that is the fact that we
910 only have a single level of undo information on symbols. What this
911 means is for a simple IF, we must re-match the whole IF statement
912 multiple times in order to guarantee that the symbol table ends up
913 in the proper state. */
915 static match match_simple_forall (void);
916 static match match_simple_where (void);
919 gfc_match_if (gfc_statement * if_type)
922 gfc_st_label *l1, *l2, *l3;
927 n = gfc_match_label ();
928 if (n == MATCH_ERROR)
931 old_loc = gfc_current_locus;
933 m = gfc_match (" if ( %e", &expr);
937 if (gfc_match_char (')') != MATCH_YES)
939 gfc_error ("Syntax error in IF-expression at %C");
940 gfc_free_expr (expr);
944 m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
951 ("Block label not appropriate for arithmetic IF statement "
954 gfc_free_expr (expr);
958 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
959 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
960 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
963 gfc_free_expr (expr);
967 new_st.op = EXEC_ARITHMETIC_IF;
973 *if_type = ST_ARITHMETIC_IF;
977 if (gfc_match (" then %t") == MATCH_YES)
982 *if_type = ST_IF_BLOCK;
988 gfc_error ("Block label is not appropriate IF statement at %C");
990 gfc_free_expr (expr);
994 /* At this point the only thing left is a simple IF statement. At
995 this point, n has to be MATCH_NO, so we don't have to worry about
996 re-matching a block label. From what we've got so far, try
997 matching an assignment. */
999 *if_type = ST_SIMPLE_IF;
1001 m = gfc_match_assignment ();
1005 gfc_free_expr (expr);
1006 gfc_undo_symbols ();
1007 gfc_current_locus = old_loc;
1009 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */
1011 m = gfc_match_pointer_assignment ();
1015 gfc_free_expr (expr);
1016 gfc_undo_symbols ();
1017 gfc_current_locus = old_loc;
1019 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */
1021 /* Look at the next keyword to see which matcher to call. Matching
1022 the keyword doesn't affect the symbol table, so we don't have to
1023 restore between tries. */
1025 #define match(string, subr, statement) \
1026 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1030 match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1031 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1032 match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1033 match ("call", gfc_match_call, ST_CALL)
1034 match ("close", gfc_match_close, ST_CLOSE)
1035 match ("continue", gfc_match_continue, ST_CONTINUE)
1036 match ("cycle", gfc_match_cycle, ST_CYCLE)
1037 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1038 match ("end file", gfc_match_endfile, ST_END_FILE)
1039 match ("exit", gfc_match_exit, ST_EXIT)
1040 match ("forall", match_simple_forall, ST_FORALL)
1041 match ("go to", gfc_match_goto, ST_GOTO)
1042 match ("inquire", gfc_match_inquire, ST_INQUIRE)
1043 match ("nullify", gfc_match_nullify, ST_NULLIFY)
1044 match ("open", gfc_match_open, ST_OPEN)
1045 match ("pause", gfc_match_pause, ST_NONE)
1046 match ("print", gfc_match_print, ST_WRITE)
1047 match ("read", gfc_match_read, ST_READ)
1048 match ("return", gfc_match_return, ST_RETURN)
1049 match ("rewind", gfc_match_rewind, ST_REWIND)
1050 match ("stop", gfc_match_stop, ST_STOP)
1051 match ("where", match_simple_where, ST_WHERE)
1052 match ("write", gfc_match_write, ST_WRITE)
1054 /* All else has failed, so give up. See if any of the matchers has
1055 stored an error message of some sort. */
1056 if (gfc_error_check () == 0)
1057 gfc_error ("Unclassifiable statement in IF-clause at %C");
1059 gfc_free_expr (expr);
1064 gfc_error ("Syntax error in IF-clause at %C");
1067 gfc_free_expr (expr);
1071 /* At this point, we've matched the single IF and the action clause
1072 is in new_st. Rearrange things so that the IF statement appears
1075 p = gfc_get_code ();
1076 p->next = gfc_get_code ();
1078 p->next->loc = gfc_current_locus;
1083 gfc_clear_new_st ();
1085 new_st.op = EXEC_IF;
1094 /* Match an ELSE statement. */
1097 gfc_match_else (void)
1099 char name[GFC_MAX_SYMBOL_LEN + 1];
1101 if (gfc_match_eos () == MATCH_YES)
1104 if (gfc_match_name (name) != MATCH_YES
1105 || gfc_current_block () == NULL
1106 || gfc_match_eos () != MATCH_YES)
1108 gfc_error ("Unexpected junk after ELSE statement at %C");
1112 if (strcmp (name, gfc_current_block ()->name) != 0)
1114 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1115 name, gfc_current_block ()->name);
1123 /* Match an ELSE IF statement. */
1126 gfc_match_elseif (void)
1128 char name[GFC_MAX_SYMBOL_LEN + 1];
1132 m = gfc_match (" ( %e ) then", &expr);
1136 if (gfc_match_eos () == MATCH_YES)
1139 if (gfc_match_name (name) != MATCH_YES
1140 || gfc_current_block () == NULL
1141 || gfc_match_eos () != MATCH_YES)
1143 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1147 if (strcmp (name, gfc_current_block ()->name) != 0)
1149 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1150 name, gfc_current_block ()->name);
1155 new_st.op = EXEC_IF;
1160 gfc_free_expr (expr);
1165 /* Free a gfc_iterator structure. */
1168 gfc_free_iterator (gfc_iterator * iter, int flag)
1174 gfc_free_expr (iter->var);
1175 gfc_free_expr (iter->start);
1176 gfc_free_expr (iter->end);
1177 gfc_free_expr (iter->step);
1184 /* Match a DO statement. */
1189 gfc_iterator iter, *ip;
1191 gfc_st_label *label;
1194 old_loc = gfc_current_locus;
1197 iter.var = iter.start = iter.end = iter.step = NULL;
1199 m = gfc_match_label ();
1200 if (m == MATCH_ERROR)
1203 if (gfc_match (" do") != MATCH_YES)
1206 m = gfc_match_st_label (&label, 0);
1207 if (m == MATCH_ERROR)
1210 /* Match an infinite DO, make it like a DO WHILE(.TRUE.) */
1212 if (gfc_match_eos () == MATCH_YES)
1214 iter.end = gfc_logical_expr (1, NULL);
1215 new_st.op = EXEC_DO_WHILE;
1219 /* match an optional comma, if no comma is found a space is obligatory. */
1220 if (gfc_match_char(',') != MATCH_YES
1221 && gfc_match ("% ") != MATCH_YES)
1224 /* See if we have a DO WHILE. */
1225 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1227 new_st.op = EXEC_DO_WHILE;
1231 /* The abortive DO WHILE may have done something to the symbol
1232 table, so we start over: */
1233 gfc_undo_symbols ();
1234 gfc_current_locus = old_loc;
1236 gfc_match_label (); /* This won't error */
1237 gfc_match (" do "); /* This will work */
1239 gfc_match_st_label (&label, 0); /* Can't error out */
1240 gfc_match_char (','); /* Optional comma */
1242 m = gfc_match_iterator (&iter, 0);
1245 if (m == MATCH_ERROR)
1248 gfc_check_do_variable (iter.var->symtree);
1250 if (gfc_match_eos () != MATCH_YES)
1252 gfc_syntax_error (ST_DO);
1256 new_st.op = EXEC_DO;
1260 && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1263 new_st.label = label;
1265 if (new_st.op == EXEC_DO_WHILE)
1266 new_st.expr = iter.end;
1269 new_st.ext.iterator = ip = gfc_get_iterator ();
1276 gfc_free_iterator (&iter, 0);
1282 /* Match an EXIT or CYCLE statement. */
1285 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1291 if (gfc_match_eos () == MATCH_YES)
1295 m = gfc_match ("% %s%t", &sym);
1296 if (m == MATCH_ERROR)
1300 gfc_syntax_error (st);
1304 if (sym->attr.flavor != FL_LABEL)
1306 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1307 sym->name, gfc_ascii_statement (st));
1312 /* Find the loop mentioned specified by the label (or lack of a
1314 for (p = gfc_state_stack; p; p = p->previous)
1315 if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1321 gfc_error ("%s statement at %C is not within a loop",
1322 gfc_ascii_statement (st));
1324 gfc_error ("%s statement at %C is not within loop '%s'",
1325 gfc_ascii_statement (st), sym->name);
1330 /* Save the first statement in the loop - needed by the backend. */
1331 new_st.ext.whichloop = p->head;
1334 /* new_st.sym = sym;*/
1340 /* Match the EXIT statement. */
1343 gfc_match_exit (void)
1346 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1350 /* Match the CYCLE statement. */
1353 gfc_match_cycle (void)
1356 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1360 /* Match a number or character constant after a STOP or PAUSE statement. */
1363 gfc_match_stopcode (gfc_statement st)
1372 if (gfc_match_eos () != MATCH_YES)
1374 m = gfc_match_small_literal_int (&stop_code);
1375 if (m == MATCH_ERROR)
1378 if (m == MATCH_YES && stop_code > 99999)
1380 gfc_error ("STOP code out of range at %C");
1386 /* Try a character constant. */
1387 m = gfc_match_expr (&e);
1388 if (m == MATCH_ERROR)
1392 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1396 if (gfc_match_eos () != MATCH_YES)
1400 if (gfc_pure (NULL))
1402 gfc_error ("%s statement not allowed in PURE procedure at %C",
1403 gfc_ascii_statement (st));
1407 new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1409 new_st.ext.stop_code = stop_code;
1414 gfc_syntax_error (st);
1422 /* Match the (deprecated) PAUSE statement. */
1425 gfc_match_pause (void)
1429 m = gfc_match_stopcode (ST_PAUSE);
1432 if (gfc_notify_std (GFC_STD_F95_DEL,
1433 "Obsolete: PAUSE statement at %C")
1441 /* Match the STOP statement. */
1444 gfc_match_stop (void)
1446 return gfc_match_stopcode (ST_STOP);
1450 /* Match a CONTINUE statement. */
1453 gfc_match_continue (void)
1456 if (gfc_match_eos () != MATCH_YES)
1458 gfc_syntax_error (ST_CONTINUE);
1462 new_st.op = EXEC_CONTINUE;
1467 /* Match the (deprecated) ASSIGN statement. */
1470 gfc_match_assign (void)
1473 gfc_st_label *label;
1475 if (gfc_match (" %l", &label) == MATCH_YES)
1477 if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
1479 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
1481 if (gfc_notify_std (GFC_STD_F95_DEL,
1482 "Obsolete: ASSIGN statement at %C")
1486 expr->symtree->n.sym->attr.assign = 1;
1488 new_st.op = EXEC_LABEL_ASSIGN;
1489 new_st.label = label;
1498 /* Match the GO TO statement. As a computed GOTO statement is
1499 matched, it is transformed into an equivalent SELECT block. No
1500 tree is necessary, and the resulting jumps-to-jumps are
1501 specifically optimized away by the back end. */
1504 gfc_match_goto (void)
1506 gfc_code *head, *tail;
1509 gfc_st_label *label;
1513 if (gfc_match (" %l%t", &label) == MATCH_YES)
1515 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1518 new_st.op = EXEC_GOTO;
1519 new_st.label = label;
1523 /* The assigned GO TO statement. */
1525 if (gfc_match_variable (&expr, 0) == MATCH_YES)
1527 if (gfc_notify_std (GFC_STD_F95_DEL,
1528 "Obsolete: Assigned GOTO statement at %C")
1532 expr->symtree->n.sym->attr.assign = 1;
1533 new_st.op = EXEC_GOTO;
1536 if (gfc_match_eos () == MATCH_YES)
1539 /* Match label list. */
1540 gfc_match_char (',');
1541 if (gfc_match_char ('(') != MATCH_YES)
1543 gfc_syntax_error (ST_GOTO);
1550 m = gfc_match_st_label (&label, 0);
1554 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1558 head = tail = gfc_get_code ();
1561 tail->block = gfc_get_code ();
1565 tail->label = label;
1566 tail->op = EXEC_GOTO;
1568 while (gfc_match_char (',') == MATCH_YES);
1570 if (gfc_match (")%t") != MATCH_YES)
1576 "Statement label list in GOTO at %C cannot be empty");
1579 new_st.block = head;
1584 /* Last chance is a computed GO TO statement. */
1585 if (gfc_match_char ('(') != MATCH_YES)
1587 gfc_syntax_error (ST_GOTO);
1596 m = gfc_match_st_label (&label, 0);
1600 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1604 head = tail = gfc_get_code ();
1607 tail->block = gfc_get_code ();
1611 cp = gfc_get_case ();
1612 cp->low = cp->high = gfc_int_expr (i++);
1614 tail->op = EXEC_SELECT;
1615 tail->ext.case_list = cp;
1617 tail->next = gfc_get_code ();
1618 tail->next->op = EXEC_GOTO;
1619 tail->next->label = label;
1621 while (gfc_match_char (',') == MATCH_YES);
1623 if (gfc_match_char (')') != MATCH_YES)
1628 gfc_error ("Statement label list in GOTO at %C cannot be empty");
1632 /* Get the rest of the statement. */
1633 gfc_match_char (',');
1635 if (gfc_match (" %e%t", &expr) != MATCH_YES)
1638 /* At this point, a computed GOTO has been fully matched and an
1639 equivalent SELECT statement constructed. */
1641 new_st.op = EXEC_SELECT;
1644 /* Hack: For a "real" SELECT, the expression is in expr. We put
1645 it in expr2 so we can distinguish then and produce the correct
1647 new_st.expr2 = expr;
1648 new_st.block = head;
1652 gfc_syntax_error (ST_GOTO);
1654 gfc_free_statements (head);
1659 /* Frees a list of gfc_alloc structures. */
1662 gfc_free_alloc_list (gfc_alloc * p)
1669 gfc_free_expr (p->expr);
1675 /* Match an ALLOCATE statement. */
1678 gfc_match_allocate (void)
1680 gfc_alloc *head, *tail;
1687 if (gfc_match_char ('(') != MATCH_YES)
1693 head = tail = gfc_get_alloc ();
1696 tail->next = gfc_get_alloc ();
1700 m = gfc_match_variable (&tail->expr, 0);
1703 if (m == MATCH_ERROR)
1706 if (gfc_check_do_variable (tail->expr->symtree))
1710 && gfc_impure_variable (tail->expr->symtree->n.sym))
1712 gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1717 if (gfc_match_char (',') != MATCH_YES)
1720 m = gfc_match (" stat = %v", &stat);
1721 if (m == MATCH_ERROR)
1729 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1732 ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
1733 "INTENT(IN)", stat->symtree->n.sym->name);
1737 if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
1740 ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
1745 if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1747 gfc_error("STAT expression at %C must be a variable");
1751 gfc_check_do_variable(stat->symtree);
1754 if (gfc_match (" )%t") != MATCH_YES)
1757 new_st.op = EXEC_ALLOCATE;
1759 new_st.ext.alloc_list = head;
1764 gfc_syntax_error (ST_ALLOCATE);
1767 gfc_free_expr (stat);
1768 gfc_free_alloc_list (head);
1773 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1774 a set of pointer assignments to intrinsic NULL(). */
1777 gfc_match_nullify (void)
1785 if (gfc_match_char ('(') != MATCH_YES)
1790 m = gfc_match_variable (&p, 0);
1791 if (m == MATCH_ERROR)
1796 if (gfc_check_do_variable(p->symtree))
1799 if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
1802 ("Illegal variable in NULLIFY at %C for a PURE procedure");
1806 /* build ' => NULL() ' */
1807 e = gfc_get_expr ();
1808 e->where = gfc_current_locus;
1809 e->expr_type = EXPR_NULL;
1810 e->ts.type = BT_UNKNOWN;
1817 tail->next = gfc_get_code ();
1821 tail->op = EXEC_POINTER_ASSIGN;
1825 if (gfc_match_char (')') == MATCH_YES)
1827 if (gfc_match_char (',') != MATCH_YES)
1834 gfc_syntax_error (ST_NULLIFY);
1837 gfc_free_statements (tail);
1842 /* Match a DEALLOCATE statement. */
1845 gfc_match_deallocate (void)
1847 gfc_alloc *head, *tail;
1854 if (gfc_match_char ('(') != MATCH_YES)
1860 head = tail = gfc_get_alloc ();
1863 tail->next = gfc_get_alloc ();
1867 m = gfc_match_variable (&tail->expr, 0);
1868 if (m == MATCH_ERROR)
1873 if (gfc_check_do_variable (tail->expr->symtree))
1877 && gfc_impure_variable (tail->expr->symtree->n.sym))
1880 ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
1885 if (gfc_match_char (',') != MATCH_YES)
1888 m = gfc_match (" stat = %v", &stat);
1889 if (m == MATCH_ERROR)
1897 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1899 gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
1900 "cannot be INTENT(IN)", stat->symtree->n.sym->name);
1904 if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym))
1906 gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
1907 "for a PURE procedure");
1911 if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1913 gfc_error("STAT expression at %C must be a variable");
1917 gfc_check_do_variable(stat->symtree);
1920 if (gfc_match (" )%t") != MATCH_YES)
1923 new_st.op = EXEC_DEALLOCATE;
1925 new_st.ext.alloc_list = head;
1930 gfc_syntax_error (ST_DEALLOCATE);
1933 gfc_free_expr (stat);
1934 gfc_free_alloc_list (head);
1939 /* Match a RETURN statement. */
1942 gfc_match_return (void)
1946 gfc_compile_state s;
1948 gfc_enclosing_unit (&s);
1949 if (s == COMP_PROGRAM
1950 && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
1951 "main program at %C") == FAILURE)
1955 if (gfc_match_eos () == MATCH_YES)
1958 if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
1960 gfc_error ("Alternate RETURN statement at %C is only allowed within "
1965 m = gfc_match ("% %e%t", &e);
1968 if (m == MATCH_ERROR)
1971 gfc_syntax_error (ST_RETURN);
1978 new_st.op = EXEC_RETURN;
1985 /* Match a CALL statement. The tricky part here are possible
1986 alternate return specifiers. We handle these by having all
1987 "subroutines" actually return an integer via a register that gives
1988 the return number. If the call specifies alternate returns, we
1989 generate code for a SELECT statement whose case clauses contain
1990 GOTOs to the various labels. */
1993 gfc_match_call (void)
1995 char name[GFC_MAX_SYMBOL_LEN + 1];
1996 gfc_actual_arglist *a, *arglist;
2006 m = gfc_match ("% %n", name);
2012 if (gfc_get_ha_sym_tree (name, &st))
2016 gfc_set_sym_referenced (sym);
2018 if (!sym->attr.generic
2019 && !sym->attr.subroutine
2020 && gfc_add_subroutine (&sym->attr, NULL) == FAILURE)
2023 if (gfc_match_eos () != MATCH_YES)
2025 m = gfc_match_actual_arglist (1, &arglist);
2028 if (m == MATCH_ERROR)
2031 if (gfc_match_eos () != MATCH_YES)
2035 /* If any alternate return labels were found, construct a SELECT
2036 statement that will jump to the right place. */
2039 for (a = arglist; a; a = a->next)
2040 if (a->expr == NULL)
2045 gfc_symtree *select_st;
2046 gfc_symbol *select_sym;
2047 char name[GFC_MAX_SYMBOL_LEN + 1];
2049 new_st.next = c = gfc_get_code ();
2050 c->op = EXEC_SELECT;
2051 sprintf (name, "_result_%s",sym->name);
2052 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail */
2054 select_sym = select_st->n.sym;
2055 select_sym->ts.type = BT_INTEGER;
2056 select_sym->ts.kind = gfc_default_integer_kind;
2057 gfc_set_sym_referenced (select_sym);
2058 c->expr = gfc_get_expr ();
2059 c->expr->expr_type = EXPR_VARIABLE;
2060 c->expr->symtree = select_st;
2061 c->expr->ts = select_sym->ts;
2062 c->expr->where = gfc_current_locus;
2065 for (a = arglist; a; a = a->next)
2067 if (a->expr != NULL)
2070 if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2075 c->block = gfc_get_code ();
2077 c->op = EXEC_SELECT;
2079 new_case = gfc_get_case ();
2080 new_case->high = new_case->low = gfc_int_expr (i);
2081 c->ext.case_list = new_case;
2083 c->next = gfc_get_code ();
2084 c->next->op = EXEC_GOTO;
2085 c->next->label = a->label;
2089 new_st.op = EXEC_CALL;
2090 new_st.symtree = st;
2091 new_st.ext.actual = arglist;
2096 gfc_syntax_error (ST_CALL);
2099 gfc_free_actual_arglist (arglist);
2104 /* Given a name, return a pointer to the common head structure,
2105 creating it if it does not exist. If FROM_MODULE is nonzero, we
2106 mangle the name so that it doesn't interfere with commons defined
2107 in the using namespace.
2108 TODO: Add to global symbol tree. */
2111 gfc_get_common (const char *name, int from_module)
2114 static int serial = 0;
2115 char mangled_name[GFC_MAX_SYMBOL_LEN+1];
2119 /* A use associated common block is only needed to correctly layout
2120 the variables it contains. */
2121 snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2122 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2126 st = gfc_find_symtree (gfc_current_ns->common_root, name);
2129 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2132 if (st->n.common == NULL)
2134 st->n.common = gfc_get_common_head ();
2135 st->n.common->where = gfc_current_locus;
2136 strcpy (st->n.common->name, name);
2139 return st->n.common;
2143 /* Match a common block name. */
2146 match_common_name (char *name)
2150 if (gfc_match_char ('/') == MATCH_NO)
2156 if (gfc_match_char ('/') == MATCH_YES)
2162 m = gfc_match_name (name);
2164 if (m == MATCH_ERROR)
2166 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2169 gfc_error ("Syntax error in common block name at %C");
2174 /* Match a COMMON statement. */
2177 gfc_match_common (void)
2179 gfc_symbol *sym, **head, *tail, *old_blank_common;
2180 char name[GFC_MAX_SYMBOL_LEN+1];
2185 old_blank_common = gfc_current_ns->blank_common.head;
2186 if (old_blank_common)
2188 while (old_blank_common->common_next)
2189 old_blank_common = old_blank_common->common_next;
2194 if (gfc_match_eos () == MATCH_YES)
2199 m = match_common_name (name);
2200 if (m == MATCH_ERROR)
2203 if (name[0] == '\0')
2205 t = &gfc_current_ns->blank_common;
2206 if (t->head == NULL)
2207 t->where = gfc_current_locus;
2212 t = gfc_get_common (name, 0);
2221 while (tail->common_next)
2222 tail = tail->common_next;
2225 /* Grab the list of symbols. */
2226 if (gfc_match_eos () == MATCH_YES)
2231 m = gfc_match_symbol (&sym, 0);
2232 if (m == MATCH_ERROR)
2237 if (sym->attr.in_common)
2239 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2244 if (gfc_add_in_common (&sym->attr, NULL) == FAILURE)
2247 if (sym->value != NULL
2248 && (name[0] == '\0' || !sym->attr.data))
2250 if (name[0] == '\0')
2251 gfc_error ("Previously initialized symbol '%s' in "
2252 "blank COMMON block at %C", sym->name);
2254 gfc_error ("Previously initialized symbol '%s' in "
2255 "COMMON block '%s' at %C", sym->name, name);
2259 if (gfc_add_in_common (&sym->attr, NULL) == FAILURE)
2262 /* Derived type names must have the SEQUENCE attribute. */
2263 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2266 ("Derived type variable in COMMON at %C does not have the "
2267 "SEQUENCE attribute");
2272 tail->common_next = sym;
2278 /* Deal with an optional array specification after the
2280 m = gfc_match_array_spec (&as);
2281 if (m == MATCH_ERROR)
2286 if (as->type != AS_EXPLICIT)
2289 ("Array specification for symbol '%s' in COMMON at %C "
2290 "must be explicit", sym->name);
2294 if (gfc_add_dimension (&sym->attr, NULL) == FAILURE)
2297 if (sym->attr.pointer)
2300 ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2309 if (gfc_match_eos () == MATCH_YES)
2311 if (gfc_peek_char () == '/')
2313 if (gfc_match_char (',') != MATCH_YES)
2315 if (gfc_peek_char () == '/')
2324 gfc_syntax_error (ST_COMMON);
2327 if (old_blank_common)
2328 old_blank_common->common_next = NULL;
2330 gfc_current_ns->blank_common.head = NULL;
2331 gfc_free_array_spec (as);
2336 /* Match a BLOCK DATA program unit. */
2339 gfc_match_block_data (void)
2341 char name[GFC_MAX_SYMBOL_LEN + 1];
2345 if (gfc_match_eos () == MATCH_YES)
2347 gfc_new_block = NULL;
2351 m = gfc_match ("% %n%t", name);
2355 if (gfc_get_symbol (name, NULL, &sym))
2358 if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, NULL) == FAILURE)
2361 gfc_new_block = sym;
2367 /* Free a namelist structure. */
2370 gfc_free_namelist (gfc_namelist * name)
2374 for (; name; name = n)
2382 /* Match a NAMELIST statement. */
2385 gfc_match_namelist (void)
2387 gfc_symbol *group_name, *sym;
2391 m = gfc_match (" / %s /", &group_name);
2394 if (m == MATCH_ERROR)
2399 if (group_name->ts.type != BT_UNKNOWN)
2402 ("Namelist group name '%s' at %C already has a basic type "
2403 "of %s", group_name->name, gfc_typename (&group_name->ts));
2407 if (group_name->attr.flavor != FL_NAMELIST
2408 && gfc_add_flavor (&group_name->attr, FL_NAMELIST, NULL) == FAILURE)
2413 m = gfc_match_symbol (&sym, 1);
2416 if (m == MATCH_ERROR)
2419 if (sym->attr.in_namelist == 0
2420 && gfc_add_in_namelist (&sym->attr, NULL) == FAILURE)
2423 /* TODO: worry about PRIVATE members of a PUBLIC namelist
2426 nl = gfc_get_namelist ();
2429 if (group_name->namelist == NULL)
2430 group_name->namelist = group_name->namelist_tail = nl;
2433 group_name->namelist_tail->next = nl;
2434 group_name->namelist_tail = nl;
2437 if (gfc_match_eos () == MATCH_YES)
2440 m = gfc_match_char (',');
2442 if (gfc_match_char ('/') == MATCH_YES)
2444 m2 = gfc_match (" %s /", &group_name);
2445 if (m2 == MATCH_YES)
2447 if (m2 == MATCH_ERROR)
2461 gfc_syntax_error (ST_NAMELIST);
2468 /* Match a MODULE statement. */
2471 gfc_match_module (void)
2475 m = gfc_match (" %s%t", &gfc_new_block);
2479 if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, NULL) == FAILURE)
2486 /* Free equivalence sets and lists. Recursively is the easiest way to
2490 gfc_free_equiv (gfc_equiv * eq)
2496 gfc_free_equiv (eq->eq);
2497 gfc_free_equiv (eq->next);
2499 gfc_free_expr (eq->expr);
2504 /* Match an EQUIVALENCE statement. */
2507 gfc_match_equivalence (void)
2509 gfc_equiv *eq, *set, *tail;
2517 eq = gfc_get_equiv ();
2521 eq->next = gfc_current_ns->equiv;
2522 gfc_current_ns->equiv = eq;
2524 if (gfc_match_char ('(') != MATCH_YES)
2531 m = gfc_match_variable (&set->expr, 1);
2532 if (m == MATCH_ERROR)
2537 for (ref = set->expr->ref; ref; ref = ref->next)
2538 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2541 ("Array reference in EQUIVALENCE at %C cannot be an "
2546 if (gfc_match_char (')') == MATCH_YES)
2548 if (gfc_match_char (',') != MATCH_YES)
2551 set->eq = gfc_get_equiv ();
2555 if (gfc_match_eos () == MATCH_YES)
2557 if (gfc_match_char (',') != MATCH_YES)
2564 gfc_syntax_error (ST_EQUIVALENCE);
2570 gfc_free_equiv (gfc_current_ns->equiv);
2571 gfc_current_ns->equiv = eq;
2577 /* Match a statement function declaration. It is so easy to match
2578 non-statement function statements with a MATCH_ERROR as opposed to
2579 MATCH_NO that we suppress error message in most cases. */
2582 gfc_match_st_function (void)
2584 gfc_error_buf old_error;
2589 m = gfc_match_symbol (&sym, 0);
2593 gfc_push_error (&old_error);
2595 if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, NULL) == FAILURE)
2598 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2601 m = gfc_match (" = %e%t", &expr);
2604 if (m == MATCH_ERROR)
2612 gfc_pop_error (&old_error);
2617 /***************** SELECT CASE subroutines ******************/
2619 /* Free a single case structure. */
2622 free_case (gfc_case * p)
2624 if (p->low == p->high)
2626 gfc_free_expr (p->low);
2627 gfc_free_expr (p->high);
2632 /* Free a list of case structures. */
2635 gfc_free_case_list (gfc_case * p)
2647 /* Match a single case selector. */
2650 match_case_selector (gfc_case ** cp)
2655 c = gfc_get_case ();
2656 c->where = gfc_current_locus;
2658 if (gfc_match_char (':') == MATCH_YES)
2660 m = gfc_match_init_expr (&c->high);
2663 if (m == MATCH_ERROR)
2669 m = gfc_match_init_expr (&c->low);
2670 if (m == MATCH_ERROR)
2675 /* If we're not looking at a ':' now, make a range out of a single
2676 target. Else get the upper bound for the case range. */
2677 if (gfc_match_char (':') != MATCH_YES)
2681 m = gfc_match_init_expr (&c->high);
2682 if (m == MATCH_ERROR)
2684 /* MATCH_NO is fine. It's OK if nothing is there! */
2692 gfc_error ("Expected initialization expression in CASE at %C");
2700 /* Match the end of a case statement. */
2703 match_case_eos (void)
2705 char name[GFC_MAX_SYMBOL_LEN + 1];
2708 if (gfc_match_eos () == MATCH_YES)
2711 gfc_gobble_whitespace ();
2713 m = gfc_match_name (name);
2717 if (strcmp (name, gfc_current_block ()->name) != 0)
2719 gfc_error ("Expected case name of '%s' at %C",
2720 gfc_current_block ()->name);
2724 return gfc_match_eos ();
2728 /* Match a SELECT statement. */
2731 gfc_match_select (void)
2736 m = gfc_match_label ();
2737 if (m == MATCH_ERROR)
2740 m = gfc_match (" select case ( %e )%t", &expr);
2744 new_st.op = EXEC_SELECT;
2751 /* Match a CASE statement. */
2754 gfc_match_case (void)
2756 gfc_case *c, *head, *tail;
2761 if (gfc_current_state () != COMP_SELECT)
2763 gfc_error ("Unexpected CASE statement at %C");
2767 if (gfc_match ("% default") == MATCH_YES)
2769 m = match_case_eos ();
2772 if (m == MATCH_ERROR)
2775 new_st.op = EXEC_SELECT;
2776 c = gfc_get_case ();
2777 c->where = gfc_current_locus;
2778 new_st.ext.case_list = c;
2782 if (gfc_match_char ('(') != MATCH_YES)
2787 if (match_case_selector (&c) == MATCH_ERROR)
2797 if (gfc_match_char (')') == MATCH_YES)
2799 if (gfc_match_char (',') != MATCH_YES)
2803 m = match_case_eos ();
2806 if (m == MATCH_ERROR)
2809 new_st.op = EXEC_SELECT;
2810 new_st.ext.case_list = head;
2815 gfc_error ("Syntax error in CASE-specification at %C");
2818 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
2822 /********************* WHERE subroutines ********************/
2824 /* Match the rest of a simple WHERE statement that follows an IF statement.
2828 match_simple_where (void)
2834 m = gfc_match (" ( %e )", &expr);
2838 m = gfc_match_assignment ();
2841 if (m == MATCH_ERROR)
2844 if (gfc_match_eos () != MATCH_YES)
2847 c = gfc_get_code ();
2851 c->next = gfc_get_code ();
2854 gfc_clear_new_st ();
2856 new_st.op = EXEC_WHERE;
2862 gfc_syntax_error (ST_WHERE);
2865 gfc_free_expr (expr);
2869 /* Match a WHERE statement. */
2872 gfc_match_where (gfc_statement * st)
2878 m0 = gfc_match_label ();
2879 if (m0 == MATCH_ERROR)
2882 m = gfc_match (" where ( %e )", &expr);
2886 if (gfc_match_eos () == MATCH_YES)
2888 *st = ST_WHERE_BLOCK;
2890 new_st.op = EXEC_WHERE;
2895 m = gfc_match_assignment ();
2897 gfc_syntax_error (ST_WHERE);
2901 gfc_free_expr (expr);
2905 /* We've got a simple WHERE statement. */
2907 c = gfc_get_code ();
2911 c->next = gfc_get_code ();
2914 gfc_clear_new_st ();
2916 new_st.op = EXEC_WHERE;
2923 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
2924 new_st if successful. */
2927 gfc_match_elsewhere (void)
2929 char name[GFC_MAX_SYMBOL_LEN + 1];
2933 if (gfc_current_state () != COMP_WHERE)
2935 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
2941 if (gfc_match_char ('(') == MATCH_YES)
2943 m = gfc_match_expr (&expr);
2946 if (m == MATCH_ERROR)
2949 if (gfc_match_char (')') != MATCH_YES)
2953 if (gfc_match_eos () != MATCH_YES)
2954 { /* Better be a name at this point */
2955 m = gfc_match_name (name);
2958 if (m == MATCH_ERROR)
2961 if (gfc_match_eos () != MATCH_YES)
2964 if (strcmp (name, gfc_current_block ()->name) != 0)
2966 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
2967 name, gfc_current_block ()->name);
2972 new_st.op = EXEC_WHERE;
2977 gfc_syntax_error (ST_ELSEWHERE);
2980 gfc_free_expr (expr);
2985 /******************** FORALL subroutines ********************/
2987 /* Free a list of FORALL iterators. */
2990 gfc_free_forall_iterator (gfc_forall_iterator * iter)
2992 gfc_forall_iterator *next;
2998 gfc_free_expr (iter->var);
2999 gfc_free_expr (iter->start);
3000 gfc_free_expr (iter->end);
3001 gfc_free_expr (iter->stride);
3009 /* Match an iterator as part of a FORALL statement. The format is:
3011 <var> = <start>:<end>[:<stride>][, <scalar mask>] */
3014 match_forall_iterator (gfc_forall_iterator ** result)
3016 gfc_forall_iterator *iter;
3020 where = gfc_current_locus;
3021 iter = gfc_getmem (sizeof (gfc_forall_iterator));
3023 m = gfc_match_variable (&iter->var, 0);
3027 if (gfc_match_char ('=') != MATCH_YES)
3033 m = gfc_match_expr (&iter->start);
3036 if (m == MATCH_ERROR)
3039 if (gfc_match_char (':') != MATCH_YES)
3042 m = gfc_match_expr (&iter->end);
3045 if (m == MATCH_ERROR)
3048 if (gfc_match_char (':') == MATCH_NO)
3049 iter->stride = gfc_int_expr (1);
3052 m = gfc_match_expr (&iter->stride);
3055 if (m == MATCH_ERROR)
3063 gfc_error ("Syntax error in FORALL iterator at %C");
3067 gfc_current_locus = where;
3068 gfc_free_forall_iterator (iter);
3073 /* Match the header of a FORALL statement. */
3076 match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask)
3078 gfc_forall_iterator *head, *tail, *new;
3081 gfc_gobble_whitespace ();
3086 if (gfc_match_char ('(') != MATCH_YES)
3089 m = match_forall_iterator (&new);
3090 if (m == MATCH_ERROR)
3099 if (gfc_match_char (',') != MATCH_YES)
3102 m = match_forall_iterator (&new);
3103 if (m == MATCH_ERROR)
3112 /* Have to have a mask expression */
3114 m = gfc_match_expr (mask);
3117 if (m == MATCH_ERROR)
3123 if (gfc_match_char (')') == MATCH_NO)
3130 gfc_syntax_error (ST_FORALL);
3133 gfc_free_expr (*mask);
3134 gfc_free_forall_iterator (head);
3139 /* Match the rest of a simple FORALL statement that follows an IF statement.
3143 match_simple_forall (void)
3145 gfc_forall_iterator *head;
3154 m = match_forall_header (&head, &mask);
3161 m = gfc_match_assignment ();
3163 if (m == MATCH_ERROR)
3167 m = gfc_match_pointer_assignment ();
3168 if (m == MATCH_ERROR)
3174 c = gfc_get_code ();
3176 c->loc = gfc_current_locus;
3178 if (gfc_match_eos () != MATCH_YES)
3181 gfc_clear_new_st ();
3182 new_st.op = EXEC_FORALL;
3184 new_st.ext.forall_iterator = head;
3185 new_st.block = gfc_get_code ();
3187 new_st.block->op = EXEC_FORALL;
3188 new_st.block->next = c;
3193 gfc_syntax_error (ST_FORALL);
3196 gfc_free_forall_iterator (head);
3197 gfc_free_expr (mask);
3203 /* Match a FORALL statement. */
3206 gfc_match_forall (gfc_statement * st)
3208 gfc_forall_iterator *head;
3217 m0 = gfc_match_label ();
3218 if (m0 == MATCH_ERROR)
3221 m = gfc_match (" forall");
3225 m = match_forall_header (&head, &mask);
3226 if (m == MATCH_ERROR)
3231 if (gfc_match_eos () == MATCH_YES)
3233 *st = ST_FORALL_BLOCK;
3235 new_st.op = EXEC_FORALL;
3237 new_st.ext.forall_iterator = head;
3242 m = gfc_match_assignment ();
3243 if (m == MATCH_ERROR)
3247 m = gfc_match_pointer_assignment ();
3248 if (m == MATCH_ERROR)
3254 c = gfc_get_code ();
3257 if (gfc_match_eos () != MATCH_YES)
3260 gfc_clear_new_st ();
3261 new_st.op = EXEC_FORALL;
3263 new_st.ext.forall_iterator = head;
3264 new_st.block = gfc_get_code ();
3266 new_st.block->op = EXEC_FORALL;
3267 new_st.block->next = c;
3273 gfc_syntax_error (ST_FORALL);
3276 gfc_free_forall_iterator (head);
3277 gfc_free_expr (mask);
3278 gfc_free_statements (c);