* ggc.h (empty_string): Delete.
[official-gcc.git] / gcc / fortran / match.c
blob006ac0312ac9fede15af5bd446402ac9b63b17fd
1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000-2017 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
21 #include "config.h"
22 #include "system.h"
23 #include "coretypes.h"
24 #include "options.h"
25 #include "gfortran.h"
26 #include "match.h"
27 #include "parse.h"
29 int gfc_matching_ptr_assignment = 0;
30 int gfc_matching_procptr_assignment = 0;
31 bool gfc_matching_prefix = false;
33 /* Stack of SELECT TYPE statements. */
34 gfc_select_type_stack *select_type_stack = NULL;
36 /* For debugging and diagnostic purposes. Return the textual representation
37 of the intrinsic operator OP. */
38 const char *
39 gfc_op2string (gfc_intrinsic_op op)
41 switch (op)
43 case INTRINSIC_UPLUS:
44 case INTRINSIC_PLUS:
45 return "+";
47 case INTRINSIC_UMINUS:
48 case INTRINSIC_MINUS:
49 return "-";
51 case INTRINSIC_POWER:
52 return "**";
53 case INTRINSIC_CONCAT:
54 return "//";
55 case INTRINSIC_TIMES:
56 return "*";
57 case INTRINSIC_DIVIDE:
58 return "/";
60 case INTRINSIC_AND:
61 return ".and.";
62 case INTRINSIC_OR:
63 return ".or.";
64 case INTRINSIC_EQV:
65 return ".eqv.";
66 case INTRINSIC_NEQV:
67 return ".neqv.";
69 case INTRINSIC_EQ_OS:
70 return ".eq.";
71 case INTRINSIC_EQ:
72 return "==";
73 case INTRINSIC_NE_OS:
74 return ".ne.";
75 case INTRINSIC_NE:
76 return "/=";
77 case INTRINSIC_GE_OS:
78 return ".ge.";
79 case INTRINSIC_GE:
80 return ">=";
81 case INTRINSIC_LE_OS:
82 return ".le.";
83 case INTRINSIC_LE:
84 return "<=";
85 case INTRINSIC_LT_OS:
86 return ".lt.";
87 case INTRINSIC_LT:
88 return "<";
89 case INTRINSIC_GT_OS:
90 return ".gt.";
91 case INTRINSIC_GT:
92 return ">";
93 case INTRINSIC_NOT:
94 return ".not.";
96 case INTRINSIC_ASSIGN:
97 return "=";
99 case INTRINSIC_PARENTHESES:
100 return "parens";
102 case INTRINSIC_NONE:
103 return "none";
105 /* DTIO */
106 case INTRINSIC_FORMATTED:
107 return "formatted";
108 case INTRINSIC_UNFORMATTED:
109 return "unformatted";
111 default:
112 break;
115 gfc_internal_error ("gfc_op2string(): Bad code");
116 /* Not reached. */
120 /******************** Generic matching subroutines ************************/
122 /* Matches a member separator. With standard FORTRAN this is '%', but with
123 DEC structures we must carefully match dot ('.').
124 Because operators are spelled ".op.", a dotted string such as "x.y.z..."
125 can be either a component reference chain or a combination of binary
126 operations.
127 There is no real way to win because the string may be grammatically
128 ambiguous. The following rules help avoid ambiguities - they match
129 some behavior of other (older) compilers. If the rules here are changed
130 the test cases should be updated. If the user has problems with these rules
131 they probably deserve the consequences. Consider "x.y.z":
132 (1) If any user defined operator ".y." exists, this is always y(x,z)
133 (even if ".y." is the wrong type and/or x has a member y).
134 (2) Otherwise if x has a member y, and y is itself a derived type,
135 this is (x->y)->z, even if an intrinsic operator exists which
136 can handle (x,z).
137 (3) If x has no member y or (x->y) is not a derived type but ".y."
138 is an intrinsic operator (such as ".eq."), this is y(x,z).
139 (4) Lastly if there is no operator ".y." and x has no member "y", it is an
140 error.
141 It is worth noting that the logic here does not support mixed use of member
142 accessors within a single string. That is, even if x has component y and y
143 has component z, the following are all syntax errors:
144 "x%y.z" "x.y%z" "(x.y).z" "(x%y)%z"
147 match
148 gfc_match_member_sep(gfc_symbol *sym)
150 char name[GFC_MAX_SYMBOL_LEN + 1];
151 locus dot_loc, start_loc;
152 gfc_intrinsic_op iop;
153 match m;
154 gfc_symbol *tsym;
155 gfc_component *c = NULL;
157 /* What a relief: '%' is an unambiguous member separator. */
158 if (gfc_match_char ('%') == MATCH_YES)
159 return MATCH_YES;
161 /* Beware ye who enter here. */
162 if (!flag_dec_structure || !sym)
163 return MATCH_NO;
165 tsym = NULL;
167 /* We may be given either a derived type variable or the derived type
168 declaration itself (which actually contains the components);
169 we need the latter to search for components. */
170 if (gfc_fl_struct (sym->attr.flavor))
171 tsym = sym;
172 else if (gfc_bt_struct (sym->ts.type))
173 tsym = sym->ts.u.derived;
175 iop = INTRINSIC_NONE;
176 name[0] = '\0';
177 m = MATCH_NO;
179 /* If we have to reject come back here later. */
180 start_loc = gfc_current_locus;
182 /* Look for a component access next. */
183 if (gfc_match_char ('.') != MATCH_YES)
184 return MATCH_NO;
186 /* If we accept, come back here. */
187 dot_loc = gfc_current_locus;
189 /* Try to match a symbol name following the dot. */
190 if (gfc_match_name (name) != MATCH_YES)
192 gfc_error ("Expected structure component or operator name "
193 "after '.' at %C");
194 goto error;
197 /* If no dot follows we have "x.y" which should be a component access. */
198 if (gfc_match_char ('.') != MATCH_YES)
199 goto yes;
201 /* Now we have a string "x.y.z" which could be a nested member access
202 (x->y)->z or a binary operation y on x and z. */
204 /* First use any user-defined operators ".y." */
205 if (gfc_find_uop (name, sym->ns) != NULL)
206 goto no;
208 /* Match accesses to existing derived-type components for
209 derived-type vars: "x.y.z" = (x->y)->z */
210 c = gfc_find_component(tsym, name, false, true, NULL);
211 if (c && (gfc_bt_struct (c->ts.type) || c->ts.type == BT_CLASS))
212 goto yes;
214 /* If y is not a component or has no members, try intrinsic operators. */
215 gfc_current_locus = start_loc;
216 if (gfc_match_intrinsic_op (&iop) != MATCH_YES)
218 /* If ".y." is not an intrinsic operator but y was a valid non-
219 structure component, match and leave the trailing dot to be
220 dealt with later. */
221 if (c)
222 goto yes;
224 gfc_error ("%qs is neither a defined operator nor a "
225 "structure component in dotted string at %C", name);
226 goto error;
229 /* .y. is an intrinsic operator, overriding any possible member access. */
230 goto no;
232 /* Return keeping the current locus consistent with the match result. */
233 error:
234 m = MATCH_ERROR;
236 gfc_current_locus = start_loc;
237 return m;
238 yes:
239 gfc_current_locus = dot_loc;
240 return MATCH_YES;
244 /* This function scans the current statement counting the opened and closed
245 parenthesis to make sure they are balanced. */
247 match
248 gfc_match_parens (void)
250 locus old_loc, where;
251 int count;
252 gfc_instring instring;
253 gfc_char_t c, quote;
255 old_loc = gfc_current_locus;
256 count = 0;
257 instring = NONSTRING;
258 quote = ' ';
260 for (;;)
262 c = gfc_next_char_literal (instring);
263 if (c == '\n')
264 break;
265 if (quote == ' ' && ((c == '\'') || (c == '"')))
267 quote = c;
268 instring = INSTRING_WARN;
269 continue;
271 if (quote != ' ' && c == quote)
273 quote = ' ';
274 instring = NONSTRING;
275 continue;
278 if (c == '(' && quote == ' ')
280 count++;
281 where = gfc_current_locus;
283 if (c == ')' && quote == ' ')
285 count--;
286 where = gfc_current_locus;
290 gfc_current_locus = old_loc;
292 if (count > 0)
294 gfc_error ("Missing %<)%> in statement at or before %L", &where);
295 return MATCH_ERROR;
297 if (count < 0)
299 gfc_error ("Missing %<(%> in statement at or before %L", &where);
300 return MATCH_ERROR;
303 return MATCH_YES;
307 /* See if the next character is a special character that has
308 escaped by a \ via the -fbackslash option. */
310 match
311 gfc_match_special_char (gfc_char_t *res)
313 int len, i;
314 gfc_char_t c, n;
315 match m;
317 m = MATCH_YES;
319 switch ((c = gfc_next_char_literal (INSTRING_WARN)))
321 case 'a':
322 *res = '\a';
323 break;
324 case 'b':
325 *res = '\b';
326 break;
327 case 't':
328 *res = '\t';
329 break;
330 case 'f':
331 *res = '\f';
332 break;
333 case 'n':
334 *res = '\n';
335 break;
336 case 'r':
337 *res = '\r';
338 break;
339 case 'v':
340 *res = '\v';
341 break;
342 case '\\':
343 *res = '\\';
344 break;
345 case '0':
346 *res = '\0';
347 break;
349 case 'x':
350 case 'u':
351 case 'U':
352 /* Hexadecimal form of wide characters. */
353 len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8));
354 n = 0;
355 for (i = 0; i < len; i++)
357 char buf[2] = { '\0', '\0' };
359 c = gfc_next_char_literal (INSTRING_WARN);
360 if (!gfc_wide_fits_in_byte (c)
361 || !gfc_check_digit ((unsigned char) c, 16))
362 return MATCH_NO;
364 buf[0] = (unsigned char) c;
365 n = n << 4;
366 n += strtol (buf, NULL, 16);
368 *res = n;
369 break;
371 default:
372 /* Unknown backslash codes are simply not expanded. */
373 m = MATCH_NO;
374 break;
377 return m;
381 /* In free form, match at least one space. Always matches in fixed
382 form. */
384 match
385 gfc_match_space (void)
387 locus old_loc;
388 char c;
390 if (gfc_current_form == FORM_FIXED)
391 return MATCH_YES;
393 old_loc = gfc_current_locus;
395 c = gfc_next_ascii_char ();
396 if (!gfc_is_whitespace (c))
398 gfc_current_locus = old_loc;
399 return MATCH_NO;
402 gfc_gobble_whitespace ();
404 return MATCH_YES;
408 /* Match an end of statement. End of statement is optional
409 whitespace, followed by a ';' or '\n' or comment '!'. If a
410 semicolon is found, we continue to eat whitespace and semicolons. */
412 match
413 gfc_match_eos (void)
415 locus old_loc;
416 int flag;
417 char c;
419 flag = 0;
421 for (;;)
423 old_loc = gfc_current_locus;
424 gfc_gobble_whitespace ();
426 c = gfc_next_ascii_char ();
427 switch (c)
429 case '!':
432 c = gfc_next_ascii_char ();
434 while (c != '\n');
436 /* Fall through. */
438 case '\n':
439 return MATCH_YES;
441 case ';':
442 flag = 1;
443 continue;
446 break;
449 gfc_current_locus = old_loc;
450 return (flag) ? MATCH_YES : MATCH_NO;
454 /* Match a literal integer on the input, setting the value on
455 MATCH_YES. Literal ints occur in kind-parameters as well as
456 old-style character length specifications. If cnt is non-NULL it
457 will be set to the number of digits. */
459 match
460 gfc_match_small_literal_int (int *value, int *cnt)
462 locus old_loc;
463 char c;
464 int i, j;
466 old_loc = gfc_current_locus;
468 *value = -1;
469 gfc_gobble_whitespace ();
470 c = gfc_next_ascii_char ();
471 if (cnt)
472 *cnt = 0;
474 if (!ISDIGIT (c))
476 gfc_current_locus = old_loc;
477 return MATCH_NO;
480 i = c - '0';
481 j = 1;
483 for (;;)
485 old_loc = gfc_current_locus;
486 c = gfc_next_ascii_char ();
488 if (!ISDIGIT (c))
489 break;
491 i = 10 * i + c - '0';
492 j++;
494 if (i > 99999999)
496 gfc_error ("Integer too large at %C");
497 return MATCH_ERROR;
501 gfc_current_locus = old_loc;
503 *value = i;
504 if (cnt)
505 *cnt = j;
506 return MATCH_YES;
510 /* Match a small, constant integer expression, like in a kind
511 statement. On MATCH_YES, 'value' is set. */
513 match
514 gfc_match_small_int (int *value)
516 gfc_expr *expr;
517 match m;
518 int i;
520 m = gfc_match_expr (&expr);
521 if (m != MATCH_YES)
522 return m;
524 if (gfc_extract_int (expr, &i, 1))
525 m = MATCH_ERROR;
526 gfc_free_expr (expr);
528 *value = i;
529 return m;
533 /* This function is the same as the gfc_match_small_int, except that
534 we're keeping the pointer to the expr. This function could just be
535 removed and the previously mentioned one modified, though all calls
536 to it would have to be modified then (and there were a number of
537 them). Return MATCH_ERROR if fail to extract the int; otherwise,
538 return the result of gfc_match_expr(). The expr (if any) that was
539 matched is returned in the parameter expr. */
541 match
542 gfc_match_small_int_expr (int *value, gfc_expr **expr)
544 match m;
545 int i;
547 m = gfc_match_expr (expr);
548 if (m != MATCH_YES)
549 return m;
551 if (gfc_extract_int (*expr, &i, 1))
552 m = MATCH_ERROR;
554 *value = i;
555 return m;
559 /* Matches a statement label. Uses gfc_match_small_literal_int() to
560 do most of the work. */
562 match
563 gfc_match_st_label (gfc_st_label **label)
565 locus old_loc;
566 match m;
567 int i, cnt;
569 old_loc = gfc_current_locus;
571 m = gfc_match_small_literal_int (&i, &cnt);
572 if (m != MATCH_YES)
573 return m;
575 if (cnt > 5)
577 gfc_error ("Too many digits in statement label at %C");
578 goto cleanup;
581 if (i == 0)
583 gfc_error ("Statement label at %C is zero");
584 goto cleanup;
587 *label = gfc_get_st_label (i);
588 return MATCH_YES;
590 cleanup:
592 gfc_current_locus = old_loc;
593 return MATCH_ERROR;
597 /* Match and validate a label associated with a named IF, DO or SELECT
598 statement. If the symbol does not have the label attribute, we add
599 it. We also make sure the symbol does not refer to another
600 (active) block. A matched label is pointed to by gfc_new_block. */
602 match
603 gfc_match_label (void)
605 char name[GFC_MAX_SYMBOL_LEN + 1];
606 match m;
608 gfc_new_block = NULL;
610 m = gfc_match (" %n :", name);
611 if (m != MATCH_YES)
612 return m;
614 if (gfc_get_symbol (name, NULL, &gfc_new_block))
616 gfc_error ("Label name %qs at %C is ambiguous", name);
617 return MATCH_ERROR;
620 if (gfc_new_block->attr.flavor == FL_LABEL)
622 gfc_error ("Duplicate construct label %qs at %C", name);
623 return MATCH_ERROR;
626 if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
627 gfc_new_block->name, NULL))
628 return MATCH_ERROR;
630 return MATCH_YES;
634 /* See if the current input looks like a name of some sort. Modifies
635 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
636 Note that options.c restricts max_identifier_length to not more
637 than GFC_MAX_SYMBOL_LEN. */
639 match
640 gfc_match_name (char *buffer)
642 locus old_loc;
643 int i;
644 char c;
646 old_loc = gfc_current_locus;
647 gfc_gobble_whitespace ();
649 c = gfc_next_ascii_char ();
650 if (!(ISALPHA (c) || (c == '_' && flag_allow_leading_underscore)))
652 /* Special cases for unary minus and plus, which allows for a sensible
653 error message for code of the form 'c = exp(-a*b) )' where an
654 extra ')' appears at the end of statement. */
655 if (!gfc_error_flag_test () && c != '(' && c != '-' && c != '+')
656 gfc_error ("Invalid character in name at %C");
657 gfc_current_locus = old_loc;
658 return MATCH_NO;
661 i = 0;
665 buffer[i++] = c;
667 if (i > gfc_option.max_identifier_length)
669 gfc_error ("Name at %C is too long");
670 return MATCH_ERROR;
673 old_loc = gfc_current_locus;
674 c = gfc_next_ascii_char ();
676 while (ISALNUM (c) || c == '_' || (flag_dollar_ok && c == '$'));
678 if (c == '$' && !flag_dollar_ok)
680 gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to "
681 "allow it as an extension", &old_loc);
682 return MATCH_ERROR;
685 buffer[i] = '\0';
686 gfc_current_locus = old_loc;
688 return MATCH_YES;
692 /* Match a symbol on the input. Modifies the pointer to the symbol
693 pointer if successful. */
695 match
696 gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
698 char buffer[GFC_MAX_SYMBOL_LEN + 1];
699 match m;
701 m = gfc_match_name (buffer);
702 if (m != MATCH_YES)
703 return m;
705 if (host_assoc)
706 return (gfc_get_ha_sym_tree (buffer, matched_symbol))
707 ? MATCH_ERROR : MATCH_YES;
709 if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false))
710 return MATCH_ERROR;
712 return MATCH_YES;
716 match
717 gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
719 gfc_symtree *st;
720 match m;
722 m = gfc_match_sym_tree (&st, host_assoc);
724 if (m == MATCH_YES)
726 if (st)
727 *matched_symbol = st->n.sym;
728 else
729 *matched_symbol = NULL;
731 else
732 *matched_symbol = NULL;
733 return m;
737 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
738 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
739 in matchexp.c. */
741 match
742 gfc_match_intrinsic_op (gfc_intrinsic_op *result)
744 locus orig_loc = gfc_current_locus;
745 char ch;
747 gfc_gobble_whitespace ();
748 ch = gfc_next_ascii_char ();
749 switch (ch)
751 case '+':
752 /* Matched "+". */
753 *result = INTRINSIC_PLUS;
754 return MATCH_YES;
756 case '-':
757 /* Matched "-". */
758 *result = INTRINSIC_MINUS;
759 return MATCH_YES;
761 case '=':
762 if (gfc_next_ascii_char () == '=')
764 /* Matched "==". */
765 *result = INTRINSIC_EQ;
766 return MATCH_YES;
768 break;
770 case '<':
771 if (gfc_peek_ascii_char () == '=')
773 /* Matched "<=". */
774 gfc_next_ascii_char ();
775 *result = INTRINSIC_LE;
776 return MATCH_YES;
778 /* Matched "<". */
779 *result = INTRINSIC_LT;
780 return MATCH_YES;
782 case '>':
783 if (gfc_peek_ascii_char () == '=')
785 /* Matched ">=". */
786 gfc_next_ascii_char ();
787 *result = INTRINSIC_GE;
788 return MATCH_YES;
790 /* Matched ">". */
791 *result = INTRINSIC_GT;
792 return MATCH_YES;
794 case '*':
795 if (gfc_peek_ascii_char () == '*')
797 /* Matched "**". */
798 gfc_next_ascii_char ();
799 *result = INTRINSIC_POWER;
800 return MATCH_YES;
802 /* Matched "*". */
803 *result = INTRINSIC_TIMES;
804 return MATCH_YES;
806 case '/':
807 ch = gfc_peek_ascii_char ();
808 if (ch == '=')
810 /* Matched "/=". */
811 gfc_next_ascii_char ();
812 *result = INTRINSIC_NE;
813 return MATCH_YES;
815 else if (ch == '/')
817 /* Matched "//". */
818 gfc_next_ascii_char ();
819 *result = INTRINSIC_CONCAT;
820 return MATCH_YES;
822 /* Matched "/". */
823 *result = INTRINSIC_DIVIDE;
824 return MATCH_YES;
826 case '.':
827 ch = gfc_next_ascii_char ();
828 switch (ch)
830 case 'a':
831 if (gfc_next_ascii_char () == 'n'
832 && gfc_next_ascii_char () == 'd'
833 && gfc_next_ascii_char () == '.')
835 /* Matched ".and.". */
836 *result = INTRINSIC_AND;
837 return MATCH_YES;
839 break;
841 case 'e':
842 if (gfc_next_ascii_char () == 'q')
844 ch = gfc_next_ascii_char ();
845 if (ch == '.')
847 /* Matched ".eq.". */
848 *result = INTRINSIC_EQ_OS;
849 return MATCH_YES;
851 else if (ch == 'v')
853 if (gfc_next_ascii_char () == '.')
855 /* Matched ".eqv.". */
856 *result = INTRINSIC_EQV;
857 return MATCH_YES;
861 break;
863 case 'g':
864 ch = gfc_next_ascii_char ();
865 if (ch == 'e')
867 if (gfc_next_ascii_char () == '.')
869 /* Matched ".ge.". */
870 *result = INTRINSIC_GE_OS;
871 return MATCH_YES;
874 else if (ch == 't')
876 if (gfc_next_ascii_char () == '.')
878 /* Matched ".gt.". */
879 *result = INTRINSIC_GT_OS;
880 return MATCH_YES;
883 break;
885 case 'l':
886 ch = gfc_next_ascii_char ();
887 if (ch == 'e')
889 if (gfc_next_ascii_char () == '.')
891 /* Matched ".le.". */
892 *result = INTRINSIC_LE_OS;
893 return MATCH_YES;
896 else if (ch == 't')
898 if (gfc_next_ascii_char () == '.')
900 /* Matched ".lt.". */
901 *result = INTRINSIC_LT_OS;
902 return MATCH_YES;
905 break;
907 case 'n':
908 ch = gfc_next_ascii_char ();
909 if (ch == 'e')
911 ch = gfc_next_ascii_char ();
912 if (ch == '.')
914 /* Matched ".ne.". */
915 *result = INTRINSIC_NE_OS;
916 return MATCH_YES;
918 else if (ch == 'q')
920 if (gfc_next_ascii_char () == 'v'
921 && gfc_next_ascii_char () == '.')
923 /* Matched ".neqv.". */
924 *result = INTRINSIC_NEQV;
925 return MATCH_YES;
929 else if (ch == 'o')
931 if (gfc_next_ascii_char () == 't'
932 && gfc_next_ascii_char () == '.')
934 /* Matched ".not.". */
935 *result = INTRINSIC_NOT;
936 return MATCH_YES;
939 break;
941 case 'o':
942 if (gfc_next_ascii_char () == 'r'
943 && gfc_next_ascii_char () == '.')
945 /* Matched ".or.". */
946 *result = INTRINSIC_OR;
947 return MATCH_YES;
949 break;
951 case 'x':
952 if (gfc_next_ascii_char () == 'o'
953 && gfc_next_ascii_char () == 'r'
954 && gfc_next_ascii_char () == '.')
956 if (!gfc_notify_std (GFC_STD_LEGACY, ".XOR. operator at %C"))
957 return MATCH_ERROR;
958 /* Matched ".xor." - equivalent to ".neqv.". */
959 *result = INTRINSIC_NEQV;
960 return MATCH_YES;
962 break;
964 default:
965 break;
967 break;
969 default:
970 break;
973 gfc_current_locus = orig_loc;
974 return MATCH_NO;
978 /* Match a loop control phrase:
980 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
982 If the final integer expression is not present, a constant unity
983 expression is returned. We don't return MATCH_ERROR until after
984 the equals sign is seen. */
986 match
987 gfc_match_iterator (gfc_iterator *iter, int init_flag)
989 char name[GFC_MAX_SYMBOL_LEN + 1];
990 gfc_expr *var, *e1, *e2, *e3;
991 locus start;
992 match m;
994 e1 = e2 = e3 = NULL;
996 /* Match the start of an iterator without affecting the symbol table. */
998 start = gfc_current_locus;
999 m = gfc_match (" %n =", name);
1000 gfc_current_locus = start;
1002 if (m != MATCH_YES)
1003 return MATCH_NO;
1005 m = gfc_match_variable (&var, 0);
1006 if (m != MATCH_YES)
1007 return MATCH_NO;
1009 if (var->symtree->n.sym->attr.dimension)
1011 gfc_error ("Loop variable at %C cannot be an array");
1012 goto cleanup;
1015 /* F2008, C617 & C565. */
1016 if (var->symtree->n.sym->attr.codimension)
1018 gfc_error ("Loop variable at %C cannot be a coarray");
1019 goto cleanup;
1022 if (var->ref != NULL)
1024 gfc_error ("Loop variable at %C cannot be a sub-component");
1025 goto cleanup;
1028 gfc_match_char ('=');
1030 var->symtree->n.sym->attr.implied_index = 1;
1032 m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
1033 if (m == MATCH_NO)
1034 goto syntax;
1035 if (m == MATCH_ERROR)
1036 goto cleanup;
1038 if (gfc_match_char (',') != MATCH_YES)
1039 goto syntax;
1041 m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
1042 if (m == MATCH_NO)
1043 goto syntax;
1044 if (m == MATCH_ERROR)
1045 goto cleanup;
1047 if (gfc_match_char (',') != MATCH_YES)
1049 e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
1050 goto done;
1053 m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
1054 if (m == MATCH_ERROR)
1055 goto cleanup;
1056 if (m == MATCH_NO)
1058 gfc_error ("Expected a step value in iterator at %C");
1059 goto cleanup;
1062 done:
1063 iter->var = var;
1064 iter->start = e1;
1065 iter->end = e2;
1066 iter->step = e3;
1067 return MATCH_YES;
1069 syntax:
1070 gfc_error ("Syntax error in iterator at %C");
1072 cleanup:
1073 gfc_free_expr (e1);
1074 gfc_free_expr (e2);
1075 gfc_free_expr (e3);
1077 return MATCH_ERROR;
1081 /* Tries to match the next non-whitespace character on the input.
1082 This subroutine does not return MATCH_ERROR. */
1084 match
1085 gfc_match_char (char c)
1087 locus where;
1089 where = gfc_current_locus;
1090 gfc_gobble_whitespace ();
1092 if (gfc_next_ascii_char () == c)
1093 return MATCH_YES;
1095 gfc_current_locus = where;
1096 return MATCH_NO;
1100 /* General purpose matching subroutine. The target string is a
1101 scanf-like format string in which spaces correspond to arbitrary
1102 whitespace (including no whitespace), characters correspond to
1103 themselves. The %-codes are:
1105 %% Literal percent sign
1106 %e Expression, pointer to a pointer is set
1107 %s Symbol, pointer to the symbol is set
1108 %n Name, character buffer is set to name
1109 %t Matches end of statement.
1110 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1111 %l Matches a statement label
1112 %v Matches a variable expression (an lvalue)
1113 % Matches a required space (in free form) and optional spaces. */
1115 match
1116 gfc_match (const char *target, ...)
1118 gfc_st_label **label;
1119 int matches, *ip;
1120 locus old_loc;
1121 va_list argp;
1122 char c, *np;
1123 match m, n;
1124 void **vp;
1125 const char *p;
1127 old_loc = gfc_current_locus;
1128 va_start (argp, target);
1129 m = MATCH_NO;
1130 matches = 0;
1131 p = target;
1133 loop:
1134 c = *p++;
1135 switch (c)
1137 case ' ':
1138 gfc_gobble_whitespace ();
1139 goto loop;
1140 case '\0':
1141 m = MATCH_YES;
1142 break;
1144 case '%':
1145 c = *p++;
1146 switch (c)
1148 case 'e':
1149 vp = va_arg (argp, void **);
1150 n = gfc_match_expr ((gfc_expr **) vp);
1151 if (n != MATCH_YES)
1153 m = n;
1154 goto not_yes;
1157 matches++;
1158 goto loop;
1160 case 'v':
1161 vp = va_arg (argp, void **);
1162 n = gfc_match_variable ((gfc_expr **) vp, 0);
1163 if (n != MATCH_YES)
1165 m = n;
1166 goto not_yes;
1169 matches++;
1170 goto loop;
1172 case 's':
1173 vp = va_arg (argp, void **);
1174 n = gfc_match_symbol ((gfc_symbol **) vp, 0);
1175 if (n != MATCH_YES)
1177 m = n;
1178 goto not_yes;
1181 matches++;
1182 goto loop;
1184 case 'n':
1185 np = va_arg (argp, char *);
1186 n = gfc_match_name (np);
1187 if (n != MATCH_YES)
1189 m = n;
1190 goto not_yes;
1193 matches++;
1194 goto loop;
1196 case 'l':
1197 label = va_arg (argp, gfc_st_label **);
1198 n = gfc_match_st_label (label);
1199 if (n != MATCH_YES)
1201 m = n;
1202 goto not_yes;
1205 matches++;
1206 goto loop;
1208 case 'o':
1209 ip = va_arg (argp, int *);
1210 n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
1211 if (n != MATCH_YES)
1213 m = n;
1214 goto not_yes;
1217 matches++;
1218 goto loop;
1220 case 't':
1221 if (gfc_match_eos () != MATCH_YES)
1223 m = MATCH_NO;
1224 goto not_yes;
1226 goto loop;
1228 case ' ':
1229 if (gfc_match_space () == MATCH_YES)
1230 goto loop;
1231 m = MATCH_NO;
1232 goto not_yes;
1234 case '%':
1235 break; /* Fall through to character matcher. */
1237 default:
1238 gfc_internal_error ("gfc_match(): Bad match code %c", c);
1241 default:
1243 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1244 expect an upper case character here! */
1245 gcc_assert (TOLOWER (c) == c);
1247 if (c == gfc_next_ascii_char ())
1248 goto loop;
1249 break;
1252 not_yes:
1253 va_end (argp);
1255 if (m != MATCH_YES)
1257 /* Clean up after a failed match. */
1258 gfc_current_locus = old_loc;
1259 va_start (argp, target);
1261 p = target;
1262 for (; matches > 0; matches--)
1264 while (*p++ != '%');
1266 switch (*p++)
1268 case '%':
1269 matches++;
1270 break; /* Skip. */
1272 /* Matches that don't have to be undone */
1273 case 'o':
1274 case 'l':
1275 case 'n':
1276 case 's':
1277 (void) va_arg (argp, void **);
1278 break;
1280 case 'e':
1281 case 'v':
1282 vp = va_arg (argp, void **);
1283 gfc_free_expr ((struct gfc_expr *)*vp);
1284 *vp = NULL;
1285 break;
1289 va_end (argp);
1292 return m;
1296 /*********************** Statement level matching **********************/
1298 /* Matches the start of a program unit, which is the program keyword
1299 followed by an obligatory symbol. */
1301 match
1302 gfc_match_program (void)
1304 gfc_symbol *sym;
1305 match m;
1307 m = gfc_match ("% %s%t", &sym);
1309 if (m == MATCH_NO)
1311 gfc_error ("Invalid form of PROGRAM statement at %C");
1312 m = MATCH_ERROR;
1315 if (m == MATCH_ERROR)
1316 return m;
1318 if (!gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL))
1319 return MATCH_ERROR;
1321 gfc_new_block = sym;
1323 return MATCH_YES;
1327 /* Match a simple assignment statement. */
1329 match
1330 gfc_match_assignment (void)
1332 gfc_expr *lvalue, *rvalue;
1333 locus old_loc;
1334 match m;
1336 old_loc = gfc_current_locus;
1338 lvalue = NULL;
1339 m = gfc_match (" %v =", &lvalue);
1340 if (m != MATCH_YES)
1342 gfc_current_locus = old_loc;
1343 gfc_free_expr (lvalue);
1344 return MATCH_NO;
1347 rvalue = NULL;
1348 m = gfc_match (" %e%t", &rvalue);
1349 if (m != MATCH_YES)
1351 gfc_current_locus = old_loc;
1352 gfc_free_expr (lvalue);
1353 gfc_free_expr (rvalue);
1354 return m;
1357 gfc_set_sym_referenced (lvalue->symtree->n.sym);
1359 new_st.op = EXEC_ASSIGN;
1360 new_st.expr1 = lvalue;
1361 new_st.expr2 = rvalue;
1363 gfc_check_do_variable (lvalue->symtree);
1365 return MATCH_YES;
1369 /* Match a pointer assignment statement. */
1371 match
1372 gfc_match_pointer_assignment (void)
1374 gfc_expr *lvalue, *rvalue;
1375 locus old_loc;
1376 match m;
1378 old_loc = gfc_current_locus;
1380 lvalue = rvalue = NULL;
1381 gfc_matching_ptr_assignment = 0;
1382 gfc_matching_procptr_assignment = 0;
1384 m = gfc_match (" %v =>", &lvalue);
1385 if (m != MATCH_YES)
1387 m = MATCH_NO;
1388 goto cleanup;
1391 if (lvalue->symtree->n.sym->attr.proc_pointer
1392 || gfc_is_proc_ptr_comp (lvalue))
1393 gfc_matching_procptr_assignment = 1;
1394 else
1395 gfc_matching_ptr_assignment = 1;
1397 m = gfc_match (" %e%t", &rvalue);
1398 gfc_matching_ptr_assignment = 0;
1399 gfc_matching_procptr_assignment = 0;
1400 if (m != MATCH_YES)
1401 goto cleanup;
1403 new_st.op = EXEC_POINTER_ASSIGN;
1404 new_st.expr1 = lvalue;
1405 new_st.expr2 = rvalue;
1407 return MATCH_YES;
1409 cleanup:
1410 gfc_current_locus = old_loc;
1411 gfc_free_expr (lvalue);
1412 gfc_free_expr (rvalue);
1413 return m;
1417 /* We try to match an easy arithmetic IF statement. This only happens
1418 when just after having encountered a simple IF statement. This code
1419 is really duplicate with parts of the gfc_match_if code, but this is
1420 *much* easier. */
1422 static match
1423 match_arithmetic_if (void)
1425 gfc_st_label *l1, *l2, *l3;
1426 gfc_expr *expr;
1427 match m;
1429 m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
1430 if (m != MATCH_YES)
1431 return m;
1433 if (!gfc_reference_st_label (l1, ST_LABEL_TARGET)
1434 || !gfc_reference_st_label (l2, ST_LABEL_TARGET)
1435 || !gfc_reference_st_label (l3, ST_LABEL_TARGET))
1437 gfc_free_expr (expr);
1438 return MATCH_ERROR;
1441 if (!gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF statement at %C"))
1442 return MATCH_ERROR;
1444 new_st.op = EXEC_ARITHMETIC_IF;
1445 new_st.expr1 = expr;
1446 new_st.label1 = l1;
1447 new_st.label2 = l2;
1448 new_st.label3 = l3;
1450 return MATCH_YES;
1454 /* The IF statement is a bit of a pain. First of all, there are three
1455 forms of it, the simple IF, the IF that starts a block and the
1456 arithmetic IF.
1458 There is a problem with the simple IF and that is the fact that we
1459 only have a single level of undo information on symbols. What this
1460 means is for a simple IF, we must re-match the whole IF statement
1461 multiple times in order to guarantee that the symbol table ends up
1462 in the proper state. */
1464 static match match_simple_forall (void);
1465 static match match_simple_where (void);
1467 match
1468 gfc_match_if (gfc_statement *if_type)
1470 gfc_expr *expr;
1471 gfc_st_label *l1, *l2, *l3;
1472 locus old_loc, old_loc2;
1473 gfc_code *p;
1474 match m, n;
1476 n = gfc_match_label ();
1477 if (n == MATCH_ERROR)
1478 return n;
1480 old_loc = gfc_current_locus;
1482 m = gfc_match (" if ( %e", &expr);
1483 if (m != MATCH_YES)
1484 return m;
1486 old_loc2 = gfc_current_locus;
1487 gfc_current_locus = old_loc;
1489 if (gfc_match_parens () == MATCH_ERROR)
1490 return MATCH_ERROR;
1492 gfc_current_locus = old_loc2;
1494 if (gfc_match_char (')') != MATCH_YES)
1496 gfc_error ("Syntax error in IF-expression at %C");
1497 gfc_free_expr (expr);
1498 return MATCH_ERROR;
1501 m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
1503 if (m == MATCH_YES)
1505 if (n == MATCH_YES)
1507 gfc_error ("Block label not appropriate for arithmetic IF "
1508 "statement at %C");
1509 gfc_free_expr (expr);
1510 return MATCH_ERROR;
1513 if (!gfc_reference_st_label (l1, ST_LABEL_TARGET)
1514 || !gfc_reference_st_label (l2, ST_LABEL_TARGET)
1515 || !gfc_reference_st_label (l3, ST_LABEL_TARGET))
1517 gfc_free_expr (expr);
1518 return MATCH_ERROR;
1521 if (!gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF statement at %C"))
1522 return MATCH_ERROR;
1524 new_st.op = EXEC_ARITHMETIC_IF;
1525 new_st.expr1 = expr;
1526 new_st.label1 = l1;
1527 new_st.label2 = l2;
1528 new_st.label3 = l3;
1530 *if_type = ST_ARITHMETIC_IF;
1531 return MATCH_YES;
1534 if (gfc_match (" then%t") == MATCH_YES)
1536 new_st.op = EXEC_IF;
1537 new_st.expr1 = expr;
1538 *if_type = ST_IF_BLOCK;
1539 return MATCH_YES;
1542 if (n == MATCH_YES)
1544 gfc_error ("Block label is not appropriate for IF statement at %C");
1545 gfc_free_expr (expr);
1546 return MATCH_ERROR;
1549 /* At this point the only thing left is a simple IF statement. At
1550 this point, n has to be MATCH_NO, so we don't have to worry about
1551 re-matching a block label. From what we've got so far, try
1552 matching an assignment. */
1554 *if_type = ST_SIMPLE_IF;
1556 m = gfc_match_assignment ();
1557 if (m == MATCH_YES)
1558 goto got_match;
1560 gfc_free_expr (expr);
1561 gfc_undo_symbols ();
1562 gfc_current_locus = old_loc;
1564 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1565 assignment was found. For MATCH_NO, continue to call the various
1566 matchers. */
1567 if (m == MATCH_ERROR)
1568 return MATCH_ERROR;
1570 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
1572 m = gfc_match_pointer_assignment ();
1573 if (m == MATCH_YES)
1574 goto got_match;
1576 gfc_free_expr (expr);
1577 gfc_undo_symbols ();
1578 gfc_current_locus = old_loc;
1580 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
1582 /* Look at the next keyword to see which matcher to call. Matching
1583 the keyword doesn't affect the symbol table, so we don't have to
1584 restore between tries. */
1586 #define match(string, subr, statement) \
1587 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1589 gfc_clear_error ();
1591 match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1592 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1593 match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1594 match ("call", gfc_match_call, ST_CALL)
1595 match ("close", gfc_match_close, ST_CLOSE)
1596 match ("continue", gfc_match_continue, ST_CONTINUE)
1597 match ("cycle", gfc_match_cycle, ST_CYCLE)
1598 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1599 match ("end file", gfc_match_endfile, ST_END_FILE)
1600 match ("error stop", gfc_match_error_stop, ST_ERROR_STOP)
1601 match ("event post", gfc_match_event_post, ST_EVENT_POST)
1602 match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT)
1603 match ("exit", gfc_match_exit, ST_EXIT)
1604 match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE)
1605 match ("flush", gfc_match_flush, ST_FLUSH)
1606 match ("forall", match_simple_forall, ST_FORALL)
1607 match ("go to", gfc_match_goto, ST_GOTO)
1608 match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1609 match ("inquire", gfc_match_inquire, ST_INQUIRE)
1610 match ("lock", gfc_match_lock, ST_LOCK)
1611 match ("nullify", gfc_match_nullify, ST_NULLIFY)
1612 match ("open", gfc_match_open, ST_OPEN)
1613 match ("pause", gfc_match_pause, ST_NONE)
1614 match ("print", gfc_match_print, ST_WRITE)
1615 match ("read", gfc_match_read, ST_READ)
1616 match ("return", gfc_match_return, ST_RETURN)
1617 match ("rewind", gfc_match_rewind, ST_REWIND)
1618 match ("stop", gfc_match_stop, ST_STOP)
1619 match ("wait", gfc_match_wait, ST_WAIT)
1620 match ("sync all", gfc_match_sync_all, ST_SYNC_CALL);
1621 match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
1622 match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
1623 match ("unlock", gfc_match_unlock, ST_UNLOCK)
1624 match ("where", match_simple_where, ST_WHERE)
1625 match ("write", gfc_match_write, ST_WRITE)
1627 if (flag_dec)
1628 match ("type", gfc_match_print, ST_WRITE)
1630 /* The gfc_match_assignment() above may have returned a MATCH_NO
1631 where the assignment was to a named constant. Check that
1632 special case here. */
1633 m = gfc_match_assignment ();
1634 if (m == MATCH_NO)
1636 gfc_error ("Cannot assign to a named constant at %C");
1637 gfc_free_expr (expr);
1638 gfc_undo_symbols ();
1639 gfc_current_locus = old_loc;
1640 return MATCH_ERROR;
1643 /* All else has failed, so give up. See if any of the matchers has
1644 stored an error message of some sort. */
1645 if (!gfc_error_check ())
1646 gfc_error ("Unclassifiable statement in IF-clause at %C");
1648 gfc_free_expr (expr);
1649 return MATCH_ERROR;
1651 got_match:
1652 if (m == MATCH_NO)
1653 gfc_error ("Syntax error in IF-clause at %C");
1654 if (m != MATCH_YES)
1656 gfc_free_expr (expr);
1657 return MATCH_ERROR;
1660 /* At this point, we've matched the single IF and the action clause
1661 is in new_st. Rearrange things so that the IF statement appears
1662 in new_st. */
1664 p = gfc_get_code (EXEC_IF);
1665 p->next = XCNEW (gfc_code);
1666 *p->next = new_st;
1667 p->next->loc = gfc_current_locus;
1669 p->expr1 = expr;
1671 gfc_clear_new_st ();
1673 new_st.op = EXEC_IF;
1674 new_st.block = p;
1676 return MATCH_YES;
1679 #undef match
1682 /* Match an ELSE statement. */
1684 match
1685 gfc_match_else (void)
1687 char name[GFC_MAX_SYMBOL_LEN + 1];
1689 if (gfc_match_eos () == MATCH_YES)
1690 return MATCH_YES;
1692 if (gfc_match_name (name) != MATCH_YES
1693 || gfc_current_block () == NULL
1694 || gfc_match_eos () != MATCH_YES)
1696 gfc_error ("Unexpected junk after ELSE statement at %C");
1697 return MATCH_ERROR;
1700 if (strcmp (name, gfc_current_block ()->name) != 0)
1702 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1703 name, gfc_current_block ()->name);
1704 return MATCH_ERROR;
1707 return MATCH_YES;
1711 /* Match an ELSE IF statement. */
1713 match
1714 gfc_match_elseif (void)
1716 char name[GFC_MAX_SYMBOL_LEN + 1];
1717 gfc_expr *expr;
1718 match m;
1720 m = gfc_match (" ( %e ) then", &expr);
1721 if (m != MATCH_YES)
1722 return m;
1724 if (gfc_match_eos () == MATCH_YES)
1725 goto done;
1727 if (gfc_match_name (name) != MATCH_YES
1728 || gfc_current_block () == NULL
1729 || gfc_match_eos () != MATCH_YES)
1731 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1732 goto cleanup;
1735 if (strcmp (name, gfc_current_block ()->name) != 0)
1737 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1738 name, gfc_current_block ()->name);
1739 goto cleanup;
1742 done:
1743 new_st.op = EXEC_IF;
1744 new_st.expr1 = expr;
1745 return MATCH_YES;
1747 cleanup:
1748 gfc_free_expr (expr);
1749 return MATCH_ERROR;
1753 /* Free a gfc_iterator structure. */
1755 void
1756 gfc_free_iterator (gfc_iterator *iter, int flag)
1759 if (iter == NULL)
1760 return;
1762 gfc_free_expr (iter->var);
1763 gfc_free_expr (iter->start);
1764 gfc_free_expr (iter->end);
1765 gfc_free_expr (iter->step);
1767 if (flag)
1768 free (iter);
1772 /* Match a CRITICAL statement. */
1773 match
1774 gfc_match_critical (void)
1776 gfc_st_label *label = NULL;
1778 if (gfc_match_label () == MATCH_ERROR)
1779 return MATCH_ERROR;
1781 if (gfc_match (" critical") != MATCH_YES)
1782 return MATCH_NO;
1784 if (gfc_match_st_label (&label) == MATCH_ERROR)
1785 return MATCH_ERROR;
1787 if (gfc_match_eos () != MATCH_YES)
1789 gfc_syntax_error (ST_CRITICAL);
1790 return MATCH_ERROR;
1793 if (gfc_pure (NULL))
1795 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1796 return MATCH_ERROR;
1799 if (gfc_find_state (COMP_DO_CONCURRENT))
1801 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1802 "block");
1803 return MATCH_ERROR;
1806 gfc_unset_implicit_pure (NULL);
1808 if (!gfc_notify_std (GFC_STD_F2008, "CRITICAL statement at %C"))
1809 return MATCH_ERROR;
1811 if (flag_coarray == GFC_FCOARRAY_NONE)
1813 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1814 "enable");
1815 return MATCH_ERROR;
1818 if (gfc_find_state (COMP_CRITICAL))
1820 gfc_error ("Nested CRITICAL block at %C");
1821 return MATCH_ERROR;
1824 new_st.op = EXEC_CRITICAL;
1826 if (label != NULL
1827 && !gfc_reference_st_label (label, ST_LABEL_TARGET))
1828 return MATCH_ERROR;
1830 return MATCH_YES;
1834 /* Match a BLOCK statement. */
1836 match
1837 gfc_match_block (void)
1839 match m;
1841 if (gfc_match_label () == MATCH_ERROR)
1842 return MATCH_ERROR;
1844 if (gfc_match (" block") != MATCH_YES)
1845 return MATCH_NO;
1847 /* For this to be a correct BLOCK statement, the line must end now. */
1848 m = gfc_match_eos ();
1849 if (m == MATCH_ERROR)
1850 return MATCH_ERROR;
1851 if (m == MATCH_NO)
1852 return MATCH_NO;
1854 return MATCH_YES;
1858 /* Match an ASSOCIATE statement. */
1860 match
1861 gfc_match_associate (void)
1863 if (gfc_match_label () == MATCH_ERROR)
1864 return MATCH_ERROR;
1866 if (gfc_match (" associate") != MATCH_YES)
1867 return MATCH_NO;
1869 /* Match the association list. */
1870 if (gfc_match_char ('(') != MATCH_YES)
1872 gfc_error ("Expected association list at %C");
1873 return MATCH_ERROR;
1875 new_st.ext.block.assoc = NULL;
1876 while (true)
1878 gfc_association_list* newAssoc = gfc_get_association_list ();
1879 gfc_association_list* a;
1881 /* Match the next association. */
1882 if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
1883 != MATCH_YES)
1885 gfc_error ("Expected association at %C");
1886 goto assocListError;
1888 newAssoc->where = gfc_current_locus;
1890 /* Check that the current name is not yet in the list. */
1891 for (a = new_st.ext.block.assoc; a; a = a->next)
1892 if (!strcmp (a->name, newAssoc->name))
1894 gfc_error ("Duplicate name %qs in association at %C",
1895 newAssoc->name);
1896 goto assocListError;
1899 /* The target expression must not be coindexed. */
1900 if (gfc_is_coindexed (newAssoc->target))
1902 gfc_error ("Association target at %C must not be coindexed");
1903 goto assocListError;
1906 /* The `variable' field is left blank for now; because the target is not
1907 yet resolved, we can't use gfc_has_vector_subscript to determine it
1908 for now. This is set during resolution. */
1910 /* Put it into the list. */
1911 newAssoc->next = new_st.ext.block.assoc;
1912 new_st.ext.block.assoc = newAssoc;
1914 /* Try next one or end if closing parenthesis is found. */
1915 gfc_gobble_whitespace ();
1916 if (gfc_peek_char () == ')')
1917 break;
1918 if (gfc_match_char (',') != MATCH_YES)
1920 gfc_error ("Expected %<)%> or %<,%> at %C");
1921 return MATCH_ERROR;
1924 continue;
1926 assocListError:
1927 free (newAssoc);
1928 goto error;
1930 if (gfc_match_char (')') != MATCH_YES)
1932 /* This should never happen as we peek above. */
1933 gcc_unreachable ();
1936 if (gfc_match_eos () != MATCH_YES)
1938 gfc_error ("Junk after ASSOCIATE statement at %C");
1939 goto error;
1942 return MATCH_YES;
1944 error:
1945 gfc_free_association_list (new_st.ext.block.assoc);
1946 return MATCH_ERROR;
1950 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1951 an accessible derived type. */
1953 static match
1954 match_derived_type_spec (gfc_typespec *ts)
1956 char name[GFC_MAX_SYMBOL_LEN + 1];
1957 locus old_locus;
1958 gfc_symbol *derived;
1960 old_locus = gfc_current_locus;
1962 if (gfc_match ("%n", name) != MATCH_YES)
1964 gfc_current_locus = old_locus;
1965 return MATCH_NO;
1968 gfc_find_symbol (name, NULL, 1, &derived);
1970 if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
1971 derived = gfc_find_dt_in_generic (derived);
1973 if (derived && derived->attr.flavor == FL_DERIVED)
1975 ts->type = BT_DERIVED;
1976 ts->u.derived = derived;
1977 return MATCH_YES;
1980 gfc_current_locus = old_locus;
1981 return MATCH_NO;
1985 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
1986 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
1987 It only includes the intrinsic types from the Fortran 2003 standard
1988 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
1989 the implicit_flag is not needed, so it was removed. Derived types are
1990 identified by their name alone. */
1992 match
1993 gfc_match_type_spec (gfc_typespec *ts)
1995 match m;
1996 locus old_locus;
1997 char name[GFC_MAX_SYMBOL_LEN + 1];
1999 gfc_clear_ts (ts);
2000 gfc_gobble_whitespace ();
2001 old_locus = gfc_current_locus;
2003 if (match_derived_type_spec (ts) == MATCH_YES)
2005 /* Enforce F03:C401. */
2006 if (ts->u.derived->attr.abstract)
2008 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
2009 ts->u.derived->name, &old_locus);
2010 return MATCH_ERROR;
2012 return MATCH_YES;
2015 if (gfc_match ("integer") == MATCH_YES)
2017 ts->type = BT_INTEGER;
2018 ts->kind = gfc_default_integer_kind;
2019 goto kind_selector;
2022 if (gfc_match ("double precision") == MATCH_YES)
2024 ts->type = BT_REAL;
2025 ts->kind = gfc_default_double_kind;
2026 return MATCH_YES;
2029 if (gfc_match ("complex") == MATCH_YES)
2031 ts->type = BT_COMPLEX;
2032 ts->kind = gfc_default_complex_kind;
2033 goto kind_selector;
2036 if (gfc_match ("character") == MATCH_YES)
2038 ts->type = BT_CHARACTER;
2040 m = gfc_match_char_spec (ts);
2042 if (m == MATCH_NO)
2043 m = MATCH_YES;
2045 return m;
2048 if (gfc_match ("logical") == MATCH_YES)
2050 ts->type = BT_LOGICAL;
2051 ts->kind = gfc_default_logical_kind;
2052 goto kind_selector;
2055 /* REAL is a real pain because it can be a type, intrinsic subprogram,
2056 or list item in a type-list of an OpenMP reduction clause. Need to
2057 differentiate REAL([KIND]=scalar-int-initialization-expr) from
2058 REAL(A,[KIND]) and REAL(KIND,A). */
2060 m = gfc_match (" %n", name);
2061 if (m == MATCH_YES && strcmp (name, "real") == 0)
2063 char c;
2064 gfc_expr *e;
2065 locus where;
2067 ts->type = BT_REAL;
2068 ts->kind = gfc_default_real_kind;
2070 gfc_gobble_whitespace ();
2072 /* Prevent REAL*4, etc. */
2073 c = gfc_peek_ascii_char ();
2074 if (c == '*')
2076 gfc_error ("Invalid type-spec at %C");
2077 return MATCH_ERROR;
2080 /* Found leading colon in REAL::, a trailing ')' in for example
2081 TYPE IS (REAL), or REAL, for an OpenMP list-item. */
2082 if (c == ':' || c == ')' || (flag_openmp && c == ','))
2083 return MATCH_YES;
2085 /* Found something other than the opening '(' in REAL(... */
2086 if (c != '(')
2087 return MATCH_NO;
2088 else
2089 gfc_next_char (); /* Burn the '('. */
2091 /* Look for the optional KIND=. */
2092 where = gfc_current_locus;
2093 m = gfc_match ("%n", name);
2094 if (m == MATCH_YES)
2096 gfc_gobble_whitespace ();
2097 c = gfc_next_char ();
2098 if (c == '=')
2100 if (strcmp(name, "a") == 0)
2101 return MATCH_NO;
2102 else if (strcmp(name, "kind") == 0)
2103 goto found;
2104 else
2105 return MATCH_ERROR;
2107 else
2108 gfc_current_locus = where;
2110 else
2111 gfc_current_locus = where;
2113 found:
2115 m = gfc_match_init_expr (&e);
2116 if (m == MATCH_NO || m == MATCH_ERROR)
2117 return MATCH_NO;
2119 /* If a comma appears, it is an intrinsic subprogram. */
2120 gfc_gobble_whitespace ();
2121 c = gfc_peek_ascii_char ();
2122 if (c == ',')
2124 gfc_free_expr (e);
2125 return MATCH_NO;
2128 /* If ')' appears, we have REAL(initialization-expr), here check for
2129 a scalar integer initialization-expr and valid kind parameter. */
2130 if (c == ')')
2132 if (e->ts.type != BT_INTEGER || e->rank > 0)
2134 gfc_free_expr (e);
2135 return MATCH_NO;
2138 gfc_next_char (); /* Burn the ')'. */
2139 ts->kind = (int) mpz_get_si (e->value.integer);
2140 if (gfc_validate_kind (BT_REAL, ts->kind , true) == -1)
2142 gfc_error ("Invalid type-spec at %C");
2143 return MATCH_ERROR;
2146 gfc_free_expr (e);
2148 return MATCH_YES;
2152 /* If a type is not matched, simply return MATCH_NO. */
2153 gfc_current_locus = old_locus;
2154 return MATCH_NO;
2156 kind_selector:
2158 gfc_gobble_whitespace ();
2160 /* This prevents INTEGER*4, etc. */
2161 if (gfc_peek_ascii_char () == '*')
2163 gfc_error ("Invalid type-spec at %C");
2164 return MATCH_ERROR;
2167 m = gfc_match_kind_spec (ts, false);
2169 /* No kind specifier found. */
2170 if (m == MATCH_NO)
2171 m = MATCH_YES;
2173 return m;
2177 /******************** FORALL subroutines ********************/
2179 /* Free a list of FORALL iterators. */
2181 void
2182 gfc_free_forall_iterator (gfc_forall_iterator *iter)
2184 gfc_forall_iterator *next;
2186 while (iter)
2188 next = iter->next;
2189 gfc_free_expr (iter->var);
2190 gfc_free_expr (iter->start);
2191 gfc_free_expr (iter->end);
2192 gfc_free_expr (iter->stride);
2193 free (iter);
2194 iter = next;
2199 /* Match an iterator as part of a FORALL statement. The format is:
2201 <var> = <start>:<end>[:<stride>]
2203 On MATCH_NO, the caller tests for the possibility that there is a
2204 scalar mask expression. */
2206 static match
2207 match_forall_iterator (gfc_forall_iterator **result)
2209 gfc_forall_iterator *iter;
2210 locus where;
2211 match m;
2213 where = gfc_current_locus;
2214 iter = XCNEW (gfc_forall_iterator);
2216 m = gfc_match_expr (&iter->var);
2217 if (m != MATCH_YES)
2218 goto cleanup;
2220 if (gfc_match_char ('=') != MATCH_YES
2221 || iter->var->expr_type != EXPR_VARIABLE)
2223 m = MATCH_NO;
2224 goto cleanup;
2227 m = gfc_match_expr (&iter->start);
2228 if (m != MATCH_YES)
2229 goto cleanup;
2231 if (gfc_match_char (':') != MATCH_YES)
2232 goto syntax;
2234 m = gfc_match_expr (&iter->end);
2235 if (m == MATCH_NO)
2236 goto syntax;
2237 if (m == MATCH_ERROR)
2238 goto cleanup;
2240 if (gfc_match_char (':') == MATCH_NO)
2241 iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
2242 else
2244 m = gfc_match_expr (&iter->stride);
2245 if (m == MATCH_NO)
2246 goto syntax;
2247 if (m == MATCH_ERROR)
2248 goto cleanup;
2251 /* Mark the iteration variable's symbol as used as a FORALL index. */
2252 iter->var->symtree->n.sym->forall_index = true;
2254 *result = iter;
2255 return MATCH_YES;
2257 syntax:
2258 gfc_error ("Syntax error in FORALL iterator at %C");
2259 m = MATCH_ERROR;
2261 cleanup:
2263 gfc_current_locus = where;
2264 gfc_free_forall_iterator (iter);
2265 return m;
2269 /* Match the header of a FORALL statement. */
2271 static match
2272 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
2274 gfc_forall_iterator *head, *tail, *new_iter;
2275 gfc_expr *msk;
2276 match m;
2278 gfc_gobble_whitespace ();
2280 head = tail = NULL;
2281 msk = NULL;
2283 if (gfc_match_char ('(') != MATCH_YES)
2284 return MATCH_NO;
2286 m = match_forall_iterator (&new_iter);
2287 if (m == MATCH_ERROR)
2288 goto cleanup;
2289 if (m == MATCH_NO)
2290 goto syntax;
2292 head = tail = new_iter;
2294 for (;;)
2296 if (gfc_match_char (',') != MATCH_YES)
2297 break;
2299 m = match_forall_iterator (&new_iter);
2300 if (m == MATCH_ERROR)
2301 goto cleanup;
2303 if (m == MATCH_YES)
2305 tail->next = new_iter;
2306 tail = new_iter;
2307 continue;
2310 /* Have to have a mask expression. */
2312 m = gfc_match_expr (&msk);
2313 if (m == MATCH_NO)
2314 goto syntax;
2315 if (m == MATCH_ERROR)
2316 goto cleanup;
2318 break;
2321 if (gfc_match_char (')') == MATCH_NO)
2322 goto syntax;
2324 *phead = head;
2325 *mask = msk;
2326 return MATCH_YES;
2328 syntax:
2329 gfc_syntax_error (ST_FORALL);
2331 cleanup:
2332 gfc_free_expr (msk);
2333 gfc_free_forall_iterator (head);
2335 return MATCH_ERROR;
2338 /* Match the rest of a simple FORALL statement that follows an
2339 IF statement. */
2341 static match
2342 match_simple_forall (void)
2344 gfc_forall_iterator *head;
2345 gfc_expr *mask;
2346 gfc_code *c;
2347 match m;
2349 mask = NULL;
2350 head = NULL;
2351 c = NULL;
2353 m = match_forall_header (&head, &mask);
2355 if (m == MATCH_NO)
2356 goto syntax;
2357 if (m != MATCH_YES)
2358 goto cleanup;
2360 m = gfc_match_assignment ();
2362 if (m == MATCH_ERROR)
2363 goto cleanup;
2364 if (m == MATCH_NO)
2366 m = gfc_match_pointer_assignment ();
2367 if (m == MATCH_ERROR)
2368 goto cleanup;
2369 if (m == MATCH_NO)
2370 goto syntax;
2373 c = XCNEW (gfc_code);
2374 *c = new_st;
2375 c->loc = gfc_current_locus;
2377 if (gfc_match_eos () != MATCH_YES)
2378 goto syntax;
2380 gfc_clear_new_st ();
2381 new_st.op = EXEC_FORALL;
2382 new_st.expr1 = mask;
2383 new_st.ext.forall_iterator = head;
2384 new_st.block = gfc_get_code (EXEC_FORALL);
2385 new_st.block->next = c;
2387 return MATCH_YES;
2389 syntax:
2390 gfc_syntax_error (ST_FORALL);
2392 cleanup:
2393 gfc_free_forall_iterator (head);
2394 gfc_free_expr (mask);
2396 return MATCH_ERROR;
2400 /* Match a FORALL statement. */
2402 match
2403 gfc_match_forall (gfc_statement *st)
2405 gfc_forall_iterator *head;
2406 gfc_expr *mask;
2407 gfc_code *c;
2408 match m0, m;
2410 head = NULL;
2411 mask = NULL;
2412 c = NULL;
2414 m0 = gfc_match_label ();
2415 if (m0 == MATCH_ERROR)
2416 return MATCH_ERROR;
2418 m = gfc_match (" forall");
2419 if (m != MATCH_YES)
2420 return m;
2422 m = match_forall_header (&head, &mask);
2423 if (m == MATCH_ERROR)
2424 goto cleanup;
2425 if (m == MATCH_NO)
2426 goto syntax;
2428 if (gfc_match_eos () == MATCH_YES)
2430 *st = ST_FORALL_BLOCK;
2431 new_st.op = EXEC_FORALL;
2432 new_st.expr1 = mask;
2433 new_st.ext.forall_iterator = head;
2434 return MATCH_YES;
2437 m = gfc_match_assignment ();
2438 if (m == MATCH_ERROR)
2439 goto cleanup;
2440 if (m == MATCH_NO)
2442 m = gfc_match_pointer_assignment ();
2443 if (m == MATCH_ERROR)
2444 goto cleanup;
2445 if (m == MATCH_NO)
2446 goto syntax;
2449 c = XCNEW (gfc_code);
2450 *c = new_st;
2451 c->loc = gfc_current_locus;
2453 gfc_clear_new_st ();
2454 new_st.op = EXEC_FORALL;
2455 new_st.expr1 = mask;
2456 new_st.ext.forall_iterator = head;
2457 new_st.block = gfc_get_code (EXEC_FORALL);
2458 new_st.block->next = c;
2460 *st = ST_FORALL;
2461 return MATCH_YES;
2463 syntax:
2464 gfc_syntax_error (ST_FORALL);
2466 cleanup:
2467 gfc_free_forall_iterator (head);
2468 gfc_free_expr (mask);
2469 gfc_free_statements (c);
2470 return MATCH_NO;
2474 /* Match a DO statement. */
2476 match
2477 gfc_match_do (void)
2479 gfc_iterator iter, *ip;
2480 locus old_loc;
2481 gfc_st_label *label;
2482 match m;
2484 old_loc = gfc_current_locus;
2486 label = NULL;
2487 iter.var = iter.start = iter.end = iter.step = NULL;
2489 m = gfc_match_label ();
2490 if (m == MATCH_ERROR)
2491 return m;
2493 if (gfc_match (" do") != MATCH_YES)
2494 return MATCH_NO;
2496 m = gfc_match_st_label (&label);
2497 if (m == MATCH_ERROR)
2498 goto cleanup;
2500 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2502 if (gfc_match_eos () == MATCH_YES)
2504 iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
2505 new_st.op = EXEC_DO_WHILE;
2506 goto done;
2509 /* Match an optional comma, if no comma is found, a space is obligatory. */
2510 if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
2511 return MATCH_NO;
2513 /* Check for balanced parens. */
2515 if (gfc_match_parens () == MATCH_ERROR)
2516 return MATCH_ERROR;
2518 if (gfc_match (" concurrent") == MATCH_YES)
2520 gfc_forall_iterator *head;
2521 gfc_expr *mask;
2523 if (!gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT construct at %C"))
2524 return MATCH_ERROR;
2527 mask = NULL;
2528 head = NULL;
2529 m = match_forall_header (&head, &mask);
2531 if (m == MATCH_NO)
2532 return m;
2533 if (m == MATCH_ERROR)
2534 goto concurr_cleanup;
2536 if (gfc_match_eos () != MATCH_YES)
2537 goto concurr_cleanup;
2539 if (label != NULL
2540 && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
2541 goto concurr_cleanup;
2543 new_st.label1 = label;
2544 new_st.op = EXEC_DO_CONCURRENT;
2545 new_st.expr1 = mask;
2546 new_st.ext.forall_iterator = head;
2548 return MATCH_YES;
2550 concurr_cleanup:
2551 gfc_syntax_error (ST_DO);
2552 gfc_free_expr (mask);
2553 gfc_free_forall_iterator (head);
2554 return MATCH_ERROR;
2557 /* See if we have a DO WHILE. */
2558 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
2560 new_st.op = EXEC_DO_WHILE;
2561 goto done;
2564 /* The abortive DO WHILE may have done something to the symbol
2565 table, so we start over. */
2566 gfc_undo_symbols ();
2567 gfc_current_locus = old_loc;
2569 gfc_match_label (); /* This won't error. */
2570 gfc_match (" do "); /* This will work. */
2572 gfc_match_st_label (&label); /* Can't error out. */
2573 gfc_match_char (','); /* Optional comma. */
2575 m = gfc_match_iterator (&iter, 0);
2576 if (m == MATCH_NO)
2577 return MATCH_NO;
2578 if (m == MATCH_ERROR)
2579 goto cleanup;
2581 iter.var->symtree->n.sym->attr.implied_index = 0;
2582 gfc_check_do_variable (iter.var->symtree);
2584 if (gfc_match_eos () != MATCH_YES)
2586 gfc_syntax_error (ST_DO);
2587 goto cleanup;
2590 new_st.op = EXEC_DO;
2592 done:
2593 if (label != NULL
2594 && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
2595 goto cleanup;
2597 new_st.label1 = label;
2599 if (new_st.op == EXEC_DO_WHILE)
2600 new_st.expr1 = iter.end;
2601 else
2603 new_st.ext.iterator = ip = gfc_get_iterator ();
2604 *ip = iter;
2607 return MATCH_YES;
2609 cleanup:
2610 gfc_free_iterator (&iter, 0);
2612 return MATCH_ERROR;
2616 /* Match an EXIT or CYCLE statement. */
2618 static match
2619 match_exit_cycle (gfc_statement st, gfc_exec_op op)
2621 gfc_state_data *p, *o;
2622 gfc_symbol *sym;
2623 match m;
2624 int cnt;
2626 if (gfc_match_eos () == MATCH_YES)
2627 sym = NULL;
2628 else
2630 char name[GFC_MAX_SYMBOL_LEN + 1];
2631 gfc_symtree* stree;
2633 m = gfc_match ("% %n%t", name);
2634 if (m == MATCH_ERROR)
2635 return MATCH_ERROR;
2636 if (m == MATCH_NO)
2638 gfc_syntax_error (st);
2639 return MATCH_ERROR;
2642 /* Find the corresponding symbol. If there's a BLOCK statement
2643 between here and the label, it is not in gfc_current_ns but a parent
2644 namespace! */
2645 stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
2646 if (!stree)
2648 gfc_error ("Name %qs in %s statement at %C is unknown",
2649 name, gfc_ascii_statement (st));
2650 return MATCH_ERROR;
2653 sym = stree->n.sym;
2654 if (sym->attr.flavor != FL_LABEL)
2656 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2657 name, gfc_ascii_statement (st));
2658 return MATCH_ERROR;
2662 /* Find the loop specified by the label (or lack of a label). */
2663 for (o = NULL, p = gfc_state_stack; p; p = p->previous)
2664 if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
2665 o = p;
2666 else if (p->state == COMP_CRITICAL)
2668 gfc_error("%s statement at %C leaves CRITICAL construct",
2669 gfc_ascii_statement (st));
2670 return MATCH_ERROR;
2672 else if (p->state == COMP_DO_CONCURRENT
2673 && (op == EXEC_EXIT || (sym && sym != p->sym)))
2675 /* F2008, C821 & C845. */
2676 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2677 gfc_ascii_statement (st));
2678 return MATCH_ERROR;
2680 else if ((sym && sym == p->sym)
2681 || (!sym && (p->state == COMP_DO
2682 || p->state == COMP_DO_CONCURRENT)))
2683 break;
2685 if (p == NULL)
2687 if (sym == NULL)
2688 gfc_error ("%s statement at %C is not within a construct",
2689 gfc_ascii_statement (st));
2690 else
2691 gfc_error ("%s statement at %C is not within construct %qs",
2692 gfc_ascii_statement (st), sym->name);
2694 return MATCH_ERROR;
2697 /* Special checks for EXIT from non-loop constructs. */
2698 switch (p->state)
2700 case COMP_DO:
2701 case COMP_DO_CONCURRENT:
2702 break;
2704 case COMP_CRITICAL:
2705 /* This is already handled above. */
2706 gcc_unreachable ();
2708 case COMP_ASSOCIATE:
2709 case COMP_BLOCK:
2710 case COMP_IF:
2711 case COMP_SELECT:
2712 case COMP_SELECT_TYPE:
2713 gcc_assert (sym);
2714 if (op == EXEC_CYCLE)
2716 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2717 " construct %qs", sym->name);
2718 return MATCH_ERROR;
2720 gcc_assert (op == EXEC_EXIT);
2721 if (!gfc_notify_std (GFC_STD_F2008, "EXIT statement with no"
2722 " do-construct-name at %C"))
2723 return MATCH_ERROR;
2724 break;
2726 default:
2727 gfc_error ("%s statement at %C is not applicable to construct %qs",
2728 gfc_ascii_statement (st), sym->name);
2729 return MATCH_ERROR;
2732 if (o != NULL)
2734 gfc_error (is_oacc (p)
2735 ? G_("%s statement at %C leaving OpenACC structured block")
2736 : G_("%s statement at %C leaving OpenMP structured block"),
2737 gfc_ascii_statement (st));
2738 return MATCH_ERROR;
2741 for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++)
2742 o = o->previous;
2743 if (cnt > 0
2744 && o != NULL
2745 && o->state == COMP_OMP_STRUCTURED_BLOCK
2746 && (o->head->op == EXEC_OACC_LOOP
2747 || o->head->op == EXEC_OACC_PARALLEL_LOOP))
2749 int collapse = 1;
2750 gcc_assert (o->head->next != NULL
2751 && (o->head->next->op == EXEC_DO
2752 || o->head->next->op == EXEC_DO_WHILE)
2753 && o->previous != NULL
2754 && o->previous->tail->op == o->head->op);
2755 if (o->previous->tail->ext.omp_clauses != NULL
2756 && o->previous->tail->ext.omp_clauses->collapse > 1)
2757 collapse = o->previous->tail->ext.omp_clauses->collapse;
2758 if (st == ST_EXIT && cnt <= collapse)
2760 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2761 return MATCH_ERROR;
2763 if (st == ST_CYCLE && cnt < collapse)
2765 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2766 " !$ACC LOOP loop");
2767 return MATCH_ERROR;
2770 if (cnt > 0
2771 && o != NULL
2772 && (o->state == COMP_OMP_STRUCTURED_BLOCK)
2773 && (o->head->op == EXEC_OMP_DO
2774 || o->head->op == EXEC_OMP_PARALLEL_DO
2775 || o->head->op == EXEC_OMP_SIMD
2776 || o->head->op == EXEC_OMP_DO_SIMD
2777 || o->head->op == EXEC_OMP_PARALLEL_DO_SIMD))
2779 int count = 1;
2780 gcc_assert (o->head->next != NULL
2781 && (o->head->next->op == EXEC_DO
2782 || o->head->next->op == EXEC_DO_WHILE)
2783 && o->previous != NULL
2784 && o->previous->tail->op == o->head->op);
2785 if (o->previous->tail->ext.omp_clauses != NULL)
2787 if (o->previous->tail->ext.omp_clauses->collapse > 1)
2788 count = o->previous->tail->ext.omp_clauses->collapse;
2789 if (o->previous->tail->ext.omp_clauses->orderedc)
2790 count = o->previous->tail->ext.omp_clauses->orderedc;
2792 if (st == ST_EXIT && cnt <= count)
2794 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2795 return MATCH_ERROR;
2797 if (st == ST_CYCLE && cnt < count)
2799 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2800 " !$OMP DO loop");
2801 return MATCH_ERROR;
2805 /* Save the first statement in the construct - needed by the backend. */
2806 new_st.ext.which_construct = p->construct;
2808 new_st.op = op;
2810 return MATCH_YES;
2814 /* Match the EXIT statement. */
2816 match
2817 gfc_match_exit (void)
2819 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
2823 /* Match the CYCLE statement. */
2825 match
2826 gfc_match_cycle (void)
2828 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
2832 /* Match a stop-code after an (ERROR) STOP or PAUSE statement. The
2833 requirements for a stop-code differ in the standards.
2835 Fortran 95 has
2837 R840 stop-stmt is STOP [ stop-code ]
2838 R841 stop-code is scalar-char-constant
2839 or digit [ digit [ digit [ digit [ digit ] ] ] ]
2841 Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
2842 Fortran 2008 has
2844 R855 stop-stmt is STOP [ stop-code ]
2845 R856 allstop-stmt is ALL STOP [ stop-code ]
2846 R857 stop-code is scalar-default-char-constant-expr
2847 or scalar-int-constant-expr
2849 For free-form source code, all standards contain a statement of the form:
2851 A blank shall be used to separate names, constants, or labels from
2852 adjacent keywords, names, constants, or labels.
2854 A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003,
2856 STOP123
2858 is valid, but it is invalid Fortran 2008. */
2860 static match
2861 gfc_match_stopcode (gfc_statement st)
2863 gfc_expr *e = NULL;
2864 match m;
2865 bool f95, f03;
2867 /* Set f95 for -std=f95. */
2868 f95 = gfc_option.allow_std == (GFC_STD_F95_OBS | GFC_STD_F95 | GFC_STD_F77
2869 | GFC_STD_F2008_OBS);
2871 /* Set f03 for -std=f2003. */
2872 f03 = gfc_option.allow_std == (GFC_STD_F95_OBS | GFC_STD_F95 | GFC_STD_F77
2873 | GFC_STD_F2008_OBS | GFC_STD_F2003);
2875 /* Look for a blank between STOP and the stop-code for F2008 or later. */
2876 if (gfc_current_form != FORM_FIXED && !(f95 || f03))
2878 char c = gfc_peek_ascii_char ();
2880 /* Look for end-of-statement. There is no stop-code. */
2881 if (c == '\n' || c == '!' || c == ';')
2882 goto done;
2884 if (c != ' ')
2886 gfc_error ("Blank required in %s statement near %C",
2887 gfc_ascii_statement (st));
2888 return MATCH_ERROR;
2892 if (gfc_match_eos () != MATCH_YES)
2894 int stopcode;
2895 locus old_locus;
2897 /* First look for the F95 or F2003 digit [...] construct. */
2898 old_locus = gfc_current_locus;
2899 m = gfc_match_small_int (&stopcode);
2900 if (m == MATCH_YES && (f95 || f03))
2902 if (stopcode < 0)
2904 gfc_error ("STOP code at %C cannot be negative");
2905 return MATCH_ERROR;
2908 if (stopcode > 99999)
2910 gfc_error ("STOP code at %C contains too many digits");
2911 return MATCH_ERROR;
2915 /* Reset the locus and now load gfc_expr. */
2916 gfc_current_locus = old_locus;
2917 m = gfc_match_expr (&e);
2918 if (m == MATCH_ERROR)
2919 goto cleanup;
2920 if (m == MATCH_NO)
2921 goto syntax;
2923 if (gfc_match_eos () != MATCH_YES)
2924 goto syntax;
2927 if (gfc_pure (NULL))
2929 if (st == ST_ERROR_STOP)
2931 if (!gfc_notify_std (GFC_STD_F2015, "%s statement at %C in PURE "
2932 "procedure", gfc_ascii_statement (st)))
2933 goto cleanup;
2935 else
2937 gfc_error ("%s statement not allowed in PURE procedure at %C",
2938 gfc_ascii_statement (st));
2939 goto cleanup;
2943 gfc_unset_implicit_pure (NULL);
2945 if (st == ST_STOP && gfc_find_state (COMP_CRITICAL))
2947 gfc_error ("Image control statement STOP at %C in CRITICAL block");
2948 goto cleanup;
2950 if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT))
2952 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
2953 goto cleanup;
2956 if (e != NULL)
2958 gfc_simplify_expr (e, 0);
2960 /* Test for F95 and F2003 style STOP stop-code. */
2961 if (e->expr_type != EXPR_CONSTANT && (f95 || f03))
2963 gfc_error ("STOP code at %L must be a scalar CHARACTER constant or "
2964 "digit[digit[digit[digit[digit]]]]", &e->where);
2965 goto cleanup;
2968 /* Use the machinery for an initialization expression to reduce the
2969 stop-code to a constant. */
2970 gfc_init_expr_flag = true;
2971 gfc_reduce_init_expr (e);
2972 gfc_init_expr_flag = false;
2974 if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
2976 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2977 &e->where);
2978 goto cleanup;
2981 if (e->rank != 0)
2983 gfc_error ("STOP code at %L must be scalar", &e->where);
2984 goto cleanup;
2987 if (e->ts.type == BT_CHARACTER
2988 && e->ts.kind != gfc_default_character_kind)
2990 gfc_error ("STOP code at %L must be default character KIND=%d",
2991 &e->where, (int) gfc_default_character_kind);
2992 goto cleanup;
2995 if (e->ts.type == BT_INTEGER && e->ts.kind != gfc_default_integer_kind)
2997 gfc_error ("STOP code at %L must be default integer KIND=%d",
2998 &e->where, (int) gfc_default_integer_kind);
2999 goto cleanup;
3003 done:
3005 switch (st)
3007 case ST_STOP:
3008 new_st.op = EXEC_STOP;
3009 break;
3010 case ST_ERROR_STOP:
3011 new_st.op = EXEC_ERROR_STOP;
3012 break;
3013 case ST_PAUSE:
3014 new_st.op = EXEC_PAUSE;
3015 break;
3016 default:
3017 gcc_unreachable ();
3020 new_st.expr1 = e;
3021 new_st.ext.stop_code = -1;
3023 return MATCH_YES;
3025 syntax:
3026 gfc_syntax_error (st);
3028 cleanup:
3030 gfc_free_expr (e);
3031 return MATCH_ERROR;
3035 /* Match the (deprecated) PAUSE statement. */
3037 match
3038 gfc_match_pause (void)
3040 match m;
3042 m = gfc_match_stopcode (ST_PAUSE);
3043 if (m == MATCH_YES)
3045 if (!gfc_notify_std (GFC_STD_F95_DEL, "PAUSE statement at %C"))
3046 m = MATCH_ERROR;
3048 return m;
3052 /* Match the STOP statement. */
3054 match
3055 gfc_match_stop (void)
3057 return gfc_match_stopcode (ST_STOP);
3061 /* Match the ERROR STOP statement. */
3063 match
3064 gfc_match_error_stop (void)
3066 if (!gfc_notify_std (GFC_STD_F2008, "ERROR STOP statement at %C"))
3067 return MATCH_ERROR;
3069 return gfc_match_stopcode (ST_ERROR_STOP);
3072 /* Match EVENT POST/WAIT statement. Syntax:
3073 EVENT POST ( event-variable [, sync-stat-list] )
3074 EVENT WAIT ( event-variable [, wait-spec-list] )
3075 with
3076 wait-spec-list is sync-stat-list or until-spec
3077 until-spec is UNTIL_COUNT = scalar-int-expr
3078 sync-stat is STAT= or ERRMSG=. */
3080 static match
3081 event_statement (gfc_statement st)
3083 match m;
3084 gfc_expr *tmp, *eventvar, *until_count, *stat, *errmsg;
3085 bool saw_until_count, saw_stat, saw_errmsg;
3087 tmp = eventvar = until_count = stat = errmsg = NULL;
3088 saw_until_count = saw_stat = saw_errmsg = false;
3090 if (gfc_pure (NULL))
3092 gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
3093 st == ST_EVENT_POST ? "POST" : "WAIT");
3094 return MATCH_ERROR;
3097 gfc_unset_implicit_pure (NULL);
3099 if (flag_coarray == GFC_FCOARRAY_NONE)
3101 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3102 return MATCH_ERROR;
3105 if (gfc_find_state (COMP_CRITICAL))
3107 gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
3108 st == ST_EVENT_POST ? "POST" : "WAIT");
3109 return MATCH_ERROR;
3112 if (gfc_find_state (COMP_DO_CONCURRENT))
3114 gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
3115 "block", st == ST_EVENT_POST ? "POST" : "WAIT");
3116 return MATCH_ERROR;
3119 if (gfc_match_char ('(') != MATCH_YES)
3120 goto syntax;
3122 if (gfc_match ("%e", &eventvar) != MATCH_YES)
3123 goto syntax;
3124 m = gfc_match_char (',');
3125 if (m == MATCH_ERROR)
3126 goto syntax;
3127 if (m == MATCH_NO)
3129 m = gfc_match_char (')');
3130 if (m == MATCH_YES)
3131 goto done;
3132 goto syntax;
3135 for (;;)
3137 m = gfc_match (" stat = %v", &tmp);
3138 if (m == MATCH_ERROR)
3139 goto syntax;
3140 if (m == MATCH_YES)
3142 if (saw_stat)
3144 gfc_error ("Redundant STAT tag found at %L", &tmp->where);
3145 goto cleanup;
3147 stat = tmp;
3148 saw_stat = true;
3150 m = gfc_match_char (',');
3151 if (m == MATCH_YES)
3152 continue;
3154 tmp = NULL;
3155 break;
3158 m = gfc_match (" errmsg = %v", &tmp);
3159 if (m == MATCH_ERROR)
3160 goto syntax;
3161 if (m == MATCH_YES)
3163 if (saw_errmsg)
3165 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
3166 goto cleanup;
3168 errmsg = tmp;
3169 saw_errmsg = true;
3171 m = gfc_match_char (',');
3172 if (m == MATCH_YES)
3173 continue;
3175 tmp = NULL;
3176 break;
3179 m = gfc_match (" until_count = %e", &tmp);
3180 if (m == MATCH_ERROR || st == ST_EVENT_POST)
3181 goto syntax;
3182 if (m == MATCH_YES)
3184 if (saw_until_count)
3186 gfc_error ("Redundant UNTIL_COUNT tag found at %L",
3187 &tmp->where);
3188 goto cleanup;
3190 until_count = tmp;
3191 saw_until_count = true;
3193 m = gfc_match_char (',');
3194 if (m == MATCH_YES)
3195 continue;
3197 tmp = NULL;
3198 break;
3201 break;
3204 if (m == MATCH_ERROR)
3205 goto syntax;
3207 if (gfc_match (" )%t") != MATCH_YES)
3208 goto syntax;
3210 done:
3211 switch (st)
3213 case ST_EVENT_POST:
3214 new_st.op = EXEC_EVENT_POST;
3215 break;
3216 case ST_EVENT_WAIT:
3217 new_st.op = EXEC_EVENT_WAIT;
3218 break;
3219 default:
3220 gcc_unreachable ();
3223 new_st.expr1 = eventvar;
3224 new_st.expr2 = stat;
3225 new_st.expr3 = errmsg;
3226 new_st.expr4 = until_count;
3228 return MATCH_YES;
3230 syntax:
3231 gfc_syntax_error (st);
3233 cleanup:
3234 if (until_count != tmp)
3235 gfc_free_expr (until_count);
3236 if (errmsg != tmp)
3237 gfc_free_expr (errmsg);
3238 if (stat != tmp)
3239 gfc_free_expr (stat);
3241 gfc_free_expr (tmp);
3242 gfc_free_expr (eventvar);
3244 return MATCH_ERROR;
3249 match
3250 gfc_match_event_post (void)
3252 if (!gfc_notify_std (GFC_STD_F2008_TS, "EVENT POST statement at %C"))
3253 return MATCH_ERROR;
3255 return event_statement (ST_EVENT_POST);
3259 match
3260 gfc_match_event_wait (void)
3262 if (!gfc_notify_std (GFC_STD_F2008_TS, "EVENT WAIT statement at %C"))
3263 return MATCH_ERROR;
3265 return event_statement (ST_EVENT_WAIT);
3269 /* Match a FAIL IMAGE statement. */
3271 match
3272 gfc_match_fail_image (void)
3274 if (!gfc_notify_std (GFC_STD_F2008_TS, "FAIL IMAGE statement at %C"))
3275 return MATCH_ERROR;
3277 if (gfc_match_char ('(') == MATCH_YES)
3278 goto syntax;
3280 new_st.op = EXEC_FAIL_IMAGE;
3282 return MATCH_YES;
3284 syntax:
3285 gfc_syntax_error (ST_FAIL_IMAGE);
3287 return MATCH_ERROR;
3291 /* Match LOCK/UNLOCK statement. Syntax:
3292 LOCK ( lock-variable [ , lock-stat-list ] )
3293 UNLOCK ( lock-variable [ , sync-stat-list ] )
3294 where lock-stat is ACQUIRED_LOCK or sync-stat
3295 and sync-stat is STAT= or ERRMSG=. */
3297 static match
3298 lock_unlock_statement (gfc_statement st)
3300 match m;
3301 gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg;
3302 bool saw_acq_lock, saw_stat, saw_errmsg;
3304 tmp = lockvar = acq_lock = stat = errmsg = NULL;
3305 saw_acq_lock = saw_stat = saw_errmsg = false;
3307 if (gfc_pure (NULL))
3309 gfc_error ("Image control statement %s at %C in PURE procedure",
3310 st == ST_LOCK ? "LOCK" : "UNLOCK");
3311 return MATCH_ERROR;
3314 gfc_unset_implicit_pure (NULL);
3316 if (flag_coarray == GFC_FCOARRAY_NONE)
3318 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3319 return MATCH_ERROR;
3322 if (gfc_find_state (COMP_CRITICAL))
3324 gfc_error ("Image control statement %s at %C in CRITICAL block",
3325 st == ST_LOCK ? "LOCK" : "UNLOCK");
3326 return MATCH_ERROR;
3329 if (gfc_find_state (COMP_DO_CONCURRENT))
3331 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
3332 st == ST_LOCK ? "LOCK" : "UNLOCK");
3333 return MATCH_ERROR;
3336 if (gfc_match_char ('(') != MATCH_YES)
3337 goto syntax;
3339 if (gfc_match ("%e", &lockvar) != MATCH_YES)
3340 goto syntax;
3341 m = gfc_match_char (',');
3342 if (m == MATCH_ERROR)
3343 goto syntax;
3344 if (m == MATCH_NO)
3346 m = gfc_match_char (')');
3347 if (m == MATCH_YES)
3348 goto done;
3349 goto syntax;
3352 for (;;)
3354 m = gfc_match (" stat = %v", &tmp);
3355 if (m == MATCH_ERROR)
3356 goto syntax;
3357 if (m == MATCH_YES)
3359 if (saw_stat)
3361 gfc_error ("Redundant STAT tag found at %L", &tmp->where);
3362 goto cleanup;
3364 stat = tmp;
3365 saw_stat = true;
3367 m = gfc_match_char (',');
3368 if (m == MATCH_YES)
3369 continue;
3371 tmp = NULL;
3372 break;
3375 m = gfc_match (" errmsg = %v", &tmp);
3376 if (m == MATCH_ERROR)
3377 goto syntax;
3378 if (m == MATCH_YES)
3380 if (saw_errmsg)
3382 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
3383 goto cleanup;
3385 errmsg = tmp;
3386 saw_errmsg = true;
3388 m = gfc_match_char (',');
3389 if (m == MATCH_YES)
3390 continue;
3392 tmp = NULL;
3393 break;
3396 m = gfc_match (" acquired_lock = %v", &tmp);
3397 if (m == MATCH_ERROR || st == ST_UNLOCK)
3398 goto syntax;
3399 if (m == MATCH_YES)
3401 if (saw_acq_lock)
3403 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L",
3404 &tmp->where);
3405 goto cleanup;
3407 acq_lock = tmp;
3408 saw_acq_lock = true;
3410 m = gfc_match_char (',');
3411 if (m == MATCH_YES)
3412 continue;
3414 tmp = NULL;
3415 break;
3418 break;
3421 if (m == MATCH_ERROR)
3422 goto syntax;
3424 if (gfc_match (" )%t") != MATCH_YES)
3425 goto syntax;
3427 done:
3428 switch (st)
3430 case ST_LOCK:
3431 new_st.op = EXEC_LOCK;
3432 break;
3433 case ST_UNLOCK:
3434 new_st.op = EXEC_UNLOCK;
3435 break;
3436 default:
3437 gcc_unreachable ();
3440 new_st.expr1 = lockvar;
3441 new_st.expr2 = stat;
3442 new_st.expr3 = errmsg;
3443 new_st.expr4 = acq_lock;
3445 return MATCH_YES;
3447 syntax:
3448 gfc_syntax_error (st);
3450 cleanup:
3451 if (acq_lock != tmp)
3452 gfc_free_expr (acq_lock);
3453 if (errmsg != tmp)
3454 gfc_free_expr (errmsg);
3455 if (stat != tmp)
3456 gfc_free_expr (stat);
3458 gfc_free_expr (tmp);
3459 gfc_free_expr (lockvar);
3461 return MATCH_ERROR;
3465 match
3466 gfc_match_lock (void)
3468 if (!gfc_notify_std (GFC_STD_F2008, "LOCK statement at %C"))
3469 return MATCH_ERROR;
3471 return lock_unlock_statement (ST_LOCK);
3475 match
3476 gfc_match_unlock (void)
3478 if (!gfc_notify_std (GFC_STD_F2008, "UNLOCK statement at %C"))
3479 return MATCH_ERROR;
3481 return lock_unlock_statement (ST_UNLOCK);
3485 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
3486 SYNC ALL [(sync-stat-list)]
3487 SYNC MEMORY [(sync-stat-list)]
3488 SYNC IMAGES (image-set [, sync-stat-list] )
3489 with sync-stat is int-expr or *. */
3491 static match
3492 sync_statement (gfc_statement st)
3494 match m;
3495 gfc_expr *tmp, *imageset, *stat, *errmsg;
3496 bool saw_stat, saw_errmsg;
3498 tmp = imageset = stat = errmsg = NULL;
3499 saw_stat = saw_errmsg = false;
3501 if (gfc_pure (NULL))
3503 gfc_error ("Image control statement SYNC at %C in PURE procedure");
3504 return MATCH_ERROR;
3507 gfc_unset_implicit_pure (NULL);
3509 if (!gfc_notify_std (GFC_STD_F2008, "SYNC statement at %C"))
3510 return MATCH_ERROR;
3512 if (flag_coarray == GFC_FCOARRAY_NONE)
3514 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
3515 "enable");
3516 return MATCH_ERROR;
3519 if (gfc_find_state (COMP_CRITICAL))
3521 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3522 return MATCH_ERROR;
3525 if (gfc_find_state (COMP_DO_CONCURRENT))
3527 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3528 return MATCH_ERROR;
3531 if (gfc_match_eos () == MATCH_YES)
3533 if (st == ST_SYNC_IMAGES)
3534 goto syntax;
3535 goto done;
3538 if (gfc_match_char ('(') != MATCH_YES)
3539 goto syntax;
3541 if (st == ST_SYNC_IMAGES)
3543 /* Denote '*' as imageset == NULL. */
3544 m = gfc_match_char ('*');
3545 if (m == MATCH_ERROR)
3546 goto syntax;
3547 if (m == MATCH_NO)
3549 if (gfc_match ("%e", &imageset) != MATCH_YES)
3550 goto syntax;
3552 m = gfc_match_char (',');
3553 if (m == MATCH_ERROR)
3554 goto syntax;
3555 if (m == MATCH_NO)
3557 m = gfc_match_char (')');
3558 if (m == MATCH_YES)
3559 goto done;
3560 goto syntax;
3564 for (;;)
3566 m = gfc_match (" stat = %v", &tmp);
3567 if (m == MATCH_ERROR)
3568 goto syntax;
3569 if (m == MATCH_YES)
3571 if (saw_stat)
3573 gfc_error ("Redundant STAT tag found at %L", &tmp->where);
3574 goto cleanup;
3576 stat = tmp;
3577 saw_stat = true;
3579 if (gfc_match_char (',') == MATCH_YES)
3580 continue;
3582 tmp = NULL;
3583 break;
3586 m = gfc_match (" errmsg = %v", &tmp);
3587 if (m == MATCH_ERROR)
3588 goto syntax;
3589 if (m == MATCH_YES)
3591 if (saw_errmsg)
3593 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
3594 goto cleanup;
3596 errmsg = tmp;
3597 saw_errmsg = true;
3599 if (gfc_match_char (',') == MATCH_YES)
3600 continue;
3602 tmp = NULL;
3603 break;
3606 break;
3609 if (gfc_match (" )%t") != MATCH_YES)
3610 goto syntax;
3612 done:
3613 switch (st)
3615 case ST_SYNC_ALL:
3616 new_st.op = EXEC_SYNC_ALL;
3617 break;
3618 case ST_SYNC_IMAGES:
3619 new_st.op = EXEC_SYNC_IMAGES;
3620 break;
3621 case ST_SYNC_MEMORY:
3622 new_st.op = EXEC_SYNC_MEMORY;
3623 break;
3624 default:
3625 gcc_unreachable ();
3628 new_st.expr1 = imageset;
3629 new_st.expr2 = stat;
3630 new_st.expr3 = errmsg;
3632 return MATCH_YES;
3634 syntax:
3635 gfc_syntax_error (st);
3637 cleanup:
3638 if (stat != tmp)
3639 gfc_free_expr (stat);
3640 if (errmsg != tmp)
3641 gfc_free_expr (errmsg);
3643 gfc_free_expr (tmp);
3644 gfc_free_expr (imageset);
3646 return MATCH_ERROR;
3650 /* Match SYNC ALL statement. */
3652 match
3653 gfc_match_sync_all (void)
3655 return sync_statement (ST_SYNC_ALL);
3659 /* Match SYNC IMAGES statement. */
3661 match
3662 gfc_match_sync_images (void)
3664 return sync_statement (ST_SYNC_IMAGES);
3668 /* Match SYNC MEMORY statement. */
3670 match
3671 gfc_match_sync_memory (void)
3673 return sync_statement (ST_SYNC_MEMORY);
3677 /* Match a CONTINUE statement. */
3679 match
3680 gfc_match_continue (void)
3682 if (gfc_match_eos () != MATCH_YES)
3684 gfc_syntax_error (ST_CONTINUE);
3685 return MATCH_ERROR;
3688 new_st.op = EXEC_CONTINUE;
3689 return MATCH_YES;
3693 /* Match the (deprecated) ASSIGN statement. */
3695 match
3696 gfc_match_assign (void)
3698 gfc_expr *expr;
3699 gfc_st_label *label;
3701 if (gfc_match (" %l", &label) == MATCH_YES)
3703 if (!gfc_reference_st_label (label, ST_LABEL_UNKNOWN))
3704 return MATCH_ERROR;
3705 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
3707 if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGN statement at %C"))
3708 return MATCH_ERROR;
3710 expr->symtree->n.sym->attr.assign = 1;
3712 new_st.op = EXEC_LABEL_ASSIGN;
3713 new_st.label1 = label;
3714 new_st.expr1 = expr;
3715 return MATCH_YES;
3718 return MATCH_NO;
3722 /* Match the GO TO statement. As a computed GOTO statement is
3723 matched, it is transformed into an equivalent SELECT block. No
3724 tree is necessary, and the resulting jumps-to-jumps are
3725 specifically optimized away by the back end. */
3727 match
3728 gfc_match_goto (void)
3730 gfc_code *head, *tail;
3731 gfc_expr *expr;
3732 gfc_case *cp;
3733 gfc_st_label *label;
3734 int i;
3735 match m;
3737 if (gfc_match (" %l%t", &label) == MATCH_YES)
3739 if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
3740 return MATCH_ERROR;
3742 new_st.op = EXEC_GOTO;
3743 new_st.label1 = label;
3744 return MATCH_YES;
3747 /* The assigned GO TO statement. */
3749 if (gfc_match_variable (&expr, 0) == MATCH_YES)
3751 if (!gfc_notify_std (GFC_STD_F95_DEL, "Assigned GOTO statement at %C"))
3752 return MATCH_ERROR;
3754 new_st.op = EXEC_GOTO;
3755 new_st.expr1 = expr;
3757 if (gfc_match_eos () == MATCH_YES)
3758 return MATCH_YES;
3760 /* Match label list. */
3761 gfc_match_char (',');
3762 if (gfc_match_char ('(') != MATCH_YES)
3764 gfc_syntax_error (ST_GOTO);
3765 return MATCH_ERROR;
3767 head = tail = NULL;
3771 m = gfc_match_st_label (&label);
3772 if (m != MATCH_YES)
3773 goto syntax;
3775 if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
3776 goto cleanup;
3778 if (head == NULL)
3779 head = tail = gfc_get_code (EXEC_GOTO);
3780 else
3782 tail->block = gfc_get_code (EXEC_GOTO);
3783 tail = tail->block;
3786 tail->label1 = label;
3788 while (gfc_match_char (',') == MATCH_YES);
3790 if (gfc_match (")%t") != MATCH_YES)
3791 goto syntax;
3793 if (head == NULL)
3795 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3796 goto syntax;
3798 new_st.block = head;
3800 return MATCH_YES;
3803 /* Last chance is a computed GO TO statement. */
3804 if (gfc_match_char ('(') != MATCH_YES)
3806 gfc_syntax_error (ST_GOTO);
3807 return MATCH_ERROR;
3810 head = tail = NULL;
3811 i = 1;
3815 m = gfc_match_st_label (&label);
3816 if (m != MATCH_YES)
3817 goto syntax;
3819 if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
3820 goto cleanup;
3822 if (head == NULL)
3823 head = tail = gfc_get_code (EXEC_SELECT);
3824 else
3826 tail->block = gfc_get_code (EXEC_SELECT);
3827 tail = tail->block;
3830 cp = gfc_get_case ();
3831 cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
3832 NULL, i++);
3834 tail->ext.block.case_list = cp;
3836 tail->next = gfc_get_code (EXEC_GOTO);
3837 tail->next->label1 = label;
3839 while (gfc_match_char (',') == MATCH_YES);
3841 if (gfc_match_char (')') != MATCH_YES)
3842 goto syntax;
3844 if (head == NULL)
3846 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3847 goto syntax;
3850 /* Get the rest of the statement. */
3851 gfc_match_char (',');
3853 if (gfc_match (" %e%t", &expr) != MATCH_YES)
3854 goto syntax;
3856 if (!gfc_notify_std (GFC_STD_F95_OBS, "Computed GOTO at %C"))
3857 return MATCH_ERROR;
3859 /* At this point, a computed GOTO has been fully matched and an
3860 equivalent SELECT statement constructed. */
3862 new_st.op = EXEC_SELECT;
3863 new_st.expr1 = NULL;
3865 /* Hack: For a "real" SELECT, the expression is in expr. We put
3866 it in expr2 so we can distinguish then and produce the correct
3867 diagnostics. */
3868 new_st.expr2 = expr;
3869 new_st.block = head;
3870 return MATCH_YES;
3872 syntax:
3873 gfc_syntax_error (ST_GOTO);
3874 cleanup:
3875 gfc_free_statements (head);
3876 return MATCH_ERROR;
3880 /* Frees a list of gfc_alloc structures. */
3882 void
3883 gfc_free_alloc_list (gfc_alloc *p)
3885 gfc_alloc *q;
3887 for (; p; p = q)
3889 q = p->next;
3890 gfc_free_expr (p->expr);
3891 free (p);
3896 /* Match an ALLOCATE statement. */
3898 match
3899 gfc_match_allocate (void)
3901 gfc_alloc *head, *tail;
3902 gfc_expr *stat, *errmsg, *tmp, *source, *mold;
3903 gfc_typespec ts;
3904 gfc_symbol *sym;
3905 match m;
3906 locus old_locus, deferred_locus;
3907 bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
3908 bool saw_unlimited = false;
3910 head = tail = NULL;
3911 stat = errmsg = source = mold = tmp = NULL;
3912 saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
3914 if (gfc_match_char ('(') != MATCH_YES)
3915 goto syntax;
3917 /* Match an optional type-spec. */
3918 old_locus = gfc_current_locus;
3919 m = gfc_match_type_spec (&ts);
3920 if (m == MATCH_ERROR)
3921 goto cleanup;
3922 else if (m == MATCH_NO)
3924 char name[GFC_MAX_SYMBOL_LEN + 3];
3926 if (gfc_match ("%n :: ", name) == MATCH_YES)
3928 gfc_error ("Error in type-spec at %L", &old_locus);
3929 goto cleanup;
3932 ts.type = BT_UNKNOWN;
3934 else
3936 if (gfc_match (" :: ") == MATCH_YES)
3938 if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L",
3939 &old_locus))
3940 goto cleanup;
3942 if (ts.deferred)
3944 gfc_error ("Type-spec at %L cannot contain a deferred "
3945 "type parameter", &old_locus);
3946 goto cleanup;
3949 if (ts.type == BT_CHARACTER)
3950 ts.u.cl->length_from_typespec = true;
3952 else
3954 ts.type = BT_UNKNOWN;
3955 gfc_current_locus = old_locus;
3959 for (;;)
3961 if (head == NULL)
3962 head = tail = gfc_get_alloc ();
3963 else
3965 tail->next = gfc_get_alloc ();
3966 tail = tail->next;
3969 m = gfc_match_variable (&tail->expr, 0);
3970 if (m == MATCH_NO)
3971 goto syntax;
3972 if (m == MATCH_ERROR)
3973 goto cleanup;
3975 if (gfc_check_do_variable (tail->expr->symtree))
3976 goto cleanup;
3978 bool impure = gfc_impure_variable (tail->expr->symtree->n.sym);
3979 if (impure && gfc_pure (NULL))
3981 gfc_error ("Bad allocate-object at %C for a PURE procedure");
3982 goto cleanup;
3985 if (impure)
3986 gfc_unset_implicit_pure (NULL);
3988 if (tail->expr->ts.deferred)
3990 saw_deferred = true;
3991 deferred_locus = tail->expr->where;
3994 if (gfc_find_state (COMP_DO_CONCURRENT)
3995 || gfc_find_state (COMP_CRITICAL))
3997 gfc_ref *ref;
3998 bool coarray = tail->expr->symtree->n.sym->attr.codimension;
3999 for (ref = tail->expr->ref; ref; ref = ref->next)
4000 if (ref->type == REF_COMPONENT)
4001 coarray = ref->u.c.component->attr.codimension;
4003 if (coarray && gfc_find_state (COMP_DO_CONCURRENT))
4005 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
4006 goto cleanup;
4008 if (coarray && gfc_find_state (COMP_CRITICAL))
4010 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
4011 goto cleanup;
4015 /* Check for F08:C628. */
4016 sym = tail->expr->symtree->n.sym;
4017 b1 = !(tail->expr->ref
4018 && (tail->expr->ref->type == REF_COMPONENT
4019 || tail->expr->ref->type == REF_ARRAY));
4020 if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok)
4021 b2 = !(CLASS_DATA (sym)->attr.allocatable
4022 || CLASS_DATA (sym)->attr.class_pointer);
4023 else
4024 b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
4025 || sym->attr.proc_pointer);
4026 b3 = sym && sym->ns && sym->ns->proc_name
4027 && (sym->ns->proc_name->attr.allocatable
4028 || sym->ns->proc_name->attr.pointer
4029 || sym->ns->proc_name->attr.proc_pointer);
4030 if (b1 && b2 && !b3)
4032 gfc_error ("Allocate-object at %L is neither a data pointer "
4033 "nor an allocatable variable", &tail->expr->where);
4034 goto cleanup;
4037 /* The ALLOCATE statement had an optional typespec. Check the
4038 constraints. */
4039 if (ts.type != BT_UNKNOWN)
4041 /* Enforce F03:C624. */
4042 if (!gfc_type_compatible (&tail->expr->ts, &ts))
4044 gfc_error ("Type of entity at %L is type incompatible with "
4045 "typespec", &tail->expr->where);
4046 goto cleanup;
4049 /* Enforce F03:C627. */
4050 if (ts.kind != tail->expr->ts.kind && !UNLIMITED_POLY (tail->expr))
4052 gfc_error ("Kind type parameter for entity at %L differs from "
4053 "the kind type parameter of the typespec",
4054 &tail->expr->where);
4055 goto cleanup;
4059 if (tail->expr->ts.type == BT_DERIVED)
4060 tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
4062 saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr);
4064 if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
4066 gfc_error ("Shape specification for allocatable scalar at %C");
4067 goto cleanup;
4070 if (gfc_match_char (',') != MATCH_YES)
4071 break;
4073 alloc_opt_list:
4075 m = gfc_match (" stat = %v", &tmp);
4076 if (m == MATCH_ERROR)
4077 goto cleanup;
4078 if (m == MATCH_YES)
4080 /* Enforce C630. */
4081 if (saw_stat)
4083 gfc_error ("Redundant STAT tag found at %L", &tmp->where);
4084 goto cleanup;
4087 stat = tmp;
4088 tmp = NULL;
4089 saw_stat = true;
4091 if (gfc_check_do_variable (stat->symtree))
4092 goto cleanup;
4094 if (gfc_match_char (',') == MATCH_YES)
4095 goto alloc_opt_list;
4098 m = gfc_match (" errmsg = %v", &tmp);
4099 if (m == MATCH_ERROR)
4100 goto cleanup;
4101 if (m == MATCH_YES)
4103 if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG tag at %L", &tmp->where))
4104 goto cleanup;
4106 /* Enforce C630. */
4107 if (saw_errmsg)
4109 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
4110 goto cleanup;
4113 errmsg = tmp;
4114 tmp = NULL;
4115 saw_errmsg = true;
4117 if (gfc_match_char (',') == MATCH_YES)
4118 goto alloc_opt_list;
4121 m = gfc_match (" source = %e", &tmp);
4122 if (m == MATCH_ERROR)
4123 goto cleanup;
4124 if (m == MATCH_YES)
4126 if (!gfc_notify_std (GFC_STD_F2003, "SOURCE tag at %L", &tmp->where))
4127 goto cleanup;
4129 /* Enforce C630. */
4130 if (saw_source)
4132 gfc_error ("Redundant SOURCE tag found at %L", &tmp->where);
4133 goto cleanup;
4136 /* The next 2 conditionals check C631. */
4137 if (ts.type != BT_UNKNOWN)
4139 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
4140 &tmp->where, &old_locus);
4141 goto cleanup;
4144 if (head->next
4145 && !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L"
4146 " with more than a single allocate object",
4147 &tmp->where))
4148 goto cleanup;
4150 source = tmp;
4151 tmp = NULL;
4152 saw_source = true;
4154 if (gfc_match_char (',') == MATCH_YES)
4155 goto alloc_opt_list;
4158 m = gfc_match (" mold = %e", &tmp);
4159 if (m == MATCH_ERROR)
4160 goto cleanup;
4161 if (m == MATCH_YES)
4163 if (!gfc_notify_std (GFC_STD_F2008, "MOLD tag at %L", &tmp->where))
4164 goto cleanup;
4166 /* Check F08:C636. */
4167 if (saw_mold)
4169 gfc_error ("Redundant MOLD tag found at %L", &tmp->where);
4170 goto cleanup;
4173 /* Check F08:C637. */
4174 if (ts.type != BT_UNKNOWN)
4176 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
4177 &tmp->where, &old_locus);
4178 goto cleanup;
4181 mold = tmp;
4182 tmp = NULL;
4183 saw_mold = true;
4184 mold->mold = 1;
4186 if (gfc_match_char (',') == MATCH_YES)
4187 goto alloc_opt_list;
4190 gfc_gobble_whitespace ();
4192 if (gfc_peek_char () == ')')
4193 break;
4196 if (gfc_match (" )%t") != MATCH_YES)
4197 goto syntax;
4199 /* Check F08:C637. */
4200 if (source && mold)
4202 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
4203 &mold->where, &source->where);
4204 goto cleanup;
4207 /* Check F03:C623, */
4208 if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold)
4210 gfc_error ("Allocate-object at %L with a deferred type parameter "
4211 "requires either a type-spec or SOURCE tag or a MOLD tag",
4212 &deferred_locus);
4213 goto cleanup;
4216 /* Check F03:C625, */
4217 if (saw_unlimited && ts.type == BT_UNKNOWN && !source && !mold)
4219 for (tail = head; tail; tail = tail->next)
4221 if (UNLIMITED_POLY (tail->expr))
4222 gfc_error ("Unlimited polymorphic allocate-object at %L "
4223 "requires either a type-spec or SOURCE tag "
4224 "or a MOLD tag", &tail->expr->where);
4226 goto cleanup;
4229 new_st.op = EXEC_ALLOCATE;
4230 new_st.expr1 = stat;
4231 new_st.expr2 = errmsg;
4232 if (source)
4233 new_st.expr3 = source;
4234 else
4235 new_st.expr3 = mold;
4236 new_st.ext.alloc.list = head;
4237 new_st.ext.alloc.ts = ts;
4239 return MATCH_YES;
4241 syntax:
4242 gfc_syntax_error (ST_ALLOCATE);
4244 cleanup:
4245 gfc_free_expr (errmsg);
4246 gfc_free_expr (source);
4247 gfc_free_expr (stat);
4248 gfc_free_expr (mold);
4249 if (tmp && tmp->expr_type) gfc_free_expr (tmp);
4250 gfc_free_alloc_list (head);
4251 return MATCH_ERROR;
4255 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
4256 a set of pointer assignments to intrinsic NULL(). */
4258 match
4259 gfc_match_nullify (void)
4261 gfc_code *tail;
4262 gfc_expr *e, *p;
4263 match m;
4265 tail = NULL;
4267 if (gfc_match_char ('(') != MATCH_YES)
4268 goto syntax;
4270 for (;;)
4272 m = gfc_match_variable (&p, 0);
4273 if (m == MATCH_ERROR)
4274 goto cleanup;
4275 if (m == MATCH_NO)
4276 goto syntax;
4278 if (gfc_check_do_variable (p->symtree))
4279 goto cleanup;
4281 /* F2008, C1242. */
4282 if (gfc_is_coindexed (p))
4284 gfc_error ("Pointer object at %C shall not be coindexed");
4285 goto cleanup;
4288 /* build ' => NULL() '. */
4289 e = gfc_get_null_expr (&gfc_current_locus);
4291 /* Chain to list. */
4292 if (tail == NULL)
4294 tail = &new_st;
4295 tail->op = EXEC_POINTER_ASSIGN;
4297 else
4299 tail->next = gfc_get_code (EXEC_POINTER_ASSIGN);
4300 tail = tail->next;
4303 tail->expr1 = p;
4304 tail->expr2 = e;
4306 if (gfc_match (" )%t") == MATCH_YES)
4307 break;
4308 if (gfc_match_char (',') != MATCH_YES)
4309 goto syntax;
4312 return MATCH_YES;
4314 syntax:
4315 gfc_syntax_error (ST_NULLIFY);
4317 cleanup:
4318 gfc_free_statements (new_st.next);
4319 new_st.next = NULL;
4320 gfc_free_expr (new_st.expr1);
4321 new_st.expr1 = NULL;
4322 gfc_free_expr (new_st.expr2);
4323 new_st.expr2 = NULL;
4324 return MATCH_ERROR;
4328 /* Match a DEALLOCATE statement. */
4330 match
4331 gfc_match_deallocate (void)
4333 gfc_alloc *head, *tail;
4334 gfc_expr *stat, *errmsg, *tmp;
4335 gfc_symbol *sym;
4336 match m;
4337 bool saw_stat, saw_errmsg, b1, b2;
4339 head = tail = NULL;
4340 stat = errmsg = tmp = NULL;
4341 saw_stat = saw_errmsg = false;
4343 if (gfc_match_char ('(') != MATCH_YES)
4344 goto syntax;
4346 for (;;)
4348 if (head == NULL)
4349 head = tail = gfc_get_alloc ();
4350 else
4352 tail->next = gfc_get_alloc ();
4353 tail = tail->next;
4356 m = gfc_match_variable (&tail->expr, 0);
4357 if (m == MATCH_ERROR)
4358 goto cleanup;
4359 if (m == MATCH_NO)
4360 goto syntax;
4362 if (gfc_check_do_variable (tail->expr->symtree))
4363 goto cleanup;
4365 sym = tail->expr->symtree->n.sym;
4367 bool impure = gfc_impure_variable (sym);
4368 if (impure && gfc_pure (NULL))
4370 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
4371 goto cleanup;
4374 if (impure)
4375 gfc_unset_implicit_pure (NULL);
4377 if (gfc_is_coarray (tail->expr)
4378 && gfc_find_state (COMP_DO_CONCURRENT))
4380 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
4381 goto cleanup;
4384 if (gfc_is_coarray (tail->expr)
4385 && gfc_find_state (COMP_CRITICAL))
4387 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
4388 goto cleanup;
4391 /* FIXME: disable the checking on derived types. */
4392 b1 = !(tail->expr->ref
4393 && (tail->expr->ref->type == REF_COMPONENT
4394 || tail->expr->ref->type == REF_ARRAY));
4395 if (sym && sym->ts.type == BT_CLASS)
4396 b2 = !(CLASS_DATA (sym)->attr.allocatable
4397 || CLASS_DATA (sym)->attr.class_pointer);
4398 else
4399 b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
4400 || sym->attr.proc_pointer);
4401 if (b1 && b2)
4403 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
4404 "nor an allocatable variable");
4405 goto cleanup;
4408 if (gfc_match_char (',') != MATCH_YES)
4409 break;
4411 dealloc_opt_list:
4413 m = gfc_match (" stat = %v", &tmp);
4414 if (m == MATCH_ERROR)
4415 goto cleanup;
4416 if (m == MATCH_YES)
4418 if (saw_stat)
4420 gfc_error ("Redundant STAT tag found at %L", &tmp->where);
4421 gfc_free_expr (tmp);
4422 goto cleanup;
4425 stat = tmp;
4426 saw_stat = true;
4428 if (gfc_check_do_variable (stat->symtree))
4429 goto cleanup;
4431 if (gfc_match_char (',') == MATCH_YES)
4432 goto dealloc_opt_list;
4435 m = gfc_match (" errmsg = %v", &tmp);
4436 if (m == MATCH_ERROR)
4437 goto cleanup;
4438 if (m == MATCH_YES)
4440 if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG at %L", &tmp->where))
4441 goto cleanup;
4443 if (saw_errmsg)
4445 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
4446 gfc_free_expr (tmp);
4447 goto cleanup;
4450 errmsg = tmp;
4451 saw_errmsg = true;
4453 if (gfc_match_char (',') == MATCH_YES)
4454 goto dealloc_opt_list;
4457 gfc_gobble_whitespace ();
4459 if (gfc_peek_char () == ')')
4460 break;
4463 if (gfc_match (" )%t") != MATCH_YES)
4464 goto syntax;
4466 new_st.op = EXEC_DEALLOCATE;
4467 new_st.expr1 = stat;
4468 new_st.expr2 = errmsg;
4469 new_st.ext.alloc.list = head;
4471 return MATCH_YES;
4473 syntax:
4474 gfc_syntax_error (ST_DEALLOCATE);
4476 cleanup:
4477 gfc_free_expr (errmsg);
4478 gfc_free_expr (stat);
4479 gfc_free_alloc_list (head);
4480 return MATCH_ERROR;
4484 /* Match a RETURN statement. */
4486 match
4487 gfc_match_return (void)
4489 gfc_expr *e;
4490 match m;
4491 gfc_compile_state s;
4493 e = NULL;
4495 if (gfc_find_state (COMP_CRITICAL))
4497 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4498 return MATCH_ERROR;
4501 if (gfc_find_state (COMP_DO_CONCURRENT))
4503 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4504 return MATCH_ERROR;
4507 if (gfc_match_eos () == MATCH_YES)
4508 goto done;
4510 if (!gfc_find_state (COMP_SUBROUTINE))
4512 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4513 "a SUBROUTINE");
4514 goto cleanup;
4517 if (gfc_current_form == FORM_FREE)
4519 /* The following are valid, so we can't require a blank after the
4520 RETURN keyword:
4521 return+1
4522 return(1) */
4523 char c = gfc_peek_ascii_char ();
4524 if (ISALPHA (c) || ISDIGIT (c))
4525 return MATCH_NO;
4528 m = gfc_match (" %e%t", &e);
4529 if (m == MATCH_YES)
4530 goto done;
4531 if (m == MATCH_ERROR)
4532 goto cleanup;
4534 gfc_syntax_error (ST_RETURN);
4536 cleanup:
4537 gfc_free_expr (e);
4538 return MATCH_ERROR;
4540 done:
4541 gfc_enclosing_unit (&s);
4542 if (s == COMP_PROGRAM
4543 && !gfc_notify_std (GFC_STD_GNU, "RETURN statement in "
4544 "main program at %C"))
4545 return MATCH_ERROR;
4547 new_st.op = EXEC_RETURN;
4548 new_st.expr1 = e;
4550 return MATCH_YES;
4554 /* Match the call of a type-bound procedure, if CALL%var has already been
4555 matched and var found to be a derived-type variable. */
4557 static match
4558 match_typebound_call (gfc_symtree* varst)
4560 gfc_expr* base;
4561 match m;
4563 base = gfc_get_expr ();
4564 base->expr_type = EXPR_VARIABLE;
4565 base->symtree = varst;
4566 base->where = gfc_current_locus;
4567 gfc_set_sym_referenced (varst->n.sym);
4569 m = gfc_match_varspec (base, 0, true, true);
4570 if (m == MATCH_NO)
4571 gfc_error ("Expected component reference at %C");
4572 if (m != MATCH_YES)
4574 gfc_free_expr (base);
4575 return MATCH_ERROR;
4578 if (gfc_match_eos () != MATCH_YES)
4580 gfc_error ("Junk after CALL at %C");
4581 gfc_free_expr (base);
4582 return MATCH_ERROR;
4585 if (base->expr_type == EXPR_COMPCALL)
4586 new_st.op = EXEC_COMPCALL;
4587 else if (base->expr_type == EXPR_PPC)
4588 new_st.op = EXEC_CALL_PPC;
4589 else
4591 gfc_error ("Expected type-bound procedure or procedure pointer component "
4592 "at %C");
4593 gfc_free_expr (base);
4594 return MATCH_ERROR;
4596 new_st.expr1 = base;
4598 return MATCH_YES;
4602 /* Match a CALL statement. The tricky part here are possible
4603 alternate return specifiers. We handle these by having all
4604 "subroutines" actually return an integer via a register that gives
4605 the return number. If the call specifies alternate returns, we
4606 generate code for a SELECT statement whose case clauses contain
4607 GOTOs to the various labels. */
4609 match
4610 gfc_match_call (void)
4612 char name[GFC_MAX_SYMBOL_LEN + 1];
4613 gfc_actual_arglist *a, *arglist;
4614 gfc_case *new_case;
4615 gfc_symbol *sym;
4616 gfc_symtree *st;
4617 gfc_code *c;
4618 match m;
4619 int i;
4621 arglist = NULL;
4623 m = gfc_match ("% %n", name);
4624 if (m == MATCH_NO)
4625 goto syntax;
4626 if (m != MATCH_YES)
4627 return m;
4629 if (gfc_get_ha_sym_tree (name, &st))
4630 return MATCH_ERROR;
4632 sym = st->n.sym;
4634 /* If this is a variable of derived-type, it probably starts a type-bound
4635 procedure call. */
4636 if ((sym->attr.flavor != FL_PROCEDURE
4637 || gfc_is_function_return_value (sym, gfc_current_ns))
4638 && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
4639 return match_typebound_call (st);
4641 /* If it does not seem to be callable (include functions so that the
4642 right association is made. They are thrown out in resolution.)
4643 ... */
4644 if (!sym->attr.generic
4645 && !sym->attr.subroutine
4646 && !sym->attr.function)
4648 if (!(sym->attr.external && !sym->attr.referenced))
4650 /* ...create a symbol in this scope... */
4651 if (sym->ns != gfc_current_ns
4652 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
4653 return MATCH_ERROR;
4655 if (sym != st->n.sym)
4656 sym = st->n.sym;
4659 /* ...and then to try to make the symbol into a subroutine. */
4660 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
4661 return MATCH_ERROR;
4664 gfc_set_sym_referenced (sym);
4666 if (gfc_match_eos () != MATCH_YES)
4668 m = gfc_match_actual_arglist (1, &arglist);
4669 if (m == MATCH_NO)
4670 goto syntax;
4671 if (m == MATCH_ERROR)
4672 goto cleanup;
4674 if (gfc_match_eos () != MATCH_YES)
4675 goto syntax;
4678 /* If any alternate return labels were found, construct a SELECT
4679 statement that will jump to the right place. */
4681 i = 0;
4682 for (a = arglist; a; a = a->next)
4683 if (a->expr == NULL)
4685 i = 1;
4686 break;
4689 if (i)
4691 gfc_symtree *select_st;
4692 gfc_symbol *select_sym;
4693 char name[GFC_MAX_SYMBOL_LEN + 1];
4695 new_st.next = c = gfc_get_code (EXEC_SELECT);
4696 sprintf (name, "_result_%s", sym->name);
4697 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
4699 select_sym = select_st->n.sym;
4700 select_sym->ts.type = BT_INTEGER;
4701 select_sym->ts.kind = gfc_default_integer_kind;
4702 gfc_set_sym_referenced (select_sym);
4703 c->expr1 = gfc_get_expr ();
4704 c->expr1->expr_type = EXPR_VARIABLE;
4705 c->expr1->symtree = select_st;
4706 c->expr1->ts = select_sym->ts;
4707 c->expr1->where = gfc_current_locus;
4709 i = 0;
4710 for (a = arglist; a; a = a->next)
4712 if (a->expr != NULL)
4713 continue;
4715 if (!gfc_reference_st_label (a->label, ST_LABEL_TARGET))
4716 continue;
4718 i++;
4720 c->block = gfc_get_code (EXEC_SELECT);
4721 c = c->block;
4723 new_case = gfc_get_case ();
4724 new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
4725 new_case->low = new_case->high;
4726 c->ext.block.case_list = new_case;
4728 c->next = gfc_get_code (EXEC_GOTO);
4729 c->next->label1 = a->label;
4733 new_st.op = EXEC_CALL;
4734 new_st.symtree = st;
4735 new_st.ext.actual = arglist;
4737 return MATCH_YES;
4739 syntax:
4740 gfc_syntax_error (ST_CALL);
4742 cleanup:
4743 gfc_free_actual_arglist (arglist);
4744 return MATCH_ERROR;
4748 /* Given a name, return a pointer to the common head structure,
4749 creating it if it does not exist. If FROM_MODULE is nonzero, we
4750 mangle the name so that it doesn't interfere with commons defined
4751 in the using namespace.
4752 TODO: Add to global symbol tree. */
4754 gfc_common_head *
4755 gfc_get_common (const char *name, int from_module)
4757 gfc_symtree *st;
4758 static int serial = 0;
4759 char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
4761 if (from_module)
4763 /* A use associated common block is only needed to correctly layout
4764 the variables it contains. */
4765 snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
4766 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
4768 else
4770 st = gfc_find_symtree (gfc_current_ns->common_root, name);
4772 if (st == NULL)
4773 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
4776 if (st->n.common == NULL)
4778 st->n.common = gfc_get_common_head ();
4779 st->n.common->where = gfc_current_locus;
4780 strcpy (st->n.common->name, name);
4783 return st->n.common;
4787 /* Match a common block name. */
4789 match match_common_name (char *name)
4791 match m;
4793 if (gfc_match_char ('/') == MATCH_NO)
4795 name[0] = '\0';
4796 return MATCH_YES;
4799 if (gfc_match_char ('/') == MATCH_YES)
4801 name[0] = '\0';
4802 return MATCH_YES;
4805 m = gfc_match_name (name);
4807 if (m == MATCH_ERROR)
4808 return MATCH_ERROR;
4809 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
4810 return MATCH_YES;
4812 gfc_error ("Syntax error in common block name at %C");
4813 return MATCH_ERROR;
4817 /* Match a COMMON statement. */
4819 match
4820 gfc_match_common (void)
4822 gfc_symbol *sym, **head, *tail, *other;
4823 char name[GFC_MAX_SYMBOL_LEN + 1];
4824 gfc_common_head *t;
4825 gfc_array_spec *as;
4826 gfc_equiv *e1, *e2;
4827 match m;
4829 as = NULL;
4831 for (;;)
4833 m = match_common_name (name);
4834 if (m == MATCH_ERROR)
4835 goto cleanup;
4837 if (name[0] == '\0')
4839 t = &gfc_current_ns->blank_common;
4840 if (t->head == NULL)
4841 t->where = gfc_current_locus;
4843 else
4845 t = gfc_get_common (name, 0);
4847 head = &t->head;
4849 if (*head == NULL)
4850 tail = NULL;
4851 else
4853 tail = *head;
4854 while (tail->common_next)
4855 tail = tail->common_next;
4858 /* Grab the list of symbols. */
4859 for (;;)
4861 m = gfc_match_symbol (&sym, 0);
4862 if (m == MATCH_ERROR)
4863 goto cleanup;
4864 if (m == MATCH_NO)
4865 goto syntax;
4867 /* See if we know the current common block is bind(c), and if
4868 so, then see if we can check if the symbol is (which it'll
4869 need to be). This can happen if the bind(c) attr stmt was
4870 applied to the common block, and the variable(s) already
4871 defined, before declaring the common block. */
4872 if (t->is_bind_c == 1)
4874 if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
4876 /* If we find an error, just print it and continue,
4877 cause it's just semantic, and we can see if there
4878 are more errors. */
4879 gfc_error_now ("Variable %qs at %L in common block %qs "
4880 "at %C must be declared with a C "
4881 "interoperable kind since common block "
4882 "%qs is bind(c)",
4883 sym->name, &(sym->declared_at), t->name,
4884 t->name);
4887 if (sym->attr.is_bind_c == 1)
4888 gfc_error_now ("Variable %qs in common block %qs at %C can not "
4889 "be bind(c) since it is not global", sym->name,
4890 t->name);
4893 if (sym->attr.in_common)
4895 gfc_error ("Symbol %qs at %C is already in a COMMON block",
4896 sym->name);
4897 goto cleanup;
4900 if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
4901 || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
4903 if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol %qs at "
4904 "%C can only be COMMON in BLOCK DATA",
4905 sym->name))
4906 goto cleanup;
4909 /* Deal with an optional array specification after the
4910 symbol name. */
4911 m = gfc_match_array_spec (&as, true, true);
4912 if (m == MATCH_ERROR)
4913 goto cleanup;
4915 if (m == MATCH_YES)
4917 if (as->type != AS_EXPLICIT)
4919 gfc_error ("Array specification for symbol %qs in COMMON "
4920 "at %C must be explicit", sym->name);
4921 goto cleanup;
4924 if (!gfc_add_dimension (&sym->attr, sym->name, NULL))
4925 goto cleanup;
4927 if (sym->attr.pointer)
4929 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
4930 "POINTER array", sym->name);
4931 goto cleanup;
4934 sym->as = as;
4935 as = NULL;
4939 /* Add the in_common attribute, but ignore the reported errors
4940 if any, and continue matching. */
4941 gfc_add_in_common (&sym->attr, sym->name, NULL);
4943 sym->common_block = t;
4944 sym->common_block->refs++;
4946 if (tail != NULL)
4947 tail->common_next = sym;
4948 else
4949 *head = sym;
4951 tail = sym;
4953 sym->common_head = t;
4955 /* Check to see if the symbol is already in an equivalence group.
4956 If it is, set the other members as being in common. */
4957 if (sym->attr.in_equivalence)
4959 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
4961 for (e2 = e1; e2; e2 = e2->eq)
4962 if (e2->expr->symtree->n.sym == sym)
4963 goto equiv_found;
4965 continue;
4967 equiv_found:
4969 for (e2 = e1; e2; e2 = e2->eq)
4971 other = e2->expr->symtree->n.sym;
4972 if (other->common_head
4973 && other->common_head != sym->common_head)
4975 gfc_error ("Symbol %qs, in COMMON block %qs at "
4976 "%C is being indirectly equivalenced to "
4977 "another COMMON block %qs",
4978 sym->name, sym->common_head->name,
4979 other->common_head->name);
4980 goto cleanup;
4982 other->attr.in_common = 1;
4983 other->common_head = t;
4989 gfc_gobble_whitespace ();
4990 if (gfc_match_eos () == MATCH_YES)
4991 goto done;
4992 if (gfc_peek_ascii_char () == '/')
4993 break;
4994 if (gfc_match_char (',') != MATCH_YES)
4995 goto syntax;
4996 gfc_gobble_whitespace ();
4997 if (gfc_peek_ascii_char () == '/')
4998 break;
5002 done:
5003 return MATCH_YES;
5005 syntax:
5006 gfc_syntax_error (ST_COMMON);
5008 cleanup:
5009 gfc_free_array_spec (as);
5010 return MATCH_ERROR;
5014 /* Match a BLOCK DATA program unit. */
5016 match
5017 gfc_match_block_data (void)
5019 char name[GFC_MAX_SYMBOL_LEN + 1];
5020 gfc_symbol *sym;
5021 match m;
5023 if (gfc_match_eos () == MATCH_YES)
5025 gfc_new_block = NULL;
5026 return MATCH_YES;
5029 m = gfc_match ("% %n%t", name);
5030 if (m != MATCH_YES)
5031 return MATCH_ERROR;
5033 if (gfc_get_symbol (name, NULL, &sym))
5034 return MATCH_ERROR;
5036 if (!gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL))
5037 return MATCH_ERROR;
5039 gfc_new_block = sym;
5041 return MATCH_YES;
5045 /* Free a namelist structure. */
5047 void
5048 gfc_free_namelist (gfc_namelist *name)
5050 gfc_namelist *n;
5052 for (; name; name = n)
5054 n = name->next;
5055 free (name);
5060 /* Free an OpenMP namelist structure. */
5062 void
5063 gfc_free_omp_namelist (gfc_omp_namelist *name)
5065 gfc_omp_namelist *n;
5067 for (; name; name = n)
5069 gfc_free_expr (name->expr);
5070 if (name->udr)
5072 if (name->udr->combiner)
5073 gfc_free_statement (name->udr->combiner);
5074 if (name->udr->initializer)
5075 gfc_free_statement (name->udr->initializer);
5076 free (name->udr);
5078 n = name->next;
5079 free (name);
5084 /* Match a NAMELIST statement. */
5086 match
5087 gfc_match_namelist (void)
5089 gfc_symbol *group_name, *sym;
5090 gfc_namelist *nl;
5091 match m, m2;
5093 m = gfc_match (" / %s /", &group_name);
5094 if (m == MATCH_NO)
5095 goto syntax;
5096 if (m == MATCH_ERROR)
5097 goto error;
5099 for (;;)
5101 if (group_name->ts.type != BT_UNKNOWN)
5103 gfc_error ("Namelist group name %qs at %C already has a basic "
5104 "type of %s", group_name->name,
5105 gfc_typename (&group_name->ts));
5106 return MATCH_ERROR;
5109 if (group_name->attr.flavor == FL_NAMELIST
5110 && group_name->attr.use_assoc
5111 && !gfc_notify_std (GFC_STD_GNU, "Namelist group name %qs "
5112 "at %C already is USE associated and can"
5113 "not be respecified.", group_name->name))
5114 return MATCH_ERROR;
5116 if (group_name->attr.flavor != FL_NAMELIST
5117 && !gfc_add_flavor (&group_name->attr, FL_NAMELIST,
5118 group_name->name, NULL))
5119 return MATCH_ERROR;
5121 for (;;)
5123 m = gfc_match_symbol (&sym, 1);
5124 if (m == MATCH_NO)
5125 goto syntax;
5126 if (m == MATCH_ERROR)
5127 goto error;
5129 if (sym->attr.in_namelist == 0
5130 && !gfc_add_in_namelist (&sym->attr, sym->name, NULL))
5131 goto error;
5133 /* Use gfc_error_check here, rather than goto error, so that
5134 these are the only errors for the next two lines. */
5135 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
5137 gfc_error ("Assumed size array %qs in namelist %qs at "
5138 "%C is not allowed", sym->name, group_name->name);
5139 gfc_error_check ();
5142 nl = gfc_get_namelist ();
5143 nl->sym = sym;
5144 sym->refs++;
5146 if (group_name->namelist == NULL)
5147 group_name->namelist = group_name->namelist_tail = nl;
5148 else
5150 group_name->namelist_tail->next = nl;
5151 group_name->namelist_tail = nl;
5154 if (gfc_match_eos () == MATCH_YES)
5155 goto done;
5157 m = gfc_match_char (',');
5159 if (gfc_match_char ('/') == MATCH_YES)
5161 m2 = gfc_match (" %s /", &group_name);
5162 if (m2 == MATCH_YES)
5163 break;
5164 if (m2 == MATCH_ERROR)
5165 goto error;
5166 goto syntax;
5169 if (m != MATCH_YES)
5170 goto syntax;
5174 done:
5175 return MATCH_YES;
5177 syntax:
5178 gfc_syntax_error (ST_NAMELIST);
5180 error:
5181 return MATCH_ERROR;
5185 /* Match a MODULE statement. */
5187 match
5188 gfc_match_module (void)
5190 match m;
5192 m = gfc_match (" %s%t", &gfc_new_block);
5193 if (m != MATCH_YES)
5194 return m;
5196 if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
5197 gfc_new_block->name, NULL))
5198 return MATCH_ERROR;
5200 return MATCH_YES;
5204 /* Free equivalence sets and lists. Recursively is the easiest way to
5205 do this. */
5207 void
5208 gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop)
5210 if (eq == stop)
5211 return;
5213 gfc_free_equiv (eq->eq);
5214 gfc_free_equiv_until (eq->next, stop);
5215 gfc_free_expr (eq->expr);
5216 free (eq);
5220 void
5221 gfc_free_equiv (gfc_equiv *eq)
5223 gfc_free_equiv_until (eq, NULL);
5227 /* Match an EQUIVALENCE statement. */
5229 match
5230 gfc_match_equivalence (void)
5232 gfc_equiv *eq, *set, *tail;
5233 gfc_ref *ref;
5234 gfc_symbol *sym;
5235 match m;
5236 gfc_common_head *common_head = NULL;
5237 bool common_flag;
5238 int cnt;
5240 tail = NULL;
5242 for (;;)
5244 eq = gfc_get_equiv ();
5245 if (tail == NULL)
5246 tail = eq;
5248 eq->next = gfc_current_ns->equiv;
5249 gfc_current_ns->equiv = eq;
5251 if (gfc_match_char ('(') != MATCH_YES)
5252 goto syntax;
5254 set = eq;
5255 common_flag = FALSE;
5256 cnt = 0;
5258 for (;;)
5260 m = gfc_match_equiv_variable (&set->expr);
5261 if (m == MATCH_ERROR)
5262 goto cleanup;
5263 if (m == MATCH_NO)
5264 goto syntax;
5266 /* count the number of objects. */
5267 cnt++;
5269 if (gfc_match_char ('%') == MATCH_YES)
5271 gfc_error ("Derived type component %C is not a "
5272 "permitted EQUIVALENCE member");
5273 goto cleanup;
5276 for (ref = set->expr->ref; ref; ref = ref->next)
5277 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
5279 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
5280 "be an array section");
5281 goto cleanup;
5284 sym = set->expr->symtree->n.sym;
5286 if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL))
5287 goto cleanup;
5289 if (sym->attr.in_common)
5291 common_flag = TRUE;
5292 common_head = sym->common_head;
5295 if (gfc_match_char (')') == MATCH_YES)
5296 break;
5298 if (gfc_match_char (',') != MATCH_YES)
5299 goto syntax;
5301 set->eq = gfc_get_equiv ();
5302 set = set->eq;
5305 if (cnt < 2)
5307 gfc_error ("EQUIVALENCE at %C requires two or more objects");
5308 goto cleanup;
5311 /* If one of the members of an equivalence is in common, then
5312 mark them all as being in common. Before doing this, check
5313 that members of the equivalence group are not in different
5314 common blocks. */
5315 if (common_flag)
5316 for (set = eq; set; set = set->eq)
5318 sym = set->expr->symtree->n.sym;
5319 if (sym->common_head && sym->common_head != common_head)
5321 gfc_error ("Attempt to indirectly overlap COMMON "
5322 "blocks %s and %s by EQUIVALENCE at %C",
5323 sym->common_head->name, common_head->name);
5324 goto cleanup;
5326 sym->attr.in_common = 1;
5327 sym->common_head = common_head;
5330 if (gfc_match_eos () == MATCH_YES)
5331 break;
5332 if (gfc_match_char (',') != MATCH_YES)
5334 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
5335 goto cleanup;
5339 return MATCH_YES;
5341 syntax:
5342 gfc_syntax_error (ST_EQUIVALENCE);
5344 cleanup:
5345 eq = tail->next;
5346 tail->next = NULL;
5348 gfc_free_equiv (gfc_current_ns->equiv);
5349 gfc_current_ns->equiv = eq;
5351 return MATCH_ERROR;
5355 /* Check that a statement function is not recursive. This is done by looking
5356 for the statement function symbol(sym) by looking recursively through its
5357 expression(e). If a reference to sym is found, true is returned.
5358 12.5.4 requires that any variable of function that is implicitly typed
5359 shall have that type confirmed by any subsequent type declaration. The
5360 implicit typing is conveniently done here. */
5361 static bool
5362 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
5364 static bool
5365 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
5368 if (e == NULL)
5369 return false;
5371 switch (e->expr_type)
5373 case EXPR_FUNCTION:
5374 if (e->symtree == NULL)
5375 return false;
5377 /* Check the name before testing for nested recursion! */
5378 if (sym->name == e->symtree->n.sym->name)
5379 return true;
5381 /* Catch recursion via other statement functions. */
5382 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
5383 && e->symtree->n.sym->value
5384 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
5385 return true;
5387 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
5388 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
5390 break;
5392 case EXPR_VARIABLE:
5393 if (e->symtree && sym->name == e->symtree->n.sym->name)
5394 return true;
5396 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
5397 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
5398 break;
5400 default:
5401 break;
5404 return false;
5408 static bool
5409 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
5411 return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
5415 /* Match a statement function declaration. It is so easy to match
5416 non-statement function statements with a MATCH_ERROR as opposed to
5417 MATCH_NO that we suppress error message in most cases. */
5419 match
5420 gfc_match_st_function (void)
5422 gfc_error_buffer old_error;
5423 gfc_symbol *sym;
5424 gfc_expr *expr;
5425 match m;
5427 m = gfc_match_symbol (&sym, 0);
5428 if (m != MATCH_YES)
5429 return m;
5431 gfc_push_error (&old_error);
5433 if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL))
5434 goto undo_error;
5436 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
5437 goto undo_error;
5439 m = gfc_match (" = %e%t", &expr);
5440 if (m == MATCH_NO)
5441 goto undo_error;
5443 gfc_free_error (&old_error);
5445 if (m == MATCH_ERROR)
5446 return m;
5448 if (recursive_stmt_fcn (expr, sym))
5450 gfc_error ("Statement function at %L is recursive", &expr->where);
5451 return MATCH_ERROR;
5454 sym->value = expr;
5456 if ((gfc_current_state () == COMP_FUNCTION
5457 || gfc_current_state () == COMP_SUBROUTINE)
5458 && gfc_state_stack->previous->state == COMP_INTERFACE)
5460 gfc_error ("Statement function at %L cannot appear within an INTERFACE",
5461 &expr->where);
5462 return MATCH_ERROR;
5465 if (!gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C"))
5466 return MATCH_ERROR;
5468 return MATCH_YES;
5470 undo_error:
5471 gfc_pop_error (&old_error);
5472 return MATCH_NO;
5476 /* Match an assignment to a pointer function (F2008). This could, in
5477 general be ambiguous with a statement function. In this implementation
5478 it remains so if it is the first statement after the specification
5479 block. */
5481 match
5482 gfc_match_ptr_fcn_assign (void)
5484 gfc_error_buffer old_error;
5485 locus old_loc;
5486 gfc_symbol *sym;
5487 gfc_expr *expr;
5488 match m;
5489 char name[GFC_MAX_SYMBOL_LEN + 1];
5491 old_loc = gfc_current_locus;
5492 m = gfc_match_name (name);
5493 if (m != MATCH_YES)
5494 return m;
5496 gfc_find_symbol (name, NULL, 1, &sym);
5497 if (sym && sym->attr.flavor != FL_PROCEDURE)
5498 return MATCH_NO;
5500 gfc_push_error (&old_error);
5502 if (sym && sym->attr.function)
5503 goto match_actual_arglist;
5505 gfc_current_locus = old_loc;
5506 m = gfc_match_symbol (&sym, 0);
5507 if (m != MATCH_YES)
5508 return m;
5510 if (!gfc_add_procedure (&sym->attr, PROC_UNKNOWN, sym->name, NULL))
5511 goto undo_error;
5513 match_actual_arglist:
5514 gfc_current_locus = old_loc;
5515 m = gfc_match (" %e", &expr);
5516 if (m != MATCH_YES)
5517 goto undo_error;
5519 new_st.op = EXEC_ASSIGN;
5520 new_st.expr1 = expr;
5521 expr = NULL;
5523 m = gfc_match (" = %e%t", &expr);
5524 if (m != MATCH_YES)
5525 goto undo_error;
5527 new_st.expr2 = expr;
5528 return MATCH_YES;
5530 undo_error:
5531 gfc_pop_error (&old_error);
5532 return MATCH_NO;
5536 /***************** SELECT CASE subroutines ******************/
5538 /* Free a single case structure. */
5540 static void
5541 free_case (gfc_case *p)
5543 if (p->low == p->high)
5544 p->high = NULL;
5545 gfc_free_expr (p->low);
5546 gfc_free_expr (p->high);
5547 free (p);
5551 /* Free a list of case structures. */
5553 void
5554 gfc_free_case_list (gfc_case *p)
5556 gfc_case *q;
5558 for (; p; p = q)
5560 q = p->next;
5561 free_case (p);
5566 /* Match a single case selector. Combining the requirements of F08:C830
5567 and F08:C832 (R838) means that the case-value must have either CHARACTER,
5568 INTEGER, or LOGICAL type. */
5570 static match
5571 match_case_selector (gfc_case **cp)
5573 gfc_case *c;
5574 match m;
5576 c = gfc_get_case ();
5577 c->where = gfc_current_locus;
5579 if (gfc_match_char (':') == MATCH_YES)
5581 m = gfc_match_init_expr (&c->high);
5582 if (m == MATCH_NO)
5583 goto need_expr;
5584 if (m == MATCH_ERROR)
5585 goto cleanup;
5587 if (c->high->ts.type != BT_LOGICAL && c->high->ts.type != BT_INTEGER
5588 && c->high->ts.type != BT_CHARACTER)
5590 gfc_error ("Expression in CASE selector at %L cannot be %s",
5591 &c->high->where, gfc_typename (&c->high->ts));
5592 goto cleanup;
5595 else
5597 m = gfc_match_init_expr (&c->low);
5598 if (m == MATCH_ERROR)
5599 goto cleanup;
5600 if (m == MATCH_NO)
5601 goto need_expr;
5603 if (c->low->ts.type != BT_LOGICAL && c->low->ts.type != BT_INTEGER
5604 && c->low->ts.type != BT_CHARACTER)
5606 gfc_error ("Expression in CASE selector at %L cannot be %s",
5607 &c->low->where, gfc_typename (&c->low->ts));
5608 goto cleanup;
5611 /* If we're not looking at a ':' now, make a range out of a single
5612 target. Else get the upper bound for the case range. */
5613 if (gfc_match_char (':') != MATCH_YES)
5614 c->high = c->low;
5615 else
5617 m = gfc_match_init_expr (&c->high);
5618 if (m == MATCH_ERROR)
5619 goto cleanup;
5620 /* MATCH_NO is fine. It's OK if nothing is there! */
5624 *cp = c;
5625 return MATCH_YES;
5627 need_expr:
5628 gfc_error ("Expected initialization expression in CASE at %C");
5630 cleanup:
5631 free_case (c);
5632 return MATCH_ERROR;
5636 /* Match the end of a case statement. */
5638 static match
5639 match_case_eos (void)
5641 char name[GFC_MAX_SYMBOL_LEN + 1];
5642 match m;
5644 if (gfc_match_eos () == MATCH_YES)
5645 return MATCH_YES;
5647 /* If the case construct doesn't have a case-construct-name, we
5648 should have matched the EOS. */
5649 if (!gfc_current_block ())
5650 return MATCH_NO;
5652 gfc_gobble_whitespace ();
5654 m = gfc_match_name (name);
5655 if (m != MATCH_YES)
5656 return m;
5658 if (strcmp (name, gfc_current_block ()->name) != 0)
5660 gfc_error ("Expected block name %qs of SELECT construct at %C",
5661 gfc_current_block ()->name);
5662 return MATCH_ERROR;
5665 return gfc_match_eos ();
5669 /* Match a SELECT statement. */
5671 match
5672 gfc_match_select (void)
5674 gfc_expr *expr;
5675 match m;
5677 m = gfc_match_label ();
5678 if (m == MATCH_ERROR)
5679 return m;
5681 m = gfc_match (" select case ( %e )%t", &expr);
5682 if (m != MATCH_YES)
5683 return m;
5685 new_st.op = EXEC_SELECT;
5686 new_st.expr1 = expr;
5688 return MATCH_YES;
5692 /* Transfer the selector typespec to the associate name. */
5694 static void
5695 copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
5697 gfc_ref *ref;
5698 gfc_symbol *assoc_sym;
5700 assoc_sym = associate->symtree->n.sym;
5702 /* At this stage the expression rank and arrayspec dimensions have
5703 not been completely sorted out. We must get the expr2->rank
5704 right here, so that the correct class container is obtained. */
5705 ref = selector->ref;
5706 while (ref && ref->next)
5707 ref = ref->next;
5709 if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as
5710 && ref && ref->type == REF_ARRAY)
5712 /* Ensure that the array reference type is set. We cannot use
5713 gfc_resolve_expr at this point, so the usable parts of
5714 resolve.c(resolve_array_ref) are employed to do it. */
5715 if (ref->u.ar.type == AR_UNKNOWN)
5717 ref->u.ar.type = AR_ELEMENT;
5718 for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
5719 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5720 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR
5721 || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
5722 && ref->u.ar.start[i] && ref->u.ar.start[i]->rank))
5724 ref->u.ar.type = AR_SECTION;
5725 break;
5729 if (ref->u.ar.type == AR_FULL)
5730 selector->rank = CLASS_DATA (selector)->as->rank;
5731 else if (ref->u.ar.type == AR_SECTION)
5732 selector->rank = ref->u.ar.dimen;
5733 else
5734 selector->rank = 0;
5737 if (selector->rank)
5739 assoc_sym->attr.dimension = 1;
5740 assoc_sym->as = gfc_get_array_spec ();
5741 assoc_sym->as->rank = selector->rank;
5742 assoc_sym->as->type = AS_DEFERRED;
5744 else
5745 assoc_sym->as = NULL;
5747 if (selector->ts.type == BT_CLASS)
5749 /* The correct class container has to be available. */
5750 assoc_sym->ts.type = BT_CLASS;
5751 assoc_sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
5752 assoc_sym->attr.pointer = 1;
5753 gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
5758 /* Push the current selector onto the SELECT TYPE stack. */
5760 static void
5761 select_type_push (gfc_symbol *sel)
5763 gfc_select_type_stack *top = gfc_get_select_type_stack ();
5764 top->selector = sel;
5765 top->tmp = NULL;
5766 top->prev = select_type_stack;
5768 select_type_stack = top;
5772 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
5774 static gfc_symtree *
5775 select_intrinsic_set_tmp (gfc_typespec *ts)
5777 char name[GFC_MAX_SYMBOL_LEN];
5778 gfc_symtree *tmp;
5779 int charlen = 0;
5781 if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
5782 return NULL;
5784 if (select_type_stack->selector->ts.type == BT_CLASS
5785 && !select_type_stack->selector->attr.class_ok)
5786 return NULL;
5788 if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
5789 && ts->u.cl->length->expr_type == EXPR_CONSTANT)
5790 charlen = mpz_get_si (ts->u.cl->length->value.integer);
5792 if (ts->type != BT_CHARACTER)
5793 sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
5794 ts->kind);
5795 else
5796 sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (ts->type),
5797 charlen, ts->kind);
5799 gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
5800 gfc_add_type (tmp->n.sym, ts, NULL);
5802 /* Copy across the array spec to the selector. */
5803 if (select_type_stack->selector->ts.type == BT_CLASS
5804 && (CLASS_DATA (select_type_stack->selector)->attr.dimension
5805 || CLASS_DATA (select_type_stack->selector)->attr.codimension))
5807 tmp->n.sym->attr.pointer = 1;
5808 tmp->n.sym->attr.dimension
5809 = CLASS_DATA (select_type_stack->selector)->attr.dimension;
5810 tmp->n.sym->attr.codimension
5811 = CLASS_DATA (select_type_stack->selector)->attr.codimension;
5812 tmp->n.sym->as
5813 = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
5816 gfc_set_sym_referenced (tmp->n.sym);
5817 gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
5818 tmp->n.sym->attr.select_type_temporary = 1;
5820 return tmp;
5824 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
5826 static void
5827 select_type_set_tmp (gfc_typespec *ts)
5829 char name[GFC_MAX_SYMBOL_LEN];
5830 gfc_symtree *tmp = NULL;
5832 if (!ts)
5834 select_type_stack->tmp = NULL;
5835 return;
5838 tmp = select_intrinsic_set_tmp (ts);
5840 if (tmp == NULL)
5842 if (!ts->u.derived)
5843 return;
5845 if (ts->type == BT_CLASS)
5846 sprintf (name, "__tmp_class_%s", ts->u.derived->name);
5847 else
5848 sprintf (name, "__tmp_type_%s", ts->u.derived->name);
5849 gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
5850 gfc_add_type (tmp->n.sym, ts, NULL);
5852 if (select_type_stack->selector->ts.type == BT_CLASS
5853 && select_type_stack->selector->attr.class_ok)
5855 tmp->n.sym->attr.pointer
5856 = CLASS_DATA (select_type_stack->selector)->attr.class_pointer;
5858 /* Copy across the array spec to the selector. */
5859 if (CLASS_DATA (select_type_stack->selector)->attr.dimension
5860 || CLASS_DATA (select_type_stack->selector)->attr.codimension)
5862 tmp->n.sym->attr.dimension
5863 = CLASS_DATA (select_type_stack->selector)->attr.dimension;
5864 tmp->n.sym->attr.codimension
5865 = CLASS_DATA (select_type_stack->selector)->attr.codimension;
5866 tmp->n.sym->as
5867 = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
5871 gfc_set_sym_referenced (tmp->n.sym);
5872 gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
5873 tmp->n.sym->attr.select_type_temporary = 1;
5875 if (ts->type == BT_CLASS)
5876 gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
5877 &tmp->n.sym->as);
5880 /* Add an association for it, so the rest of the parser knows it is
5881 an associate-name. The target will be set during resolution. */
5882 tmp->n.sym->assoc = gfc_get_association_list ();
5883 tmp->n.sym->assoc->dangling = 1;
5884 tmp->n.sym->assoc->st = tmp;
5886 select_type_stack->tmp = tmp;
5890 /* Match a SELECT TYPE statement. */
5892 match
5893 gfc_match_select_type (void)
5895 gfc_expr *expr1, *expr2 = NULL;
5896 match m;
5897 char name[GFC_MAX_SYMBOL_LEN];
5898 bool class_array;
5899 gfc_symbol *sym;
5900 gfc_namespace *ns = gfc_current_ns;
5902 m = gfc_match_label ();
5903 if (m == MATCH_ERROR)
5904 return m;
5906 m = gfc_match (" select type ( ");
5907 if (m != MATCH_YES)
5908 return m;
5910 gfc_current_ns = gfc_build_block_ns (ns);
5911 m = gfc_match (" %n => %e", name, &expr2);
5912 if (m == MATCH_YES)
5914 expr1 = gfc_get_expr ();
5915 expr1->expr_type = EXPR_VARIABLE;
5916 expr1->where = expr2->where;
5917 if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
5919 m = MATCH_ERROR;
5920 goto cleanup;
5923 sym = expr1->symtree->n.sym;
5924 if (expr2->ts.type == BT_UNKNOWN)
5925 sym->attr.untyped = 1;
5926 else
5927 copy_ts_from_selector_to_associate (expr1, expr2);
5929 sym->attr.flavor = FL_VARIABLE;
5930 sym->attr.referenced = 1;
5931 sym->attr.class_ok = 1;
5933 else
5935 m = gfc_match (" %e ", &expr1);
5936 if (m != MATCH_YES)
5938 std::swap (ns, gfc_current_ns);
5939 gfc_free_namespace (ns);
5940 return m;
5944 m = gfc_match (" )%t");
5945 if (m != MATCH_YES)
5947 gfc_error ("parse error in SELECT TYPE statement at %C");
5948 goto cleanup;
5951 /* This ghastly expression seems to be needed to distinguish a CLASS
5952 array, which can have a reference, from other expressions that
5953 have references, such as derived type components, and are not
5954 allowed by the standard.
5955 TODO: see if it is sufficient to exclude component and substring
5956 references. */
5957 class_array = (expr1->expr_type == EXPR_VARIABLE
5958 && expr1->ts.type == BT_CLASS
5959 && CLASS_DATA (expr1)
5960 && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0)
5961 && (CLASS_DATA (expr1)->attr.dimension
5962 || CLASS_DATA (expr1)->attr.codimension)
5963 && expr1->ref
5964 && expr1->ref->type == REF_ARRAY
5965 && expr1->ref->next == NULL);
5967 /* Check for F03:C811. */
5968 if (!expr2 && (expr1->expr_type != EXPR_VARIABLE
5969 || (!class_array && expr1->ref != NULL)))
5971 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
5972 "use associate-name=>");
5973 m = MATCH_ERROR;
5974 goto cleanup;
5977 new_st.op = EXEC_SELECT_TYPE;
5978 new_st.expr1 = expr1;
5979 new_st.expr2 = expr2;
5980 new_st.ext.block.ns = gfc_current_ns;
5982 select_type_push (expr1->symtree->n.sym);
5983 gfc_current_ns = ns;
5985 return MATCH_YES;
5987 cleanup:
5988 gfc_free_expr (expr1);
5989 gfc_free_expr (expr2);
5990 gfc_undo_symbols ();
5991 std::swap (ns, gfc_current_ns);
5992 gfc_free_namespace (ns);
5993 return m;
5997 /* Match a CASE statement. */
5999 match
6000 gfc_match_case (void)
6002 gfc_case *c, *head, *tail;
6003 match m;
6005 head = tail = NULL;
6007 if (gfc_current_state () != COMP_SELECT)
6009 gfc_error ("Unexpected CASE statement at %C");
6010 return MATCH_ERROR;
6013 if (gfc_match ("% default") == MATCH_YES)
6015 m = match_case_eos ();
6016 if (m == MATCH_NO)
6017 goto syntax;
6018 if (m == MATCH_ERROR)
6019 goto cleanup;
6021 new_st.op = EXEC_SELECT;
6022 c = gfc_get_case ();
6023 c->where = gfc_current_locus;
6024 new_st.ext.block.case_list = c;
6025 return MATCH_YES;
6028 if (gfc_match_char ('(') != MATCH_YES)
6029 goto syntax;
6031 for (;;)
6033 if (match_case_selector (&c) == MATCH_ERROR)
6034 goto cleanup;
6036 if (head == NULL)
6037 head = c;
6038 else
6039 tail->next = c;
6041 tail = c;
6043 if (gfc_match_char (')') == MATCH_YES)
6044 break;
6045 if (gfc_match_char (',') != MATCH_YES)
6046 goto syntax;
6049 m = match_case_eos ();
6050 if (m == MATCH_NO)
6051 goto syntax;
6052 if (m == MATCH_ERROR)
6053 goto cleanup;
6055 new_st.op = EXEC_SELECT;
6056 new_st.ext.block.case_list = head;
6058 return MATCH_YES;
6060 syntax:
6061 gfc_error ("Syntax error in CASE specification at %C");
6063 cleanup:
6064 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
6065 return MATCH_ERROR;
6069 /* Match a TYPE IS statement. */
6071 match
6072 gfc_match_type_is (void)
6074 gfc_case *c = NULL;
6075 match m;
6077 if (gfc_current_state () != COMP_SELECT_TYPE)
6079 gfc_error ("Unexpected TYPE IS statement at %C");
6080 return MATCH_ERROR;
6083 if (gfc_match_char ('(') != MATCH_YES)
6084 goto syntax;
6086 c = gfc_get_case ();
6087 c->where = gfc_current_locus;
6089 m = gfc_match_type_spec (&c->ts);
6090 if (m == MATCH_NO)
6091 goto syntax;
6092 if (m == MATCH_ERROR)
6093 goto cleanup;
6095 if (gfc_match_char (')') != MATCH_YES)
6096 goto syntax;
6098 m = match_case_eos ();
6099 if (m == MATCH_NO)
6100 goto syntax;
6101 if (m == MATCH_ERROR)
6102 goto cleanup;
6104 new_st.op = EXEC_SELECT_TYPE;
6105 new_st.ext.block.case_list = c;
6107 if (c->ts.type == BT_DERIVED && c->ts.u.derived
6108 && (c->ts.u.derived->attr.sequence
6109 || c->ts.u.derived->attr.is_bind_c))
6111 gfc_error ("The type-spec shall not specify a sequence derived "
6112 "type or a type with the BIND attribute in SELECT "
6113 "TYPE at %C [F2003:C815]");
6114 return MATCH_ERROR;
6117 /* Create temporary variable. */
6118 select_type_set_tmp (&c->ts);
6120 return MATCH_YES;
6122 syntax:
6123 gfc_error ("Syntax error in TYPE IS specification at %C");
6125 cleanup:
6126 if (c != NULL)
6127 gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
6128 return MATCH_ERROR;
6132 /* Match a CLASS IS or CLASS DEFAULT statement. */
6134 match
6135 gfc_match_class_is (void)
6137 gfc_case *c = NULL;
6138 match m;
6140 if (gfc_current_state () != COMP_SELECT_TYPE)
6141 return MATCH_NO;
6143 if (gfc_match ("% default") == MATCH_YES)
6145 m = match_case_eos ();
6146 if (m == MATCH_NO)
6147 goto syntax;
6148 if (m == MATCH_ERROR)
6149 goto cleanup;
6151 new_st.op = EXEC_SELECT_TYPE;
6152 c = gfc_get_case ();
6153 c->where = gfc_current_locus;
6154 c->ts.type = BT_UNKNOWN;
6155 new_st.ext.block.case_list = c;
6156 select_type_set_tmp (NULL);
6157 return MATCH_YES;
6160 m = gfc_match ("% is");
6161 if (m == MATCH_NO)
6162 goto syntax;
6163 if (m == MATCH_ERROR)
6164 goto cleanup;
6166 if (gfc_match_char ('(') != MATCH_YES)
6167 goto syntax;
6169 c = gfc_get_case ();
6170 c->where = gfc_current_locus;
6172 m = match_derived_type_spec (&c->ts);
6173 if (m == MATCH_NO)
6174 goto syntax;
6175 if (m == MATCH_ERROR)
6176 goto cleanup;
6178 if (c->ts.type == BT_DERIVED)
6179 c->ts.type = BT_CLASS;
6181 if (gfc_match_char (')') != MATCH_YES)
6182 goto syntax;
6184 m = match_case_eos ();
6185 if (m == MATCH_NO)
6186 goto syntax;
6187 if (m == MATCH_ERROR)
6188 goto cleanup;
6190 new_st.op = EXEC_SELECT_TYPE;
6191 new_st.ext.block.case_list = c;
6193 /* Create temporary variable. */
6194 select_type_set_tmp (&c->ts);
6196 return MATCH_YES;
6198 syntax:
6199 gfc_error ("Syntax error in CLASS IS specification at %C");
6201 cleanup:
6202 if (c != NULL)
6203 gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
6204 return MATCH_ERROR;
6208 /********************* WHERE subroutines ********************/
6210 /* Match the rest of a simple WHERE statement that follows an IF statement.
6213 static match
6214 match_simple_where (void)
6216 gfc_expr *expr;
6217 gfc_code *c;
6218 match m;
6220 m = gfc_match (" ( %e )", &expr);
6221 if (m != MATCH_YES)
6222 return m;
6224 m = gfc_match_assignment ();
6225 if (m == MATCH_NO)
6226 goto syntax;
6227 if (m == MATCH_ERROR)
6228 goto cleanup;
6230 if (gfc_match_eos () != MATCH_YES)
6231 goto syntax;
6233 c = gfc_get_code (EXEC_WHERE);
6234 c->expr1 = expr;
6236 c->next = XCNEW (gfc_code);
6237 *c->next = new_st;
6238 c->next->loc = gfc_current_locus;
6239 gfc_clear_new_st ();
6241 new_st.op = EXEC_WHERE;
6242 new_st.block = c;
6244 return MATCH_YES;
6246 syntax:
6247 gfc_syntax_error (ST_WHERE);
6249 cleanup:
6250 gfc_free_expr (expr);
6251 return MATCH_ERROR;
6255 /* Match a WHERE statement. */
6257 match
6258 gfc_match_where (gfc_statement *st)
6260 gfc_expr *expr;
6261 match m0, m;
6262 gfc_code *c;
6264 m0 = gfc_match_label ();
6265 if (m0 == MATCH_ERROR)
6266 return m0;
6268 m = gfc_match (" where ( %e )", &expr);
6269 if (m != MATCH_YES)
6270 return m;
6272 if (gfc_match_eos () == MATCH_YES)
6274 *st = ST_WHERE_BLOCK;
6275 new_st.op = EXEC_WHERE;
6276 new_st.expr1 = expr;
6277 return MATCH_YES;
6280 m = gfc_match_assignment ();
6281 if (m == MATCH_NO)
6282 gfc_syntax_error (ST_WHERE);
6284 if (m != MATCH_YES)
6286 gfc_free_expr (expr);
6287 return MATCH_ERROR;
6290 /* We've got a simple WHERE statement. */
6291 *st = ST_WHERE;
6292 c = gfc_get_code (EXEC_WHERE);
6293 c->expr1 = expr;
6295 /* Put in the assignment. It will not be processed by add_statement, so we
6296 need to copy the location here. */
6298 c->next = XCNEW (gfc_code);
6299 *c->next = new_st;
6300 c->next->loc = gfc_current_locus;
6301 gfc_clear_new_st ();
6303 new_st.op = EXEC_WHERE;
6304 new_st.block = c;
6306 return MATCH_YES;
6310 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
6311 new_st if successful. */
6313 match
6314 gfc_match_elsewhere (void)
6316 char name[GFC_MAX_SYMBOL_LEN + 1];
6317 gfc_expr *expr;
6318 match m;
6320 if (gfc_current_state () != COMP_WHERE)
6322 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
6323 return MATCH_ERROR;
6326 expr = NULL;
6328 if (gfc_match_char ('(') == MATCH_YES)
6330 m = gfc_match_expr (&expr);
6331 if (m == MATCH_NO)
6332 goto syntax;
6333 if (m == MATCH_ERROR)
6334 return MATCH_ERROR;
6336 if (gfc_match_char (')') != MATCH_YES)
6337 goto syntax;
6340 if (gfc_match_eos () != MATCH_YES)
6342 /* Only makes sense if we have a where-construct-name. */
6343 if (!gfc_current_block ())
6345 m = MATCH_ERROR;
6346 goto cleanup;
6348 /* Better be a name at this point. */
6349 m = gfc_match_name (name);
6350 if (m == MATCH_NO)
6351 goto syntax;
6352 if (m == MATCH_ERROR)
6353 goto cleanup;
6355 if (gfc_match_eos () != MATCH_YES)
6356 goto syntax;
6358 if (strcmp (name, gfc_current_block ()->name) != 0)
6360 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
6361 name, gfc_current_block ()->name);
6362 goto cleanup;
6366 new_st.op = EXEC_WHERE;
6367 new_st.expr1 = expr;
6368 return MATCH_YES;
6370 syntax:
6371 gfc_syntax_error (ST_ELSEWHERE);
6373 cleanup:
6374 gfc_free_expr (expr);
6375 return MATCH_ERROR;