2006-01-16 Richard Guenther <rguenther@suse.de>
[official-gcc.git] / gcc / fortran / match.c
bloba07de602fbf60d93ad7b7bb11288fa058d5985d3
1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
3 Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
11 version.
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
16 for more details.
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
21 02110-1301, USA. */
24 #include "config.h"
25 #include "system.h"
26 #include "flags.h"
27 #include "gfortran.h"
28 #include "match.h"
29 #include "parse.h"
31 /* For matching and debugging purposes. Order matters here! The
32 unary operators /must/ precede the binary plus and minus, or
33 the expression parser breaks. */
35 mstring intrinsic_operators[] = {
36 minit ("+", INTRINSIC_UPLUS),
37 minit ("-", INTRINSIC_UMINUS),
38 minit ("+", INTRINSIC_PLUS),
39 minit ("-", INTRINSIC_MINUS),
40 minit ("**", INTRINSIC_POWER),
41 minit ("//", INTRINSIC_CONCAT),
42 minit ("*", INTRINSIC_TIMES),
43 minit ("/", INTRINSIC_DIVIDE),
44 minit (".and.", INTRINSIC_AND),
45 minit (".or.", INTRINSIC_OR),
46 minit (".eqv.", INTRINSIC_EQV),
47 minit (".neqv.", INTRINSIC_NEQV),
48 minit (".eq.", INTRINSIC_EQ),
49 minit ("==", INTRINSIC_EQ),
50 minit (".ne.", INTRINSIC_NE),
51 minit ("/=", INTRINSIC_NE),
52 minit (".ge.", INTRINSIC_GE),
53 minit (">=", INTRINSIC_GE),
54 minit (".le.", INTRINSIC_LE),
55 minit ("<=", INTRINSIC_LE),
56 minit (".lt.", INTRINSIC_LT),
57 minit ("<", INTRINSIC_LT),
58 minit (".gt.", INTRINSIC_GT),
59 minit (">", INTRINSIC_GT),
60 minit (".not.", INTRINSIC_NOT),
61 minit (NULL, INTRINSIC_NONE)
65 /******************** Generic matching subroutines ************************/
67 /* In free form, match at least one space. Always matches in fixed
68 form. */
70 match
71 gfc_match_space (void)
73 locus old_loc;
74 int c;
76 if (gfc_current_form == FORM_FIXED)
77 return MATCH_YES;
79 old_loc = gfc_current_locus;
81 c = gfc_next_char ();
82 if (!gfc_is_whitespace (c))
84 gfc_current_locus = old_loc;
85 return MATCH_NO;
88 gfc_gobble_whitespace ();
90 return MATCH_YES;
94 /* Match an end of statement. End of statement is optional
95 whitespace, followed by a ';' or '\n' or comment '!'. If a
96 semicolon is found, we continue to eat whitespace and semicolons. */
98 match
99 gfc_match_eos (void)
101 locus old_loc;
102 int flag, c;
104 flag = 0;
106 for (;;)
108 old_loc = gfc_current_locus;
109 gfc_gobble_whitespace ();
111 c = gfc_next_char ();
112 switch (c)
114 case '!':
117 c = gfc_next_char ();
119 while (c != '\n');
121 /* Fall through */
123 case '\n':
124 return MATCH_YES;
126 case ';':
127 flag = 1;
128 continue;
131 break;
134 gfc_current_locus = old_loc;
135 return (flag) ? MATCH_YES : MATCH_NO;
139 /* Match a literal integer on the input, setting the value on
140 MATCH_YES. Literal ints occur in kind-parameters as well as
141 old-style character length specifications. */
143 match
144 gfc_match_small_literal_int (int *value, int *cnt)
146 locus old_loc;
147 char c;
148 int i, j;
150 old_loc = gfc_current_locus;
152 gfc_gobble_whitespace ();
153 c = gfc_next_char ();
154 *cnt = 0;
156 if (!ISDIGIT (c))
158 gfc_current_locus = old_loc;
159 return MATCH_NO;
162 i = c - '0';
163 j = 1;
165 for (;;)
167 old_loc = gfc_current_locus;
168 c = gfc_next_char ();
170 if (!ISDIGIT (c))
171 break;
173 i = 10 * i + c - '0';
174 j++;
176 if (i > 99999999)
178 gfc_error ("Integer too large at %C");
179 return MATCH_ERROR;
183 gfc_current_locus = old_loc;
185 *value = i;
186 *cnt = j;
187 return MATCH_YES;
191 /* Match a small, constant integer expression, like in a kind
192 statement. On MATCH_YES, 'value' is set. */
194 match
195 gfc_match_small_int (int *value)
197 gfc_expr *expr;
198 const char *p;
199 match m;
200 int i;
202 m = gfc_match_expr (&expr);
203 if (m != MATCH_YES)
204 return m;
206 p = gfc_extract_int (expr, &i);
207 gfc_free_expr (expr);
209 if (p != NULL)
211 gfc_error (p);
212 m = MATCH_ERROR;
215 *value = i;
216 return m;
220 /* Matches a statement label. Uses gfc_match_small_literal_int() to
221 do most of the work. */
223 match
224 gfc_match_st_label (gfc_st_label ** label)
226 locus old_loc;
227 match m;
228 int i, cnt;
230 old_loc = gfc_current_locus;
232 m = gfc_match_small_literal_int (&i, &cnt);
233 if (m != MATCH_YES)
234 return m;
236 if (cnt > 5)
238 gfc_error ("Too many digits in statement label at %C");
239 goto cleanup;
242 if (i == 0)
244 gfc_error ("Statement label at %C is zero");
245 goto cleanup;
248 *label = gfc_get_st_label (i);
249 return MATCH_YES;
251 cleanup:
253 gfc_current_locus = old_loc;
254 return MATCH_ERROR;
258 /* Match and validate a label associated with a named IF, DO or SELECT
259 statement. If the symbol does not have the label attribute, we add
260 it. We also make sure the symbol does not refer to another
261 (active) block. A matched label is pointed to by gfc_new_block. */
263 match
264 gfc_match_label (void)
266 char name[GFC_MAX_SYMBOL_LEN + 1];
267 match m;
269 gfc_new_block = NULL;
271 m = gfc_match (" %n :", name);
272 if (m != MATCH_YES)
273 return m;
275 if (gfc_get_symbol (name, NULL, &gfc_new_block))
277 gfc_error ("Label name '%s' at %C is ambiguous", name);
278 return MATCH_ERROR;
281 if (gfc_new_block->attr.flavor == FL_LABEL)
283 gfc_error ("Duplicate construct label '%s' at %C", name);
284 return MATCH_ERROR;
287 if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
288 gfc_new_block->name, NULL) == FAILURE)
289 return MATCH_ERROR;
291 return MATCH_YES;
295 /* Try and match the input against an array of possibilities. If one
296 potential matching string is a substring of another, the longest
297 match takes precedence. Spaces in the target strings are optional
298 spaces that do not necessarily have to be found in the input
299 stream. In fixed mode, spaces never appear. If whitespace is
300 matched, it matches unlimited whitespace in the input. For this
301 reason, the 'mp' member of the mstring structure is used to track
302 the progress of each potential match.
304 If there is no match we return the tag associated with the
305 terminating NULL mstring structure and leave the locus pointer
306 where it started. If there is a match we return the tag member of
307 the matched mstring and leave the locus pointer after the matched
308 character.
310 A '%' character is a mandatory space. */
313 gfc_match_strings (mstring * a)
315 mstring *p, *best_match;
316 int no_match, c, possibles;
317 locus match_loc;
319 possibles = 0;
321 for (p = a; p->string != NULL; p++)
323 p->mp = p->string;
324 possibles++;
327 no_match = p->tag;
329 best_match = NULL;
330 match_loc = gfc_current_locus;
332 gfc_gobble_whitespace ();
334 while (possibles > 0)
336 c = gfc_next_char ();
338 /* Apply the next character to the current possibilities. */
339 for (p = a; p->string != NULL; p++)
341 if (p->mp == NULL)
342 continue;
344 if (*p->mp == ' ')
346 /* Space matches 1+ whitespace(s). */
347 if ((gfc_current_form == FORM_FREE)
348 && gfc_is_whitespace (c))
349 continue;
351 p->mp++;
354 if (*p->mp != c)
356 /* Match failed. */
357 p->mp = NULL;
358 possibles--;
359 continue;
362 p->mp++;
363 if (*p->mp == '\0')
365 /* Found a match. */
366 match_loc = gfc_current_locus;
367 best_match = p;
368 possibles--;
369 p->mp = NULL;
374 gfc_current_locus = match_loc;
376 return (best_match == NULL) ? no_match : best_match->tag;
380 /* See if the current input looks like a name of some sort. Modifies
381 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long. */
383 match
384 gfc_match_name (char *buffer)
386 locus old_loc;
387 int i, c;
389 old_loc = gfc_current_locus;
390 gfc_gobble_whitespace ();
392 c = gfc_next_char ();
393 if (!ISALPHA (c))
395 gfc_current_locus = old_loc;
396 return MATCH_NO;
399 i = 0;
403 buffer[i++] = c;
405 if (i > gfc_option.max_identifier_length)
407 gfc_error ("Name at %C is too long");
408 return MATCH_ERROR;
411 old_loc = gfc_current_locus;
412 c = gfc_next_char ();
414 while (ISALNUM (c)
415 || c == '_'
416 || (gfc_option.flag_dollar_ok && c == '$'));
418 buffer[i] = '\0';
419 gfc_current_locus = old_loc;
421 return MATCH_YES;
425 /* Match a symbol on the input. Modifies the pointer to the symbol
426 pointer if successful. */
428 match
429 gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc)
431 char buffer[GFC_MAX_SYMBOL_LEN + 1];
432 match m;
434 m = gfc_match_name (buffer);
435 if (m != MATCH_YES)
436 return m;
438 if (host_assoc)
439 return (gfc_get_ha_sym_tree (buffer, matched_symbol))
440 ? MATCH_ERROR : MATCH_YES;
442 if (gfc_get_sym_tree (buffer, NULL, matched_symbol))
443 return MATCH_ERROR;
445 return MATCH_YES;
449 match
450 gfc_match_symbol (gfc_symbol ** matched_symbol, int host_assoc)
452 gfc_symtree *st;
453 match m;
455 m = gfc_match_sym_tree (&st, host_assoc);
457 if (m == MATCH_YES)
459 if (st)
460 *matched_symbol = st->n.sym;
461 else
462 *matched_symbol = NULL;
464 else
465 *matched_symbol = NULL;
466 return m;
469 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
470 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
471 in matchexp.c. */
473 match
474 gfc_match_intrinsic_op (gfc_intrinsic_op * result)
476 gfc_intrinsic_op op;
478 op = (gfc_intrinsic_op) gfc_match_strings (intrinsic_operators);
480 if (op == INTRINSIC_NONE)
481 return MATCH_NO;
483 *result = op;
484 return MATCH_YES;
488 /* Match a loop control phrase:
490 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
492 If the final integer expression is not present, a constant unity
493 expression is returned. We don't return MATCH_ERROR until after
494 the equals sign is seen. */
496 match
497 gfc_match_iterator (gfc_iterator * iter, int init_flag)
499 char name[GFC_MAX_SYMBOL_LEN + 1];
500 gfc_expr *var, *e1, *e2, *e3;
501 locus start;
502 match m;
504 /* Match the start of an iterator without affecting the symbol
505 table. */
507 start = gfc_current_locus;
508 m = gfc_match (" %n =", name);
509 gfc_current_locus = start;
511 if (m != MATCH_YES)
512 return MATCH_NO;
514 m = gfc_match_variable (&var, 0);
515 if (m != MATCH_YES)
516 return MATCH_NO;
518 gfc_match_char ('=');
520 e1 = e2 = e3 = NULL;
522 if (var->ref != NULL)
524 gfc_error ("Loop variable at %C cannot be a sub-component");
525 goto cleanup;
528 if (var->symtree->n.sym->attr.intent == INTENT_IN)
530 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
531 var->symtree->n.sym->name);
532 goto cleanup;
535 if (var->symtree->n.sym->attr.pointer)
537 gfc_error ("Loop variable at %C cannot have the POINTER attribute");
538 goto cleanup;
541 m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
542 if (m == MATCH_NO)
543 goto syntax;
544 if (m == MATCH_ERROR)
545 goto cleanup;
547 if (gfc_match_char (',') != MATCH_YES)
548 goto syntax;
550 m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
551 if (m == MATCH_NO)
552 goto syntax;
553 if (m == MATCH_ERROR)
554 goto cleanup;
556 if (gfc_match_char (',') != MATCH_YES)
558 e3 = gfc_int_expr (1);
559 goto done;
562 m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
563 if (m == MATCH_ERROR)
564 goto cleanup;
565 if (m == MATCH_NO)
567 gfc_error ("Expected a step value in iterator at %C");
568 goto cleanup;
571 done:
572 iter->var = var;
573 iter->start = e1;
574 iter->end = e2;
575 iter->step = e3;
576 return MATCH_YES;
578 syntax:
579 gfc_error ("Syntax error in iterator at %C");
581 cleanup:
582 gfc_free_expr (e1);
583 gfc_free_expr (e2);
584 gfc_free_expr (e3);
586 return MATCH_ERROR;
590 /* Tries to match the next non-whitespace character on the input.
591 This subroutine does not return MATCH_ERROR. */
593 match
594 gfc_match_char (char c)
596 locus where;
598 where = gfc_current_locus;
599 gfc_gobble_whitespace ();
601 if (gfc_next_char () == c)
602 return MATCH_YES;
604 gfc_current_locus = where;
605 return MATCH_NO;
609 /* General purpose matching subroutine. The target string is a
610 scanf-like format string in which spaces correspond to arbitrary
611 whitespace (including no whitespace), characters correspond to
612 themselves. The %-codes are:
614 %% Literal percent sign
615 %e Expression, pointer to a pointer is set
616 %s Symbol, pointer to the symbol is set
617 %n Name, character buffer is set to name
618 %t Matches end of statement.
619 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
620 %l Matches a statement label
621 %v Matches a variable expression (an lvalue)
622 % Matches a required space (in free form) and optional spaces. */
624 match
625 gfc_match (const char *target, ...)
627 gfc_st_label **label;
628 int matches, *ip;
629 locus old_loc;
630 va_list argp;
631 char c, *np;
632 match m, n;
633 void **vp;
634 const char *p;
636 old_loc = gfc_current_locus;
637 va_start (argp, target);
638 m = MATCH_NO;
639 matches = 0;
640 p = target;
642 loop:
643 c = *p++;
644 switch (c)
646 case ' ':
647 gfc_gobble_whitespace ();
648 goto loop;
649 case '\0':
650 m = MATCH_YES;
651 break;
653 case '%':
654 c = *p++;
655 switch (c)
657 case 'e':
658 vp = va_arg (argp, void **);
659 n = gfc_match_expr ((gfc_expr **) vp);
660 if (n != MATCH_YES)
662 m = n;
663 goto not_yes;
666 matches++;
667 goto loop;
669 case 'v':
670 vp = va_arg (argp, void **);
671 n = gfc_match_variable ((gfc_expr **) vp, 0);
672 if (n != MATCH_YES)
674 m = n;
675 goto not_yes;
678 matches++;
679 goto loop;
681 case 's':
682 vp = va_arg (argp, void **);
683 n = gfc_match_symbol ((gfc_symbol **) vp, 0);
684 if (n != MATCH_YES)
686 m = n;
687 goto not_yes;
690 matches++;
691 goto loop;
693 case 'n':
694 np = va_arg (argp, char *);
695 n = gfc_match_name (np);
696 if (n != MATCH_YES)
698 m = n;
699 goto not_yes;
702 matches++;
703 goto loop;
705 case 'l':
706 label = va_arg (argp, gfc_st_label **);
707 n = gfc_match_st_label (label);
708 if (n != MATCH_YES)
710 m = n;
711 goto not_yes;
714 matches++;
715 goto loop;
717 case 'o':
718 ip = va_arg (argp, int *);
719 n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
720 if (n != MATCH_YES)
722 m = n;
723 goto not_yes;
726 matches++;
727 goto loop;
729 case 't':
730 if (gfc_match_eos () != MATCH_YES)
732 m = MATCH_NO;
733 goto not_yes;
735 goto loop;
737 case ' ':
738 if (gfc_match_space () == MATCH_YES)
739 goto loop;
740 m = MATCH_NO;
741 goto not_yes;
743 case '%':
744 break; /* Fall through to character matcher */
746 default:
747 gfc_internal_error ("gfc_match(): Bad match code %c", c);
750 default:
751 if (c == gfc_next_char ())
752 goto loop;
753 break;
756 not_yes:
757 va_end (argp);
759 if (m != MATCH_YES)
761 /* Clean up after a failed match. */
762 gfc_current_locus = old_loc;
763 va_start (argp, target);
765 p = target;
766 for (; matches > 0; matches--)
768 while (*p++ != '%');
770 switch (*p++)
772 case '%':
773 matches++;
774 break; /* Skip */
776 /* Matches that don't have to be undone */
777 case 'o':
778 case 'l':
779 case 'n':
780 case 's':
781 (void)va_arg (argp, void **);
782 break;
784 case 'e':
785 case 'v':
786 vp = va_arg (argp, void **);
787 gfc_free_expr (*vp);
788 *vp = NULL;
789 break;
793 va_end (argp);
796 return m;
800 /*********************** Statement level matching **********************/
802 /* Matches the start of a program unit, which is the program keyword
803 followed by an obligatory symbol. */
805 match
806 gfc_match_program (void)
808 gfc_symbol *sym;
809 match m;
811 m = gfc_match ("% %s%t", &sym);
813 if (m == MATCH_NO)
815 gfc_error ("Invalid form of PROGRAM statement at %C");
816 m = MATCH_ERROR;
819 if (m == MATCH_ERROR)
820 return m;
822 if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
823 return MATCH_ERROR;
825 gfc_new_block = sym;
827 return MATCH_YES;
831 /* Match a simple assignment statement. */
833 match
834 gfc_match_assignment (void)
836 gfc_expr *lvalue, *rvalue;
837 locus old_loc;
838 match m;
840 old_loc = gfc_current_locus;
842 lvalue = rvalue = NULL;
843 m = gfc_match (" %v =", &lvalue);
844 if (m != MATCH_YES)
845 goto cleanup;
847 if (lvalue->symtree->n.sym->attr.flavor == FL_PARAMETER)
849 gfc_error ("Cannot assign to a PARAMETER variable at %C");
850 m = MATCH_ERROR;
851 goto cleanup;
854 m = gfc_match (" %e%t", &rvalue);
855 if (m != MATCH_YES)
856 goto cleanup;
858 gfc_set_sym_referenced (lvalue->symtree->n.sym);
860 new_st.op = EXEC_ASSIGN;
861 new_st.expr = lvalue;
862 new_st.expr2 = rvalue;
864 gfc_check_do_variable (lvalue->symtree);
866 return MATCH_YES;
868 cleanup:
869 gfc_current_locus = old_loc;
870 gfc_free_expr (lvalue);
871 gfc_free_expr (rvalue);
872 return m;
876 /* Match a pointer assignment statement. */
878 match
879 gfc_match_pointer_assignment (void)
881 gfc_expr *lvalue, *rvalue;
882 locus old_loc;
883 match m;
885 old_loc = gfc_current_locus;
887 lvalue = rvalue = NULL;
889 m = gfc_match (" %v =>", &lvalue);
890 if (m != MATCH_YES)
892 m = MATCH_NO;
893 goto cleanup;
896 m = gfc_match (" %e%t", &rvalue);
897 if (m != MATCH_YES)
898 goto cleanup;
900 new_st.op = EXEC_POINTER_ASSIGN;
901 new_st.expr = lvalue;
902 new_st.expr2 = rvalue;
904 return MATCH_YES;
906 cleanup:
907 gfc_current_locus = old_loc;
908 gfc_free_expr (lvalue);
909 gfc_free_expr (rvalue);
910 return m;
914 /* We try to match an easy arithmetic IF statement. This only happens
915 when just after having encountered a simple IF statement. This code
916 is really duplicate with parts of the gfc_match_if code, but this is
917 *much* easier. */
918 static match
919 match_arithmetic_if (void)
921 gfc_st_label *l1, *l2, *l3;
922 gfc_expr *expr;
923 match m;
925 m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
926 if (m != MATCH_YES)
927 return m;
929 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
930 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
931 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
933 gfc_free_expr (expr);
934 return MATCH_ERROR;
937 if (gfc_notify_std (GFC_STD_F95_DEL,
938 "Obsolete: arithmetic IF statement at %C") == FAILURE)
939 return MATCH_ERROR;
941 new_st.op = EXEC_ARITHMETIC_IF;
942 new_st.expr = expr;
943 new_st.label = l1;
944 new_st.label2 = l2;
945 new_st.label3 = l3;
947 return MATCH_YES;
951 /* The IF statement is a bit of a pain. First of all, there are three
952 forms of it, the simple IF, the IF that starts a block and the
953 arithmetic IF.
955 There is a problem with the simple IF and that is the fact that we
956 only have a single level of undo information on symbols. What this
957 means is for a simple IF, we must re-match the whole IF statement
958 multiple times in order to guarantee that the symbol table ends up
959 in the proper state. */
961 static match match_simple_forall (void);
962 static match match_simple_where (void);
964 match
965 gfc_match_if (gfc_statement * if_type)
967 gfc_expr *expr;
968 gfc_st_label *l1, *l2, *l3;
969 locus old_loc;
970 gfc_code *p;
971 match m, n;
973 n = gfc_match_label ();
974 if (n == MATCH_ERROR)
975 return n;
977 old_loc = gfc_current_locus;
979 m = gfc_match (" if ( %e", &expr);
980 if (m != MATCH_YES)
981 return m;
983 if (gfc_match_char (')') != MATCH_YES)
985 gfc_error ("Syntax error in IF-expression at %C");
986 gfc_free_expr (expr);
987 return MATCH_ERROR;
990 m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
992 if (m == MATCH_YES)
994 if (n == MATCH_YES)
996 gfc_error
997 ("Block label not appropriate for arithmetic IF statement "
998 "at %C");
1000 gfc_free_expr (expr);
1001 return MATCH_ERROR;
1004 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1005 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1006 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1009 gfc_free_expr (expr);
1010 return MATCH_ERROR;
1013 if (gfc_notify_std (GFC_STD_F95_DEL,
1014 "Obsolete: arithmetic IF statement at %C")
1015 == FAILURE)
1016 return MATCH_ERROR;
1018 new_st.op = EXEC_ARITHMETIC_IF;
1019 new_st.expr = expr;
1020 new_st.label = l1;
1021 new_st.label2 = l2;
1022 new_st.label3 = l3;
1024 *if_type = ST_ARITHMETIC_IF;
1025 return MATCH_YES;
1028 if (gfc_match (" then%t") == MATCH_YES)
1030 new_st.op = EXEC_IF;
1031 new_st.expr = expr;
1033 *if_type = ST_IF_BLOCK;
1034 return MATCH_YES;
1037 if (n == MATCH_YES)
1039 gfc_error ("Block label is not appropriate IF statement at %C");
1041 gfc_free_expr (expr);
1042 return MATCH_ERROR;
1045 /* At this point the only thing left is a simple IF statement. At
1046 this point, n has to be MATCH_NO, so we don't have to worry about
1047 re-matching a block label. From what we've got so far, try
1048 matching an assignment. */
1050 *if_type = ST_SIMPLE_IF;
1052 m = gfc_match_assignment ();
1053 if (m == MATCH_YES)
1054 goto got_match;
1056 gfc_free_expr (expr);
1057 gfc_undo_symbols ();
1058 gfc_current_locus = old_loc;
1060 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */
1062 m = gfc_match_pointer_assignment ();
1063 if (m == MATCH_YES)
1064 goto got_match;
1066 gfc_free_expr (expr);
1067 gfc_undo_symbols ();
1068 gfc_current_locus = old_loc;
1070 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */
1072 /* Look at the next keyword to see which matcher to call. Matching
1073 the keyword doesn't affect the symbol table, so we don't have to
1074 restore between tries. */
1076 #define match(string, subr, statement) \
1077 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1079 gfc_clear_error ();
1081 match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1082 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1083 match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1084 match ("call", gfc_match_call, ST_CALL)
1085 match ("close", gfc_match_close, ST_CLOSE)
1086 match ("continue", gfc_match_continue, ST_CONTINUE)
1087 match ("cycle", gfc_match_cycle, ST_CYCLE)
1088 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1089 match ("end file", gfc_match_endfile, ST_END_FILE)
1090 match ("exit", gfc_match_exit, ST_EXIT)
1091 match ("flush", gfc_match_flush, ST_FLUSH)
1092 match ("forall", match_simple_forall, ST_FORALL)
1093 match ("go to", gfc_match_goto, ST_GOTO)
1094 match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1095 match ("inquire", gfc_match_inquire, ST_INQUIRE)
1096 match ("nullify", gfc_match_nullify, ST_NULLIFY)
1097 match ("open", gfc_match_open, ST_OPEN)
1098 match ("pause", gfc_match_pause, ST_NONE)
1099 match ("print", gfc_match_print, ST_WRITE)
1100 match ("read", gfc_match_read, ST_READ)
1101 match ("return", gfc_match_return, ST_RETURN)
1102 match ("rewind", gfc_match_rewind, ST_REWIND)
1103 match ("stop", gfc_match_stop, ST_STOP)
1104 match ("where", match_simple_where, ST_WHERE)
1105 match ("write", gfc_match_write, ST_WRITE)
1107 /* All else has failed, so give up. See if any of the matchers has
1108 stored an error message of some sort. */
1109 if (gfc_error_check () == 0)
1110 gfc_error ("Unclassifiable statement in IF-clause at %C");
1112 gfc_free_expr (expr);
1113 return MATCH_ERROR;
1115 got_match:
1116 if (m == MATCH_NO)
1117 gfc_error ("Syntax error in IF-clause at %C");
1118 if (m != MATCH_YES)
1120 gfc_free_expr (expr);
1121 return MATCH_ERROR;
1124 /* At this point, we've matched the single IF and the action clause
1125 is in new_st. Rearrange things so that the IF statement appears
1126 in new_st. */
1128 p = gfc_get_code ();
1129 p->next = gfc_get_code ();
1130 *p->next = new_st;
1131 p->next->loc = gfc_current_locus;
1133 p->expr = expr;
1134 p->op = EXEC_IF;
1136 gfc_clear_new_st ();
1138 new_st.op = EXEC_IF;
1139 new_st.block = p;
1141 return MATCH_YES;
1144 #undef match
1147 /* Match an ELSE statement. */
1149 match
1150 gfc_match_else (void)
1152 char name[GFC_MAX_SYMBOL_LEN + 1];
1154 if (gfc_match_eos () == MATCH_YES)
1155 return MATCH_YES;
1157 if (gfc_match_name (name) != MATCH_YES
1158 || gfc_current_block () == NULL
1159 || gfc_match_eos () != MATCH_YES)
1161 gfc_error ("Unexpected junk after ELSE statement at %C");
1162 return MATCH_ERROR;
1165 if (strcmp (name, gfc_current_block ()->name) != 0)
1167 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1168 name, gfc_current_block ()->name);
1169 return MATCH_ERROR;
1172 return MATCH_YES;
1176 /* Match an ELSE IF statement. */
1178 match
1179 gfc_match_elseif (void)
1181 char name[GFC_MAX_SYMBOL_LEN + 1];
1182 gfc_expr *expr;
1183 match m;
1185 m = gfc_match (" ( %e ) then", &expr);
1186 if (m != MATCH_YES)
1187 return m;
1189 if (gfc_match_eos () == MATCH_YES)
1190 goto done;
1192 if (gfc_match_name (name) != MATCH_YES
1193 || gfc_current_block () == NULL
1194 || gfc_match_eos () != MATCH_YES)
1196 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1197 goto cleanup;
1200 if (strcmp (name, gfc_current_block ()->name) != 0)
1202 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1203 name, gfc_current_block ()->name);
1204 goto cleanup;
1207 done:
1208 new_st.op = EXEC_IF;
1209 new_st.expr = expr;
1210 return MATCH_YES;
1212 cleanup:
1213 gfc_free_expr (expr);
1214 return MATCH_ERROR;
1218 /* Free a gfc_iterator structure. */
1220 void
1221 gfc_free_iterator (gfc_iterator * iter, int flag)
1224 if (iter == NULL)
1225 return;
1227 gfc_free_expr (iter->var);
1228 gfc_free_expr (iter->start);
1229 gfc_free_expr (iter->end);
1230 gfc_free_expr (iter->step);
1232 if (flag)
1233 gfc_free (iter);
1237 /* Match a DO statement. */
1239 match
1240 gfc_match_do (void)
1242 gfc_iterator iter, *ip;
1243 locus old_loc;
1244 gfc_st_label *label;
1245 match m;
1247 old_loc = gfc_current_locus;
1249 label = NULL;
1250 iter.var = iter.start = iter.end = iter.step = NULL;
1252 m = gfc_match_label ();
1253 if (m == MATCH_ERROR)
1254 return m;
1256 if (gfc_match (" do") != MATCH_YES)
1257 return MATCH_NO;
1259 m = gfc_match_st_label (&label);
1260 if (m == MATCH_ERROR)
1261 goto cleanup;
1263 /* Match an infinite DO, make it like a DO WHILE(.TRUE.) */
1265 if (gfc_match_eos () == MATCH_YES)
1267 iter.end = gfc_logical_expr (1, NULL);
1268 new_st.op = EXEC_DO_WHILE;
1269 goto done;
1272 /* match an optional comma, if no comma is found a space is obligatory. */
1273 if (gfc_match_char(',') != MATCH_YES
1274 && gfc_match ("% ") != MATCH_YES)
1275 return MATCH_NO;
1277 /* See if we have a DO WHILE. */
1278 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1280 new_st.op = EXEC_DO_WHILE;
1281 goto done;
1284 /* The abortive DO WHILE may have done something to the symbol
1285 table, so we start over: */
1286 gfc_undo_symbols ();
1287 gfc_current_locus = old_loc;
1289 gfc_match_label (); /* This won't error */
1290 gfc_match (" do "); /* This will work */
1292 gfc_match_st_label (&label); /* Can't error out */
1293 gfc_match_char (','); /* Optional comma */
1295 m = gfc_match_iterator (&iter, 0);
1296 if (m == MATCH_NO)
1297 return MATCH_NO;
1298 if (m == MATCH_ERROR)
1299 goto cleanup;
1301 gfc_check_do_variable (iter.var->symtree);
1303 if (gfc_match_eos () != MATCH_YES)
1305 gfc_syntax_error (ST_DO);
1306 goto cleanup;
1309 new_st.op = EXEC_DO;
1311 done:
1312 if (label != NULL
1313 && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1314 goto cleanup;
1316 new_st.label = label;
1318 if (new_st.op == EXEC_DO_WHILE)
1319 new_st.expr = iter.end;
1320 else
1322 new_st.ext.iterator = ip = gfc_get_iterator ();
1323 *ip = iter;
1326 return MATCH_YES;
1328 cleanup:
1329 gfc_free_iterator (&iter, 0);
1331 return MATCH_ERROR;
1335 /* Match an EXIT or CYCLE statement. */
1337 static match
1338 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1340 gfc_state_data *p;
1341 gfc_symbol *sym;
1342 match m;
1344 if (gfc_match_eos () == MATCH_YES)
1345 sym = NULL;
1346 else
1348 m = gfc_match ("% %s%t", &sym);
1349 if (m == MATCH_ERROR)
1350 return MATCH_ERROR;
1351 if (m == MATCH_NO)
1353 gfc_syntax_error (st);
1354 return MATCH_ERROR;
1357 if (sym->attr.flavor != FL_LABEL)
1359 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1360 sym->name, gfc_ascii_statement (st));
1361 return MATCH_ERROR;
1365 /* Find the loop mentioned specified by the label (or lack of a
1366 label). */
1367 for (p = gfc_state_stack; p; p = p->previous)
1368 if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1369 break;
1371 if (p == NULL)
1373 if (sym == NULL)
1374 gfc_error ("%s statement at %C is not within a loop",
1375 gfc_ascii_statement (st));
1376 else
1377 gfc_error ("%s statement at %C is not within loop '%s'",
1378 gfc_ascii_statement (st), sym->name);
1380 return MATCH_ERROR;
1383 /* Save the first statement in the loop - needed by the backend. */
1384 new_st.ext.whichloop = p->head;
1386 new_st.op = op;
1387 /* new_st.sym = sym;*/
1389 return MATCH_YES;
1393 /* Match the EXIT statement. */
1395 match
1396 gfc_match_exit (void)
1399 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1403 /* Match the CYCLE statement. */
1405 match
1406 gfc_match_cycle (void)
1409 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1413 /* Match a number or character constant after a STOP or PAUSE statement. */
1415 static match
1416 gfc_match_stopcode (gfc_statement st)
1418 int stop_code;
1419 gfc_expr *e;
1420 match m;
1421 int cnt;
1423 stop_code = -1;
1424 e = NULL;
1426 if (gfc_match_eos () != MATCH_YES)
1428 m = gfc_match_small_literal_int (&stop_code, &cnt);
1429 if (m == MATCH_ERROR)
1430 goto cleanup;
1432 if (m == MATCH_YES && cnt > 5)
1434 gfc_error ("Too many digits in STOP code at %C");
1435 goto cleanup;
1438 if (m == MATCH_NO)
1440 /* Try a character constant. */
1441 m = gfc_match_expr (&e);
1442 if (m == MATCH_ERROR)
1443 goto cleanup;
1444 if (m == MATCH_NO)
1445 goto syntax;
1446 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1447 goto syntax;
1450 if (gfc_match_eos () != MATCH_YES)
1451 goto syntax;
1454 if (gfc_pure (NULL))
1456 gfc_error ("%s statement not allowed in PURE procedure at %C",
1457 gfc_ascii_statement (st));
1458 goto cleanup;
1461 new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1462 new_st.expr = e;
1463 new_st.ext.stop_code = stop_code;
1465 return MATCH_YES;
1467 syntax:
1468 gfc_syntax_error (st);
1470 cleanup:
1472 gfc_free_expr (e);
1473 return MATCH_ERROR;
1476 /* Match the (deprecated) PAUSE statement. */
1478 match
1479 gfc_match_pause (void)
1481 match m;
1483 m = gfc_match_stopcode (ST_PAUSE);
1484 if (m == MATCH_YES)
1486 if (gfc_notify_std (GFC_STD_F95_DEL,
1487 "Obsolete: PAUSE statement at %C")
1488 == FAILURE)
1489 m = MATCH_ERROR;
1491 return m;
1495 /* Match the STOP statement. */
1497 match
1498 gfc_match_stop (void)
1500 return gfc_match_stopcode (ST_STOP);
1504 /* Match a CONTINUE statement. */
1506 match
1507 gfc_match_continue (void)
1510 if (gfc_match_eos () != MATCH_YES)
1512 gfc_syntax_error (ST_CONTINUE);
1513 return MATCH_ERROR;
1516 new_st.op = EXEC_CONTINUE;
1517 return MATCH_YES;
1521 /* Match the (deprecated) ASSIGN statement. */
1523 match
1524 gfc_match_assign (void)
1526 gfc_expr *expr;
1527 gfc_st_label *label;
1529 if (gfc_match (" %l", &label) == MATCH_YES)
1531 if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
1532 return MATCH_ERROR;
1533 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
1535 if (gfc_notify_std (GFC_STD_F95_DEL,
1536 "Obsolete: ASSIGN statement at %C")
1537 == FAILURE)
1538 return MATCH_ERROR;
1540 expr->symtree->n.sym->attr.assign = 1;
1542 new_st.op = EXEC_LABEL_ASSIGN;
1543 new_st.label = label;
1544 new_st.expr = expr;
1545 return MATCH_YES;
1548 return MATCH_NO;
1552 /* Match the GO TO statement. As a computed GOTO statement is
1553 matched, it is transformed into an equivalent SELECT block. No
1554 tree is necessary, and the resulting jumps-to-jumps are
1555 specifically optimized away by the back end. */
1557 match
1558 gfc_match_goto (void)
1560 gfc_code *head, *tail;
1561 gfc_expr *expr;
1562 gfc_case *cp;
1563 gfc_st_label *label;
1564 int i;
1565 match m;
1567 if (gfc_match (" %l%t", &label) == MATCH_YES)
1569 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1570 return MATCH_ERROR;
1572 new_st.op = EXEC_GOTO;
1573 new_st.label = label;
1574 return MATCH_YES;
1577 /* The assigned GO TO statement. */
1579 if (gfc_match_variable (&expr, 0) == MATCH_YES)
1581 if (gfc_notify_std (GFC_STD_F95_DEL,
1582 "Obsolete: Assigned GOTO statement at %C")
1583 == FAILURE)
1584 return MATCH_ERROR;
1586 new_st.op = EXEC_GOTO;
1587 new_st.expr = expr;
1589 if (gfc_match_eos () == MATCH_YES)
1590 return MATCH_YES;
1592 /* Match label list. */
1593 gfc_match_char (',');
1594 if (gfc_match_char ('(') != MATCH_YES)
1596 gfc_syntax_error (ST_GOTO);
1597 return MATCH_ERROR;
1599 head = tail = NULL;
1603 m = gfc_match_st_label (&label);
1604 if (m != MATCH_YES)
1605 goto syntax;
1607 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1608 goto cleanup;
1610 if (head == NULL)
1611 head = tail = gfc_get_code ();
1612 else
1614 tail->block = gfc_get_code ();
1615 tail = tail->block;
1618 tail->label = label;
1619 tail->op = EXEC_GOTO;
1621 while (gfc_match_char (',') == MATCH_YES);
1623 if (gfc_match (")%t") != MATCH_YES)
1624 goto syntax;
1626 if (head == NULL)
1628 gfc_error (
1629 "Statement label list in GOTO at %C cannot be empty");
1630 goto syntax;
1632 new_st.block = head;
1634 return MATCH_YES;
1637 /* Last chance is a computed GO TO statement. */
1638 if (gfc_match_char ('(') != MATCH_YES)
1640 gfc_syntax_error (ST_GOTO);
1641 return MATCH_ERROR;
1644 head = tail = NULL;
1645 i = 1;
1649 m = gfc_match_st_label (&label);
1650 if (m != MATCH_YES)
1651 goto syntax;
1653 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1654 goto cleanup;
1656 if (head == NULL)
1657 head = tail = gfc_get_code ();
1658 else
1660 tail->block = gfc_get_code ();
1661 tail = tail->block;
1664 cp = gfc_get_case ();
1665 cp->low = cp->high = gfc_int_expr (i++);
1667 tail->op = EXEC_SELECT;
1668 tail->ext.case_list = cp;
1670 tail->next = gfc_get_code ();
1671 tail->next->op = EXEC_GOTO;
1672 tail->next->label = label;
1674 while (gfc_match_char (',') == MATCH_YES);
1676 if (gfc_match_char (')') != MATCH_YES)
1677 goto syntax;
1679 if (head == NULL)
1681 gfc_error ("Statement label list in GOTO at %C cannot be empty");
1682 goto syntax;
1685 /* Get the rest of the statement. */
1686 gfc_match_char (',');
1688 if (gfc_match (" %e%t", &expr) != MATCH_YES)
1689 goto syntax;
1691 /* At this point, a computed GOTO has been fully matched and an
1692 equivalent SELECT statement constructed. */
1694 new_st.op = EXEC_SELECT;
1695 new_st.expr = NULL;
1697 /* Hack: For a "real" SELECT, the expression is in expr. We put
1698 it in expr2 so we can distinguish then and produce the correct
1699 diagnostics. */
1700 new_st.expr2 = expr;
1701 new_st.block = head;
1702 return MATCH_YES;
1704 syntax:
1705 gfc_syntax_error (ST_GOTO);
1706 cleanup:
1707 gfc_free_statements (head);
1708 return MATCH_ERROR;
1712 /* Frees a list of gfc_alloc structures. */
1714 void
1715 gfc_free_alloc_list (gfc_alloc * p)
1717 gfc_alloc *q;
1719 for (; p; p = q)
1721 q = p->next;
1722 gfc_free_expr (p->expr);
1723 gfc_free (p);
1728 /* Match an ALLOCATE statement. */
1730 match
1731 gfc_match_allocate (void)
1733 gfc_alloc *head, *tail;
1734 gfc_expr *stat;
1735 match m;
1737 head = tail = NULL;
1738 stat = NULL;
1740 if (gfc_match_char ('(') != MATCH_YES)
1741 goto syntax;
1743 for (;;)
1745 if (head == NULL)
1746 head = tail = gfc_get_alloc ();
1747 else
1749 tail->next = gfc_get_alloc ();
1750 tail = tail->next;
1753 m = gfc_match_variable (&tail->expr, 0);
1754 if (m == MATCH_NO)
1755 goto syntax;
1756 if (m == MATCH_ERROR)
1757 goto cleanup;
1759 if (gfc_check_do_variable (tail->expr->symtree))
1760 goto cleanup;
1762 if (gfc_pure (NULL)
1763 && gfc_impure_variable (tail->expr->symtree->n.sym))
1765 gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1766 "PURE procedure");
1767 goto cleanup;
1770 if (gfc_match_char (',') != MATCH_YES)
1771 break;
1773 m = gfc_match (" stat = %v", &stat);
1774 if (m == MATCH_ERROR)
1775 goto cleanup;
1776 if (m == MATCH_YES)
1777 break;
1780 if (stat != NULL)
1782 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1784 gfc_error
1785 ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
1786 "INTENT(IN)", stat->symtree->n.sym->name);
1787 goto cleanup;
1790 if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
1792 gfc_error
1793 ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
1794 "procedure");
1795 goto cleanup;
1798 if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1800 gfc_error("STAT expression at %C must be a variable");
1801 goto cleanup;
1804 gfc_check_do_variable(stat->symtree);
1807 if (gfc_match (" )%t") != MATCH_YES)
1808 goto syntax;
1810 new_st.op = EXEC_ALLOCATE;
1811 new_st.expr = stat;
1812 new_st.ext.alloc_list = head;
1814 return MATCH_YES;
1816 syntax:
1817 gfc_syntax_error (ST_ALLOCATE);
1819 cleanup:
1820 gfc_free_expr (stat);
1821 gfc_free_alloc_list (head);
1822 return MATCH_ERROR;
1826 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1827 a set of pointer assignments to intrinsic NULL(). */
1829 match
1830 gfc_match_nullify (void)
1832 gfc_code *tail;
1833 gfc_expr *e, *p;
1834 match m;
1836 tail = NULL;
1838 if (gfc_match_char ('(') != MATCH_YES)
1839 goto syntax;
1841 for (;;)
1843 m = gfc_match_variable (&p, 0);
1844 if (m == MATCH_ERROR)
1845 goto cleanup;
1846 if (m == MATCH_NO)
1847 goto syntax;
1849 if (gfc_check_do_variable(p->symtree))
1850 goto cleanup;
1852 if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
1854 gfc_error
1855 ("Illegal variable in NULLIFY at %C for a PURE procedure");
1856 goto cleanup;
1859 /* build ' => NULL() ' */
1860 e = gfc_get_expr ();
1861 e->where = gfc_current_locus;
1862 e->expr_type = EXPR_NULL;
1863 e->ts.type = BT_UNKNOWN;
1865 /* Chain to list */
1866 if (tail == NULL)
1867 tail = &new_st;
1868 else
1870 tail->next = gfc_get_code ();
1871 tail = tail->next;
1874 tail->op = EXEC_POINTER_ASSIGN;
1875 tail->expr = p;
1876 tail->expr2 = e;
1878 if (gfc_match (" )%t") == MATCH_YES)
1879 break;
1880 if (gfc_match_char (',') != MATCH_YES)
1881 goto syntax;
1884 return MATCH_YES;
1886 syntax:
1887 gfc_syntax_error (ST_NULLIFY);
1889 cleanup:
1890 gfc_free_statements (tail);
1891 return MATCH_ERROR;
1895 /* Match a DEALLOCATE statement. */
1897 match
1898 gfc_match_deallocate (void)
1900 gfc_alloc *head, *tail;
1901 gfc_expr *stat;
1902 match m;
1904 head = tail = NULL;
1905 stat = NULL;
1907 if (gfc_match_char ('(') != MATCH_YES)
1908 goto syntax;
1910 for (;;)
1912 if (head == NULL)
1913 head = tail = gfc_get_alloc ();
1914 else
1916 tail->next = gfc_get_alloc ();
1917 tail = tail->next;
1920 m = gfc_match_variable (&tail->expr, 0);
1921 if (m == MATCH_ERROR)
1922 goto cleanup;
1923 if (m == MATCH_NO)
1924 goto syntax;
1926 if (gfc_check_do_variable (tail->expr->symtree))
1927 goto cleanup;
1929 if (gfc_pure (NULL)
1930 && gfc_impure_variable (tail->expr->symtree->n.sym))
1932 gfc_error
1933 ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
1934 "procedure");
1935 goto cleanup;
1938 if (gfc_match_char (',') != MATCH_YES)
1939 break;
1941 m = gfc_match (" stat = %v", &stat);
1942 if (m == MATCH_ERROR)
1943 goto cleanup;
1944 if (m == MATCH_YES)
1945 break;
1948 if (stat != NULL)
1950 if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1952 gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
1953 "cannot be INTENT(IN)", stat->symtree->n.sym->name);
1954 goto cleanup;
1957 if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym))
1959 gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
1960 "for a PURE procedure");
1961 goto cleanup;
1964 if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1966 gfc_error("STAT expression at %C must be a variable");
1967 goto cleanup;
1970 gfc_check_do_variable(stat->symtree);
1973 if (gfc_match (" )%t") != MATCH_YES)
1974 goto syntax;
1976 new_st.op = EXEC_DEALLOCATE;
1977 new_st.expr = stat;
1978 new_st.ext.alloc_list = head;
1980 return MATCH_YES;
1982 syntax:
1983 gfc_syntax_error (ST_DEALLOCATE);
1985 cleanup:
1986 gfc_free_expr (stat);
1987 gfc_free_alloc_list (head);
1988 return MATCH_ERROR;
1992 /* Match a RETURN statement. */
1994 match
1995 gfc_match_return (void)
1997 gfc_expr *e;
1998 match m;
1999 gfc_compile_state s;
2000 int c;
2002 e = NULL;
2003 if (gfc_match_eos () == MATCH_YES)
2004 goto done;
2006 if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
2008 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2009 "a SUBROUTINE");
2010 goto cleanup;
2013 if (gfc_current_form == FORM_FREE)
2015 /* The following are valid, so we can't require a blank after the
2016 RETURN keyword:
2017 return+1
2018 return(1) */
2019 c = gfc_peek_char ();
2020 if (ISALPHA (c) || ISDIGIT (c))
2021 return MATCH_NO;
2024 m = gfc_match (" %e%t", &e);
2025 if (m == MATCH_YES)
2026 goto done;
2027 if (m == MATCH_ERROR)
2028 goto cleanup;
2030 gfc_syntax_error (ST_RETURN);
2032 cleanup:
2033 gfc_free_expr (e);
2034 return MATCH_ERROR;
2036 done:
2037 gfc_enclosing_unit (&s);
2038 if (s == COMP_PROGRAM
2039 && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
2040 "main program at %C") == FAILURE)
2041 return MATCH_ERROR;
2043 new_st.op = EXEC_RETURN;
2044 new_st.expr = e;
2046 return MATCH_YES;
2050 /* Match a CALL statement. The tricky part here are possible
2051 alternate return specifiers. We handle these by having all
2052 "subroutines" actually return an integer via a register that gives
2053 the return number. If the call specifies alternate returns, we
2054 generate code for a SELECT statement whose case clauses contain
2055 GOTOs to the various labels. */
2057 match
2058 gfc_match_call (void)
2060 char name[GFC_MAX_SYMBOL_LEN + 1];
2061 gfc_actual_arglist *a, *arglist;
2062 gfc_case *new_case;
2063 gfc_symbol *sym;
2064 gfc_symtree *st;
2065 gfc_code *c;
2066 match m;
2067 int i;
2069 arglist = NULL;
2071 m = gfc_match ("% %n", name);
2072 if (m == MATCH_NO)
2073 goto syntax;
2074 if (m != MATCH_YES)
2075 return m;
2077 if (gfc_get_ha_sym_tree (name, &st))
2078 return MATCH_ERROR;
2080 sym = st->n.sym;
2081 gfc_set_sym_referenced (sym);
2083 if (!sym->attr.generic
2084 && !sym->attr.subroutine
2085 && gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2086 return MATCH_ERROR;
2088 if (gfc_match_eos () != MATCH_YES)
2090 m = gfc_match_actual_arglist (1, &arglist);
2091 if (m == MATCH_NO)
2092 goto syntax;
2093 if (m == MATCH_ERROR)
2094 goto cleanup;
2096 if (gfc_match_eos () != MATCH_YES)
2097 goto syntax;
2100 /* If any alternate return labels were found, construct a SELECT
2101 statement that will jump to the right place. */
2103 i = 0;
2104 for (a = arglist; a; a = a->next)
2105 if (a->expr == NULL)
2106 i = 1;
2108 if (i)
2110 gfc_symtree *select_st;
2111 gfc_symbol *select_sym;
2112 char name[GFC_MAX_SYMBOL_LEN + 1];
2114 new_st.next = c = gfc_get_code ();
2115 c->op = EXEC_SELECT;
2116 sprintf (name, "_result_%s",sym->name);
2117 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail */
2119 select_sym = select_st->n.sym;
2120 select_sym->ts.type = BT_INTEGER;
2121 select_sym->ts.kind = gfc_default_integer_kind;
2122 gfc_set_sym_referenced (select_sym);
2123 c->expr = gfc_get_expr ();
2124 c->expr->expr_type = EXPR_VARIABLE;
2125 c->expr->symtree = select_st;
2126 c->expr->ts = select_sym->ts;
2127 c->expr->where = gfc_current_locus;
2129 i = 0;
2130 for (a = arglist; a; a = a->next)
2132 if (a->expr != NULL)
2133 continue;
2135 if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2136 continue;
2138 i++;
2140 c->block = gfc_get_code ();
2141 c = c->block;
2142 c->op = EXEC_SELECT;
2144 new_case = gfc_get_case ();
2145 new_case->high = new_case->low = gfc_int_expr (i);
2146 c->ext.case_list = new_case;
2148 c->next = gfc_get_code ();
2149 c->next->op = EXEC_GOTO;
2150 c->next->label = a->label;
2154 new_st.op = EXEC_CALL;
2155 new_st.symtree = st;
2156 new_st.ext.actual = arglist;
2158 return MATCH_YES;
2160 syntax:
2161 gfc_syntax_error (ST_CALL);
2163 cleanup:
2164 gfc_free_actual_arglist (arglist);
2165 return MATCH_ERROR;
2169 /* Given a name, return a pointer to the common head structure,
2170 creating it if it does not exist. If FROM_MODULE is nonzero, we
2171 mangle the name so that it doesn't interfere with commons defined
2172 in the using namespace.
2173 TODO: Add to global symbol tree. */
2175 gfc_common_head *
2176 gfc_get_common (const char *name, int from_module)
2178 gfc_symtree *st;
2179 static int serial = 0;
2180 char mangled_name[GFC_MAX_SYMBOL_LEN+1];
2182 if (from_module)
2184 /* A use associated common block is only needed to correctly layout
2185 the variables it contains. */
2186 snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2187 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2189 else
2191 st = gfc_find_symtree (gfc_current_ns->common_root, name);
2193 if (st == NULL)
2194 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2197 if (st->n.common == NULL)
2199 st->n.common = gfc_get_common_head ();
2200 st->n.common->where = gfc_current_locus;
2201 strcpy (st->n.common->name, name);
2204 return st->n.common;
2208 /* Match a common block name. */
2210 static match
2211 match_common_name (char *name)
2213 match m;
2215 if (gfc_match_char ('/') == MATCH_NO)
2217 name[0] = '\0';
2218 return MATCH_YES;
2221 if (gfc_match_char ('/') == MATCH_YES)
2223 name[0] = '\0';
2224 return MATCH_YES;
2227 m = gfc_match_name (name);
2229 if (m == MATCH_ERROR)
2230 return MATCH_ERROR;
2231 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2232 return MATCH_YES;
2234 gfc_error ("Syntax error in common block name at %C");
2235 return MATCH_ERROR;
2239 /* Match a COMMON statement. */
2241 match
2242 gfc_match_common (void)
2244 gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
2245 char name[GFC_MAX_SYMBOL_LEN+1];
2246 gfc_common_head *t;
2247 gfc_array_spec *as;
2248 gfc_equiv * e1, * e2;
2249 match m;
2251 old_blank_common = gfc_current_ns->blank_common.head;
2252 if (old_blank_common)
2254 while (old_blank_common->common_next)
2255 old_blank_common = old_blank_common->common_next;
2258 as = NULL;
2260 for (;;)
2262 m = match_common_name (name);
2263 if (m == MATCH_ERROR)
2264 goto cleanup;
2266 if (name[0] == '\0')
2268 t = &gfc_current_ns->blank_common;
2269 if (t->head == NULL)
2270 t->where = gfc_current_locus;
2271 head = &t->head;
2273 else
2275 t = gfc_get_common (name, 0);
2276 head = &t->head;
2279 if (*head == NULL)
2280 tail = NULL;
2281 else
2283 tail = *head;
2284 while (tail->common_next)
2285 tail = tail->common_next;
2288 /* Grab the list of symbols. */
2289 for (;;)
2291 m = gfc_match_symbol (&sym, 0);
2292 if (m == MATCH_ERROR)
2293 goto cleanup;
2294 if (m == MATCH_NO)
2295 goto syntax;
2297 if (sym->attr.in_common)
2299 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2300 sym->name);
2301 goto cleanup;
2304 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2305 goto cleanup;
2307 if (sym->value != NULL
2308 && (name[0] == '\0' || !sym->attr.data))
2310 if (name[0] == '\0')
2311 gfc_error ("Previously initialized symbol '%s' in "
2312 "blank COMMON block at %C", sym->name);
2313 else
2314 gfc_error ("Previously initialized symbol '%s' in "
2315 "COMMON block '%s' at %C", sym->name, name);
2316 goto cleanup;
2319 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2320 goto cleanup;
2322 /* Derived type names must have the SEQUENCE attribute. */
2323 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2325 gfc_error
2326 ("Derived type variable in COMMON at %C does not have the "
2327 "SEQUENCE attribute");
2328 goto cleanup;
2331 if (tail != NULL)
2332 tail->common_next = sym;
2333 else
2334 *head = sym;
2336 tail = sym;
2338 /* Deal with an optional array specification after the
2339 symbol name. */
2340 m = gfc_match_array_spec (&as);
2341 if (m == MATCH_ERROR)
2342 goto cleanup;
2344 if (m == MATCH_YES)
2346 if (as->type != AS_EXPLICIT)
2348 gfc_error
2349 ("Array specification for symbol '%s' in COMMON at %C "
2350 "must be explicit", sym->name);
2351 goto cleanup;
2354 if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2355 goto cleanup;
2357 if (sym->attr.pointer)
2359 gfc_error
2360 ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2361 sym->name);
2362 goto cleanup;
2365 sym->as = as;
2366 as = NULL;
2370 sym->common_head = t;
2372 /* Check to see if the symbol is already in an equivalence group.
2373 If it is, set the other members as being in common. */
2374 if (sym->attr.in_equivalence)
2376 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
2378 for (e2 = e1; e2; e2 = e2->eq)
2379 if (e2->expr->symtree->n.sym == sym)
2380 goto equiv_found;
2382 continue;
2384 equiv_found:
2386 for (e2 = e1; e2; e2 = e2->eq)
2388 other = e2->expr->symtree->n.sym;
2389 if (other->common_head
2390 && other->common_head != sym->common_head)
2392 gfc_error ("Symbol '%s', in COMMON block '%s' at "
2393 "%C is being indirectly equivalenced to "
2394 "another COMMON block '%s'",
2395 sym->name,
2396 sym->common_head->name,
2397 other->common_head->name);
2398 goto cleanup;
2400 other->attr.in_common = 1;
2401 other->common_head = t;
2407 gfc_gobble_whitespace ();
2408 if (gfc_match_eos () == MATCH_YES)
2409 goto done;
2410 if (gfc_peek_char () == '/')
2411 break;
2412 if (gfc_match_char (',') != MATCH_YES)
2413 goto syntax;
2414 gfc_gobble_whitespace ();
2415 if (gfc_peek_char () == '/')
2416 break;
2420 done:
2421 return MATCH_YES;
2423 syntax:
2424 gfc_syntax_error (ST_COMMON);
2426 cleanup:
2427 if (old_blank_common)
2428 old_blank_common->common_next = NULL;
2429 else
2430 gfc_current_ns->blank_common.head = NULL;
2431 gfc_free_array_spec (as);
2432 return MATCH_ERROR;
2436 /* Match a BLOCK DATA program unit. */
2438 match
2439 gfc_match_block_data (void)
2441 char name[GFC_MAX_SYMBOL_LEN + 1];
2442 gfc_symbol *sym;
2443 match m;
2445 if (gfc_match_eos () == MATCH_YES)
2447 gfc_new_block = NULL;
2448 return MATCH_YES;
2451 m = gfc_match ("% %n%t", name);
2452 if (m != MATCH_YES)
2453 return MATCH_ERROR;
2455 if (gfc_get_symbol (name, NULL, &sym))
2456 return MATCH_ERROR;
2458 if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
2459 return MATCH_ERROR;
2461 gfc_new_block = sym;
2463 return MATCH_YES;
2467 /* Free a namelist structure. */
2469 void
2470 gfc_free_namelist (gfc_namelist * name)
2472 gfc_namelist *n;
2474 for (; name; name = n)
2476 n = name->next;
2477 gfc_free (name);
2482 /* Match a NAMELIST statement. */
2484 match
2485 gfc_match_namelist (void)
2487 gfc_symbol *group_name, *sym;
2488 gfc_namelist *nl;
2489 match m, m2;
2491 m = gfc_match (" / %s /", &group_name);
2492 if (m == MATCH_NO)
2493 goto syntax;
2494 if (m == MATCH_ERROR)
2495 goto error;
2497 for (;;)
2499 if (group_name->ts.type != BT_UNKNOWN)
2501 gfc_error
2502 ("Namelist group name '%s' at %C already has a basic type "
2503 "of %s", group_name->name, gfc_typename (&group_name->ts));
2504 return MATCH_ERROR;
2507 if (group_name->attr.flavor == FL_NAMELIST
2508 && group_name->attr.use_assoc
2509 && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
2510 "at %C already is USE associated and can"
2511 "not be respecified.", group_name->name)
2512 == FAILURE)
2513 return MATCH_ERROR;
2515 if (group_name->attr.flavor != FL_NAMELIST
2516 && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
2517 group_name->name, NULL) == FAILURE)
2518 return MATCH_ERROR;
2520 for (;;)
2522 m = gfc_match_symbol (&sym, 1);
2523 if (m == MATCH_NO)
2524 goto syntax;
2525 if (m == MATCH_ERROR)
2526 goto error;
2528 if (sym->attr.in_namelist == 0
2529 && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
2530 goto error;
2532 /* Use gfc_error_check here, rather than goto error, so that this
2533 these are the only errors for the next two lines. */
2534 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
2536 gfc_error ("Assumed size array '%s' in namelist '%s'at "
2537 "%C is not allowed.", sym->name, group_name->name);
2538 gfc_error_check ();
2541 if (sym->as && sym->as->type == AS_ASSUMED_SHAPE
2542 && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
2543 "namelist '%s' at %C is an extension.",
2544 sym->name, group_name->name) == FAILURE)
2545 gfc_error_check ();
2547 nl = gfc_get_namelist ();
2548 nl->sym = sym;
2550 if (group_name->namelist == NULL)
2551 group_name->namelist = group_name->namelist_tail = nl;
2552 else
2554 group_name->namelist_tail->next = nl;
2555 group_name->namelist_tail = nl;
2558 if (gfc_match_eos () == MATCH_YES)
2559 goto done;
2561 m = gfc_match_char (',');
2563 if (gfc_match_char ('/') == MATCH_YES)
2565 m2 = gfc_match (" %s /", &group_name);
2566 if (m2 == MATCH_YES)
2567 break;
2568 if (m2 == MATCH_ERROR)
2569 goto error;
2570 goto syntax;
2573 if (m != MATCH_YES)
2574 goto syntax;
2578 done:
2579 return MATCH_YES;
2581 syntax:
2582 gfc_syntax_error (ST_NAMELIST);
2584 error:
2585 return MATCH_ERROR;
2589 /* Match a MODULE statement. */
2591 match
2592 gfc_match_module (void)
2594 match m;
2596 m = gfc_match (" %s%t", &gfc_new_block);
2597 if (m != MATCH_YES)
2598 return m;
2600 if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
2601 gfc_new_block->name, NULL) == FAILURE)
2602 return MATCH_ERROR;
2604 return MATCH_YES;
2608 /* Free equivalence sets and lists. Recursively is the easiest way to
2609 do this. */
2611 void
2612 gfc_free_equiv (gfc_equiv * eq)
2615 if (eq == NULL)
2616 return;
2618 gfc_free_equiv (eq->eq);
2619 gfc_free_equiv (eq->next);
2621 gfc_free_expr (eq->expr);
2622 gfc_free (eq);
2626 /* Match an EQUIVALENCE statement. */
2628 match
2629 gfc_match_equivalence (void)
2631 gfc_equiv *eq, *set, *tail;
2632 gfc_ref *ref;
2633 gfc_symbol *sym;
2634 match m;
2635 gfc_common_head *common_head = NULL;
2636 bool common_flag;
2637 int cnt;
2639 tail = NULL;
2641 for (;;)
2643 eq = gfc_get_equiv ();
2644 if (tail == NULL)
2645 tail = eq;
2647 eq->next = gfc_current_ns->equiv;
2648 gfc_current_ns->equiv = eq;
2650 if (gfc_match_char ('(') != MATCH_YES)
2651 goto syntax;
2653 set = eq;
2654 common_flag = FALSE;
2655 cnt = 0;
2657 for (;;)
2659 m = gfc_match_equiv_variable (&set->expr);
2660 if (m == MATCH_ERROR)
2661 goto cleanup;
2662 if (m == MATCH_NO)
2663 goto syntax;
2665 /* count the number of objects. */
2666 cnt++;
2668 if (gfc_match_char ('%') == MATCH_YES)
2670 gfc_error ("Derived type component %C is not a "
2671 "permitted EQUIVALENCE member");
2672 goto cleanup;
2675 for (ref = set->expr->ref; ref; ref = ref->next)
2676 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2678 gfc_error
2679 ("Array reference in EQUIVALENCE at %C cannot be an "
2680 "array section");
2681 goto cleanup;
2684 sym = set->expr->symtree->n.sym;
2686 if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL)
2687 == FAILURE)
2688 goto cleanup;
2690 if (sym->attr.in_common)
2692 common_flag = TRUE;
2693 common_head = sym->common_head;
2696 if (gfc_match_char (')') == MATCH_YES)
2697 break;
2699 if (gfc_match_char (',') != MATCH_YES)
2700 goto syntax;
2702 set->eq = gfc_get_equiv ();
2703 set = set->eq;
2706 if (cnt < 2)
2708 gfc_error ("EQUIVALENCE at %C requires two or more objects");
2709 goto cleanup;
2712 /* If one of the members of an equivalence is in common, then
2713 mark them all as being in common. Before doing this, check
2714 that members of the equivalence group are not in different
2715 common blocks. */
2716 if (common_flag)
2717 for (set = eq; set; set = set->eq)
2719 sym = set->expr->symtree->n.sym;
2720 if (sym->common_head && sym->common_head != common_head)
2722 gfc_error ("Attempt to indirectly overlap COMMON "
2723 "blocks %s and %s by EQUIVALENCE at %C",
2724 sym->common_head->name,
2725 common_head->name);
2726 goto cleanup;
2728 sym->attr.in_common = 1;
2729 sym->common_head = common_head;
2732 if (gfc_match_eos () == MATCH_YES)
2733 break;
2734 if (gfc_match_char (',') != MATCH_YES)
2735 goto syntax;
2738 return MATCH_YES;
2740 syntax:
2741 gfc_syntax_error (ST_EQUIVALENCE);
2743 cleanup:
2744 eq = tail->next;
2745 tail->next = NULL;
2747 gfc_free_equiv (gfc_current_ns->equiv);
2748 gfc_current_ns->equiv = eq;
2750 return MATCH_ERROR;
2753 /* Check that a statement function is not recursive. This is done by looking
2754 for the statement function symbol(sym) by looking recursively through its
2755 expression(e). If a reference to sym is found, true is returned. */
2756 static bool
2757 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
2759 gfc_actual_arglist *arg;
2760 gfc_ref *ref;
2761 int i;
2763 if (e == NULL)
2764 return false;
2766 switch (e->expr_type)
2768 case EXPR_FUNCTION:
2769 for (arg = e->value.function.actual; arg; arg = arg->next)
2771 if (sym->name == arg->name
2772 || recursive_stmt_fcn (arg->expr, sym))
2773 return true;
2776 if (e->symtree == NULL)
2777 return false;
2779 /* Check the name before testing for nested recursion! */
2780 if (sym->name == e->symtree->n.sym->name)
2781 return true;
2783 /* Catch recursion via other statement functions. */
2784 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
2785 && e->symtree->n.sym->value
2786 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
2787 return true;
2789 break;
2791 case EXPR_VARIABLE:
2792 if (e->symtree && sym->name == e->symtree->n.sym->name)
2793 return true;
2794 break;
2796 case EXPR_OP:
2797 if (recursive_stmt_fcn (e->value.op.op1, sym)
2798 || recursive_stmt_fcn (e->value.op.op2, sym))
2799 return true;
2800 break;
2802 default:
2803 break;
2806 /* Component references do not need to be checked. */
2807 if (e->ref)
2809 for (ref = e->ref; ref; ref = ref->next)
2811 switch (ref->type)
2813 case REF_ARRAY:
2814 for (i = 0; i < ref->u.ar.dimen; i++)
2816 if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
2817 || recursive_stmt_fcn (ref->u.ar.end[i], sym)
2818 || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
2819 return true;
2821 break;
2823 case REF_SUBSTRING:
2824 if (recursive_stmt_fcn (ref->u.ss.start, sym)
2825 || recursive_stmt_fcn (ref->u.ss.end, sym))
2826 return true;
2828 break;
2830 default:
2831 break;
2835 return false;
2839 /* Match a statement function declaration. It is so easy to match
2840 non-statement function statements with a MATCH_ERROR as opposed to
2841 MATCH_NO that we suppress error message in most cases. */
2843 match
2844 gfc_match_st_function (void)
2846 gfc_error_buf old_error;
2847 gfc_symbol *sym;
2848 gfc_expr *expr;
2849 match m;
2851 m = gfc_match_symbol (&sym, 0);
2852 if (m != MATCH_YES)
2853 return m;
2855 gfc_push_error (&old_error);
2857 if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
2858 sym->name, NULL) == FAILURE)
2859 goto undo_error;
2861 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2862 goto undo_error;
2864 m = gfc_match (" = %e%t", &expr);
2865 if (m == MATCH_NO)
2866 goto undo_error;
2868 gfc_free_error (&old_error);
2869 if (m == MATCH_ERROR)
2870 return m;
2872 if (recursive_stmt_fcn (expr, sym))
2874 gfc_error ("Statement function at %L is recursive",
2875 &expr->where);
2876 return MATCH_ERROR;
2879 sym->value = expr;
2881 return MATCH_YES;
2883 undo_error:
2884 gfc_pop_error (&old_error);
2885 return MATCH_NO;
2889 /***************** SELECT CASE subroutines ******************/
2891 /* Free a single case structure. */
2893 static void
2894 free_case (gfc_case * p)
2896 if (p->low == p->high)
2897 p->high = NULL;
2898 gfc_free_expr (p->low);
2899 gfc_free_expr (p->high);
2900 gfc_free (p);
2904 /* Free a list of case structures. */
2906 void
2907 gfc_free_case_list (gfc_case * p)
2909 gfc_case *q;
2911 for (; p; p = q)
2913 q = p->next;
2914 free_case (p);
2919 /* Match a single case selector. */
2921 static match
2922 match_case_selector (gfc_case ** cp)
2924 gfc_case *c;
2925 match m;
2927 c = gfc_get_case ();
2928 c->where = gfc_current_locus;
2930 if (gfc_match_char (':') == MATCH_YES)
2932 m = gfc_match_init_expr (&c->high);
2933 if (m == MATCH_NO)
2934 goto need_expr;
2935 if (m == MATCH_ERROR)
2936 goto cleanup;
2939 else
2941 m = gfc_match_init_expr (&c->low);
2942 if (m == MATCH_ERROR)
2943 goto cleanup;
2944 if (m == MATCH_NO)
2945 goto need_expr;
2947 /* If we're not looking at a ':' now, make a range out of a single
2948 target. Else get the upper bound for the case range. */
2949 if (gfc_match_char (':') != MATCH_YES)
2950 c->high = c->low;
2951 else
2953 m = gfc_match_init_expr (&c->high);
2954 if (m == MATCH_ERROR)
2955 goto cleanup;
2956 /* MATCH_NO is fine. It's OK if nothing is there! */
2960 *cp = c;
2961 return MATCH_YES;
2963 need_expr:
2964 gfc_error ("Expected initialization expression in CASE at %C");
2966 cleanup:
2967 free_case (c);
2968 return MATCH_ERROR;
2972 /* Match the end of a case statement. */
2974 static match
2975 match_case_eos (void)
2977 char name[GFC_MAX_SYMBOL_LEN + 1];
2978 match m;
2980 if (gfc_match_eos () == MATCH_YES)
2981 return MATCH_YES;
2983 gfc_gobble_whitespace ();
2985 m = gfc_match_name (name);
2986 if (m != MATCH_YES)
2987 return m;
2989 if (strcmp (name, gfc_current_block ()->name) != 0)
2991 gfc_error ("Expected case name of '%s' at %C",
2992 gfc_current_block ()->name);
2993 return MATCH_ERROR;
2996 return gfc_match_eos ();
3000 /* Match a SELECT statement. */
3002 match
3003 gfc_match_select (void)
3005 gfc_expr *expr;
3006 match m;
3008 m = gfc_match_label ();
3009 if (m == MATCH_ERROR)
3010 return m;
3012 m = gfc_match (" select case ( %e )%t", &expr);
3013 if (m != MATCH_YES)
3014 return m;
3016 new_st.op = EXEC_SELECT;
3017 new_st.expr = expr;
3019 return MATCH_YES;
3023 /* Match a CASE statement. */
3025 match
3026 gfc_match_case (void)
3028 gfc_case *c, *head, *tail;
3029 match m;
3031 head = tail = NULL;
3033 if (gfc_current_state () != COMP_SELECT)
3035 gfc_error ("Unexpected CASE statement at %C");
3036 return MATCH_ERROR;
3039 if (gfc_match ("% default") == MATCH_YES)
3041 m = match_case_eos ();
3042 if (m == MATCH_NO)
3043 goto syntax;
3044 if (m == MATCH_ERROR)
3045 goto cleanup;
3047 new_st.op = EXEC_SELECT;
3048 c = gfc_get_case ();
3049 c->where = gfc_current_locus;
3050 new_st.ext.case_list = c;
3051 return MATCH_YES;
3054 if (gfc_match_char ('(') != MATCH_YES)
3055 goto syntax;
3057 for (;;)
3059 if (match_case_selector (&c) == MATCH_ERROR)
3060 goto cleanup;
3062 if (head == NULL)
3063 head = c;
3064 else
3065 tail->next = c;
3067 tail = c;
3069 if (gfc_match_char (')') == MATCH_YES)
3070 break;
3071 if (gfc_match_char (',') != MATCH_YES)
3072 goto syntax;
3075 m = match_case_eos ();
3076 if (m == MATCH_NO)
3077 goto syntax;
3078 if (m == MATCH_ERROR)
3079 goto cleanup;
3081 new_st.op = EXEC_SELECT;
3082 new_st.ext.case_list = head;
3084 return MATCH_YES;
3086 syntax:
3087 gfc_error ("Syntax error in CASE-specification at %C");
3089 cleanup:
3090 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
3091 return MATCH_ERROR;
3094 /********************* WHERE subroutines ********************/
3096 /* Match the rest of a simple WHERE statement that follows an IF statement.
3099 static match
3100 match_simple_where (void)
3102 gfc_expr *expr;
3103 gfc_code *c;
3104 match m;
3106 m = gfc_match (" ( %e )", &expr);
3107 if (m != MATCH_YES)
3108 return m;
3110 m = gfc_match_assignment ();
3111 if (m == MATCH_NO)
3112 goto syntax;
3113 if (m == MATCH_ERROR)
3114 goto cleanup;
3116 if (gfc_match_eos () != MATCH_YES)
3117 goto syntax;
3119 c = gfc_get_code ();
3121 c->op = EXEC_WHERE;
3122 c->expr = expr;
3123 c->next = gfc_get_code ();
3125 *c->next = new_st;
3126 gfc_clear_new_st ();
3128 new_st.op = EXEC_WHERE;
3129 new_st.block = c;
3131 return MATCH_YES;
3133 syntax:
3134 gfc_syntax_error (ST_WHERE);
3136 cleanup:
3137 gfc_free_expr (expr);
3138 return MATCH_ERROR;
3141 /* Match a WHERE statement. */
3143 match
3144 gfc_match_where (gfc_statement * st)
3146 gfc_expr *expr;
3147 match m0, m;
3148 gfc_code *c;
3150 m0 = gfc_match_label ();
3151 if (m0 == MATCH_ERROR)
3152 return m0;
3154 m = gfc_match (" where ( %e )", &expr);
3155 if (m != MATCH_YES)
3156 return m;
3158 if (gfc_match_eos () == MATCH_YES)
3160 *st = ST_WHERE_BLOCK;
3162 new_st.op = EXEC_WHERE;
3163 new_st.expr = expr;
3164 return MATCH_YES;
3167 m = gfc_match_assignment ();
3168 if (m == MATCH_NO)
3169 gfc_syntax_error (ST_WHERE);
3171 if (m != MATCH_YES)
3173 gfc_free_expr (expr);
3174 return MATCH_ERROR;
3177 /* We've got a simple WHERE statement. */
3178 *st = ST_WHERE;
3179 c = gfc_get_code ();
3181 c->op = EXEC_WHERE;
3182 c->expr = expr;
3183 c->next = gfc_get_code ();
3185 *c->next = new_st;
3186 gfc_clear_new_st ();
3188 new_st.op = EXEC_WHERE;
3189 new_st.block = c;
3191 return MATCH_YES;
3195 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3196 new_st if successful. */
3198 match
3199 gfc_match_elsewhere (void)
3201 char name[GFC_MAX_SYMBOL_LEN + 1];
3202 gfc_expr *expr;
3203 match m;
3205 if (gfc_current_state () != COMP_WHERE)
3207 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3208 return MATCH_ERROR;
3211 expr = NULL;
3213 if (gfc_match_char ('(') == MATCH_YES)
3215 m = gfc_match_expr (&expr);
3216 if (m == MATCH_NO)
3217 goto syntax;
3218 if (m == MATCH_ERROR)
3219 return MATCH_ERROR;
3221 if (gfc_match_char (')') != MATCH_YES)
3222 goto syntax;
3225 if (gfc_match_eos () != MATCH_YES)
3226 { /* Better be a name at this point */
3227 m = gfc_match_name (name);
3228 if (m == MATCH_NO)
3229 goto syntax;
3230 if (m == MATCH_ERROR)
3231 goto cleanup;
3233 if (gfc_match_eos () != MATCH_YES)
3234 goto syntax;
3236 if (strcmp (name, gfc_current_block ()->name) != 0)
3238 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3239 name, gfc_current_block ()->name);
3240 goto cleanup;
3244 new_st.op = EXEC_WHERE;
3245 new_st.expr = expr;
3246 return MATCH_YES;
3248 syntax:
3249 gfc_syntax_error (ST_ELSEWHERE);
3251 cleanup:
3252 gfc_free_expr (expr);
3253 return MATCH_ERROR;
3257 /******************** FORALL subroutines ********************/
3259 /* Free a list of FORALL iterators. */
3261 void
3262 gfc_free_forall_iterator (gfc_forall_iterator * iter)
3264 gfc_forall_iterator *next;
3266 while (iter)
3268 next = iter->next;
3270 gfc_free_expr (iter->var);
3271 gfc_free_expr (iter->start);
3272 gfc_free_expr (iter->end);
3273 gfc_free_expr (iter->stride);
3275 gfc_free (iter);
3276 iter = next;
3281 /* Match an iterator as part of a FORALL statement. The format is:
3283 <var> = <start>:<end>[:<stride>][, <scalar mask>] */
3285 static match
3286 match_forall_iterator (gfc_forall_iterator ** result)
3288 gfc_forall_iterator *iter;
3289 locus where;
3290 match m;
3292 where = gfc_current_locus;
3293 iter = gfc_getmem (sizeof (gfc_forall_iterator));
3295 m = gfc_match_variable (&iter->var, 0);
3296 if (m != MATCH_YES)
3297 goto cleanup;
3299 if (gfc_match_char ('=') != MATCH_YES)
3301 m = MATCH_NO;
3302 goto cleanup;
3305 m = gfc_match_expr (&iter->start);
3306 if (m != MATCH_YES)
3307 goto cleanup;
3309 if (gfc_match_char (':') != MATCH_YES)
3310 goto syntax;
3312 m = gfc_match_expr (&iter->end);
3313 if (m == MATCH_NO)
3314 goto syntax;
3315 if (m == MATCH_ERROR)
3316 goto cleanup;
3318 if (gfc_match_char (':') == MATCH_NO)
3319 iter->stride = gfc_int_expr (1);
3320 else
3322 m = gfc_match_expr (&iter->stride);
3323 if (m == MATCH_NO)
3324 goto syntax;
3325 if (m == MATCH_ERROR)
3326 goto cleanup;
3329 *result = iter;
3330 return MATCH_YES;
3332 syntax:
3333 gfc_error ("Syntax error in FORALL iterator at %C");
3334 m = MATCH_ERROR;
3336 cleanup:
3337 gfc_current_locus = where;
3338 gfc_free_forall_iterator (iter);
3339 return m;
3343 /* Match the header of a FORALL statement. */
3345 static match
3346 match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask)
3348 gfc_forall_iterator *head, *tail, *new;
3349 match m;
3351 gfc_gobble_whitespace ();
3353 head = tail = NULL;
3354 *mask = NULL;
3356 if (gfc_match_char ('(') != MATCH_YES)
3357 return MATCH_NO;
3359 m = match_forall_iterator (&new);
3360 if (m == MATCH_ERROR)
3361 goto cleanup;
3362 if (m == MATCH_NO)
3363 goto syntax;
3365 head = tail = new;
3367 for (;;)
3369 if (gfc_match_char (',') != MATCH_YES)
3370 break;
3372 m = match_forall_iterator (&new);
3373 if (m == MATCH_ERROR)
3374 goto cleanup;
3375 if (m == MATCH_YES)
3377 tail->next = new;
3378 tail = new;
3379 continue;
3382 /* Have to have a mask expression */
3384 m = gfc_match_expr (mask);
3385 if (m == MATCH_NO)
3386 goto syntax;
3387 if (m == MATCH_ERROR)
3388 goto cleanup;
3390 break;
3393 if (gfc_match_char (')') == MATCH_NO)
3394 goto syntax;
3396 *phead = head;
3397 return MATCH_YES;
3399 syntax:
3400 gfc_syntax_error (ST_FORALL);
3402 cleanup:
3403 gfc_free_expr (*mask);
3404 gfc_free_forall_iterator (head);
3406 return MATCH_ERROR;
3409 /* Match the rest of a simple FORALL statement that follows an IF statement.
3412 static match
3413 match_simple_forall (void)
3415 gfc_forall_iterator *head;
3416 gfc_expr *mask;
3417 gfc_code *c;
3418 match m;
3420 mask = NULL;
3421 head = NULL;
3422 c = NULL;
3424 m = match_forall_header (&head, &mask);
3426 if (m == MATCH_NO)
3427 goto syntax;
3428 if (m != MATCH_YES)
3429 goto cleanup;
3431 m = gfc_match_assignment ();
3433 if (m == MATCH_ERROR)
3434 goto cleanup;
3435 if (m == MATCH_NO)
3437 m = gfc_match_pointer_assignment ();
3438 if (m == MATCH_ERROR)
3439 goto cleanup;
3440 if (m == MATCH_NO)
3441 goto syntax;
3444 c = gfc_get_code ();
3445 *c = new_st;
3446 c->loc = gfc_current_locus;
3448 if (gfc_match_eos () != MATCH_YES)
3449 goto syntax;
3451 gfc_clear_new_st ();
3452 new_st.op = EXEC_FORALL;
3453 new_st.expr = mask;
3454 new_st.ext.forall_iterator = head;
3455 new_st.block = gfc_get_code ();
3457 new_st.block->op = EXEC_FORALL;
3458 new_st.block->next = c;
3460 return MATCH_YES;
3462 syntax:
3463 gfc_syntax_error (ST_FORALL);
3465 cleanup:
3466 gfc_free_forall_iterator (head);
3467 gfc_free_expr (mask);
3469 return MATCH_ERROR;
3473 /* Match a FORALL statement. */
3475 match
3476 gfc_match_forall (gfc_statement * st)
3478 gfc_forall_iterator *head;
3479 gfc_expr *mask;
3480 gfc_code *c;
3481 match m0, m;
3483 head = NULL;
3484 mask = NULL;
3485 c = NULL;
3487 m0 = gfc_match_label ();
3488 if (m0 == MATCH_ERROR)
3489 return MATCH_ERROR;
3491 m = gfc_match (" forall");
3492 if (m != MATCH_YES)
3493 return m;
3495 m = match_forall_header (&head, &mask);
3496 if (m == MATCH_ERROR)
3497 goto cleanup;
3498 if (m == MATCH_NO)
3499 goto syntax;
3501 if (gfc_match_eos () == MATCH_YES)
3503 *st = ST_FORALL_BLOCK;
3505 new_st.op = EXEC_FORALL;
3506 new_st.expr = mask;
3507 new_st.ext.forall_iterator = head;
3509 return MATCH_YES;
3512 m = gfc_match_assignment ();
3513 if (m == MATCH_ERROR)
3514 goto cleanup;
3515 if (m == MATCH_NO)
3517 m = gfc_match_pointer_assignment ();
3518 if (m == MATCH_ERROR)
3519 goto cleanup;
3520 if (m == MATCH_NO)
3521 goto syntax;
3524 c = gfc_get_code ();
3525 *c = new_st;
3527 if (gfc_match_eos () != MATCH_YES)
3528 goto syntax;
3530 gfc_clear_new_st ();
3531 new_st.op = EXEC_FORALL;
3532 new_st.expr = mask;
3533 new_st.ext.forall_iterator = head;
3534 new_st.block = gfc_get_code ();
3536 new_st.block->op = EXEC_FORALL;
3537 new_st.block->next = c;
3539 *st = ST_FORALL;
3540 return MATCH_YES;
3542 syntax:
3543 gfc_syntax_error (ST_FORALL);
3545 cleanup:
3546 gfc_free_forall_iterator (head);
3547 gfc_free_expr (mask);
3548 gfc_free_statements (c);
3549 return MATCH_NO;