projects / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
re PR fortran/40646 ([F03] array-valued procedure pointer components)
[gcc.git] / gcc / fortran / match.c
1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
21
22 #include "config.h"
23 #include "system.h"
24 #include "flags.h"
25 #include "gfortran.h"
26 #include "match.h"
27 #include "parse.h"
28
29 int gfc_matching_procptr_assignment = 0;
30 bool gfc_matching_prefix = false;
31
32 /* For debugging and diagnostic purposes. Return the textual representation
33 of the intrinsic operator OP. */
34 const char *
35 gfc_op2string (gfc_intrinsic_op op)
36 {
37 switch (op)
38 {
39 case INTRINSIC_UPLUS:
40 case INTRINSIC_PLUS:
41 return "+";
42
43 case INTRINSIC_UMINUS:
44 case INTRINSIC_MINUS:
45 return "-";
46
47 case INTRINSIC_POWER:
48 return "**";
49 case INTRINSIC_CONCAT:
50 return "//";
51 case INTRINSIC_TIMES:
52 return "*";
53 case INTRINSIC_DIVIDE:
54 return "/";
55
56 case INTRINSIC_AND:
57 return ".and.";
58 case INTRINSIC_OR:
59 return ".or.";
60 case INTRINSIC_EQV:
61 return ".eqv.";
62 case INTRINSIC_NEQV:
63 return ".neqv.";
64
65 case INTRINSIC_EQ_OS:
66 return ".eq.";
67 case INTRINSIC_EQ:
68 return "==";
69 case INTRINSIC_NE_OS:
70 return ".ne.";
71 case INTRINSIC_NE:
72 return "/=";
73 case INTRINSIC_GE_OS:
74 return ".ge.";
75 case INTRINSIC_GE:
76 return ">=";
77 case INTRINSIC_LE_OS:
78 return ".le.";
79 case INTRINSIC_LE:
80 return "<=";
81 case INTRINSIC_LT_OS:
82 return ".lt.";
83 case INTRINSIC_LT:
84 return "<";
85 case INTRINSIC_GT_OS:
86 return ".gt.";
87 case INTRINSIC_GT:
88 return ">";
89 case INTRINSIC_NOT:
90 return ".not.";
91
92 case INTRINSIC_ASSIGN:
93 return "=";
94
95 case INTRINSIC_PARENTHESES:
96 return "parens";
97
98 default:
99 break;
100 }
101
102 gfc_internal_error ("gfc_op2string(): Bad code");
103 /* Not reached. */
104 }
105
106
107 /******************** Generic matching subroutines ************************/
108
109 /* This function scans the current statement counting the opened and closed
110 parenthesis to make sure they are balanced. */
111
112 match
113 gfc_match_parens (void)
114 {
115 locus old_loc, where;
116 int count, instring;
117 gfc_char_t c, quote;
118
119 old_loc = gfc_current_locus;
120 count = 0;
121 instring = 0;
122 quote = ' ';
123
124 for (;;)
125 {
126 c = gfc_next_char_literal (instring);
127 if (c == '\n')
128 break;
129 if (quote == ' ' && ((c == '\'') || (c == '"')))
130 {
131 quote = c;
132 instring = 1;
133 continue;
134 }
135 if (quote != ' ' && c == quote)
136 {
137 quote = ' ';
138 instring = 0;
139 continue;
140 }
141
142 if (c == '(' && quote == ' ')
143 {
144 count++;
145 where = gfc_current_locus;
146 }
147 if (c == ')' && quote == ' ')
148 {
149 count--;
150 where = gfc_current_locus;
151 }
152 }
153
154 gfc_current_locus = old_loc;
155
156 if (count > 0)
157 {
158 gfc_error ("Missing ')' in statement at or before %L", &where);
159 return MATCH_ERROR;
160 }
161 if (count < 0)
162 {
163 gfc_error ("Missing '(' in statement at or before %L", &where);
164 return MATCH_ERROR;
165 }
166
167 return MATCH_YES;
168 }
169
170
171 /* See if the next character is a special character that has
172 escaped by a \ via the -fbackslash option. */
173
174 match
175 gfc_match_special_char (gfc_char_t *res)
176 {
177 int len, i;
178 gfc_char_t c, n;
179 match m;
180
181 m = MATCH_YES;
182
183 switch ((c = gfc_next_char_literal (1)))
184 {
185 case 'a':
186 *res = '\a';
187 break;
188 case 'b':
189 *res = '\b';
190 break;
191 case 't':
192 *res = '\t';
193 break;
194 case 'f':
195 *res = '\f';
196 break;
197 case 'n':
198 *res = '\n';
199 break;
200 case 'r':
201 *res = '\r';
202 break;
203 case 'v':
204 *res = '\v';
205 break;
206 case '\\':
207 *res = '\\';
208 break;
209 case '0':
210 *res = '\0';
211 break;
212
213 case 'x':
214 case 'u':
215 case 'U':
216 /* Hexadecimal form of wide characters. */
217 len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8));
218 n = 0;
219 for (i = 0; i < len; i++)
220 {
221 char buf[2] = { '\0', '\0' };
222
223 c = gfc_next_char_literal (1);
224 if (!gfc_wide_fits_in_byte (c)
225 || !gfc_check_digit ((unsigned char) c, 16))
226 return MATCH_NO;
227
228 buf[0] = (unsigned char) c;
229 n = n << 4;
230 n += strtol (buf, NULL, 16);
231 }
232 *res = n;
233 break;
234
235 default:
236 /* Unknown backslash codes are simply not expanded. */
237 m = MATCH_NO;
238 break;
239 }
240
241 return m;
242 }
243
244
245 /* In free form, match at least one space. Always matches in fixed
246 form. */
247
248 match
249 gfc_match_space (void)
250 {
251 locus old_loc;
252 char c;
253
254 if (gfc_current_form == FORM_FIXED)
255 return MATCH_YES;
256
257 old_loc = gfc_current_locus;
258
259 c = gfc_next_ascii_char ();
260 if (!gfc_is_whitespace (c))
261 {
262 gfc_current_locus = old_loc;
263 return MATCH_NO;
264 }
265
266 gfc_gobble_whitespace ();
267
268 return MATCH_YES;
269 }
270
271
272 /* Match an end of statement. End of statement is optional
273 whitespace, followed by a ';' or '\n' or comment '!'. If a
274 semicolon is found, we continue to eat whitespace and semicolons. */
275
276 match
277 gfc_match_eos (void)
278 {
279 locus old_loc;
280 int flag;
281 char c;
282
283 flag = 0;
284
285 for (;;)
286 {
287 old_loc = gfc_current_locus;
288 gfc_gobble_whitespace ();
289
290 c = gfc_next_ascii_char ();
291 switch (c)
292 {
293 case '!':
294 do
295 {
296 c = gfc_next_ascii_char ();
297 }
298 while (c != '\n');
299
300 /* Fall through. */
301
302 case '\n':
303 return MATCH_YES;
304
305 case ';':
306 flag = 1;
307 continue;
308 }
309
310 break;
311 }
312
313 gfc_current_locus = old_loc;
314 return (flag) ? MATCH_YES : MATCH_NO;
315 }
316
317
318 /* Match a literal integer on the input, setting the value on
319 MATCH_YES. Literal ints occur in kind-parameters as well as
320 old-style character length specifications. If cnt is non-NULL it
321 will be set to the number of digits. */
322
323 match
324 gfc_match_small_literal_int (int *value, int *cnt)
325 {
326 locus old_loc;
327 char c;
328 int i, j;
329
330 old_loc = gfc_current_locus;
331
332 *value = -1;
333 gfc_gobble_whitespace ();
334 c = gfc_next_ascii_char ();
335 if (cnt)
336 *cnt = 0;
337
338 if (!ISDIGIT (c))
339 {
340 gfc_current_locus = old_loc;
341 return MATCH_NO;
342 }
343
344 i = c - '0';
345 j = 1;
346
347 for (;;)
348 {
349 old_loc = gfc_current_locus;
350 c = gfc_next_ascii_char ();
351
352 if (!ISDIGIT (c))
353 break;
354
355 i = 10 * i + c - '0';
356 j++;
357
358 if (i > 99999999)
359 {
360 gfc_error ("Integer too large at %C");
361 return MATCH_ERROR;
362 }
363 }
364
365 gfc_current_locus = old_loc;
366
367 *value = i;
368 if (cnt)
369 *cnt = j;
370 return MATCH_YES;
371 }
372
373
374 /* Match a small, constant integer expression, like in a kind
375 statement. On MATCH_YES, 'value' is set. */
376
377 match
378 gfc_match_small_int (int *value)
379 {
380 gfc_expr *expr;
381 const char *p;
382 match m;
383 int i;
384
385 m = gfc_match_expr (&expr);
386 if (m != MATCH_YES)
387 return m;
388
389 p = gfc_extract_int (expr, &i);
390 gfc_free_expr (expr);
391
392 if (p != NULL)
393 {
394 gfc_error (p);
395 m = MATCH_ERROR;
396 }
397
398 *value = i;
399 return m;
400 }
401
402
403 /* This function is the same as the gfc_match_small_int, except that
404 we're keeping the pointer to the expr. This function could just be
405 removed and the previously mentioned one modified, though all calls
406 to it would have to be modified then (and there were a number of
407 them). Return MATCH_ERROR if fail to extract the int; otherwise,
408 return the result of gfc_match_expr(). The expr (if any) that was
409 matched is returned in the parameter expr. */
410
411 match
412 gfc_match_small_int_expr (int *value, gfc_expr **expr)
413 {
414 const char *p;
415 match m;
416 int i;
417
418 m = gfc_match_expr (expr);
419 if (m != MATCH_YES)
420 return m;
421
422 p = gfc_extract_int (*expr, &i);
423
424 if (p != NULL)
425 {
426 gfc_error (p);
427 m = MATCH_ERROR;
428 }
429
430 *value = i;
431 return m;
432 }
433
434
435 /* Matches a statement label. Uses gfc_match_small_literal_int() to
436 do most of the work. */
437
438 match
439 gfc_match_st_label (gfc_st_label **label)
440 {
441 locus old_loc;
442 match m;
443 int i, cnt;
444
445 old_loc = gfc_current_locus;
446
447 m = gfc_match_small_literal_int (&i, &cnt);
448 if (m != MATCH_YES)
449 return m;
450
451 if (cnt > 5)
452 {
453 gfc_error ("Too many digits in statement label at %C");
454 goto cleanup;
455 }
456
457 if (i == 0)
458 {
459 gfc_error ("Statement label at %C is zero");
460 goto cleanup;
461 }
462
463 *label = gfc_get_st_label (i);
464 return MATCH_YES;
465
466 cleanup:
467
468 gfc_current_locus = old_loc;
469 return MATCH_ERROR;
470 }
471
472
473 /* Match and validate a label associated with a named IF, DO or SELECT
474 statement. If the symbol does not have the label attribute, we add
475 it. We also make sure the symbol does not refer to another
476 (active) block. A matched label is pointed to by gfc_new_block. */
477
478 match
479 gfc_match_label (void)
480 {
481 char name[GFC_MAX_SYMBOL_LEN + 1];
482 match m;
483
484 gfc_new_block = NULL;
485
486 m = gfc_match (" %n :", name);
487 if (m != MATCH_YES)
488 return m;
489
490 if (gfc_get_symbol (name, NULL, &gfc_new_block))
491 {
492 gfc_error ("Label name '%s' at %C is ambiguous", name);
493 return MATCH_ERROR;
494 }
495
496 if (gfc_new_block->attr.flavor == FL_LABEL)
497 {
498 gfc_error ("Duplicate construct label '%s' at %C", name);
499 return MATCH_ERROR;
500 }
501
502 if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
503 gfc_new_block->name, NULL) == FAILURE)
504 return MATCH_ERROR;
505
506 return MATCH_YES;
507 }
508
509
510 /* See if the current input looks like a name of some sort. Modifies
511 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
512 Note that options.c restricts max_identifier_length to not more
513 than GFC_MAX_SYMBOL_LEN. */
514
515 match
516 gfc_match_name (char *buffer)
517 {
518 locus old_loc;
519 int i;
520 char c;
521
522 old_loc = gfc_current_locus;
523 gfc_gobble_whitespace ();
524
525 c = gfc_next_ascii_char ();
526 if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore)))
527 {
528 if (gfc_error_flag_test() == 0 && c != '(')
529 gfc_error ("Invalid character in name at %C");
530 gfc_current_locus = old_loc;
531 return MATCH_NO;
532 }
533
534 i = 0;
535
536 do
537 {
538 buffer[i++] = c;
539
540 if (i > gfc_option.max_identifier_length)
541 {
542 gfc_error ("Name at %C is too long");
543 return MATCH_ERROR;
544 }
545
546 old_loc = gfc_current_locus;
547 c = gfc_next_ascii_char ();
548 }
549 while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));
550
551 if (c == '$' && !gfc_option.flag_dollar_ok)
552 {
553 gfc_error ("Invalid character '$' at %C. Use -fdollar-ok to allow it "
554 "as an extension");
555 return MATCH_ERROR;
556 }
557
558 buffer[i] = '\0';
559 gfc_current_locus = old_loc;
560
561 return MATCH_YES;
562 }
563
564
565 /* Match a valid name for C, which is almost the same as for Fortran,
566 except that you can start with an underscore, etc.. It could have
567 been done by modifying the gfc_match_name, but this way other
568 things C allows can be added, such as no limits on the length.
569 Right now, the length is limited to the same thing as Fortran..
570 Also, by rewriting it, we use the gfc_next_char_C() to prevent the
571 input characters from being automatically lower cased, since C is
572 case sensitive. The parameter, buffer, is used to return the name
573 that is matched. Return MATCH_ERROR if the name is too long
574 (though this is a self-imposed limit), MATCH_NO if what we're
575 seeing isn't a name, and MATCH_YES if we successfully match a C
576 name. */
577
578 match
579 gfc_match_name_C (char *buffer)
580 {
581 locus old_loc;
582 int i = 0;
583 gfc_char_t c;
584
585 old_loc = gfc_current_locus;
586 gfc_gobble_whitespace ();
587
588 /* Get the next char (first possible char of name) and see if
589 it's valid for C (either a letter or an underscore). */
590 c = gfc_next_char_literal (1);
591
592 /* If the user put nothing expect spaces between the quotes, it is valid
593 and simply means there is no name= specifier and the name is the fortran
594 symbol name, all lowercase. */
595 if (c == '"' || c == '\'')
596 {
597 buffer[0] = '\0';
598 gfc_current_locus = old_loc;
599 return MATCH_YES;
600 }
601
602 if (!ISALPHA (c) && c != '_')
603 {
604 gfc_error ("Invalid C name in NAME= specifier at %C");
605 return MATCH_ERROR;
606 }
607
608 /* Continue to read valid variable name characters. */
609 do
610 {
611 gcc_assert (gfc_wide_fits_in_byte (c));
612
613 buffer[i++] = (unsigned char) c;
614
615 /* C does not define a maximum length of variable names, to my
616 knowledge, but the compiler typically places a limit on them.
617 For now, i'll use the same as the fortran limit for simplicity,
618 but this may need to be changed to a dynamic buffer that can
619 be realloc'ed here if necessary, or more likely, a larger
620 upper-bound set. */
621 if (i > gfc_option.max_identifier_length)
622 {
623 gfc_error ("Name at %C is too long");
624 return MATCH_ERROR;
625 }
626
627 old_loc = gfc_current_locus;
628
629 /* Get next char; param means we're in a string. */
630 c = gfc_next_char_literal (1);
631 } while (ISALNUM (c) || c == '_');
632
633 buffer[i] = '\0';
634 gfc_current_locus = old_loc;
635
636 /* See if we stopped because of whitespace. */
637 if (c == ' ')
638 {
639 gfc_gobble_whitespace ();
640 c = gfc_peek_ascii_char ();
641 if (c != '"' && c != '\'')
642 {
643 gfc_error ("Embedded space in NAME= specifier at %C");
644 return MATCH_ERROR;
645 }
646 }
647
648 /* If we stopped because we had an invalid character for a C name, report
649 that to the user by returning MATCH_NO. */
650 if (c != '"' && c != '\'')
651 {
652 gfc_error ("Invalid C name in NAME= specifier at %C");
653 return MATCH_ERROR;
654 }
655
656 return MATCH_YES;
657 }
658
659
660 /* Match a symbol on the input. Modifies the pointer to the symbol
661 pointer if successful. */
662
663 match
664 gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
665 {
666 char buffer[GFC_MAX_SYMBOL_LEN + 1];
667 match m;
668
669 m = gfc_match_name (buffer);
670 if (m != MATCH_YES)
671 return m;
672
673 if (host_assoc)
674 return (gfc_get_ha_sym_tree (buffer, matched_symbol))
675 ? MATCH_ERROR : MATCH_YES;
676
677 if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false))
678 return MATCH_ERROR;
679
680 return MATCH_YES;
681 }
682
683
684 match
685 gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
686 {
687 gfc_symtree *st;
688 match m;
689
690 m = gfc_match_sym_tree (&st, host_assoc);
691
692 if (m == MATCH_YES)
693 {
694 if (st)
695 *matched_symbol = st->n.sym;
696 else
697 *matched_symbol = NULL;
698 }
699 else
700 *matched_symbol = NULL;
701 return m;
702 }
703
704
705 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
706 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
707 in matchexp.c. */
708
709 match
710 gfc_match_intrinsic_op (gfc_intrinsic_op *result)
711 {
712 locus orig_loc = gfc_current_locus;
713 char ch;
714
715 gfc_gobble_whitespace ();
716 ch = gfc_next_ascii_char ();
717 switch (ch)
718 {
719 case '+':
720 /* Matched "+". */
721 *result = INTRINSIC_PLUS;
722 return MATCH_YES;
723
724 case '-':
725 /* Matched "-". */
726 *result = INTRINSIC_MINUS;
727 return MATCH_YES;
728
729 case '=':
730 if (gfc_next_ascii_char () == '=')
731 {
732 /* Matched "==". */
733 *result = INTRINSIC_EQ;
734 return MATCH_YES;
735 }
736 break;
737
738 case '<':
739 if (gfc_peek_ascii_char () == '=')
740 {
741 /* Matched "<=". */
742 gfc_next_ascii_char ();
743 *result = INTRINSIC_LE;
744 return MATCH_YES;
745 }
746 /* Matched "<". */
747 *result = INTRINSIC_LT;
748 return MATCH_YES;
749
750 case '>':
751 if (gfc_peek_ascii_char () == '=')
752 {
753 /* Matched ">=". */
754 gfc_next_ascii_char ();
755 *result = INTRINSIC_GE;
756 return MATCH_YES;
757 }
758 /* Matched ">". */
759 *result = INTRINSIC_GT;
760 return MATCH_YES;
761
762 case '*':
763 if (gfc_peek_ascii_char () == '*')
764 {
765 /* Matched "**". */
766 gfc_next_ascii_char ();
767 *result = INTRINSIC_POWER;
768 return MATCH_YES;
769 }
770 /* Matched "*". */
771 *result = INTRINSIC_TIMES;
772 return MATCH_YES;
773
774 case '/':
775 ch = gfc_peek_ascii_char ();
776 if (ch == '=')
777 {
778 /* Matched "/=". */
779 gfc_next_ascii_char ();
780 *result = INTRINSIC_NE;
781 return MATCH_YES;
782 }
783 else if (ch == '/')
784 {
785 /* Matched "//". */
786 gfc_next_ascii_char ();
787 *result = INTRINSIC_CONCAT;
788 return MATCH_YES;
789 }
790 /* Matched "/". */
791 *result = INTRINSIC_DIVIDE;
792 return MATCH_YES;
793
794 case '.':
795 ch = gfc_next_ascii_char ();
796 switch (ch)
797 {
798 case 'a':
799 if (gfc_next_ascii_char () == 'n'
800 && gfc_next_ascii_char () == 'd'
801 && gfc_next_ascii_char () == '.')
802 {
803 /* Matched ".and.". */
804 *result = INTRINSIC_AND;
805 return MATCH_YES;
806 }
807 break;
808
809 case 'e':
810 if (gfc_next_ascii_char () == 'q')
811 {
812 ch = gfc_next_ascii_char ();
813 if (ch == '.')
814 {
815 /* Matched ".eq.". */
816 *result = INTRINSIC_EQ_OS;
817 return MATCH_YES;
818 }
819 else if (ch == 'v')
820 {
821 if (gfc_next_ascii_char () == '.')
822 {
823 /* Matched ".eqv.". */
824 *result = INTRINSIC_EQV;
825 return MATCH_YES;
826 }
827 }
828 }
829 break;
830
831 case 'g':
832 ch = gfc_next_ascii_char ();
833 if (ch == 'e')
834 {
835 if (gfc_next_ascii_char () == '.')
836 {
837 /* Matched ".ge.". */
838 *result = INTRINSIC_GE_OS;
839 return MATCH_YES;
840 }
841 }
842 else if (ch == 't')
843 {
844 if (gfc_next_ascii_char () == '.')
845 {
846 /* Matched ".gt.". */
847 *result = INTRINSIC_GT_OS;
848 return MATCH_YES;
849 }
850 }
851 break;
852
853 case 'l':
854 ch = gfc_next_ascii_char ();
855 if (ch == 'e')
856 {
857 if (gfc_next_ascii_char () == '.')
858 {
859 /* Matched ".le.". */
860 *result = INTRINSIC_LE_OS;
861 return MATCH_YES;
862 }
863 }
864 else if (ch == 't')
865 {
866 if (gfc_next_ascii_char () == '.')
867 {
868 /* Matched ".lt.". */
869 *result = INTRINSIC_LT_OS;
870 return MATCH_YES;
871 }
872 }
873 break;
874
875 case 'n':
876 ch = gfc_next_ascii_char ();
877 if (ch == 'e')
878 {
879 ch = gfc_next_ascii_char ();
880 if (ch == '.')
881 {
882 /* Matched ".ne.". */
883 *result = INTRINSIC_NE_OS;
884 return MATCH_YES;
885 }
886 else if (ch == 'q')
887 {
888 if (gfc_next_ascii_char () == 'v'
889 && gfc_next_ascii_char () == '.')
890 {
891 /* Matched ".neqv.". */
892 *result = INTRINSIC_NEQV;
893 return MATCH_YES;
894 }
895 }
896 }
897 else if (ch == 'o')
898 {
899 if (gfc_next_ascii_char () == 't'
900 && gfc_next_ascii_char () == '.')
901 {
902 /* Matched ".not.". */
903 *result = INTRINSIC_NOT;
904 return MATCH_YES;
905 }
906 }
907 break;
908
909 case 'o':
910 if (gfc_next_ascii_char () == 'r'
911 && gfc_next_ascii_char () == '.')
912 {
913 /* Matched ".or.". */
914 *result = INTRINSIC_OR;
915 return MATCH_YES;
916 }
917 break;
918
919 default:
920 break;
921 }
922 break;
923
924 default:
925 break;
926 }
927
928 gfc_current_locus = orig_loc;
929 return MATCH_NO;
930 }
931
932
933 /* Match a loop control phrase:
934
935 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
936
937 If the final integer expression is not present, a constant unity
938 expression is returned. We don't return MATCH_ERROR until after
939 the equals sign is seen. */
940
941 match
942 gfc_match_iterator (gfc_iterator *iter, int init_flag)
943 {
944 char name[GFC_MAX_SYMBOL_LEN + 1];
945 gfc_expr *var, *e1, *e2, *e3;
946 locus start;
947 match m;
948
949 /* Match the start of an iterator without affecting the symbol table. */
950
951 start = gfc_current_locus;
952 m = gfc_match (" %n =", name);
953 gfc_current_locus = start;
954
955 if (m != MATCH_YES)
956 return MATCH_NO;
957
958 m = gfc_match_variable (&var, 0);
959 if (m != MATCH_YES)
960 return MATCH_NO;
961
962 gfc_match_char ('=');
963
964 e1 = e2 = e3 = NULL;
965
966 if (var->ref != NULL)
967 {
968 gfc_error ("Loop variable at %C cannot be a sub-component");
969 goto cleanup;
970 }
971
972 if (var->symtree->n.sym->attr.intent == INTENT_IN)
973 {
974 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
975 var->symtree->n.sym->name);
976 goto cleanup;
977 }
978
979 var->symtree->n.sym->attr.implied_index = 1;
980
981 m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
982 if (m == MATCH_NO)
983 goto syntax;
984 if (m == MATCH_ERROR)
985 goto cleanup;
986
987 if (gfc_match_char (',') != MATCH_YES)
988 goto syntax;
989
990 m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
991 if (m == MATCH_NO)
992 goto syntax;
993 if (m == MATCH_ERROR)
994 goto cleanup;
995
996 if (gfc_match_char (',') != MATCH_YES)
997 {
998 e3 = gfc_int_expr (1);
999 goto done;
1000 }
1001
1002 m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
1003 if (m == MATCH_ERROR)
1004 goto cleanup;
1005 if (m == MATCH_NO)
1006 {
1007 gfc_error ("Expected a step value in iterator at %C");
1008 goto cleanup;
1009 }
1010
1011 done:
1012 iter->var = var;
1013 iter->start = e1;
1014 iter->end = e2;
1015 iter->step = e3;
1016 return MATCH_YES;
1017
1018 syntax:
1019 gfc_error ("Syntax error in iterator at %C");
1020
1021 cleanup:
1022 gfc_free_expr (e1);
1023 gfc_free_expr (e2);
1024 gfc_free_expr (e3);
1025
1026 return MATCH_ERROR;
1027 }
1028
1029
1030 /* Tries to match the next non-whitespace character on the input.
1031 This subroutine does not return MATCH_ERROR. */
1032
1033 match
1034 gfc_match_char (char c)
1035 {
1036 locus where;
1037
1038 where = gfc_current_locus;
1039 gfc_gobble_whitespace ();
1040
1041 if (gfc_next_ascii_char () == c)
1042 return MATCH_YES;
1043
1044 gfc_current_locus = where;
1045 return MATCH_NO;
1046 }
1047
1048
1049 /* General purpose matching subroutine. The target string is a
1050 scanf-like format string in which spaces correspond to arbitrary
1051 whitespace (including no whitespace), characters correspond to
1052 themselves. The %-codes are:
1053
1054 %% Literal percent sign
1055 %e Expression, pointer to a pointer is set
1056 %s Symbol, pointer to the symbol is set
1057 %n Name, character buffer is set to name
1058 %t Matches end of statement.
1059 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1060 %l Matches a statement label
1061 %v Matches a variable expression (an lvalue)
1062 % Matches a required space (in free form) and optional spaces. */
1063
1064 match
1065 gfc_match (const char *target, ...)
1066 {
1067 gfc_st_label **label;
1068 int matches, *ip;
1069 locus old_loc;
1070 va_list argp;
1071 char c, *np;
1072 match m, n;
1073 void **vp;
1074 const char *p;
1075
1076 old_loc = gfc_current_locus;
1077 va_start (argp, target);
1078 m = MATCH_NO;
1079 matches = 0;
1080 p = target;
1081
1082 loop:
1083 c = *p++;
1084 switch (c)
1085 {
1086 case ' ':
1087 gfc_gobble_whitespace ();
1088 goto loop;
1089 case '\0':
1090 m = MATCH_YES;
1091 break;
1092
1093 case '%':
1094 c = *p++;
1095 switch (c)
1096 {
1097 case 'e':
1098 vp = va_arg (argp, void **);
1099 n = gfc_match_expr ((gfc_expr **) vp);
1100 if (n != MATCH_YES)
1101 {
1102 m = n;
1103 goto not_yes;
1104 }
1105
1106 matches++;
1107 goto loop;
1108
1109 case 'v':
1110 vp = va_arg (argp, void **);
1111 n = gfc_match_variable ((gfc_expr **) vp, 0);
1112 if (n != MATCH_YES)
1113 {
1114 m = n;
1115 goto not_yes;
1116 }
1117
1118 matches++;
1119 goto loop;
1120
1121 case 's':
1122 vp = va_arg (argp, void **);
1123 n = gfc_match_symbol ((gfc_symbol **) vp, 0);
1124 if (n != MATCH_YES)
1125 {
1126 m = n;
1127 goto not_yes;
1128 }
1129
1130 matches++;
1131 goto loop;
1132
1133 case 'n':
1134 np = va_arg (argp, char *);
1135 n = gfc_match_name (np);
1136 if (n != MATCH_YES)
1137 {
1138 m = n;
1139 goto not_yes;
1140 }
1141
1142 matches++;
1143 goto loop;
1144
1145 case 'l':
1146 label = va_arg (argp, gfc_st_label **);
1147 n = gfc_match_st_label (label);
1148 if (n != MATCH_YES)
1149 {
1150 m = n;
1151 goto not_yes;
1152 }
1153
1154 matches++;
1155 goto loop;
1156
1157 case 'o':
1158 ip = va_arg (argp, int *);
1159 n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
1160 if (n != MATCH_YES)
1161 {
1162 m = n;
1163 goto not_yes;
1164 }
1165
1166 matches++;
1167 goto loop;
1168
1169 case 't':
1170 if (gfc_match_eos () != MATCH_YES)
1171 {
1172 m = MATCH_NO;
1173 goto not_yes;
1174 }
1175 goto loop;
1176
1177 case ' ':
1178 if (gfc_match_space () == MATCH_YES)
1179 goto loop;
1180 m = MATCH_NO;
1181 goto not_yes;
1182
1183 case '%':
1184 break; /* Fall through to character matcher. */
1185
1186 default:
1187 gfc_internal_error ("gfc_match(): Bad match code %c", c);
1188 }
1189
1190 default:
1191
1192 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1193 expect an upper case character here! */
1194 gcc_assert (TOLOWER (c) == c);
1195
1196 if (c == gfc_next_ascii_char ())
1197 goto loop;
1198 break;
1199 }
1200
1201 not_yes:
1202 va_end (argp);
1203
1204 if (m != MATCH_YES)
1205 {
1206 /* Clean up after a failed match. */
1207 gfc_current_locus = old_loc;
1208 va_start (argp, target);
1209
1210 p = target;
1211 for (; matches > 0; matches--)
1212 {
1213 while (*p++ != '%');
1214
1215 switch (*p++)
1216 {
1217 case '%':
1218 matches++;
1219 break; /* Skip. */
1220
1221 /* Matches that don't have to be undone */
1222 case 'o':
1223 case 'l':
1224 case 'n':
1225 case 's':
1226 (void) va_arg (argp, void **);
1227 break;
1228
1229 case 'e':
1230 case 'v':
1231 vp = va_arg (argp, void **);
1232 gfc_free_expr ((struct gfc_expr *)*vp);
1233 *vp = NULL;
1234 break;
1235 }
1236 }
1237
1238 va_end (argp);
1239 }
1240
1241 return m;
1242 }
1243
1244
1245 /*********************** Statement level matching **********************/
1246
1247 /* Matches the start of a program unit, which is the program keyword
1248 followed by an obligatory symbol. */
1249
1250 match
1251 gfc_match_program (void)
1252 {
1253 gfc_symbol *sym;
1254 match m;
1255
1256 m = gfc_match ("% %s%t", &sym);
1257
1258 if (m == MATCH_NO)
1259 {
1260 gfc_error ("Invalid form of PROGRAM statement at %C");
1261 m = MATCH_ERROR;
1262 }
1263
1264 if (m == MATCH_ERROR)
1265 return m;
1266
1267 if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
1268 return MATCH_ERROR;
1269
1270 gfc_new_block = sym;
1271
1272 return MATCH_YES;
1273 }
1274
1275
1276 /* Match a simple assignment statement. */
1277
1278 match
1279 gfc_match_assignment (void)
1280 {
1281 gfc_expr *lvalue, *rvalue;
1282 locus old_loc;
1283 match m;
1284
1285 old_loc = gfc_current_locus;
1286
1287 lvalue = NULL;
1288 m = gfc_match (" %v =", &lvalue);
1289 if (m != MATCH_YES)
1290 {
1291 gfc_current_locus = old_loc;
1292 gfc_free_expr (lvalue);
1293 return MATCH_NO;
1294 }
1295
1296 rvalue = NULL;
1297 m = gfc_match (" %e%t", &rvalue);
1298 if (m != MATCH_YES)
1299 {
1300 gfc_current_locus = old_loc;
1301 gfc_free_expr (lvalue);
1302 gfc_free_expr (rvalue);
1303 return m;
1304 }
1305
1306 gfc_set_sym_referenced (lvalue->symtree->n.sym);
1307
1308 new_st.op = EXEC_ASSIGN;
1309 new_st.expr1 = lvalue;
1310 new_st.expr2 = rvalue;
1311
1312 gfc_check_do_variable (lvalue->symtree);
1313
1314 return MATCH_YES;
1315 }
1316
1317
1318 /* Match a pointer assignment statement. */
1319
1320 match
1321 gfc_match_pointer_assignment (void)
1322 {
1323 gfc_expr *lvalue, *rvalue;
1324 locus old_loc;
1325 match m;
1326
1327 old_loc = gfc_current_locus;
1328
1329 lvalue = rvalue = NULL;
1330 gfc_matching_procptr_assignment = 0;
1331
1332 m = gfc_match (" %v =>", &lvalue);
1333 if (m != MATCH_YES)
1334 {
1335 m = MATCH_NO;
1336 goto cleanup;
1337 }
1338
1339 if (lvalue->symtree->n.sym->attr.proc_pointer
1340 || gfc_is_proc_ptr_comp (lvalue, NULL))
1341 gfc_matching_procptr_assignment = 1;
1342
1343 m = gfc_match (" %e%t", &rvalue);
1344 gfc_matching_procptr_assignment = 0;
1345 if (m != MATCH_YES)
1346 goto cleanup;
1347
1348 new_st.op = EXEC_POINTER_ASSIGN;
1349 new_st.expr1 = lvalue;
1350 new_st.expr2 = rvalue;
1351
1352 return MATCH_YES;
1353
1354 cleanup:
1355 gfc_current_locus = old_loc;
1356 gfc_free_expr (lvalue);
1357 gfc_free_expr (rvalue);
1358 return m;
1359 }
1360
1361
1362 /* We try to match an easy arithmetic IF statement. This only happens
1363 when just after having encountered a simple IF statement. This code
1364 is really duplicate with parts of the gfc_match_if code, but this is
1365 *much* easier. */
1366
1367 static match
1368 match_arithmetic_if (void)
1369 {
1370 gfc_st_label *l1, *l2, *l3;
1371 gfc_expr *expr;
1372 match m;
1373
1374 m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
1375 if (m != MATCH_YES)
1376 return m;
1377
1378 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1379 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1380 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1381 {
1382 gfc_free_expr (expr);
1383 return MATCH_ERROR;
1384 }
1385
1386 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF statement "
1387 "at %C") == FAILURE)
1388 return MATCH_ERROR;
1389
1390 new_st.op = EXEC_ARITHMETIC_IF;
1391 new_st.expr1 = expr;
1392 new_st.label1 = l1;
1393 new_st.label2 = l2;
1394 new_st.label3 = l3;
1395
1396 return MATCH_YES;
1397 }
1398
1399
1400 /* The IF statement is a bit of a pain. First of all, there are three
1401 forms of it, the simple IF, the IF that starts a block and the
1402 arithmetic IF.
1403
1404 There is a problem with the simple IF and that is the fact that we
1405 only have a single level of undo information on symbols. What this
1406 means is for a simple IF, we must re-match the whole IF statement
1407 multiple times in order to guarantee that the symbol table ends up
1408 in the proper state. */
1409
1410 static match match_simple_forall (void);
1411 static match match_simple_where (void);
1412
1413 match
1414 gfc_match_if (gfc_statement *if_type)
1415 {
1416 gfc_expr *expr;
1417 gfc_st_label *l1, *l2, *l3;
1418 locus old_loc, old_loc2;
1419 gfc_code *p;
1420 match m, n;
1421
1422 n = gfc_match_label ();
1423 if (n == MATCH_ERROR)
1424 return n;
1425
1426 old_loc = gfc_current_locus;
1427
1428 m = gfc_match (" if ( %e", &expr);
1429 if (m != MATCH_YES)
1430 return m;
1431
1432 old_loc2 = gfc_current_locus;
1433 gfc_current_locus = old_loc;
1434
1435 if (gfc_match_parens () == MATCH_ERROR)
1436 return MATCH_ERROR;
1437
1438 gfc_current_locus = old_loc2;
1439
1440 if (gfc_match_char (')') != MATCH_YES)
1441 {
1442 gfc_error ("Syntax error in IF-expression at %C");
1443 gfc_free_expr (expr);
1444 return MATCH_ERROR;
1445 }
1446
1447 m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
1448
1449 if (m == MATCH_YES)
1450 {
1451 if (n == MATCH_YES)
1452 {
1453 gfc_error ("Block label not appropriate for arithmetic IF "
1454 "statement at %C");
1455 gfc_free_expr (expr);
1456 return MATCH_ERROR;
1457 }
1458
1459 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1460 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1461 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1462 {
1463 gfc_free_expr (expr);
1464 return MATCH_ERROR;
1465 }
1466
1467 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF "
1468 "statement at %C") == FAILURE)
1469 return MATCH_ERROR;
1470
1471 new_st.op = EXEC_ARITHMETIC_IF;
1472 new_st.expr1 = expr;
1473 new_st.label1 = l1;
1474 new_st.label2 = l2;
1475 new_st.label3 = l3;
1476
1477 *if_type = ST_ARITHMETIC_IF;
1478 return MATCH_YES;
1479 }
1480
1481 if (gfc_match (" then%t") == MATCH_YES)
1482 {
1483 new_st.op = EXEC_IF;
1484 new_st.expr1 = expr;
1485 *if_type = ST_IF_BLOCK;
1486 return MATCH_YES;
1487 }
1488
1489 if (n == MATCH_YES)
1490 {
1491 gfc_error ("Block label is not appropriate for IF statement at %C");
1492 gfc_free_expr (expr);
1493 return MATCH_ERROR;
1494 }
1495
1496 /* At this point the only thing left is a simple IF statement. At
1497 this point, n has to be MATCH_NO, so we don't have to worry about
1498 re-matching a block label. From what we've got so far, try
1499 matching an assignment. */
1500
1501 *if_type = ST_SIMPLE_IF;
1502
1503 m = gfc_match_assignment ();
1504 if (m == MATCH_YES)
1505 goto got_match;
1506
1507 gfc_free_expr (expr);
1508 gfc_undo_symbols ();
1509 gfc_current_locus = old_loc;
1510
1511 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1512 assignment was found. For MATCH_NO, continue to call the various
1513 matchers. */
1514 if (m == MATCH_ERROR)
1515 return MATCH_ERROR;
1516
1517 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
1518
1519 m = gfc_match_pointer_assignment ();
1520 if (m == MATCH_YES)
1521 goto got_match;
1522
1523 gfc_free_expr (expr);
1524 gfc_undo_symbols ();
1525 gfc_current_locus = old_loc;
1526
1527 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
1528
1529 /* Look at the next keyword to see which matcher to call. Matching
1530 the keyword doesn't affect the symbol table, so we don't have to
1531 restore between tries. */
1532
1533 #define match(string, subr, statement) \
1534 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1535
1536 gfc_clear_error ();
1537
1538 match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1539 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1540 match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1541 match ("call", gfc_match_call, ST_CALL)
1542 match ("close", gfc_match_close, ST_CLOSE)
1543 match ("continue", gfc_match_continue, ST_CONTINUE)
1544 match ("cycle", gfc_match_cycle, ST_CYCLE)
1545 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1546 match ("end file", gfc_match_endfile, ST_END_FILE)
1547 match ("exit", gfc_match_exit, ST_EXIT)
1548 match ("flush", gfc_match_flush, ST_FLUSH)
1549 match ("forall", match_simple_forall, ST_FORALL)
1550 match ("go to", gfc_match_goto, ST_GOTO)
1551 match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1552 match ("inquire", gfc_match_inquire, ST_INQUIRE)
1553 match ("nullify", gfc_match_nullify, ST_NULLIFY)
1554 match ("open", gfc_match_open, ST_OPEN)
1555 match ("pause", gfc_match_pause, ST_NONE)
1556 match ("print", gfc_match_print, ST_WRITE)
1557 match ("read", gfc_match_read, ST_READ)
1558 match ("return", gfc_match_return, ST_RETURN)
1559 match ("rewind", gfc_match_rewind, ST_REWIND)
1560 match ("stop", gfc_match_stop, ST_STOP)
1561 match ("wait", gfc_match_wait, ST_WAIT)
1562 match ("where", match_simple_where, ST_WHERE)
1563 match ("write", gfc_match_write, ST_WRITE)
1564
1565 /* The gfc_match_assignment() above may have returned a MATCH_NO
1566 where the assignment was to a named constant. Check that
1567 special case here. */
1568 m = gfc_match_assignment ();
1569 if (m == MATCH_NO)
1570 {
1571 gfc_error ("Cannot assign to a named constant at %C");
1572 gfc_free_expr (expr);
1573 gfc_undo_symbols ();
1574 gfc_current_locus = old_loc;
1575 return MATCH_ERROR;
1576 }
1577
1578 /* All else has failed, so give up. See if any of the matchers has
1579 stored an error message of some sort. */
1580 if (gfc_error_check () == 0)
1581 gfc_error ("Unclassifiable statement in IF-clause at %C");
1582
1583 gfc_free_expr (expr);
1584 return MATCH_ERROR;
1585
1586 got_match:
1587 if (m == MATCH_NO)
1588 gfc_error ("Syntax error in IF-clause at %C");
1589 if (m != MATCH_YES)
1590 {
1591 gfc_free_expr (expr);
1592 return MATCH_ERROR;
1593 }
1594
1595 /* At this point, we've matched the single IF and the action clause
1596 is in new_st. Rearrange things so that the IF statement appears
1597 in new_st. */
1598
1599 p = gfc_get_code ();
1600 p->next = gfc_get_code ();
1601 *p->next = new_st;
1602 p->next->loc = gfc_current_locus;
1603
1604 p->expr1 = expr;
1605 p->op = EXEC_IF;
1606
1607 gfc_clear_new_st ();
1608
1609 new_st.op = EXEC_IF;
1610 new_st.block = p;
1611
1612 return MATCH_YES;
1613 }
1614
1615 #undef match
1616
1617
1618 /* Match an ELSE statement. */
1619
1620 match
1621 gfc_match_else (void)
1622 {
1623 char name[GFC_MAX_SYMBOL_LEN + 1];
1624
1625 if (gfc_match_eos () == MATCH_YES)
1626 return MATCH_YES;
1627
1628 if (gfc_match_name (name) != MATCH_YES
1629 || gfc_current_block () == NULL
1630 || gfc_match_eos () != MATCH_YES)
1631 {
1632 gfc_error ("Unexpected junk after ELSE statement at %C");
1633 return MATCH_ERROR;
1634 }
1635
1636 if (strcmp (name, gfc_current_block ()->name) != 0)
1637 {
1638 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1639 name, gfc_current_block ()->name);
1640 return MATCH_ERROR;
1641 }
1642
1643 return MATCH_YES;
1644 }
1645
1646
1647 /* Match an ELSE IF statement. */
1648
1649 match
1650 gfc_match_elseif (void)
1651 {
1652 char name[GFC_MAX_SYMBOL_LEN + 1];
1653 gfc_expr *expr;
1654 match m;
1655
1656 m = gfc_match (" ( %e ) then", &expr);
1657 if (m != MATCH_YES)
1658 return m;
1659
1660 if (gfc_match_eos () == MATCH_YES)
1661 goto done;
1662
1663 if (gfc_match_name (name) != MATCH_YES
1664 || gfc_current_block () == NULL
1665 || gfc_match_eos () != MATCH_YES)
1666 {
1667 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1668 goto cleanup;
1669 }
1670
1671 if (strcmp (name, gfc_current_block ()->name) != 0)
1672 {
1673 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1674 name, gfc_current_block ()->name);
1675 goto cleanup;
1676 }
1677
1678 done:
1679 new_st.op = EXEC_IF;
1680 new_st.expr1 = expr;
1681 return MATCH_YES;
1682
1683 cleanup:
1684 gfc_free_expr (expr);
1685 return MATCH_ERROR;
1686 }
1687
1688
1689 /* Free a gfc_iterator structure. */
1690
1691 void
1692 gfc_free_iterator (gfc_iterator *iter, int flag)
1693 {
1694
1695 if (iter == NULL)
1696 return;
1697
1698 gfc_free_expr (iter->var);
1699 gfc_free_expr (iter->start);
1700 gfc_free_expr (iter->end);
1701 gfc_free_expr (iter->step);
1702
1703 if (flag)
1704 gfc_free (iter);
1705 }
1706
1707
1708 /* Match a DO statement. */
1709
1710 match
1711 gfc_match_do (void)
1712 {
1713 gfc_iterator iter, *ip;
1714 locus old_loc;
1715 gfc_st_label *label;
1716 match m;
1717
1718 old_loc = gfc_current_locus;
1719
1720 label = NULL;
1721 iter.var = iter.start = iter.end = iter.step = NULL;
1722
1723 m = gfc_match_label ();
1724 if (m == MATCH_ERROR)
1725 return m;
1726
1727 if (gfc_match (" do") != MATCH_YES)
1728 return MATCH_NO;
1729
1730 m = gfc_match_st_label (&label);
1731 if (m == MATCH_ERROR)
1732 goto cleanup;
1733
1734 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
1735
1736 if (gfc_match_eos () == MATCH_YES)
1737 {
1738 iter.end = gfc_logical_expr (1, NULL);
1739 new_st.op = EXEC_DO_WHILE;
1740 goto done;
1741 }
1742
1743 /* Match an optional comma, if no comma is found, a space is obligatory. */
1744 if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
1745 return MATCH_NO;
1746
1747 /* Check for balanced parens. */
1748
1749 if (gfc_match_parens () == MATCH_ERROR)
1750 return MATCH_ERROR;
1751
1752 /* See if we have a DO WHILE. */
1753 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1754 {
1755 new_st.op = EXEC_DO_WHILE;
1756 goto done;
1757 }
1758
1759 /* The abortive DO WHILE may have done something to the symbol
1760 table, so we start over. */
1761 gfc_undo_symbols ();
1762 gfc_current_locus = old_loc;
1763
1764 gfc_match_label (); /* This won't error. */
1765 gfc_match (" do "); /* This will work. */
1766
1767 gfc_match_st_label (&label); /* Can't error out. */
1768 gfc_match_char (','); /* Optional comma. */
1769
1770 m = gfc_match_iterator (&iter, 0);
1771 if (m == MATCH_NO)
1772 return MATCH_NO;
1773 if (m == MATCH_ERROR)
1774 goto cleanup;
1775
1776 iter.var->symtree->n.sym->attr.implied_index = 0;
1777 gfc_check_do_variable (iter.var->symtree);
1778
1779 if (gfc_match_eos () != MATCH_YES)
1780 {
1781 gfc_syntax_error (ST_DO);
1782 goto cleanup;
1783 }
1784
1785 new_st.op = EXEC_DO;
1786
1787 done:
1788 if (label != NULL
1789 && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1790 goto cleanup;
1791
1792 new_st.label1 = label;
1793
1794 if (new_st.op == EXEC_DO_WHILE)
1795 new_st.expr1 = iter.end;
1796 else
1797 {
1798 new_st.ext.iterator = ip = gfc_get_iterator ();
1799 *ip = iter;
1800 }
1801
1802 return MATCH_YES;
1803
1804 cleanup:
1805 gfc_free_iterator (&iter, 0);
1806
1807 return MATCH_ERROR;
1808 }
1809
1810
1811 /* Match an EXIT or CYCLE statement. */
1812
1813 static match
1814 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1815 {
1816 gfc_state_data *p, *o;
1817 gfc_symbol *sym;
1818 match m;
1819
1820 if (gfc_match_eos () == MATCH_YES)
1821 sym = NULL;
1822 else
1823 {
1824 m = gfc_match ("% %s%t", &sym);
1825 if (m == MATCH_ERROR)
1826 return MATCH_ERROR;
1827 if (m == MATCH_NO)
1828 {
1829 gfc_syntax_error (st);
1830 return MATCH_ERROR;
1831 }
1832
1833 if (sym->attr.flavor != FL_LABEL)
1834 {
1835 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1836 sym->name, gfc_ascii_statement (st));
1837 return MATCH_ERROR;
1838 }
1839 }
1840
1841 /* Find the loop mentioned specified by the label (or lack of a label). */
1842 for (o = NULL, p = gfc_state_stack; p; p = p->previous)
1843 if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1844 break;
1845 else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
1846 o = p;
1847
1848 if (p == NULL)
1849 {
1850 if (sym == NULL)
1851 gfc_error ("%s statement at %C is not within a loop",
1852 gfc_ascii_statement (st));
1853 else
1854 gfc_error ("%s statement at %C is not within loop '%s'",
1855 gfc_ascii_statement (st), sym->name);
1856
1857 return MATCH_ERROR;
1858 }
1859
1860 if (o != NULL)
1861 {
1862 gfc_error ("%s statement at %C leaving OpenMP structured block",
1863 gfc_ascii_statement (st));
1864 return MATCH_ERROR;
1865 }
1866 else if (st == ST_EXIT
1867 && p->previous != NULL
1868 && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
1869 && (p->previous->head->op == EXEC_OMP_DO
1870 || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
1871 {
1872 gcc_assert (p->previous->head->next != NULL);
1873 gcc_assert (p->previous->head->next->op == EXEC_DO
1874 || p->previous->head->next->op == EXEC_DO_WHILE);
1875 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1876 return MATCH_ERROR;
1877 }
1878
1879 /* Save the first statement in the loop - needed by the backend. */
1880 new_st.ext.whichloop = p->head;
1881
1882 new_st.op = op;
1883
1884 return MATCH_YES;
1885 }
1886
1887
1888 /* Match the EXIT statement. */
1889
1890 match
1891 gfc_match_exit (void)
1892 {
1893 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1894 }
1895
1896
1897 /* Match the CYCLE statement. */
1898
1899 match
1900 gfc_match_cycle (void)
1901 {
1902 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1903 }
1904
1905
1906 /* Match a number or character constant after a STOP or PAUSE statement. */
1907
1908 static match
1909 gfc_match_stopcode (gfc_statement st)
1910 {
1911 int stop_code;
1912 gfc_expr *e;
1913 match m;
1914 int cnt;
1915
1916 stop_code = -1;
1917 e = NULL;
1918
1919 if (gfc_match_eos () != MATCH_YES)
1920 {
1921 m = gfc_match_small_literal_int (&stop_code, &cnt);
1922 if (m == MATCH_ERROR)
1923 goto cleanup;
1924
1925 if (m == MATCH_YES && cnt > 5)
1926 {
1927 gfc_error ("Too many digits in STOP code at %C");
1928 goto cleanup;
1929 }
1930
1931 if (m == MATCH_NO)
1932 {
1933 /* Try a character constant. */
1934 m = gfc_match_expr (&e);
1935 if (m == MATCH_ERROR)
1936 goto cleanup;
1937 if (m == MATCH_NO)
1938 goto syntax;
1939 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1940 goto syntax;
1941 }
1942
1943 if (gfc_match_eos () != MATCH_YES)
1944 goto syntax;
1945 }
1946
1947 if (gfc_pure (NULL))
1948 {
1949 gfc_error ("%s statement not allowed in PURE procedure at %C",
1950 gfc_ascii_statement (st));
1951 goto cleanup;
1952 }
1953
1954 new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1955 new_st.expr1 = e;
1956 new_st.ext.stop_code = stop_code;
1957
1958 return MATCH_YES;
1959
1960 syntax:
1961 gfc_syntax_error (st);
1962
1963 cleanup:
1964
1965 gfc_free_expr (e);
1966 return MATCH_ERROR;
1967 }
1968
1969
1970 /* Match the (deprecated) PAUSE statement. */
1971
1972 match
1973 gfc_match_pause (void)
1974 {
1975 match m;
1976
1977 m = gfc_match_stopcode (ST_PAUSE);
1978 if (m == MATCH_YES)
1979 {
1980 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
1981 " at %C")
1982 == FAILURE)
1983 m = MATCH_ERROR;
1984 }
1985 return m;
1986 }
1987
1988
1989 /* Match the STOP statement. */
1990
1991 match
1992 gfc_match_stop (void)
1993 {
1994 return gfc_match_stopcode (ST_STOP);
1995 }
1996
1997
1998 /* Match a CONTINUE statement. */
1999
2000 match
2001 gfc_match_continue (void)
2002 {
2003 if (gfc_match_eos () != MATCH_YES)
2004 {
2005 gfc_syntax_error (ST_CONTINUE);
2006 return MATCH_ERROR;
2007 }
2008
2009 new_st.op = EXEC_CONTINUE;
2010 return MATCH_YES;
2011 }
2012
2013
2014 /* Match the (deprecated) ASSIGN statement. */
2015
2016 match
2017 gfc_match_assign (void)
2018 {
2019 gfc_expr *expr;
2020 gfc_st_label *label;
2021
2022 if (gfc_match (" %l", &label) == MATCH_YES)
2023 {
2024 if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
2025 return MATCH_ERROR;
2026 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
2027 {
2028 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
2029 "statement at %C")
2030 == FAILURE)
2031 return MATCH_ERROR;
2032
2033 expr->symtree->n.sym->attr.assign = 1;
2034
2035 new_st.op = EXEC_LABEL_ASSIGN;
2036 new_st.label1 = label;
2037 new_st.expr1 = expr;
2038 return MATCH_YES;
2039 }
2040 }
2041 return MATCH_NO;
2042 }
2043
2044
2045 /* Match the GO TO statement. As a computed GOTO statement is
2046 matched, it is transformed into an equivalent SELECT block. No
2047 tree is necessary, and the resulting jumps-to-jumps are
2048 specifically optimized away by the back end. */
2049
2050 match
2051 gfc_match_goto (void)
2052 {
2053 gfc_code *head, *tail;
2054 gfc_expr *expr;
2055 gfc_case *cp;
2056 gfc_st_label *label;
2057 int i;
2058 match m;
2059
2060 if (gfc_match (" %l%t", &label) == MATCH_YES)
2061 {
2062 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2063 return MATCH_ERROR;
2064
2065 new_st.op = EXEC_GOTO;
2066 new_st.label1 = label;
2067 return MATCH_YES;
2068 }
2069
2070 /* The assigned GO TO statement. */
2071
2072 if (gfc_match_variable (&expr, 0) == MATCH_YES)
2073 {
2074 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
2075 "statement at %C")
2076 == FAILURE)
2077 return MATCH_ERROR;
2078
2079 new_st.op = EXEC_GOTO;
2080 new_st.expr1 = expr;
2081
2082 if (gfc_match_eos () == MATCH_YES)
2083 return MATCH_YES;
2084
2085 /* Match label list. */
2086 gfc_match_char (',');
2087 if (gfc_match_char ('(') != MATCH_YES)
2088 {
2089 gfc_syntax_error (ST_GOTO);
2090 return MATCH_ERROR;
2091 }
2092 head = tail = NULL;
2093
2094 do
2095 {
2096 m = gfc_match_st_label (&label);
2097 if (m != MATCH_YES)
2098 goto syntax;
2099
2100 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2101 goto cleanup;
2102
2103 if (head == NULL)
2104 head = tail = gfc_get_code ();
2105 else
2106 {
2107 tail->block = gfc_get_code ();
2108 tail = tail->block;
2109 }
2110
2111 tail->label1 = label;
2112 tail->op = EXEC_GOTO;
2113 }
2114 while (gfc_match_char (',') == MATCH_YES);
2115
2116 if (gfc_match (")%t") != MATCH_YES)
2117 goto syntax;
2118
2119 if (head == NULL)
2120 {
2121 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2122 goto syntax;
2123 }
2124 new_st.block = head;
2125
2126 return MATCH_YES;
2127 }
2128
2129 /* Last chance is a computed GO TO statement. */
2130 if (gfc_match_char ('(') != MATCH_YES)
2131 {
2132 gfc_syntax_error (ST_GOTO);
2133 return MATCH_ERROR;
2134 }
2135
2136 head = tail = NULL;
2137 i = 1;
2138
2139 do
2140 {
2141 m = gfc_match_st_label (&label);
2142 if (m != MATCH_YES)
2143 goto syntax;
2144
2145 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2146 goto cleanup;
2147
2148 if (head == NULL)
2149 head = tail = gfc_get_code ();
2150 else
2151 {
2152 tail->block = gfc_get_code ();
2153 tail = tail->block;
2154 }
2155
2156 cp = gfc_get_case ();
2157 cp->low = cp->high = gfc_int_expr (i++);
2158
2159 tail->op = EXEC_SELECT;
2160 tail->ext.case_list = cp;
2161
2162 tail->next = gfc_get_code ();
2163 tail->next->op = EXEC_GOTO;
2164 tail->next->label1 = label;
2165 }
2166 while (gfc_match_char (',') == MATCH_YES);
2167
2168 if (gfc_match_char (')') != MATCH_YES)
2169 goto syntax;
2170
2171 if (head == NULL)
2172 {
2173 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2174 goto syntax;
2175 }
2176
2177 /* Get the rest of the statement. */
2178 gfc_match_char (',');
2179
2180 if (gfc_match (" %e%t", &expr) != MATCH_YES)
2181 goto syntax;
2182
2183 /* At this point, a computed GOTO has been fully matched and an
2184 equivalent SELECT statement constructed. */
2185
2186 new_st.op = EXEC_SELECT;
2187 new_st.expr1 = NULL;
2188
2189 /* Hack: For a "real" SELECT, the expression is in expr. We put
2190 it in expr2 so we can distinguish then and produce the correct
2191 diagnostics. */
2192 new_st.expr2 = expr;
2193 new_st.block = head;
2194 return MATCH_YES;
2195
2196 syntax:
2197 gfc_syntax_error (ST_GOTO);
2198 cleanup:
2199 gfc_free_statements (head);
2200 return MATCH_ERROR;
2201 }
2202
2203
2204 /* Frees a list of gfc_alloc structures. */
2205
2206 void
2207 gfc_free_alloc_list (gfc_alloc *p)
2208 {
2209 gfc_alloc *q;
2210
2211 for (; p; p = q)
2212 {
2213 q = p->next;
2214 gfc_free_expr (p->expr);
2215 gfc_free (p);
2216 }
2217 }
2218
2219
2220 /* Match an ALLOCATE statement. */
2221
2222 match
2223 gfc_match_allocate (void)
2224 {
2225 gfc_alloc *head, *tail;
2226 gfc_expr *stat, *errmsg, *tmp;
2227 match m;
2228 bool saw_stat, saw_errmsg;
2229
2230 head = tail = NULL;
2231 stat = errmsg = tmp = NULL;
2232 saw_stat = saw_errmsg = false;
2233
2234 if (gfc_match_char ('(') != MATCH_YES)
2235 goto syntax;
2236
2237 for (;;)
2238 {
2239 if (head == NULL)
2240 head = tail = gfc_get_alloc ();
2241 else
2242 {
2243 tail->next = gfc_get_alloc ();
2244 tail = tail->next;
2245 }
2246
2247 m = gfc_match_variable (&tail->expr, 0);
2248 if (m == MATCH_NO)
2249 goto syntax;
2250 if (m == MATCH_ERROR)
2251 goto cleanup;
2252
2253 if (gfc_check_do_variable (tail->expr->symtree))
2254 goto cleanup;
2255
2256 if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
2257 {
2258 gfc_error ("Bad allocate-object at %C for a PURE procedure");
2259 goto cleanup;
2260 }
2261
2262 if (tail->expr->ts.type == BT_DERIVED)
2263 tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
2264
2265 /* FIXME: disable the checking on derived types and arrays. */
2266 if (!(tail->expr->ref
2267 && (tail->expr->ref->type == REF_COMPONENT
2268 || tail->expr->ref->type == REF_ARRAY))
2269 && tail->expr->symtree->n.sym
2270 && !(tail->expr->symtree->n.sym->attr.allocatable
2271 || tail->expr->symtree->n.sym->attr.pointer
2272 || tail->expr->symtree->n.sym->attr.proc_pointer))
2273 {
2274 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2275 "or an allocatable variable");
2276 goto cleanup;
2277 }
2278
2279 if (gfc_match_char (',') != MATCH_YES)
2280 break;
2281
2282 alloc_opt_list:
2283
2284 m = gfc_match (" stat = %v", &tmp);
2285 if (m == MATCH_ERROR)
2286 goto cleanup;
2287 if (m == MATCH_YES)
2288 {
2289 if (saw_stat)
2290 {
2291 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2292 gfc_free_expr (tmp);
2293 goto cleanup;
2294 }
2295
2296 stat = tmp;
2297 saw_stat = true;
2298
2299 if (gfc_check_do_variable (stat->symtree))
2300 goto cleanup;
2301
2302 if (gfc_match_char (',') == MATCH_YES)
2303 goto alloc_opt_list;
2304 }
2305
2306 m = gfc_match (" errmsg = %v", &tmp);
2307 if (m == MATCH_ERROR)
2308 goto cleanup;
2309 if (m == MATCH_YES)
2310 {
2311 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
2312 &tmp->where) == FAILURE)
2313 goto cleanup;
2314
2315 if (saw_errmsg)
2316 {
2317 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2318 gfc_free_expr (tmp);
2319 goto cleanup;
2320 }
2321
2322 errmsg = tmp;
2323 saw_errmsg = true;
2324
2325 if (gfc_match_char (',') == MATCH_YES)
2326 goto alloc_opt_list;
2327 }
2328
2329 gfc_gobble_whitespace ();
2330
2331 if (gfc_peek_char () == ')')
2332 break;
2333 }
2334
2335
2336 if (gfc_match (" )%t") != MATCH_YES)
2337 goto syntax;
2338
2339 new_st.op = EXEC_ALLOCATE;
2340 new_st.expr1 = stat;
2341 new_st.expr2 = errmsg;
2342 new_st.ext.alloc_list = head;
2343
2344 return MATCH_YES;
2345
2346 syntax:
2347 gfc_syntax_error (ST_ALLOCATE);
2348
2349 cleanup:
2350 gfc_free_expr (errmsg);
2351 gfc_free_expr (stat);
2352 gfc_free_alloc_list (head);
2353 return MATCH_ERROR;
2354 }
2355
2356
2357 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
2358 a set of pointer assignments to intrinsic NULL(). */
2359
2360 match
2361 gfc_match_nullify (void)
2362 {
2363 gfc_code *tail;
2364 gfc_expr *e, *p;
2365 match m;
2366
2367 tail = NULL;
2368
2369 if (gfc_match_char ('(') != MATCH_YES)
2370 goto syntax;
2371
2372 for (;;)
2373 {
2374 m = gfc_match_variable (&p, 0);
2375 if (m == MATCH_ERROR)
2376 goto cleanup;
2377 if (m == MATCH_NO)
2378 goto syntax;
2379
2380 if (gfc_check_do_variable (p->symtree))
2381 goto cleanup;
2382
2383 if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
2384 {
2385 gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
2386 goto cleanup;
2387 }
2388
2389 /* build ' => NULL() '. */
2390 e = gfc_get_expr ();
2391 e->where = gfc_current_locus;
2392 e->expr_type = EXPR_NULL;
2393 e->ts.type = BT_UNKNOWN;
2394
2395 /* Chain to list. */
2396 if (tail == NULL)
2397 tail = &new_st;
2398 else
2399 {
2400 tail->next = gfc_get_code ();
2401 tail = tail->next;
2402 }
2403
2404 tail->op = EXEC_POINTER_ASSIGN;
2405 tail->expr1 = p;
2406 tail->expr2 = e;
2407
2408 if (gfc_match (" )%t") == MATCH_YES)
2409 break;
2410 if (gfc_match_char (',') != MATCH_YES)
2411 goto syntax;
2412 }
2413
2414 return MATCH_YES;
2415
2416 syntax:
2417 gfc_syntax_error (ST_NULLIFY);
2418
2419 cleanup:
2420 gfc_free_statements (new_st.next);
2421 new_st.next = NULL;
2422 gfc_free_expr (new_st.expr1);
2423 new_st.expr1 = NULL;
2424 gfc_free_expr (new_st.expr2);
2425 new_st.expr2 = NULL;
2426 return MATCH_ERROR;
2427 }
2428
2429
2430 /* Match a DEALLOCATE statement. */
2431
2432 match
2433 gfc_match_deallocate (void)
2434 {
2435 gfc_alloc *head, *tail;
2436 gfc_expr *stat, *errmsg, *tmp;
2437 match m;
2438 bool saw_stat, saw_errmsg;
2439
2440 head = tail = NULL;
2441 stat = errmsg = tmp = NULL;
2442 saw_stat = saw_errmsg = false;
2443
2444 if (gfc_match_char ('(') != MATCH_YES)
2445 goto syntax;
2446
2447 for (;;)
2448 {
2449 if (head == NULL)
2450 head = tail = gfc_get_alloc ();
2451 else
2452 {
2453 tail->next = gfc_get_alloc ();
2454 tail = tail->next;
2455 }
2456
2457 m = gfc_match_variable (&tail->expr, 0);
2458 if (m == MATCH_ERROR)
2459 goto cleanup;
2460 if (m == MATCH_NO)
2461 goto syntax;
2462
2463 if (gfc_check_do_variable (tail->expr->symtree))
2464 goto cleanup;
2465
2466 if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
2467 {
2468 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
2469 goto cleanup;
2470 }
2471
2472 /* FIXME: disable the checking on derived types. */
2473 if (!(tail->expr->ref
2474 && (tail->expr->ref->type == REF_COMPONENT
2475 || tail->expr->ref->type == REF_ARRAY))
2476 && tail->expr->symtree->n.sym
2477 && !(tail->expr->symtree->n.sym->attr.allocatable
2478 || tail->expr->symtree->n.sym->attr.pointer
2479 || tail->expr->symtree->n.sym->attr.proc_pointer))
2480 {
2481 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2482 "or an allocatable variable");
2483 goto cleanup;
2484 }
2485
2486 if (gfc_match_char (',') != MATCH_YES)
2487 break;
2488
2489 dealloc_opt_list:
2490
2491 m = gfc_match (" stat = %v", &tmp);
2492 if (m == MATCH_ERROR)
2493 goto cleanup;
2494 if (m == MATCH_YES)
2495 {
2496 if (saw_stat)
2497 {
2498 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2499 gfc_free_expr (tmp);
2500 goto cleanup;
2501 }
2502
2503 stat = tmp;
2504 saw_stat = true;
2505
2506 if (gfc_check_do_variable (stat->symtree))
2507 goto cleanup;
2508
2509 if (gfc_match_char (',') == MATCH_YES)
2510 goto dealloc_opt_list;
2511 }
2512
2513 m = gfc_match (" errmsg = %v", &tmp);
2514 if (m == MATCH_ERROR)
2515 goto cleanup;
2516 if (m == MATCH_YES)
2517 {
2518 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
2519 &tmp->where) == FAILURE)
2520 goto cleanup;
2521
2522 if (saw_errmsg)
2523 {
2524 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2525 gfc_free_expr (tmp);
2526 goto cleanup;
2527 }
2528
2529 errmsg = tmp;
2530 saw_errmsg = true;
2531
2532 if (gfc_match_char (',') == MATCH_YES)
2533 goto dealloc_opt_list;
2534 }
2535
2536 gfc_gobble_whitespace ();
2537
2538 if (gfc_peek_char () == ')')
2539 break;
2540 }
2541
2542 if (gfc_match (" )%t") != MATCH_YES)
2543 goto syntax;
2544
2545 new_st.op = EXEC_DEALLOCATE;
2546 new_st.expr1 = stat;
2547 new_st.expr2 = errmsg;
2548 new_st.ext.alloc_list = head;
2549
2550 return MATCH_YES;
2551
2552 syntax:
2553 gfc_syntax_error (ST_DEALLOCATE);
2554
2555 cleanup:
2556 gfc_free_expr (errmsg);
2557 gfc_free_expr (stat);
2558 gfc_free_alloc_list (head);
2559 return MATCH_ERROR;
2560 }
2561
2562
2563 /* Match a RETURN statement. */
2564
2565 match
2566 gfc_match_return (void)
2567 {
2568 gfc_expr *e;
2569 match m;
2570 gfc_compile_state s;
2571
2572 e = NULL;
2573 if (gfc_match_eos () == MATCH_YES)
2574 goto done;
2575
2576 if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
2577 {
2578 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2579 "a SUBROUTINE");
2580 goto cleanup;
2581 }
2582
2583 if (gfc_current_form == FORM_FREE)
2584 {
2585 /* The following are valid, so we can't require a blank after the
2586 RETURN keyword:
2587 return+1
2588 return(1) */
2589 char c = gfc_peek_ascii_char ();
2590 if (ISALPHA (c) || ISDIGIT (c))
2591 return MATCH_NO;
2592 }
2593
2594 m = gfc_match (" %e%t", &e);
2595 if (m == MATCH_YES)
2596 goto done;
2597 if (m == MATCH_ERROR)
2598 goto cleanup;
2599
2600 gfc_syntax_error (ST_RETURN);
2601
2602 cleanup:
2603 gfc_free_expr (e);
2604 return MATCH_ERROR;
2605
2606 done:
2607 gfc_enclosing_unit (&s);
2608 if (s == COMP_PROGRAM
2609 && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
2610 "main program at %C") == FAILURE)
2611 return MATCH_ERROR;
2612
2613 new_st.op = EXEC_RETURN;
2614 new_st.expr1 = e;
2615
2616 return MATCH_YES;
2617 }
2618
2619
2620 /* Match the call of a type-bound procedure, if CALL%var has already been
2621 matched and var found to be a derived-type variable. */
2622
2623 static match
2624 match_typebound_call (gfc_symtree* varst)
2625 {
2626 gfc_symbol* var;
2627 gfc_expr* base;
2628 match m;
2629
2630 var = varst->n.sym;
2631
2632 base = gfc_get_expr ();
2633 base->expr_type = EXPR_VARIABLE;
2634 base->symtree = varst;
2635 base->where = gfc_current_locus;
2636 gfc_set_sym_referenced (varst->n.sym);
2637
2638 m = gfc_match_varspec (base, 0, true, true);
2639 if (m == MATCH_NO)
2640 gfc_error ("Expected component reference at %C");
2641 if (m != MATCH_YES)
2642 return MATCH_ERROR;
2643
2644 if (gfc_match_eos () != MATCH_YES)
2645 {
2646 gfc_error ("Junk after CALL at %C");
2647 return MATCH_ERROR;
2648 }
2649
2650 if (base->expr_type == EXPR_COMPCALL)
2651 new_st.op = EXEC_COMPCALL;
2652 else if (base->expr_type == EXPR_PPC)
2653 new_st.op = EXEC_CALL_PPC;
2654 else
2655 {
2656 gfc_error ("Expected type-bound procedure or procedure pointer component "
2657 "at %C");
2658 return MATCH_ERROR;
2659 }
2660 new_st.expr1 = base;
2661
2662 return MATCH_YES;
2663 }
2664
2665
2666 /* Match a CALL statement. The tricky part here are possible
2667 alternate return specifiers. We handle these by having all
2668 "subroutines" actually return an integer via a register that gives
2669 the return number. If the call specifies alternate returns, we
2670 generate code for a SELECT statement whose case clauses contain
2671 GOTOs to the various labels. */
2672
2673 match
2674 gfc_match_call (void)
2675 {
2676 char name[GFC_MAX_SYMBOL_LEN + 1];
2677 gfc_actual_arglist *a, *arglist;
2678 gfc_case *new_case;
2679 gfc_symbol *sym;
2680 gfc_symtree *st;
2681 gfc_code *c;
2682 match m;
2683 int i;
2684
2685 arglist = NULL;
2686
2687 m = gfc_match ("% %n", name);
2688 if (m == MATCH_NO)
2689 goto syntax;
2690 if (m != MATCH_YES)
2691 return m;
2692
2693 if (gfc_get_ha_sym_tree (name, &st))
2694 return MATCH_ERROR;
2695
2696 sym = st->n.sym;
2697
2698 /* If this is a variable of derived-type, it probably starts a type-bound
2699 procedure call. */
2700 if (sym->attr.flavor != FL_PROCEDURE && sym->ts.type == BT_DERIVED)
2701 return match_typebound_call (st);
2702
2703 /* If it does not seem to be callable (include functions so that the
2704 right association is made. They are thrown out in resolution.)
2705 ... */
2706 if (!sym->attr.generic
2707 && !sym->attr.subroutine
2708 && !sym->attr.function)
2709 {
2710 if (!(sym->attr.external && !sym->attr.referenced))
2711 {
2712 /* ...create a symbol in this scope... */
2713 if (sym->ns != gfc_current_ns
2714 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
2715 return MATCH_ERROR;
2716
2717 if (sym != st->n.sym)
2718 sym = st->n.sym;
2719 }
2720
2721 /* ...and then to try to make the symbol into a subroutine. */
2722 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2723 return MATCH_ERROR;
2724 }
2725
2726 gfc_set_sym_referenced (sym);
2727
2728 if (gfc_match_eos () != MATCH_YES)
2729 {
2730 m = gfc_match_actual_arglist (1, &arglist);
2731 if (m == MATCH_NO)
2732 goto syntax;
2733 if (m == MATCH_ERROR)
2734 goto cleanup;
2735
2736 if (gfc_match_eos () != MATCH_YES)
2737 goto syntax;
2738 }
2739
2740 /* If any alternate return labels were found, construct a SELECT
2741 statement that will jump to the right place. */
2742
2743 i = 0;
2744 for (a = arglist; a; a = a->next)
2745 if (a->expr == NULL)
2746 i = 1;
2747
2748 if (i)
2749 {
2750 gfc_symtree *select_st;
2751 gfc_symbol *select_sym;
2752 char name[GFC_MAX_SYMBOL_LEN + 1];
2753
2754 new_st.next = c = gfc_get_code ();
2755 c->op = EXEC_SELECT;
2756 sprintf (name, "_result_%s", sym->name);
2757 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
2758
2759 select_sym = select_st->n.sym;
2760 select_sym->ts.type = BT_INTEGER;
2761 select_sym->ts.kind = gfc_default_integer_kind;
2762 gfc_set_sym_referenced (select_sym);
2763 c->expr1 = gfc_get_expr ();
2764 c->expr1->expr_type = EXPR_VARIABLE;
2765 c->expr1->symtree = select_st;
2766 c->expr1->ts = select_sym->ts;
2767 c->expr1->where = gfc_current_locus;
2768
2769 i = 0;
2770 for (a = arglist; a; a = a->next)
2771 {
2772 if (a->expr != NULL)
2773 continue;
2774
2775 if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2776 continue;
2777
2778 i++;
2779
2780 c->block = gfc_get_code ();
2781 c = c->block;
2782 c->op = EXEC_SELECT;
2783
2784 new_case = gfc_get_case ();
2785 new_case->high = new_case->low = gfc_int_expr (i);
2786 c->ext.case_list = new_case;
2787
2788 c->next = gfc_get_code ();
2789 c->next->op = EXEC_GOTO;
2790 c->next->label1 = a->label;
2791 }
2792 }
2793
2794 new_st.op = EXEC_CALL;
2795 new_st.symtree = st;
2796 new_st.ext.actual = arglist;
2797
2798 return MATCH_YES;
2799
2800 syntax:
2801 gfc_syntax_error (ST_CALL);
2802
2803 cleanup:
2804 gfc_free_actual_arglist (arglist);
2805 return MATCH_ERROR;
2806 }
2807
2808
2809 /* Given a name, return a pointer to the common head structure,
2810 creating it if it does not exist. If FROM_MODULE is nonzero, we
2811 mangle the name so that it doesn't interfere with commons defined
2812 in the using namespace.
2813 TODO: Add to global symbol tree. */
2814
2815 gfc_common_head *
2816 gfc_get_common (const char *name, int from_module)
2817 {
2818 gfc_symtree *st;
2819 static int serial = 0;
2820 char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
2821
2822 if (from_module)
2823 {
2824 /* A use associated common block is only needed to correctly layout
2825 the variables it contains. */
2826 snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2827 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2828 }
2829 else
2830 {
2831 st = gfc_find_symtree (gfc_current_ns->common_root, name);
2832
2833 if (st == NULL)
2834 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2835 }
2836
2837 if (st->n.common == NULL)
2838 {
2839 st->n.common = gfc_get_common_head ();
2840 st->n.common->where = gfc_current_locus;
2841 strcpy (st->n.common->name, name);
2842 }
2843
2844 return st->n.common;
2845 }
2846
2847
2848 /* Match a common block name. */
2849
2850 match match_common_name (char *name)
2851 {
2852 match m;
2853
2854 if (gfc_match_char ('/') == MATCH_NO)
2855 {
2856 name[0] = '\0';
2857 return MATCH_YES;
2858 }
2859
2860 if (gfc_match_char ('/') == MATCH_YES)
2861 {
2862 name[0] = '\0';
2863 return MATCH_YES;
2864 }
2865
2866 m = gfc_match_name (name);
2867
2868 if (m == MATCH_ERROR)
2869 return MATCH_ERROR;
2870 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2871 return MATCH_YES;
2872
2873 gfc_error ("Syntax error in common block name at %C");
2874 return MATCH_ERROR;
2875 }
2876
2877
2878 /* Match a COMMON statement. */
2879
2880 match
2881 gfc_match_common (void)
2882 {
2883 gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
2884 char name[GFC_MAX_SYMBOL_LEN + 1];
2885 gfc_common_head *t;
2886 gfc_array_spec *as;
2887 gfc_equiv *e1, *e2;
2888 match m;
2889 gfc_gsymbol *gsym;
2890
2891 old_blank_common = gfc_current_ns->blank_common.head;
2892 if (old_blank_common)
2893 {
2894 while (old_blank_common->common_next)
2895 old_blank_common = old_blank_common->common_next;
2896 }
2897
2898 as = NULL;
2899
2900 for (;;)
2901 {
2902 m = match_common_name (name);
2903 if (m == MATCH_ERROR)
2904 goto cleanup;
2905
2906 gsym = gfc_get_gsymbol (name);
2907 if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
2908 {
2909 gfc_error ("Symbol '%s' at %C is already an external symbol that "
2910 "is not COMMON", name);
2911 goto cleanup;
2912 }
2913
2914 if (gsym->type == GSYM_UNKNOWN)
2915 {
2916 gsym->type = GSYM_COMMON;
2917 gsym->where = gfc_current_locus;
2918 gsym->defined = 1;
2919 }
2920
2921 gsym->used = 1;
2922
2923 if (name[0] == '\0')
2924 {
2925 t = &gfc_current_ns->blank_common;
2926 if (t->head == NULL)
2927 t->where = gfc_current_locus;
2928 }
2929 else
2930 {
2931 t = gfc_get_common (name, 0);
2932 }
2933 head = &t->head;
2934
2935 if (*head == NULL)
2936 tail = NULL;
2937 else
2938 {
2939 tail = *head;
2940 while (tail->common_next)
2941 tail = tail->common_next;
2942 }
2943
2944 /* Grab the list of symbols. */
2945 for (;;)
2946 {
2947 m = gfc_match_symbol (&sym, 0);
2948 if (m == MATCH_ERROR)
2949 goto cleanup;
2950 if (m == MATCH_NO)
2951 goto syntax;
2952
2953 /* Store a ref to the common block for error checking. */
2954 sym->common_block = t;
2955
2956 /* See if we know the current common block is bind(c), and if
2957 so, then see if we can check if the symbol is (which it'll
2958 need to be). This can happen if the bind(c) attr stmt was
2959 applied to the common block, and the variable(s) already
2960 defined, before declaring the common block. */
2961 if (t->is_bind_c == 1)
2962 {
2963 if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
2964 {
2965 /* If we find an error, just print it and continue,
2966 cause it's just semantic, and we can see if there
2967 are more errors. */
2968 gfc_error_now ("Variable '%s' at %L in common block '%s' "
2969 "at %C must be declared with a C "
2970 "interoperable kind since common block "
2971 "'%s' is bind(c)",
2972 sym->name, &(sym->declared_at), t->name,
2973 t->name);
2974 }
2975
2976 if (sym->attr.is_bind_c == 1)
2977 gfc_error_now ("Variable '%s' in common block "
2978 "'%s' at %C can not be bind(c) since "
2979 "it is not global", sym->name, t->name);
2980 }
2981
2982 if (sym->attr.in_common)
2983 {
2984 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2985 sym->name);
2986 goto cleanup;
2987 }
2988
2989 if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
2990 || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
2991 {
2992 if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
2993 "can only be COMMON in "
2994 "BLOCK DATA", sym->name)
2995 == FAILURE)
2996 goto cleanup;
2997 }
2998
2999 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
3000 goto cleanup;
3001
3002 if (tail != NULL)
3003 tail->common_next = sym;
3004 else
3005 *head = sym;
3006
3007 tail = sym;
3008
3009 /* Deal with an optional array specification after the
3010 symbol name. */
3011 m = gfc_match_array_spec (&as);
3012 if (m == MATCH_ERROR)
3013 goto cleanup;
3014
3015 if (m == MATCH_YES)
3016 {
3017 if (as->type != AS_EXPLICIT)
3018 {
3019 gfc_error ("Array specification for symbol '%s' in COMMON "
3020 "at %C must be explicit", sym->name);
3021 goto cleanup;
3022 }
3023
3024 if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
3025 goto cleanup;
3026
3027 if (sym->attr.pointer)
3028 {
3029 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
3030 "POINTER array", sym->name);
3031 goto cleanup;
3032 }
3033
3034 sym->as = as;
3035 as = NULL;
3036
3037 }
3038
3039 sym->common_head = t;
3040
3041 /* Check to see if the symbol is already in an equivalence group.
3042 If it is, set the other members as being in common. */
3043 if (sym->attr.in_equivalence)
3044 {
3045 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
3046 {
3047 for (e2 = e1; e2; e2 = e2->eq)
3048 if (e2->expr->symtree->n.sym == sym)
3049 goto equiv_found;
3050
3051 continue;
3052
3053 equiv_found:
3054
3055 for (e2 = e1; e2; e2 = e2->eq)
3056 {
3057 other = e2->expr->symtree->n.sym;
3058 if (other->common_head
3059 && other->common_head != sym->common_head)
3060 {
3061 gfc_error ("Symbol '%s', in COMMON block '%s' at "
3062 "%C is being indirectly equivalenced to "
3063 "another COMMON block '%s'",
3064 sym->name, sym->common_head->name,
3065 other->common_head->name);
3066 goto cleanup;
3067 }
3068 other->attr.in_common = 1;
3069 other->common_head = t;
3070 }
3071 }
3072 }
3073
3074
3075 gfc_gobble_whitespace ();
3076 if (gfc_match_eos () == MATCH_YES)
3077 goto done;
3078 if (gfc_peek_ascii_char () == '/')
3079 break;
3080 if (gfc_match_char (',') != MATCH_YES)
3081 goto syntax;
3082 gfc_gobble_whitespace ();
3083 if (gfc_peek_ascii_char () == '/')
3084 break;
3085 }
3086 }
3087
3088 done:
3089 return MATCH_YES;
3090
3091 syntax:
3092 gfc_syntax_error (ST_COMMON);
3093
3094 cleanup:
3095 if (old_blank_common)
3096 old_blank_common->common_next = NULL;
3097 else
3098 gfc_current_ns->blank_common.head = NULL;
3099 gfc_free_array_spec (as);
3100 return MATCH_ERROR;
3101 }
3102
3103
3104 /* Match a BLOCK DATA program unit. */
3105
3106 match
3107 gfc_match_block_data (void)
3108 {
3109 char name[GFC_MAX_SYMBOL_LEN + 1];
3110 gfc_symbol *sym;
3111 match m;
3112
3113 if (gfc_match_eos () == MATCH_YES)
3114 {
3115 gfc_new_block = NULL;
3116 return MATCH_YES;
3117 }
3118
3119 m = gfc_match ("% %n%t", name);
3120 if (m != MATCH_YES)
3121 return MATCH_ERROR;
3122
3123 if (gfc_get_symbol (name, NULL, &sym))
3124 return MATCH_ERROR;
3125
3126 if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
3127 return MATCH_ERROR;
3128
3129 gfc_new_block = sym;
3130
3131 return MATCH_YES;
3132 }
3133
3134
3135 /* Free a namelist structure. */
3136
3137 void
3138 gfc_free_namelist (gfc_namelist *name)
3139 {
3140 gfc_namelist *n;
3141
3142 for (; name; name = n)
3143 {
3144 n = name->next;
3145 gfc_free (name);
3146 }
3147 }
3148
3149
3150 /* Match a NAMELIST statement. */
3151
3152 match
3153 gfc_match_namelist (void)
3154 {
3155 gfc_symbol *group_name, *sym;
3156 gfc_namelist *nl;
3157 match m, m2;
3158
3159 m = gfc_match (" / %s /", &group_name);
3160 if (m == MATCH_NO)
3161 goto syntax;
3162 if (m == MATCH_ERROR)
3163 goto error;
3164
3165 for (;;)
3166 {
3167 if (group_name->ts.type != BT_UNKNOWN)
3168 {
3169 gfc_error ("Namelist group name '%s' at %C already has a basic "
3170 "type of %s", group_name->name,
3171 gfc_typename (&group_name->ts));
3172 return MATCH_ERROR;
3173 }
3174
3175 if (group_name->attr.flavor == FL_NAMELIST
3176 && group_name->attr.use_assoc
3177 && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
3178 "at %C already is USE associated and can"
3179 "not be respecified.", group_name->name)
3180 == FAILURE)
3181 return MATCH_ERROR;
3182
3183 if (group_name->attr.flavor != FL_NAMELIST
3184 && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
3185 group_name->name, NULL) == FAILURE)
3186 return MATCH_ERROR;
3187
3188 for (;;)
3189 {
3190 m = gfc_match_symbol (&sym, 1);
3191 if (m == MATCH_NO)
3192 goto syntax;
3193 if (m == MATCH_ERROR)
3194 goto error;
3195
3196 if (sym->attr.in_namelist == 0
3197 && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
3198 goto error;
3199
3200 /* Use gfc_error_check here, rather than goto error, so that
3201 these are the only errors for the next two lines. */
3202 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
3203 {
3204 gfc_error ("Assumed size array '%s' in namelist '%s' at "
3205 "%C is not allowed", sym->name, group_name->name);
3206 gfc_error_check ();
3207 }
3208
3209 if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL)
3210 {
3211 gfc_error ("Assumed character length '%s' in namelist '%s' at "
3212 "%C is not allowed", sym->name, group_name->name);
3213 gfc_error_check ();
3214 }
3215
3216 nl = gfc_get_namelist ();
3217 nl->sym = sym;
3218 sym->refs++;
3219
3220 if (group_name->namelist == NULL)
3221 group_name->namelist = group_name->namelist_tail = nl;
3222 else
3223 {
3224 group_name->namelist_tail->next = nl;
3225 group_name->namelist_tail = nl;
3226 }
3227
3228 if (gfc_match_eos () == MATCH_YES)
3229 goto done;
3230
3231 m = gfc_match_char (',');
3232
3233 if (gfc_match_char ('/') == MATCH_YES)
3234 {
3235 m2 = gfc_match (" %s /", &group_name);
3236 if (m2 == MATCH_YES)
3237 break;
3238 if (m2 == MATCH_ERROR)
3239 goto error;
3240 goto syntax;
3241 }
3242
3243 if (m != MATCH_YES)
3244 goto syntax;
3245 }
3246 }
3247
3248 done:
3249 return MATCH_YES;
3250
3251 syntax:
3252 gfc_syntax_error (ST_NAMELIST);
3253
3254 error:
3255 return MATCH_ERROR;
3256 }
3257
3258
3259 /* Match a MODULE statement. */
3260
3261 match
3262 gfc_match_module (void)
3263 {
3264 match m;
3265
3266 m = gfc_match (" %s%t", &gfc_new_block);
3267 if (m != MATCH_YES)
3268 return m;
3269
3270 if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
3271 gfc_new_block->name, NULL) == FAILURE)
3272 return MATCH_ERROR;
3273
3274 return MATCH_YES;
3275 }
3276
3277
3278 /* Free equivalence sets and lists. Recursively is the easiest way to
3279 do this. */
3280
3281 void
3282 gfc_free_equiv (gfc_equiv *eq)
3283 {
3284 if (eq == NULL)
3285 return;
3286
3287 gfc_free_equiv (eq->eq);
3288 gfc_free_equiv (eq->next);
3289 gfc_free_expr (eq->expr);
3290 gfc_free (eq);
3291 }
3292
3293
3294 /* Match an EQUIVALENCE statement. */
3295
3296 match
3297 gfc_match_equivalence (void)
3298 {
3299 gfc_equiv *eq, *set, *tail;
3300 gfc_ref *ref;
3301 gfc_symbol *sym;
3302 match m;
3303 gfc_common_head *common_head = NULL;
3304 bool common_flag;
3305 int cnt;
3306
3307 tail = NULL;
3308
3309 for (;;)
3310 {
3311 eq = gfc_get_equiv ();
3312 if (tail == NULL)
3313 tail = eq;
3314
3315 eq->next = gfc_current_ns->equiv;
3316 gfc_current_ns->equiv = eq;
3317
3318 if (gfc_match_char ('(') != MATCH_YES)
3319 goto syntax;
3320
3321 set = eq;
3322 common_flag = FALSE;
3323 cnt = 0;
3324
3325 for (;;)
3326 {
3327 m = gfc_match_equiv_variable (&set->expr);
3328 if (m == MATCH_ERROR)
3329 goto cleanup;
3330 if (m == MATCH_NO)
3331 goto syntax;
3332
3333 /* count the number of objects. */
3334 cnt++;
3335
3336 if (gfc_match_char ('%') == MATCH_YES)
3337 {
3338 gfc_error ("Derived type component %C is not a "
3339 "permitted EQUIVALENCE member");
3340 goto cleanup;
3341 }
3342
3343 for (ref = set->expr->ref; ref; ref = ref->next)
3344 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3345 {
3346 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
3347 "be an array section");
3348 goto cleanup;
3349 }
3350
3351 sym = set->expr->symtree->n.sym;
3352
3353 if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
3354 goto cleanup;
3355
3356 if (sym->attr.in_common)
3357 {
3358 common_flag = TRUE;
3359 common_head = sym->common_head;
3360 }
3361
3362 if (gfc_match_char (')') == MATCH_YES)
3363 break;
3364
3365 if (gfc_match_char (',') != MATCH_YES)
3366 goto syntax;
3367
3368 set->eq = gfc_get_equiv ();
3369 set = set->eq;
3370 }
3371
3372 if (cnt < 2)
3373 {
3374 gfc_error ("EQUIVALENCE at %C requires two or more objects");
3375 goto cleanup;
3376 }
3377
3378 /* If one of the members of an equivalence is in common, then
3379 mark them all as being in common. Before doing this, check
3380 that members of the equivalence group are not in different
3381 common blocks. */
3382 if (common_flag)
3383 for (set = eq; set; set = set->eq)
3384 {
3385 sym = set->expr->symtree->n.sym;
3386 if (sym->common_head && sym->common_head != common_head)
3387 {
3388 gfc_error ("Attempt to indirectly overlap COMMON "
3389 "blocks %s and %s by EQUIVALENCE at %C",
3390 sym->common_head->name, common_head->name);
3391 goto cleanup;
3392 }
3393 sym->attr.in_common = 1;
3394 sym->common_head = common_head;
3395 }
3396
3397 if (gfc_match_eos () == MATCH_YES)
3398 break;
3399 if (gfc_match_char (',') != MATCH_YES)
3400 goto syntax;
3401 }
3402
3403 return MATCH_YES;
3404
3405 syntax:
3406 gfc_syntax_error (ST_EQUIVALENCE);
3407
3408 cleanup:
3409 eq = tail->next;
3410 tail->next = NULL;
3411
3412 gfc_free_equiv (gfc_current_ns->equiv);
3413 gfc_current_ns->equiv = eq;
3414
3415 return MATCH_ERROR;
3416 }
3417
3418
3419 /* Check that a statement function is not recursive. This is done by looking
3420 for the statement function symbol(sym) by looking recursively through its
3421 expression(e). If a reference to sym is found, true is returned.
3422 12.5.4 requires that any variable of function that is implicitly typed
3423 shall have that type confirmed by any subsequent type declaration. The
3424 implicit typing is conveniently done here. */
3425 static bool
3426 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
3427
3428 static bool
3429 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
3430 {
3431
3432 if (e == NULL)
3433 return false;
3434
3435 switch (e->expr_type)
3436 {
3437 case EXPR_FUNCTION:
3438 if (e->symtree == NULL)
3439 return false;
3440
3441 /* Check the name before testing for nested recursion! */
3442 if (sym->name == e->symtree->n.sym->name)
3443 return true;
3444
3445 /* Catch recursion via other statement functions. */
3446 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
3447 && e->symtree->n.sym->value
3448 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
3449 return true;
3450
3451 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3452 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3453
3454 break;
3455
3456 case EXPR_VARIABLE:
3457 if (e->symtree && sym->name == e->symtree->n.sym->name)
3458 return true;
3459
3460 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3461 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3462 break;
3463
3464 default:
3465 break;
3466 }
3467
3468 return false;
3469 }
3470
3471
3472 static bool
3473 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
3474 {
3475 return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
3476 }
3477
3478
3479 /* Match a statement function declaration. It is so easy to match
3480 non-statement function statements with a MATCH_ERROR as opposed to
3481 MATCH_NO that we suppress error message in most cases. */
3482
3483 match
3484 gfc_match_st_function (void)
3485 {
3486 gfc_error_buf old_error;
3487 gfc_symbol *sym;
3488 gfc_expr *expr;
3489 match m;
3490
3491 m = gfc_match_symbol (&sym, 0);
3492 if (m != MATCH_YES)
3493 return m;
3494
3495 gfc_push_error (&old_error);
3496
3497 if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
3498 sym->name, NULL) == FAILURE)
3499 goto undo_error;
3500
3501 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
3502 goto undo_error;
3503
3504 m = gfc_match (" = %e%t", &expr);
3505 if (m == MATCH_NO)
3506 goto undo_error;
3507
3508 gfc_free_error (&old_error);
3509 if (m == MATCH_ERROR)
3510 return m;
3511
3512 if (recursive_stmt_fcn (expr, sym))
3513 {
3514 gfc_error ("Statement function at %L is recursive", &expr->where);
3515 return MATCH_ERROR;
3516 }
3517
3518 sym->value = expr;
3519
3520 return MATCH_YES;
3521
3522 undo_error:
3523 gfc_pop_error (&old_error);
3524 return MATCH_NO;
3525 }
3526
3527
3528 /***************** SELECT CASE subroutines ******************/
3529
3530 /* Free a single case structure. */
3531
3532 static void
3533 free_case (gfc_case *p)
3534 {
3535 if (p->low == p->high)
3536 p->high = NULL;
3537 gfc_free_expr (p->low);
3538 gfc_free_expr (p->high);
3539 gfc_free (p);
3540 }
3541
3542
3543 /* Free a list of case structures. */
3544
3545 void
3546 gfc_free_case_list (gfc_case *p)
3547 {
3548 gfc_case *q;
3549
3550 for (; p; p = q)
3551 {
3552 q = p->next;
3553 free_case (p);
3554 }
3555 }
3556
3557
3558 /* Match a single case selector. */
3559
3560 static match
3561 match_case_selector (gfc_case **cp)
3562 {
3563 gfc_case *c;
3564 match m;
3565
3566 c = gfc_get_case ();
3567 c->where = gfc_current_locus;
3568
3569 if (gfc_match_char (':') == MATCH_YES)
3570 {
3571 m = gfc_match_init_expr (&c->high);
3572 if (m == MATCH_NO)
3573 goto need_expr;
3574 if (m == MATCH_ERROR)
3575 goto cleanup;
3576 }
3577 else
3578 {
3579 m = gfc_match_init_expr (&c->low);
3580 if (m == MATCH_ERROR)
3581 goto cleanup;
3582 if (m == MATCH_NO)
3583 goto need_expr;
3584
3585 /* If we're not looking at a ':' now, make a range out of a single
3586 target. Else get the upper bound for the case range. */
3587 if (gfc_match_char (':') != MATCH_YES)
3588 c->high = c->low;
3589 else
3590 {
3591 m = gfc_match_init_expr (&c->high);
3592 if (m == MATCH_ERROR)
3593 goto cleanup;
3594 /* MATCH_NO is fine. It's OK if nothing is there! */
3595 }
3596 }
3597
3598 *cp = c;
3599 return MATCH_YES;
3600
3601 need_expr:
3602 gfc_error ("Expected initialization expression in CASE at %C");
3603
3604 cleanup:
3605 free_case (c);
3606 return MATCH_ERROR;
3607 }
3608
3609
3610 /* Match the end of a case statement. */
3611
3612 static match
3613 match_case_eos (void)
3614 {
3615 char name[GFC_MAX_SYMBOL_LEN + 1];
3616 match m;
3617
3618 if (gfc_match_eos () == MATCH_YES)
3619 return MATCH_YES;
3620
3621 /* If the case construct doesn't have a case-construct-name, we
3622 should have matched the EOS. */
3623 if (!gfc_current_block ())
3624 {
3625 gfc_error ("Expected the name of the SELECT CASE construct at %C");
3626 return MATCH_ERROR;
3627 }
3628
3629 gfc_gobble_whitespace ();
3630
3631 m = gfc_match_name (name);
3632 if (m != MATCH_YES)
3633 return m;
3634
3635 if (strcmp (name, gfc_current_block ()->name) != 0)
3636 {
3637 gfc_error ("Expected case name of '%s' at %C",
3638 gfc_current_block ()->name);
3639 return MATCH_ERROR;
3640 }
3641
3642 return gfc_match_eos ();
3643 }
3644
3645
3646 /* Match a SELECT statement. */
3647
3648 match
3649 gfc_match_select (void)
3650 {
3651 gfc_expr *expr;
3652 match m;
3653
3654 m = gfc_match_label ();
3655 if (m == MATCH_ERROR)
3656 return m;
3657
3658 m = gfc_match (" select case ( %e )%t", &expr);
3659 if (m != MATCH_YES)
3660 return m;
3661
3662 new_st.op = EXEC_SELECT;
3663 new_st.expr1 = expr;
3664
3665 return MATCH_YES;
3666 }
3667
3668
3669 /* Match a CASE statement. */
3670
3671 match
3672 gfc_match_case (void)
3673 {
3674 gfc_case *c, *head, *tail;
3675 match m;
3676
3677 head = tail = NULL;
3678
3679 if (gfc_current_state () != COMP_SELECT)
3680 {
3681 gfc_error ("Unexpected CASE statement at %C");
3682 return MATCH_ERROR;
3683 }
3684
3685 if (gfc_match ("% default") == MATCH_YES)
3686 {
3687 m = match_case_eos ();
3688 if (m == MATCH_NO)
3689 goto syntax;
3690 if (m == MATCH_ERROR)
3691 goto cleanup;
3692
3693 new_st.op = EXEC_SELECT;
3694 c = gfc_get_case ();
3695 c->where = gfc_current_locus;
3696 new_st.ext.case_list = c;
3697 return MATCH_YES;
3698 }
3699
3700 if (gfc_match_char ('(') != MATCH_YES)
3701 goto syntax;
3702
3703 for (;;)
3704 {
3705 if (match_case_selector (&c) == MATCH_ERROR)
3706 goto cleanup;
3707
3708 if (head == NULL)
3709 head = c;
3710 else
3711 tail->next = c;
3712
3713 tail = c;
3714
3715 if (gfc_match_char (')') == MATCH_YES)
3716 break;
3717 if (gfc_match_char (',') != MATCH_YES)
3718 goto syntax;
3719 }
3720
3721 m = match_case_eos ();
3722 if (m == MATCH_NO)
3723 goto syntax;
3724 if (m == MATCH_ERROR)
3725 goto cleanup;
3726
3727 new_st.op = EXEC_SELECT;
3728 new_st.ext.case_list = head;
3729
3730 return MATCH_YES;
3731
3732 syntax:
3733 gfc_error ("Syntax error in CASE-specification at %C");
3734
3735 cleanup:
3736 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
3737 return MATCH_ERROR;
3738 }
3739
3740 /********************* WHERE subroutines ********************/
3741
3742 /* Match the rest of a simple WHERE statement that follows an IF statement.
3743 */
3744
3745 static match
3746 match_simple_where (void)
3747 {
3748 gfc_expr *expr;
3749 gfc_code *c;
3750 match m;
3751
3752 m = gfc_match (" ( %e )", &expr);
3753 if (m != MATCH_YES)
3754 return m;
3755
3756 m = gfc_match_assignment ();
3757 if (m == MATCH_NO)
3758 goto syntax;
3759 if (m == MATCH_ERROR)
3760 goto cleanup;
3761
3762 if (gfc_match_eos () != MATCH_YES)
3763 goto syntax;
3764
3765 c = gfc_get_code ();
3766
3767 c->op = EXEC_WHERE;
3768 c->expr1 = expr;
3769 c->next = gfc_get_code ();
3770
3771 *c->next = new_st;
3772 gfc_clear_new_st ();
3773
3774 new_st.op = EXEC_WHERE;
3775 new_st.block = c;
3776
3777 return MATCH_YES;
3778
3779 syntax:
3780 gfc_syntax_error (ST_WHERE);
3781
3782 cleanup:
3783 gfc_free_expr (expr);
3784 return MATCH_ERROR;
3785 }
3786
3787
3788 /* Match a WHERE statement. */
3789
3790 match
3791 gfc_match_where (gfc_statement *st)
3792 {
3793 gfc_expr *expr;
3794 match m0, m;
3795 gfc_code *c;
3796
3797 m0 = gfc_match_label ();
3798 if (m0 == MATCH_ERROR)
3799 return m0;
3800
3801 m = gfc_match (" where ( %e )", &expr);
3802 if (m != MATCH_YES)
3803 return m;
3804
3805 if (gfc_match_eos () == MATCH_YES)
3806 {
3807 *st = ST_WHERE_BLOCK;
3808 new_st.op = EXEC_WHERE;
3809 new_st.expr1 = expr;
3810 return MATCH_YES;
3811 }
3812
3813 m = gfc_match_assignment ();
3814 if (m == MATCH_NO)
3815 gfc_syntax_error (ST_WHERE);
3816
3817 if (m != MATCH_YES)
3818 {
3819 gfc_free_expr (expr);
3820 return MATCH_ERROR;
3821 }
3822
3823 /* We've got a simple WHERE statement. */
3824 *st = ST_WHERE;
3825 c = gfc_get_code ();
3826
3827 c->op = EXEC_WHERE;
3828 c->expr1 = expr;
3829 c->next = gfc_get_code ();
3830
3831 *c->next = new_st;
3832 gfc_clear_new_st ();
3833
3834 new_st.op = EXEC_WHERE;
3835 new_st.block = c;
3836
3837 return MATCH_YES;
3838 }
3839
3840
3841 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3842 new_st if successful. */
3843
3844 match
3845 gfc_match_elsewhere (void)
3846 {
3847 char name[GFC_MAX_SYMBOL_LEN + 1];
3848 gfc_expr *expr;
3849 match m;
3850
3851 if (gfc_current_state () != COMP_WHERE)
3852 {
3853 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3854 return MATCH_ERROR;
3855 }
3856
3857 expr = NULL;
3858
3859 if (gfc_match_char ('(') == MATCH_YES)
3860 {
3861 m = gfc_match_expr (&expr);
3862 if (m == MATCH_NO)
3863 goto syntax;
3864 if (m == MATCH_ERROR)
3865 return MATCH_ERROR;
3866
3867 if (gfc_match_char (')') != MATCH_YES)
3868 goto syntax;
3869 }
3870
3871 if (gfc_match_eos () != MATCH_YES)
3872 {
3873 /* Only makes sense if we have a where-construct-name. */
3874 if (!gfc_current_block ())
3875 {
3876 m = MATCH_ERROR;
3877 goto cleanup;
3878 }
3879 /* Better be a name at this point. */
3880 m = gfc_match_name (name);
3881 if (m == MATCH_NO)
3882 goto syntax;
3883 if (m == MATCH_ERROR)
3884 goto cleanup;
3885
3886 if (gfc_match_eos () != MATCH_YES)
3887 goto syntax;
3888
3889 if (strcmp (name, gfc_current_block ()->name) != 0)
3890 {
3891 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3892 name, gfc_current_block ()->name);
3893 goto cleanup;
3894 }
3895 }
3896
3897 new_st.op = EXEC_WHERE;
3898 new_st.expr1 = expr;
3899 return MATCH_YES;
3900
3901 syntax:
3902 gfc_syntax_error (ST_ELSEWHERE);
3903
3904 cleanup:
3905 gfc_free_expr (expr);
3906 return MATCH_ERROR;
3907 }
3908
3909
3910 /******************** FORALL subroutines ********************/
3911
3912 /* Free a list of FORALL iterators. */
3913
3914 void
3915 gfc_free_forall_iterator (gfc_forall_iterator *iter)
3916 {
3917 gfc_forall_iterator *next;
3918
3919 while (iter)
3920 {
3921 next = iter->next;
3922 gfc_free_expr (iter->var);
3923 gfc_free_expr (iter->start);
3924 gfc_free_expr (iter->end);
3925 gfc_free_expr (iter->stride);
3926 gfc_free (iter);
3927 iter = next;
3928 }
3929 }
3930
3931
3932 /* Match an iterator as part of a FORALL statement. The format is:
3933
3934 <var> = <start>:<end>[:<stride>]
3935
3936 On MATCH_NO, the caller tests for the possibility that there is a
3937 scalar mask expression. */
3938
3939 static match
3940 match_forall_iterator (gfc_forall_iterator **result)
3941 {
3942 gfc_forall_iterator *iter;
3943 locus where;
3944 match m;
3945
3946 where = gfc_current_locus;
3947 iter = XCNEW (gfc_forall_iterator);
3948
3949 m = gfc_match_expr (&iter->var);
3950 if (m != MATCH_YES)
3951 goto cleanup;
3952
3953 if (gfc_match_char ('=') != MATCH_YES
3954 || iter->var->expr_type != EXPR_VARIABLE)
3955 {
3956 m = MATCH_NO;
3957 goto cleanup;
3958 }
3959
3960 m = gfc_match_expr (&iter->start);
3961 if (m != MATCH_YES)
3962 goto cleanup;
3963
3964 if (gfc_match_char (':') != MATCH_YES)
3965 goto syntax;
3966
3967 m = gfc_match_expr (&iter->end);
3968 if (m == MATCH_NO)
3969 goto syntax;
3970 if (m == MATCH_ERROR)
3971 goto cleanup;
3972
3973 if (gfc_match_char (':') == MATCH_NO)
3974 iter->stride = gfc_int_expr (1);
3975 else
3976 {
3977 m = gfc_match_expr (&iter->stride);
3978 if (m == MATCH_NO)
3979 goto syntax;
3980 if (m == MATCH_ERROR)
3981 goto cleanup;
3982 }
3983
3984 /* Mark the iteration variable's symbol as used as a FORALL index. */
3985 iter->var->symtree->n.sym->forall_index = true;
3986
3987 *result = iter;
3988 return MATCH_YES;
3989
3990 syntax:
3991 gfc_error ("Syntax error in FORALL iterator at %C");
3992 m = MATCH_ERROR;
3993
3994 cleanup:
3995
3996 gfc_current_locus = where;
3997 gfc_free_forall_iterator (iter);
3998 return m;
3999 }
4000
4001
4002 /* Match the header of a FORALL statement. */
4003
4004 static match
4005 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
4006 {
4007 gfc_forall_iterator *head, *tail, *new_iter;
4008 gfc_expr *msk;
4009 match m;
4010
4011 gfc_gobble_whitespace ();
4012
4013 head = tail = NULL;
4014 msk = NULL;
4015
4016 if (gfc_match_char ('(') != MATCH_YES)
4017 return MATCH_NO;
4018
4019 m = match_forall_iterator (&new_iter);
4020 if (m == MATCH_ERROR)
4021 goto cleanup;
4022 if (m == MATCH_NO)
4023 goto syntax;
4024
4025 head = tail = new_iter;
4026
4027 for (;;)
4028 {
4029 if (gfc_match_char (',') != MATCH_YES)
4030 break;
4031
4032 m = match_forall_iterator (&new_iter);
4033 if (m == MATCH_ERROR)
4034 goto cleanup;
4035
4036 if (m == MATCH_YES)
4037 {
4038 tail->next = new_iter;
4039 tail = new_iter;
4040 continue;
4041 }
4042
4043 /* Have to have a mask expression. */
4044
4045 m = gfc_match_expr (&msk);
4046 if (m == MATCH_NO)
4047 goto syntax;
4048 if (m == MATCH_ERROR)
4049 goto cleanup;
4050
4051 break;
4052 }
4053
4054 if (gfc_match_char (')') == MATCH_NO)
4055 goto syntax;
4056
4057 *phead = head;
4058 *mask = msk;
4059 return MATCH_YES;
4060
4061 syntax:
4062 gfc_syntax_error (ST_FORALL);
4063
4064 cleanup:
4065 gfc_free_expr (msk);
4066 gfc_free_forall_iterator (head);
4067
4068 return MATCH_ERROR;
4069 }
4070
4071 /* Match the rest of a simple FORALL statement that follows an
4072 IF statement. */
4073
4074 static match
4075 match_simple_forall (void)
4076 {
4077 gfc_forall_iterator *head;
4078 gfc_expr *mask;
4079 gfc_code *c;
4080 match m;
4081
4082 mask = NULL;
4083 head = NULL;
4084 c = NULL;
4085
4086 m = match_forall_header (&head, &mask);
4087
4088 if (m == MATCH_NO)
4089 goto syntax;
4090 if (m != MATCH_YES)
4091 goto cleanup;
4092
4093 m = gfc_match_assignment ();
4094
4095 if (m == MATCH_ERROR)
4096 goto cleanup;
4097 if (m == MATCH_NO)
4098 {
4099 m = gfc_match_pointer_assignment ();
4100 if (m == MATCH_ERROR)
4101 goto cleanup;
4102 if (m == MATCH_NO)
4103 goto syntax;
4104 }
4105
4106 c = gfc_get_code ();
4107 *c = new_st;
4108 c->loc = gfc_current_locus;
4109
4110 if (gfc_match_eos () != MATCH_YES)
4111 goto syntax;
4112
4113 gfc_clear_new_st ();
4114 new_st.op = EXEC_FORALL;
4115 new_st.expr1 = mask;
4116 new_st.ext.forall_iterator = head;
4117 new_st.block = gfc_get_code ();
4118
4119 new_st.block->op = EXEC_FORALL;
4120 new_st.block->next = c;
4121
4122 return MATCH_YES;
4123
4124 syntax:
4125 gfc_syntax_error (ST_FORALL);
4126
4127 cleanup:
4128 gfc_free_forall_iterator (head);
4129 gfc_free_expr (mask);
4130
4131 return MATCH_ERROR;
4132 }
4133
4134
4135 /* Match a FORALL statement. */
4136
4137 match
4138 gfc_match_forall (gfc_statement *st)
4139 {
4140 gfc_forall_iterator *head;
4141 gfc_expr *mask;
4142 gfc_code *c;
4143 match m0, m;
4144
4145 head = NULL;
4146 mask = NULL;
4147 c = NULL;
4148
4149 m0 = gfc_match_label ();
4150 if (m0 == MATCH_ERROR)
4151 return MATCH_ERROR;
4152
4153 m = gfc_match (" forall");
4154 if (m != MATCH_YES)
4155 return m;
4156
4157 m = match_forall_header (&head, &mask);
4158 if (m == MATCH_ERROR)
4159 goto cleanup;
4160 if (m == MATCH_NO)
4161 goto syntax;
4162
4163 if (gfc_match_eos () == MATCH_YES)
4164 {
4165 *st = ST_FORALL_BLOCK;
4166 new_st.op = EXEC_FORALL;
4167 new_st.expr1 = mask;
4168 new_st.ext.forall_iterator = head;
4169 return MATCH_YES;
4170 }
4171
4172 m = gfc_match_assignment ();
4173 if (m == MATCH_ERROR)
4174 goto cleanup;
4175 if (m == MATCH_NO)
4176 {
4177 m = gfc_match_pointer_assignment ();
4178 if (m == MATCH_ERROR)
4179 goto cleanup;
4180 if (m == MATCH_NO)
4181 goto syntax;
4182 }
4183
4184 c = gfc_get_code ();
4185 *c = new_st;
4186 c->loc = gfc_current_locus;
4187
4188 gfc_clear_new_st ();
4189 new_st.op = EXEC_FORALL;
4190 new_st.expr1 = mask;
4191 new_st.ext.forall_iterator = head;
4192 new_st.block = gfc_get_code ();
4193 new_st.block->op = EXEC_FORALL;
4194 new_st.block->next = c;
4195
4196 *st = ST_FORALL;
4197 return MATCH_YES;
4198
4199 syntax:
4200 gfc_syntax_error (ST_FORALL);
4201
4202 cleanup:
4203 gfc_free_forall_iterator (head);
4204 gfc_free_expr (mask);
4205 gfc_free_statements (c);
4206 return MATCH_NO;
4207 }