?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2015-09-25 Vladimir Makarov <vmakarov@redhat.com>
[official-gcc.git] / gcc / fortran / match.c
blob523e9b2a7f5ed4d340f379d5423a8563830dcf66
1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000-2015 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
20
21 #include "config.h"
22 #include "system.h"
23 #include "coretypes.h"
24 #include "options.h"
25 #include "flags.h"
26 #include "gfortran.h"
27 #include "match.h"
28 #include "parse.h"
29 #include "alias.h"
30 #include "tree.h"
31 #include "stringpool.h"
32
33 int gfc_matching_ptr_assignment = 0;
34 int gfc_matching_procptr_assignment = 0;
35 bool gfc_matching_prefix = false;
36
37 /* Stack of SELECT TYPE statements. */
38 gfc_select_type_stack *select_type_stack = NULL;
39
40 /* For debugging and diagnostic purposes. Return the textual representation
41 of the intrinsic operator OP. */
42 const char *
43 gfc_op2string (gfc_intrinsic_op op)
44 {
45 switch (op)
46 {
47 case INTRINSIC_UPLUS:
48 case INTRINSIC_PLUS:
49 return "+";
50
51 case INTRINSIC_UMINUS:
52 case INTRINSIC_MINUS:
53 return "-";
54
55 case INTRINSIC_POWER:
56 return "**";
57 case INTRINSIC_CONCAT:
58 return "//";
59 case INTRINSIC_TIMES:
60 return "*";
61 case INTRINSIC_DIVIDE:
62 return "/";
63
64 case INTRINSIC_AND:
65 return ".and.";
66 case INTRINSIC_OR:
67 return ".or.";
68 case INTRINSIC_EQV:
69 return ".eqv.";
70 case INTRINSIC_NEQV:
71 return ".neqv.";
72
73 case INTRINSIC_EQ_OS:
74 return ".eq.";
75 case INTRINSIC_EQ:
76 return "==";
77 case INTRINSIC_NE_OS:
78 return ".ne.";
79 case INTRINSIC_NE:
80 return "/=";
81 case INTRINSIC_GE_OS:
82 return ".ge.";
83 case INTRINSIC_GE:
84 return ">=";
85 case INTRINSIC_LE_OS:
86 return ".le.";
87 case INTRINSIC_LE:
88 return "<=";
89 case INTRINSIC_LT_OS:
90 return ".lt.";
91 case INTRINSIC_LT:
92 return "<";
93 case INTRINSIC_GT_OS:
94 return ".gt.";
95 case INTRINSIC_GT:
96 return ">";
97 case INTRINSIC_NOT:
98 return ".not.";
99
100 case INTRINSIC_ASSIGN:
101 return "=";
102
103 case INTRINSIC_PARENTHESES:
104 return "parens";
105
106 case INTRINSIC_NONE:
107 return "none";
108
109 default:
110 break;
111 }
112
113 gfc_internal_error ("gfc_op2string(): Bad code");
114 /* Not reached. */
115 }
116
117
118 /******************** Generic matching subroutines ************************/
119
120 /* This function scans the current statement counting the opened and closed
121 parenthesis to make sure they are balanced. */
122
123 match
124 gfc_match_parens (void)
125 {
126 locus old_loc, where;
127 int count;
128 gfc_instring instring;
129 gfc_char_t c, quote;
130
131 old_loc = gfc_current_locus;
132 count = 0;
133 instring = NONSTRING;
134 quote = ' ';
135
136 for (;;)
137 {
138 c = gfc_next_char_literal (instring);
139 if (c == '\n')
140 break;
141 if (quote == ' ' && ((c == '\'') || (c == '"')))
142 {
143 quote = c;
144 instring = INSTRING_WARN;
145 continue;
146 }
147 if (quote != ' ' && c == quote)
148 {
149 quote = ' ';
150 instring = NONSTRING;
151 continue;
152 }
153
154 if (c == '(' && quote == ' ')
155 {
156 count++;
157 where = gfc_current_locus;
158 }
159 if (c == ')' && quote == ' ')
160 {
161 count--;
162 where = gfc_current_locus;
163 }
164 }
165
166 gfc_current_locus = old_loc;
167
168 if (count > 0)
169 {
170 gfc_error ("Missing %<)%> in statement at or before %L", &where);
171 return MATCH_ERROR;
172 }
173 if (count < 0)
174 {
175 gfc_error ("Missing %<(%> in statement at or before %L", &where);
176 return MATCH_ERROR;
177 }
178
179 return MATCH_YES;
180 }
181
182
183 /* See if the next character is a special character that has
184 escaped by a \ via the -fbackslash option. */
185
186 match
187 gfc_match_special_char (gfc_char_t *res)
188 {
189 int len, i;
190 gfc_char_t c, n;
191 match m;
192
193 m = MATCH_YES;
194
195 switch ((c = gfc_next_char_literal (INSTRING_WARN)))
196 {
197 case 'a':
198 *res = '\a';
199 break;
200 case 'b':
201 *res = '\b';
202 break;
203 case 't':
204 *res = '\t';
205 break;
206 case 'f':
207 *res = '\f';
208 break;
209 case 'n':
210 *res = '\n';
211 break;
212 case 'r':
213 *res = '\r';
214 break;
215 case 'v':
216 *res = '\v';
217 break;
218 case '\\':
219 *res = '\\';
220 break;
221 case '0':
222 *res = '\0';
223 break;
224
225 case 'x':
226 case 'u':
227 case 'U':
228 /* Hexadecimal form of wide characters. */
229 len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8));
230 n = 0;
231 for (i = 0; i < len; i++)
232 {
233 char buf[2] = { '\0', '\0' };
234
235 c = gfc_next_char_literal (INSTRING_WARN);
236 if (!gfc_wide_fits_in_byte (c)
237 || !gfc_check_digit ((unsigned char) c, 16))
238 return MATCH_NO;
239
240 buf[0] = (unsigned char) c;
241 n = n << 4;
242 n += strtol (buf, NULL, 16);
243 }
244 *res = n;
245 break;
246
247 default:
248 /* Unknown backslash codes are simply not expanded. */
249 m = MATCH_NO;
250 break;
251 }
252
253 return m;
254 }
255
256
257 /* In free form, match at least one space. Always matches in fixed
258 form. */
259
260 match
261 gfc_match_space (void)
262 {
263 locus old_loc;
264 char c;
265
266 if (gfc_current_form == FORM_FIXED)
267 return MATCH_YES;
268
269 old_loc = gfc_current_locus;
270
271 c = gfc_next_ascii_char ();
272 if (!gfc_is_whitespace (c))
273 {
274 gfc_current_locus = old_loc;
275 return MATCH_NO;
276 }
277
278 gfc_gobble_whitespace ();
279
280 return MATCH_YES;
281 }
282
283
284 /* Match an end of statement. End of statement is optional
285 whitespace, followed by a ';' or '\n' or comment '!'. If a
286 semicolon is found, we continue to eat whitespace and semicolons. */
287
288 match
289 gfc_match_eos (void)
290 {
291 locus old_loc;
292 int flag;
293 char c;
294
295 flag = 0;
296
297 for (;;)
298 {
299 old_loc = gfc_current_locus;
300 gfc_gobble_whitespace ();
301
302 c = gfc_next_ascii_char ();
303 switch (c)
304 {
305 case '!':
306 do
307 {
308 c = gfc_next_ascii_char ();
309 }
310 while (c != '\n');
311
312 /* Fall through. */
313
314 case '\n':
315 return MATCH_YES;
316
317 case ';':
318 flag = 1;
319 continue;
320 }
321
322 break;
323 }
324
325 gfc_current_locus = old_loc;
326 return (flag) ? MATCH_YES : MATCH_NO;
327 }
328
329
330 /* Match a literal integer on the input, setting the value on
331 MATCH_YES. Literal ints occur in kind-parameters as well as
332 old-style character length specifications. If cnt is non-NULL it
333 will be set to the number of digits. */
334
335 match
336 gfc_match_small_literal_int (int *value, int *cnt)
337 {
338 locus old_loc;
339 char c;
340 int i, j;
341
342 old_loc = gfc_current_locus;
343
344 *value = -1;
345 gfc_gobble_whitespace ();
346 c = gfc_next_ascii_char ();
347 if (cnt)
348 *cnt = 0;
349
350 if (!ISDIGIT (c))
351 {
352 gfc_current_locus = old_loc;
353 return MATCH_NO;
354 }
355
356 i = c - '0';
357 j = 1;
358
359 for (;;)
360 {
361 old_loc = gfc_current_locus;
362 c = gfc_next_ascii_char ();
363
364 if (!ISDIGIT (c))
365 break;
366
367 i = 10 * i + c - '0';
368 j++;
369
370 if (i > 99999999)
371 {
372 gfc_error ("Integer too large at %C");
373 return MATCH_ERROR;
374 }
375 }
376
377 gfc_current_locus = old_loc;
378
379 *value = i;
380 if (cnt)
381 *cnt = j;
382 return MATCH_YES;
383 }
384
385
386 /* Match a small, constant integer expression, like in a kind
387 statement. On MATCH_YES, 'value' is set. */
388
389 match
390 gfc_match_small_int (int *value)
391 {
392 gfc_expr *expr;
393 const char *p;
394 match m;
395 int i;
396
397 m = gfc_match_expr (&expr);
398 if (m != MATCH_YES)
399 return m;
400
401 p = gfc_extract_int (expr, &i);
402 gfc_free_expr (expr);
403
404 if (p != NULL)
405 {
406 gfc_error (p);
407 m = MATCH_ERROR;
408 }
409
410 *value = i;
411 return m;
412 }
413
414
415 /* This function is the same as the gfc_match_small_int, except that
416 we're keeping the pointer to the expr. This function could just be
417 removed and the previously mentioned one modified, though all calls
418 to it would have to be modified then (and there were a number of
419 them). Return MATCH_ERROR if fail to extract the int; otherwise,
420 return the result of gfc_match_expr(). The expr (if any) that was
421 matched is returned in the parameter expr. */
422
423 match
424 gfc_match_small_int_expr (int *value, gfc_expr **expr)
425 {
426 const char *p;
427 match m;
428 int i;
429
430 m = gfc_match_expr (expr);
431 if (m != MATCH_YES)
432 return m;
433
434 p = gfc_extract_int (*expr, &i);
435
436 if (p != NULL)
437 {
438 gfc_error (p);
439 m = MATCH_ERROR;
440 }
441
442 *value = i;
443 return m;
444 }
445
446
447 /* Matches a statement label. Uses gfc_match_small_literal_int() to
448 do most of the work. */
449
450 match
451 gfc_match_st_label (gfc_st_label **label)
452 {
453 locus old_loc;
454 match m;
455 int i, cnt;
456
457 old_loc = gfc_current_locus;
458
459 m = gfc_match_small_literal_int (&i, &cnt);
460 if (m != MATCH_YES)
461 return m;
462
463 if (cnt > 5)
464 {
465 gfc_error ("Too many digits in statement label at %C");
466 goto cleanup;
467 }
468
469 if (i == 0)
470 {
471 gfc_error ("Statement label at %C is zero");
472 goto cleanup;
473 }
474
475 *label = gfc_get_st_label (i);
476 return MATCH_YES;
477
478 cleanup:
479
480 gfc_current_locus = old_loc;
481 return MATCH_ERROR;
482 }
483
484
485 /* Match and validate a label associated with a named IF, DO or SELECT
486 statement. If the symbol does not have the label attribute, we add
487 it. We also make sure the symbol does not refer to another
488 (active) block. A matched label is pointed to by gfc_new_block. */
489
490 match
491 gfc_match_label (void)
492 {
493 char name[GFC_MAX_SYMBOL_LEN + 1];
494 match m;
495
496 gfc_new_block = NULL;
497
498 m = gfc_match (" %n :", name);
499 if (m != MATCH_YES)
500 return m;
501
502 if (gfc_get_symbol (name, NULL, &gfc_new_block))
503 {
504 gfc_error ("Label name %qs at %C is ambiguous", name);
505 return MATCH_ERROR;
506 }
507
508 if (gfc_new_block->attr.flavor == FL_LABEL)
509 {
510 gfc_error ("Duplicate construct label %qs at %C", name);
511 return MATCH_ERROR;
512 }
513
514 if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
515 gfc_new_block->name, NULL))
516 return MATCH_ERROR;
517
518 return MATCH_YES;
519 }
520
521
522 /* See if the current input looks like a name of some sort. Modifies
523 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
524 Note that options.c restricts max_identifier_length to not more
525 than GFC_MAX_SYMBOL_LEN. */
526
527 match
528 gfc_match_name (char *buffer)
529 {
530 locus old_loc;
531 int i;
532 char c;
533
534 old_loc = gfc_current_locus;
535 gfc_gobble_whitespace ();
536
537 c = gfc_next_ascii_char ();
538 if (!(ISALPHA (c) || (c == '_' && flag_allow_leading_underscore)))
539 {
540 /* Special cases for unary minus and plus, which allows for a sensible
541 error message for code of the form 'c = exp(-a*b) )' where an
542 extra ')' appears at the end of statement. */
543 if (!gfc_error_flag_test () && c != '(' && c != '-' && c != '+')
544 gfc_error ("Invalid character in name at %C");
545 gfc_current_locus = old_loc;
546 return MATCH_NO;
547 }
548
549 i = 0;
550
551 do
552 {
553 buffer[i++] = c;
554
555 if (i > gfc_option.max_identifier_length)
556 {
557 gfc_error ("Name at %C is too long");
558 return MATCH_ERROR;
559 }
560
561 old_loc = gfc_current_locus;
562 c = gfc_next_ascii_char ();
563 }
564 while (ISALNUM (c) || c == '_' || (flag_dollar_ok && c == '$'));
565
566 if (c == '$' && !flag_dollar_ok)
567 {
568 gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to "
569 "allow it as an extension", &old_loc);
570 return MATCH_ERROR;
571 }
572
573 buffer[i] = '\0';
574 gfc_current_locus = old_loc;
575
576 return MATCH_YES;
577 }
578
579
580 /* Match a symbol on the input. Modifies the pointer to the symbol
581 pointer if successful. */
582
583 match
584 gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
585 {
586 char buffer[GFC_MAX_SYMBOL_LEN + 1];
587 match m;
588
589 m = gfc_match_name (buffer);
590 if (m != MATCH_YES)
591 return m;
592
593 if (host_assoc)
594 return (gfc_get_ha_sym_tree (buffer, matched_symbol))
595 ? MATCH_ERROR : MATCH_YES;
596
597 if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false))
598 return MATCH_ERROR;
599
600 return MATCH_YES;
601 }
602
603
604 match
605 gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
606 {
607 gfc_symtree *st;
608 match m;
609
610 m = gfc_match_sym_tree (&st, host_assoc);
611
612 if (m == MATCH_YES)
613 {
614 if (st)
615 *matched_symbol = st->n.sym;
616 else
617 *matched_symbol = NULL;
618 }
619 else
620 *matched_symbol = NULL;
621 return m;
622 }
623
624
625 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
626 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
627 in matchexp.c. */
628
629 match
630 gfc_match_intrinsic_op (gfc_intrinsic_op *result)
631 {
632 locus orig_loc = gfc_current_locus;
633 char ch;
634
635 gfc_gobble_whitespace ();
636 ch = gfc_next_ascii_char ();
637 switch (ch)
638 {
639 case '+':
640 /* Matched "+". */
641 *result = INTRINSIC_PLUS;
642 return MATCH_YES;
643
644 case '-':
645 /* Matched "-". */
646 *result = INTRINSIC_MINUS;
647 return MATCH_YES;
648
649 case '=':
650 if (gfc_next_ascii_char () == '=')
651 {
652 /* Matched "==". */
653 *result = INTRINSIC_EQ;
654 return MATCH_YES;
655 }
656 break;
657
658 case '<':
659 if (gfc_peek_ascii_char () == '=')
660 {
661 /* Matched "<=". */
662 gfc_next_ascii_char ();
663 *result = INTRINSIC_LE;
664 return MATCH_YES;
665 }
666 /* Matched "<". */
667 *result = INTRINSIC_LT;
668 return MATCH_YES;
669
670 case '>':
671 if (gfc_peek_ascii_char () == '=')
672 {
673 /* Matched ">=". */
674 gfc_next_ascii_char ();
675 *result = INTRINSIC_GE;
676 return MATCH_YES;
677 }
678 /* Matched ">". */
679 *result = INTRINSIC_GT;
680 return MATCH_YES;
681
682 case '*':
683 if (gfc_peek_ascii_char () == '*')
684 {
685 /* Matched "**". */
686 gfc_next_ascii_char ();
687 *result = INTRINSIC_POWER;
688 return MATCH_YES;
689 }
690 /* Matched "*". */
691 *result = INTRINSIC_TIMES;
692 return MATCH_YES;
693
694 case '/':
695 ch = gfc_peek_ascii_char ();
696 if (ch == '=')
697 {
698 /* Matched "/=". */
699 gfc_next_ascii_char ();
700 *result = INTRINSIC_NE;
701 return MATCH_YES;
702 }
703 else if (ch == '/')
704 {
705 /* Matched "//". */
706 gfc_next_ascii_char ();
707 *result = INTRINSIC_CONCAT;
708 return MATCH_YES;
709 }
710 /* Matched "/". */
711 *result = INTRINSIC_DIVIDE;
712 return MATCH_YES;
713
714 case '.':
715 ch = gfc_next_ascii_char ();
716 switch (ch)
717 {
718 case 'a':
719 if (gfc_next_ascii_char () == 'n'
720 && gfc_next_ascii_char () == 'd'
721 && gfc_next_ascii_char () == '.')
722 {
723 /* Matched ".and.". */
724 *result = INTRINSIC_AND;
725 return MATCH_YES;
726 }
727 break;
728
729 case 'e':
730 if (gfc_next_ascii_char () == 'q')
731 {
732 ch = gfc_next_ascii_char ();
733 if (ch == '.')
734 {
735 /* Matched ".eq.". */
736 *result = INTRINSIC_EQ_OS;
737 return MATCH_YES;
738 }
739 else if (ch == 'v')
740 {
741 if (gfc_next_ascii_char () == '.')
742 {
743 /* Matched ".eqv.". */
744 *result = INTRINSIC_EQV;
745 return MATCH_YES;
746 }
747 }
748 }
749 break;
750
751 case 'g':
752 ch = gfc_next_ascii_char ();
753 if (ch == 'e')
754 {
755 if (gfc_next_ascii_char () == '.')
756 {
757 /* Matched ".ge.". */
758 *result = INTRINSIC_GE_OS;
759 return MATCH_YES;
760 }
761 }
762 else if (ch == 't')
763 {
764 if (gfc_next_ascii_char () == '.')
765 {
766 /* Matched ".gt.". */
767 *result = INTRINSIC_GT_OS;
768 return MATCH_YES;
769 }
770 }
771 break;
772
773 case 'l':
774 ch = gfc_next_ascii_char ();
775 if (ch == 'e')
776 {
777 if (gfc_next_ascii_char () == '.')
778 {
779 /* Matched ".le.". */
780 *result = INTRINSIC_LE_OS;
781 return MATCH_YES;
782 }
783 }
784 else if (ch == 't')
785 {
786 if (gfc_next_ascii_char () == '.')
787 {
788 /* Matched ".lt.". */
789 *result = INTRINSIC_LT_OS;
790 return MATCH_YES;
791 }
792 }
793 break;
794
795 case 'n':
796 ch = gfc_next_ascii_char ();
797 if (ch == 'e')
798 {
799 ch = gfc_next_ascii_char ();
800 if (ch == '.')
801 {
802 /* Matched ".ne.". */
803 *result = INTRINSIC_NE_OS;
804 return MATCH_YES;
805 }
806 else if (ch == 'q')
807 {
808 if (gfc_next_ascii_char () == 'v'
809 && gfc_next_ascii_char () == '.')
810 {
811 /* Matched ".neqv.". */
812 *result = INTRINSIC_NEQV;
813 return MATCH_YES;
814 }
815 }
816 }
817 else if (ch == 'o')
818 {
819 if (gfc_next_ascii_char () == 't'
820 && gfc_next_ascii_char () == '.')
821 {
822 /* Matched ".not.". */
823 *result = INTRINSIC_NOT;
824 return MATCH_YES;
825 }
826 }
827 break;
828
829 case 'o':
830 if (gfc_next_ascii_char () == 'r'
831 && gfc_next_ascii_char () == '.')
832 {
833 /* Matched ".or.". */
834 *result = INTRINSIC_OR;
835 return MATCH_YES;
836 }
837 break;
838
839 default:
840 break;
841 }
842 break;
843
844 default:
845 break;
846 }
847
848 gfc_current_locus = orig_loc;
849 return MATCH_NO;
850 }
851
852
853 /* Match a loop control phrase:
854
855 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
856
857 If the final integer expression is not present, a constant unity
858 expression is returned. We don't return MATCH_ERROR until after
859 the equals sign is seen. */
860
861 match
862 gfc_match_iterator (gfc_iterator *iter, int init_flag)
863 {
864 char name[GFC_MAX_SYMBOL_LEN + 1];
865 gfc_expr *var, *e1, *e2, *e3;
866 locus start;
867 match m;
868
869 e1 = e2 = e3 = NULL;
870
871 /* Match the start of an iterator without affecting the symbol table. */
872
873 start = gfc_current_locus;
874 m = gfc_match (" %n =", name);
875 gfc_current_locus = start;
876
877 if (m != MATCH_YES)
878 return MATCH_NO;
879
880 m = gfc_match_variable (&var, 0);
881 if (m != MATCH_YES)
882 return MATCH_NO;
883
884 /* F2008, C617 & C565. */
885 if (var->symtree->n.sym->attr.codimension)
886 {
887 gfc_error ("Loop variable at %C cannot be a coarray");
888 goto cleanup;
889 }
890
891 if (var->ref != NULL)
892 {
893 gfc_error ("Loop variable at %C cannot be a sub-component");
894 goto cleanup;
895 }
896
897 gfc_match_char ('=');
898
899 var->symtree->n.sym->attr.implied_index = 1;
900
901 m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
902 if (m == MATCH_NO)
903 goto syntax;
904 if (m == MATCH_ERROR)
905 goto cleanup;
906
907 if (gfc_match_char (',') != MATCH_YES)
908 goto syntax;
909
910 m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
911 if (m == MATCH_NO)
912 goto syntax;
913 if (m == MATCH_ERROR)
914 goto cleanup;
915
916 if (gfc_match_char (',') != MATCH_YES)
917 {
918 e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
919 goto done;
920 }
921
922 m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
923 if (m == MATCH_ERROR)
924 goto cleanup;
925 if (m == MATCH_NO)
926 {
927 gfc_error ("Expected a step value in iterator at %C");
928 goto cleanup;
929 }
930
931 done:
932 iter->var = var;
933 iter->start = e1;
934 iter->end = e2;
935 iter->step = e3;
936 return MATCH_YES;
937
938 syntax:
939 gfc_error ("Syntax error in iterator at %C");
940
941 cleanup:
942 gfc_free_expr (e1);
943 gfc_free_expr (e2);
944 gfc_free_expr (e3);
945
946 return MATCH_ERROR;
947 }
948
949
950 /* Tries to match the next non-whitespace character on the input.
951 This subroutine does not return MATCH_ERROR. */
952
953 match
954 gfc_match_char (char c)
955 {
956 locus where;
957
958 where = gfc_current_locus;
959 gfc_gobble_whitespace ();
960
961 if (gfc_next_ascii_char () == c)
962 return MATCH_YES;
963
964 gfc_current_locus = where;
965 return MATCH_NO;
966 }
967
968
969 /* General purpose matching subroutine. The target string is a
970 scanf-like format string in which spaces correspond to arbitrary
971 whitespace (including no whitespace), characters correspond to
972 themselves. The %-codes are:
973
974 %% Literal percent sign
975 %e Expression, pointer to a pointer is set
976 %s Symbol, pointer to the symbol is set
977 %n Name, character buffer is set to name
978 %t Matches end of statement.
979 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
980 %l Matches a statement label
981 %v Matches a variable expression (an lvalue)
982 % Matches a required space (in free form) and optional spaces. */
983
984 match
985 gfc_match (const char *target, ...)
986 {
987 gfc_st_label **label;
988 int matches, *ip;
989 locus old_loc;
990 va_list argp;
991 char c, *np;
992 match m, n;
993 void **vp;
994 const char *p;
995
996 old_loc = gfc_current_locus;
997 va_start (argp, target);
998 m = MATCH_NO;
999 matches = 0;
1000 p = target;
1001
1002 loop:
1003 c = *p++;
1004 switch (c)
1005 {
1006 case ' ':
1007 gfc_gobble_whitespace ();
1008 goto loop;
1009 case '\0':
1010 m = MATCH_YES;
1011 break;
1012
1013 case '%':
1014 c = *p++;
1015 switch (c)
1016 {
1017 case 'e':
1018 vp = va_arg (argp, void **);
1019 n = gfc_match_expr ((gfc_expr **) vp);
1020 if (n != MATCH_YES)
1021 {
1022 m = n;
1023 goto not_yes;
1024 }
1025
1026 matches++;
1027 goto loop;
1028
1029 case 'v':
1030 vp = va_arg (argp, void **);
1031 n = gfc_match_variable ((gfc_expr **) vp, 0);
1032 if (n != MATCH_YES)
1033 {
1034 m = n;
1035 goto not_yes;
1036 }
1037
1038 matches++;
1039 goto loop;
1040
1041 case 's':
1042 vp = va_arg (argp, void **);
1043 n = gfc_match_symbol ((gfc_symbol **) vp, 0);
1044 if (n != MATCH_YES)
1045 {
1046 m = n;
1047 goto not_yes;
1048 }
1049
1050 matches++;
1051 goto loop;
1052
1053 case 'n':
1054 np = va_arg (argp, char *);
1055 n = gfc_match_name (np);
1056 if (n != MATCH_YES)
1057 {
1058 m = n;
1059 goto not_yes;
1060 }
1061
1062 matches++;
1063 goto loop;
1064
1065 case 'l':
1066 label = va_arg (argp, gfc_st_label **);
1067 n = gfc_match_st_label (label);
1068 if (n != MATCH_YES)
1069 {
1070 m = n;
1071 goto not_yes;
1072 }
1073
1074 matches++;
1075 goto loop;
1076
1077 case 'o':
1078 ip = va_arg (argp, int *);
1079 n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
1080 if (n != MATCH_YES)
1081 {
1082 m = n;
1083 goto not_yes;
1084 }
1085
1086 matches++;
1087 goto loop;
1088
1089 case 't':
1090 if (gfc_match_eos () != MATCH_YES)
1091 {
1092 m = MATCH_NO;
1093 goto not_yes;
1094 }
1095 goto loop;
1096
1097 case ' ':
1098 if (gfc_match_space () == MATCH_YES)
1099 goto loop;
1100 m = MATCH_NO;
1101 goto not_yes;
1102
1103 case '%':
1104 break; /* Fall through to character matcher. */
1105
1106 default:
1107 gfc_internal_error ("gfc_match(): Bad match code %c", c);
1108 }
1109
1110 default:
1111
1112 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1113 expect an upper case character here! */
1114 gcc_assert (TOLOWER (c) == c);
1115
1116 if (c == gfc_next_ascii_char ())
1117 goto loop;
1118 break;
1119 }
1120
1121 not_yes:
1122 va_end (argp);
1123
1124 if (m != MATCH_YES)
1125 {
1126 /* Clean up after a failed match. */
1127 gfc_current_locus = old_loc;
1128 va_start (argp, target);
1129
1130 p = target;
1131 for (; matches > 0; matches--)
1132 {
1133 while (*p++ != '%');
1134
1135 switch (*p++)
1136 {
1137 case '%':
1138 matches++;
1139 break; /* Skip. */
1140
1141 /* Matches that don't have to be undone */
1142 case 'o':
1143 case 'l':
1144 case 'n':
1145 case 's':
1146 (void) va_arg (argp, void **);
1147 break;
1148
1149 case 'e':
1150 case 'v':
1151 vp = va_arg (argp, void **);
1152 gfc_free_expr ((struct gfc_expr *)*vp);
1153 *vp = NULL;
1154 break;
1155 }
1156 }
1157
1158 va_end (argp);
1159 }
1160
1161 return m;
1162 }
1163
1164
1165 /*********************** Statement level matching **********************/
1166
1167 /* Matches the start of a program unit, which is the program keyword
1168 followed by an obligatory symbol. */
1169
1170 match
1171 gfc_match_program (void)
1172 {
1173 gfc_symbol *sym;
1174 match m;
1175
1176 m = gfc_match ("% %s%t", &sym);
1177
1178 if (m == MATCH_NO)
1179 {
1180 gfc_error ("Invalid form of PROGRAM statement at %C");
1181 m = MATCH_ERROR;
1182 }
1183
1184 if (m == MATCH_ERROR)
1185 return m;
1186
1187 if (!gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL))
1188 return MATCH_ERROR;
1189
1190 gfc_new_block = sym;
1191
1192 return MATCH_YES;
1193 }
1194
1195
1196 /* Match a simple assignment statement. */
1197
1198 match
1199 gfc_match_assignment (void)
1200 {
1201 gfc_expr *lvalue, *rvalue;
1202 locus old_loc;
1203 match m;
1204
1205 old_loc = gfc_current_locus;
1206
1207 lvalue = NULL;
1208 m = gfc_match (" %v =", &lvalue);
1209 if (m != MATCH_YES)
1210 {
1211 gfc_current_locus = old_loc;
1212 gfc_free_expr (lvalue);
1213 return MATCH_NO;
1214 }
1215
1216 rvalue = NULL;
1217 m = gfc_match (" %e%t", &rvalue);
1218 if (m != MATCH_YES)
1219 {
1220 gfc_current_locus = old_loc;
1221 gfc_free_expr (lvalue);
1222 gfc_free_expr (rvalue);
1223 return m;
1224 }
1225
1226 gfc_set_sym_referenced (lvalue->symtree->n.sym);
1227
1228 new_st.op = EXEC_ASSIGN;
1229 new_st.expr1 = lvalue;
1230 new_st.expr2 = rvalue;
1231
1232 gfc_check_do_variable (lvalue->symtree);
1233
1234 return MATCH_YES;
1235 }
1236
1237
1238 /* Match a pointer assignment statement. */
1239
1240 match
1241 gfc_match_pointer_assignment (void)
1242 {
1243 gfc_expr *lvalue, *rvalue;
1244 locus old_loc;
1245 match m;
1246
1247 old_loc = gfc_current_locus;
1248
1249 lvalue = rvalue = NULL;
1250 gfc_matching_ptr_assignment = 0;
1251 gfc_matching_procptr_assignment = 0;
1252
1253 m = gfc_match (" %v =>", &lvalue);
1254 if (m != MATCH_YES)
1255 {
1256 m = MATCH_NO;
1257 goto cleanup;
1258 }
1259
1260 if (lvalue->symtree->n.sym->attr.proc_pointer
1261 || gfc_is_proc_ptr_comp (lvalue))
1262 gfc_matching_procptr_assignment = 1;
1263 else
1264 gfc_matching_ptr_assignment = 1;
1265
1266 m = gfc_match (" %e%t", &rvalue);
1267 gfc_matching_ptr_assignment = 0;
1268 gfc_matching_procptr_assignment = 0;
1269 if (m != MATCH_YES)
1270 goto cleanup;
1271
1272 new_st.op = EXEC_POINTER_ASSIGN;
1273 new_st.expr1 = lvalue;
1274 new_st.expr2 = rvalue;
1275
1276 return MATCH_YES;
1277
1278 cleanup:
1279 gfc_current_locus = old_loc;
1280 gfc_free_expr (lvalue);
1281 gfc_free_expr (rvalue);
1282 return m;
1283 }
1284
1285
1286 /* We try to match an easy arithmetic IF statement. This only happens
1287 when just after having encountered a simple IF statement. This code
1288 is really duplicate with parts of the gfc_match_if code, but this is
1289 *much* easier. */
1290
1291 static match
1292 match_arithmetic_if (void)
1293 {
1294 gfc_st_label *l1, *l2, *l3;
1295 gfc_expr *expr;
1296 match m;
1297
1298 m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
1299 if (m != MATCH_YES)
1300 return m;
1301
1302 if (!gfc_reference_st_label (l1, ST_LABEL_TARGET)
1303 || !gfc_reference_st_label (l2, ST_LABEL_TARGET)
1304 || !gfc_reference_st_label (l3, ST_LABEL_TARGET))
1305 {
1306 gfc_free_expr (expr);
1307 return MATCH_ERROR;
1308 }
1309
1310 if (!gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF statement at %C"))
1311 return MATCH_ERROR;
1312
1313 new_st.op = EXEC_ARITHMETIC_IF;
1314 new_st.expr1 = expr;
1315 new_st.label1 = l1;
1316 new_st.label2 = l2;
1317 new_st.label3 = l3;
1318
1319 return MATCH_YES;
1320 }
1321
1322
1323 /* The IF statement is a bit of a pain. First of all, there are three
1324 forms of it, the simple IF, the IF that starts a block and the
1325 arithmetic IF.
1326
1327 There is a problem with the simple IF and that is the fact that we
1328 only have a single level of undo information on symbols. What this
1329 means is for a simple IF, we must re-match the whole IF statement
1330 multiple times in order to guarantee that the symbol table ends up
1331 in the proper state. */
1332
1333 static match match_simple_forall (void);
1334 static match match_simple_where (void);
1335
1336 match
1337 gfc_match_if (gfc_statement *if_type)
1338 {
1339 gfc_expr *expr;
1340 gfc_st_label *l1, *l2, *l3;
1341 locus old_loc, old_loc2;
1342 gfc_code *p;
1343 match m, n;
1344
1345 n = gfc_match_label ();
1346 if (n == MATCH_ERROR)
1347 return n;
1348
1349 old_loc = gfc_current_locus;
1350
1351 m = gfc_match (" if ( %e", &expr);
1352 if (m != MATCH_YES)
1353 return m;
1354
1355 old_loc2 = gfc_current_locus;
1356 gfc_current_locus = old_loc;
1357
1358 if (gfc_match_parens () == MATCH_ERROR)
1359 return MATCH_ERROR;
1360
1361 gfc_current_locus = old_loc2;
1362
1363 if (gfc_match_char (')') != MATCH_YES)
1364 {
1365 gfc_error ("Syntax error in IF-expression at %C");
1366 gfc_free_expr (expr);
1367 return MATCH_ERROR;
1368 }
1369
1370 m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
1371
1372 if (m == MATCH_YES)
1373 {
1374 if (n == MATCH_YES)
1375 {
1376 gfc_error ("Block label not appropriate for arithmetic IF "
1377 "statement at %C");
1378 gfc_free_expr (expr);
1379 return MATCH_ERROR;
1380 }
1381
1382 if (!gfc_reference_st_label (l1, ST_LABEL_TARGET)
1383 || !gfc_reference_st_label (l2, ST_LABEL_TARGET)
1384 || !gfc_reference_st_label (l3, ST_LABEL_TARGET))
1385 {
1386 gfc_free_expr (expr);
1387 return MATCH_ERROR;
1388 }
1389
1390 if (!gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF statement at %C"))
1391 return MATCH_ERROR;
1392
1393 new_st.op = EXEC_ARITHMETIC_IF;
1394 new_st.expr1 = expr;
1395 new_st.label1 = l1;
1396 new_st.label2 = l2;
1397 new_st.label3 = l3;
1398
1399 *if_type = ST_ARITHMETIC_IF;
1400 return MATCH_YES;
1401 }
1402
1403 if (gfc_match (" then%t") == MATCH_YES)
1404 {
1405 new_st.op = EXEC_IF;
1406 new_st.expr1 = expr;
1407 *if_type = ST_IF_BLOCK;
1408 return MATCH_YES;
1409 }
1410
1411 if (n == MATCH_YES)
1412 {
1413 gfc_error ("Block label is not appropriate for IF statement at %C");
1414 gfc_free_expr (expr);
1415 return MATCH_ERROR;
1416 }
1417
1418 /* At this point the only thing left is a simple IF statement. At
1419 this point, n has to be MATCH_NO, so we don't have to worry about
1420 re-matching a block label. From what we've got so far, try
1421 matching an assignment. */
1422
1423 *if_type = ST_SIMPLE_IF;
1424
1425 m = gfc_match_assignment ();
1426 if (m == MATCH_YES)
1427 goto got_match;
1428
1429 gfc_free_expr (expr);
1430 gfc_undo_symbols ();
1431 gfc_current_locus = old_loc;
1432
1433 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1434 assignment was found. For MATCH_NO, continue to call the various
1435 matchers. */
1436 if (m == MATCH_ERROR)
1437 return MATCH_ERROR;
1438
1439 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
1440
1441 m = gfc_match_pointer_assignment ();
1442 if (m == MATCH_YES)
1443 goto got_match;
1444
1445 gfc_free_expr (expr);
1446 gfc_undo_symbols ();
1447 gfc_current_locus = old_loc;
1448
1449 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
1450
1451 /* Look at the next keyword to see which matcher to call. Matching
1452 the keyword doesn't affect the symbol table, so we don't have to
1453 restore between tries. */
1454
1455 #define match(string, subr, statement) \
1456 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1457
1458 gfc_clear_error ();
1459
1460 match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1461 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1462 match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1463 match ("call", gfc_match_call, ST_CALL)
1464 match ("close", gfc_match_close, ST_CLOSE)
1465 match ("continue", gfc_match_continue, ST_CONTINUE)
1466 match ("cycle", gfc_match_cycle, ST_CYCLE)
1467 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1468 match ("end file", gfc_match_endfile, ST_END_FILE)
1469 match ("error stop", gfc_match_error_stop, ST_ERROR_STOP)
1470 match ("exit", gfc_match_exit, ST_EXIT)
1471 match ("flush", gfc_match_flush, ST_FLUSH)
1472 match ("forall", match_simple_forall, ST_FORALL)
1473 match ("go to", gfc_match_goto, ST_GOTO)
1474 match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1475 match ("inquire", gfc_match_inquire, ST_INQUIRE)
1476 match ("lock", gfc_match_lock, ST_LOCK)
1477 match ("nullify", gfc_match_nullify, ST_NULLIFY)
1478 match ("open", gfc_match_open, ST_OPEN)
1479 match ("pause", gfc_match_pause, ST_NONE)
1480 match ("print", gfc_match_print, ST_WRITE)
1481 match ("read", gfc_match_read, ST_READ)
1482 match ("return", gfc_match_return, ST_RETURN)
1483 match ("rewind", gfc_match_rewind, ST_REWIND)
1484 match ("stop", gfc_match_stop, ST_STOP)
1485 match ("wait", gfc_match_wait, ST_WAIT)
1486 match ("sync all", gfc_match_sync_all, ST_SYNC_CALL);
1487 match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
1488 match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
1489 match ("unlock", gfc_match_unlock, ST_UNLOCK)
1490 match ("where", match_simple_where, ST_WHERE)
1491 match ("write", gfc_match_write, ST_WRITE)
1492
1493 /* The gfc_match_assignment() above may have returned a MATCH_NO
1494 where the assignment was to a named constant. Check that
1495 special case here. */
1496 m = gfc_match_assignment ();
1497 if (m == MATCH_NO)
1498 {
1499 gfc_error ("Cannot assign to a named constant at %C");
1500 gfc_free_expr (expr);
1501 gfc_undo_symbols ();
1502 gfc_current_locus = old_loc;
1503 return MATCH_ERROR;
1504 }
1505
1506 /* All else has failed, so give up. See if any of the matchers has
1507 stored an error message of some sort. */
1508 if (!gfc_error_check ())
1509 gfc_error ("Unclassifiable statement in IF-clause at %C");
1510
1511 gfc_free_expr (expr);
1512 return MATCH_ERROR;
1513
1514 got_match:
1515 if (m == MATCH_NO)
1516 gfc_error ("Syntax error in IF-clause at %C");
1517 if (m != MATCH_YES)
1518 {
1519 gfc_free_expr (expr);
1520 return MATCH_ERROR;
1521 }
1522
1523 /* At this point, we've matched the single IF and the action clause
1524 is in new_st. Rearrange things so that the IF statement appears
1525 in new_st. */
1526
1527 p = gfc_get_code (EXEC_IF);
1528 p->next = XCNEW (gfc_code);
1529 *p->next = new_st;
1530 p->next->loc = gfc_current_locus;
1531
1532 p->expr1 = expr;
1533
1534 gfc_clear_new_st ();
1535
1536 new_st.op = EXEC_IF;
1537 new_st.block = p;
1538
1539 return MATCH_YES;
1540 }
1541
1542 #undef match
1543
1544
1545 /* Match an ELSE statement. */
1546
1547 match
1548 gfc_match_else (void)
1549 {
1550 char name[GFC_MAX_SYMBOL_LEN + 1];
1551
1552 if (gfc_match_eos () == MATCH_YES)
1553 return MATCH_YES;
1554
1555 if (gfc_match_name (name) != MATCH_YES
1556 || gfc_current_block () == NULL
1557 || gfc_match_eos () != MATCH_YES)
1558 {
1559 gfc_error ("Unexpected junk after ELSE statement at %C");
1560 return MATCH_ERROR;
1561 }
1562
1563 if (strcmp (name, gfc_current_block ()->name) != 0)
1564 {
1565 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1566 name, gfc_current_block ()->name);
1567 return MATCH_ERROR;
1568 }
1569
1570 return MATCH_YES;
1571 }
1572
1573
1574 /* Match an ELSE IF statement. */
1575
1576 match
1577 gfc_match_elseif (void)
1578 {
1579 char name[GFC_MAX_SYMBOL_LEN + 1];
1580 gfc_expr *expr;
1581 match m;
1582
1583 m = gfc_match (" ( %e ) then", &expr);
1584 if (m != MATCH_YES)
1585 return m;
1586
1587 if (gfc_match_eos () == MATCH_YES)
1588 goto done;
1589
1590 if (gfc_match_name (name) != MATCH_YES
1591 || gfc_current_block () == NULL
1592 || gfc_match_eos () != MATCH_YES)
1593 {
1594 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1595 goto cleanup;
1596 }
1597
1598 if (strcmp (name, gfc_current_block ()->name) != 0)
1599 {
1600 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1601 name, gfc_current_block ()->name);
1602 goto cleanup;
1603 }
1604
1605 done:
1606 new_st.op = EXEC_IF;
1607 new_st.expr1 = expr;
1608 return MATCH_YES;
1609
1610 cleanup:
1611 gfc_free_expr (expr);
1612 return MATCH_ERROR;
1613 }
1614
1615
1616 /* Free a gfc_iterator structure. */
1617
1618 void
1619 gfc_free_iterator (gfc_iterator *iter, int flag)
1620 {
1621
1622 if (iter == NULL)
1623 return;
1624
1625 gfc_free_expr (iter->var);
1626 gfc_free_expr (iter->start);
1627 gfc_free_expr (iter->end);
1628 gfc_free_expr (iter->step);
1629
1630 if (flag)
1631 free (iter);
1632 }
1633
1634
1635 /* Match a CRITICAL statement. */
1636 match
1637 gfc_match_critical (void)
1638 {
1639 gfc_st_label *label = NULL;
1640
1641 if (gfc_match_label () == MATCH_ERROR)
1642 return MATCH_ERROR;
1643
1644 if (gfc_match (" critical") != MATCH_YES)
1645 return MATCH_NO;
1646
1647 if (gfc_match_st_label (&label) == MATCH_ERROR)
1648 return MATCH_ERROR;
1649
1650 if (gfc_match_eos () != MATCH_YES)
1651 {
1652 gfc_syntax_error (ST_CRITICAL);
1653 return MATCH_ERROR;
1654 }
1655
1656 if (gfc_pure (NULL))
1657 {
1658 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1659 return MATCH_ERROR;
1660 }
1661
1662 if (gfc_find_state (COMP_DO_CONCURRENT))
1663 {
1664 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1665 "block");
1666 return MATCH_ERROR;
1667 }
1668
1669 gfc_unset_implicit_pure (NULL);
1670
1671 if (!gfc_notify_std (GFC_STD_F2008, "CRITICAL statement at %C"))
1672 return MATCH_ERROR;
1673
1674 if (flag_coarray == GFC_FCOARRAY_NONE)
1675 {
1676 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1677 "enable");
1678 return MATCH_ERROR;
1679 }
1680
1681 if (gfc_find_state (COMP_CRITICAL))
1682 {
1683 gfc_error ("Nested CRITICAL block at %C");
1684 return MATCH_ERROR;
1685 }
1686
1687 new_st.op = EXEC_CRITICAL;
1688
1689 if (label != NULL
1690 && !gfc_reference_st_label (label, ST_LABEL_TARGET))
1691 return MATCH_ERROR;
1692
1693 return MATCH_YES;
1694 }
1695
1696
1697 /* Match a BLOCK statement. */
1698
1699 match
1700 gfc_match_block (void)
1701 {
1702 match m;
1703
1704 if (gfc_match_label () == MATCH_ERROR)
1705 return MATCH_ERROR;
1706
1707 if (gfc_match (" block") != MATCH_YES)
1708 return MATCH_NO;
1709
1710 /* For this to be a correct BLOCK statement, the line must end now. */
1711 m = gfc_match_eos ();
1712 if (m == MATCH_ERROR)
1713 return MATCH_ERROR;
1714 if (m == MATCH_NO)
1715 return MATCH_NO;
1716
1717 return MATCH_YES;
1718 }
1719
1720
1721 /* Match an ASSOCIATE statement. */
1722
1723 match
1724 gfc_match_associate (void)
1725 {
1726 if (gfc_match_label () == MATCH_ERROR)
1727 return MATCH_ERROR;
1728
1729 if (gfc_match (" associate") != MATCH_YES)
1730 return MATCH_NO;
1731
1732 /* Match the association list. */
1733 if (gfc_match_char ('(') != MATCH_YES)
1734 {
1735 gfc_error ("Expected association list at %C");
1736 return MATCH_ERROR;
1737 }
1738 new_st.ext.block.assoc = NULL;
1739 while (true)
1740 {
1741 gfc_association_list* newAssoc = gfc_get_association_list ();
1742 gfc_association_list* a;
1743
1744 /* Match the next association. */
1745 if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
1746 != MATCH_YES)
1747 {
1748 gfc_error ("Expected association at %C");
1749 goto assocListError;
1750 }
1751 newAssoc->where = gfc_current_locus;
1752
1753 /* Check that the current name is not yet in the list. */
1754 for (a = new_st.ext.block.assoc; a; a = a->next)
1755 if (!strcmp (a->name, newAssoc->name))
1756 {
1757 gfc_error ("Duplicate name %qs in association at %C",
1758 newAssoc->name);
1759 goto assocListError;
1760 }
1761
1762 /* The target expression must not be coindexed. */
1763 if (gfc_is_coindexed (newAssoc->target))
1764 {
1765 gfc_error ("Association target at %C must not be coindexed");
1766 goto assocListError;
1767 }
1768
1769 /* The `variable' field is left blank for now; because the target is not
1770 yet resolved, we can't use gfc_has_vector_subscript to determine it
1771 for now. This is set during resolution. */
1772
1773 /* Put it into the list. */
1774 newAssoc->next = new_st.ext.block.assoc;
1775 new_st.ext.block.assoc = newAssoc;
1776
1777 /* Try next one or end if closing parenthesis is found. */
1778 gfc_gobble_whitespace ();
1779 if (gfc_peek_char () == ')')
1780 break;
1781 if (gfc_match_char (',') != MATCH_YES)
1782 {
1783 gfc_error ("Expected %<)%> or %<,%> at %C");
1784 return MATCH_ERROR;
1785 }
1786
1787 continue;
1788
1789 assocListError:
1790 free (newAssoc);
1791 goto error;
1792 }
1793 if (gfc_match_char (')') != MATCH_YES)
1794 {
1795 /* This should never happen as we peek above. */
1796 gcc_unreachable ();
1797 }
1798
1799 if (gfc_match_eos () != MATCH_YES)
1800 {
1801 gfc_error ("Junk after ASSOCIATE statement at %C");
1802 goto error;
1803 }
1804
1805 return MATCH_YES;
1806
1807 error:
1808 gfc_free_association_list (new_st.ext.block.assoc);
1809 return MATCH_ERROR;
1810 }
1811
1812
1813 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1814 an accessible derived type. */
1815
1816 static match
1817 match_derived_type_spec (gfc_typespec *ts)
1818 {
1819 char name[GFC_MAX_SYMBOL_LEN + 1];
1820 locus old_locus;
1821 gfc_symbol *derived;
1822
1823 old_locus = gfc_current_locus;
1824
1825 if (gfc_match ("%n", name) != MATCH_YES)
1826 {
1827 gfc_current_locus = old_locus;
1828 return MATCH_NO;
1829 }
1830
1831 gfc_find_symbol (name, NULL, 1, &derived);
1832
1833 if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
1834 derived = gfc_find_dt_in_generic (derived);
1835
1836 if (derived && derived->attr.flavor == FL_DERIVED)
1837 {
1838 ts->type = BT_DERIVED;
1839 ts->u.derived = derived;
1840 return MATCH_YES;
1841 }
1842
1843 gfc_current_locus = old_locus;
1844 return MATCH_NO;
1845 }
1846
1847
1848 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
1849 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
1850 It only includes the intrinsic types from the Fortran 2003 standard
1851 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
1852 the implicit_flag is not needed, so it was removed. Derived types are
1853 identified by their name alone. */
1854
1855 match
1856 gfc_match_type_spec (gfc_typespec *ts)
1857 {
1858 match m;
1859 locus old_locus;
1860
1861 gfc_clear_ts (ts);
1862 gfc_gobble_whitespace ();
1863 old_locus = gfc_current_locus;
1864
1865 if (match_derived_type_spec (ts) == MATCH_YES)
1866 {
1867 /* Enforce F03:C401. */
1868 if (ts->u.derived->attr.abstract)
1869 {
1870 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
1871 ts->u.derived->name, &old_locus);
1872 return MATCH_ERROR;
1873 }
1874 return MATCH_YES;
1875 }
1876
1877 if (gfc_match ("integer") == MATCH_YES)
1878 {
1879 ts->type = BT_INTEGER;
1880 ts->kind = gfc_default_integer_kind;
1881 goto kind_selector;
1882 }
1883
1884 if (gfc_match ("real") == MATCH_YES)
1885 {
1886 ts->type = BT_REAL;
1887 ts->kind = gfc_default_real_kind;
1888 goto kind_selector;
1889 }
1890
1891 if (gfc_match ("double precision") == MATCH_YES)
1892 {
1893 ts->type = BT_REAL;
1894 ts->kind = gfc_default_double_kind;
1895 return MATCH_YES;
1896 }
1897
1898 if (gfc_match ("complex") == MATCH_YES)
1899 {
1900 ts->type = BT_COMPLEX;
1901 ts->kind = gfc_default_complex_kind;
1902 goto kind_selector;
1903 }
1904
1905 if (gfc_match ("character") == MATCH_YES)
1906 {
1907 ts->type = BT_CHARACTER;
1908
1909 m = gfc_match_char_spec (ts);
1910
1911 if (m == MATCH_NO)
1912 m = MATCH_YES;
1913
1914 return m;
1915 }
1916
1917 if (gfc_match ("logical") == MATCH_YES)
1918 {
1919 ts->type = BT_LOGICAL;
1920 ts->kind = gfc_default_logical_kind;
1921 goto kind_selector;
1922 }
1923
1924 /* If a type is not matched, simply return MATCH_NO. */
1925 gfc_current_locus = old_locus;
1926 return MATCH_NO;
1927
1928 kind_selector:
1929
1930 gfc_gobble_whitespace ();
1931 if (gfc_peek_ascii_char () == '*')
1932 {
1933 gfc_error ("Invalid type-spec at %C");
1934 return MATCH_ERROR;
1935 }
1936
1937 m = gfc_match_kind_spec (ts, false);
1938
1939 if (m == MATCH_NO)
1940 m = MATCH_YES; /* No kind specifier found. */
1941
1942 return m;
1943 }
1944
1945
1946 /******************** FORALL subroutines ********************/
1947
1948 /* Free a list of FORALL iterators. */
1949
1950 void
1951 gfc_free_forall_iterator (gfc_forall_iterator *iter)
1952 {
1953 gfc_forall_iterator *next;
1954
1955 while (iter)
1956 {
1957 next = iter->next;
1958 gfc_free_expr (iter->var);
1959 gfc_free_expr (iter->start);
1960 gfc_free_expr (iter->end);
1961 gfc_free_expr (iter->stride);
1962 free (iter);
1963 iter = next;
1964 }
1965 }
1966
1967
1968 /* Match an iterator as part of a FORALL statement. The format is:
1969
1970 <var> = <start>:<end>[:<stride>]
1971
1972 On MATCH_NO, the caller tests for the possibility that there is a
1973 scalar mask expression. */
1974
1975 static match
1976 match_forall_iterator (gfc_forall_iterator **result)
1977 {
1978 gfc_forall_iterator *iter;
1979 locus where;
1980 match m;
1981
1982 where = gfc_current_locus;
1983 iter = XCNEW (gfc_forall_iterator);
1984
1985 m = gfc_match_expr (&iter->var);
1986 if (m != MATCH_YES)
1987 goto cleanup;
1988
1989 if (gfc_match_char ('=') != MATCH_YES
1990 || iter->var->expr_type != EXPR_VARIABLE)
1991 {
1992 m = MATCH_NO;
1993 goto cleanup;
1994 }
1995
1996 m = gfc_match_expr (&iter->start);
1997 if (m != MATCH_YES)
1998 goto cleanup;
1999
2000 if (gfc_match_char (':') != MATCH_YES)
2001 goto syntax;
2002
2003 m = gfc_match_expr (&iter->end);
2004 if (m == MATCH_NO)
2005 goto syntax;
2006 if (m == MATCH_ERROR)
2007 goto cleanup;
2008
2009 if (gfc_match_char (':') == MATCH_NO)
2010 iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
2011 else
2012 {
2013 m = gfc_match_expr (&iter->stride);
2014 if (m == MATCH_NO)
2015 goto syntax;
2016 if (m == MATCH_ERROR)
2017 goto cleanup;
2018 }
2019
2020 /* Mark the iteration variable's symbol as used as a FORALL index. */
2021 iter->var->symtree->n.sym->forall_index = true;
2022
2023 *result = iter;
2024 return MATCH_YES;
2025
2026 syntax:
2027 gfc_error ("Syntax error in FORALL iterator at %C");
2028 m = MATCH_ERROR;
2029
2030 cleanup:
2031
2032 gfc_current_locus = where;
2033 gfc_free_forall_iterator (iter);
2034 return m;
2035 }
2036
2037
2038 /* Match the header of a FORALL statement. */
2039
2040 static match
2041 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
2042 {
2043 gfc_forall_iterator *head, *tail, *new_iter;
2044 gfc_expr *msk;
2045 match m;
2046
2047 gfc_gobble_whitespace ();
2048
2049 head = tail = NULL;
2050 msk = NULL;
2051
2052 if (gfc_match_char ('(') != MATCH_YES)
2053 return MATCH_NO;
2054
2055 m = match_forall_iterator (&new_iter);
2056 if (m == MATCH_ERROR)
2057 goto cleanup;
2058 if (m == MATCH_NO)
2059 goto syntax;
2060
2061 head = tail = new_iter;
2062
2063 for (;;)
2064 {
2065 if (gfc_match_char (',') != MATCH_YES)
2066 break;
2067
2068 m = match_forall_iterator (&new_iter);
2069 if (m == MATCH_ERROR)
2070 goto cleanup;
2071
2072 if (m == MATCH_YES)
2073 {
2074 tail->next = new_iter;
2075 tail = new_iter;
2076 continue;
2077 }
2078
2079 /* Have to have a mask expression. */
2080
2081 m = gfc_match_expr (&msk);
2082 if (m == MATCH_NO)
2083 goto syntax;
2084 if (m == MATCH_ERROR)
2085 goto cleanup;
2086
2087 break;
2088 }
2089
2090 if (gfc_match_char (')') == MATCH_NO)
2091 goto syntax;
2092
2093 *phead = head;
2094 *mask = msk;
2095 return MATCH_YES;
2096
2097 syntax:
2098 gfc_syntax_error (ST_FORALL);
2099
2100 cleanup:
2101 gfc_free_expr (msk);
2102 gfc_free_forall_iterator (head);
2103
2104 return MATCH_ERROR;
2105 }
2106
2107 /* Match the rest of a simple FORALL statement that follows an
2108 IF statement. */
2109
2110 static match
2111 match_simple_forall (void)
2112 {
2113 gfc_forall_iterator *head;
2114 gfc_expr *mask;
2115 gfc_code *c;
2116 match m;
2117
2118 mask = NULL;
2119 head = NULL;
2120 c = NULL;
2121
2122 m = match_forall_header (&head, &mask);
2123
2124 if (m == MATCH_NO)
2125 goto syntax;
2126 if (m != MATCH_YES)
2127 goto cleanup;
2128
2129 m = gfc_match_assignment ();
2130
2131 if (m == MATCH_ERROR)
2132 goto cleanup;
2133 if (m == MATCH_NO)
2134 {
2135 m = gfc_match_pointer_assignment ();
2136 if (m == MATCH_ERROR)
2137 goto cleanup;
2138 if (m == MATCH_NO)
2139 goto syntax;
2140 }
2141
2142 c = XCNEW (gfc_code);
2143 *c = new_st;
2144 c->loc = gfc_current_locus;
2145
2146 if (gfc_match_eos () != MATCH_YES)
2147 goto syntax;
2148
2149 gfc_clear_new_st ();
2150 new_st.op = EXEC_FORALL;
2151 new_st.expr1 = mask;
2152 new_st.ext.forall_iterator = head;
2153 new_st.block = gfc_get_code (EXEC_FORALL);
2154 new_st.block->next = c;
2155
2156 return MATCH_YES;
2157
2158 syntax:
2159 gfc_syntax_error (ST_FORALL);
2160
2161 cleanup:
2162 gfc_free_forall_iterator (head);
2163 gfc_free_expr (mask);
2164
2165 return MATCH_ERROR;
2166 }
2167
2168
2169 /* Match a FORALL statement. */
2170
2171 match
2172 gfc_match_forall (gfc_statement *st)
2173 {
2174 gfc_forall_iterator *head;
2175 gfc_expr *mask;
2176 gfc_code *c;
2177 match m0, m;
2178
2179 head = NULL;
2180 mask = NULL;
2181 c = NULL;
2182
2183 m0 = gfc_match_label ();
2184 if (m0 == MATCH_ERROR)
2185 return MATCH_ERROR;
2186
2187 m = gfc_match (" forall");
2188 if (m != MATCH_YES)
2189 return m;
2190
2191 m = match_forall_header (&head, &mask);
2192 if (m == MATCH_ERROR)
2193 goto cleanup;
2194 if (m == MATCH_NO)
2195 goto syntax;
2196
2197 if (gfc_match_eos () == MATCH_YES)
2198 {
2199 *st = ST_FORALL_BLOCK;
2200 new_st.op = EXEC_FORALL;
2201 new_st.expr1 = mask;
2202 new_st.ext.forall_iterator = head;
2203 return MATCH_YES;
2204 }
2205
2206 m = gfc_match_assignment ();
2207 if (m == MATCH_ERROR)
2208 goto cleanup;
2209 if (m == MATCH_NO)
2210 {
2211 m = gfc_match_pointer_assignment ();
2212 if (m == MATCH_ERROR)
2213 goto cleanup;
2214 if (m == MATCH_NO)
2215 goto syntax;
2216 }
2217
2218 c = XCNEW (gfc_code);
2219 *c = new_st;
2220 c->loc = gfc_current_locus;
2221
2222 gfc_clear_new_st ();
2223 new_st.op = EXEC_FORALL;
2224 new_st.expr1 = mask;
2225 new_st.ext.forall_iterator = head;
2226 new_st.block = gfc_get_code (EXEC_FORALL);
2227 new_st.block->next = c;
2228
2229 *st = ST_FORALL;
2230 return MATCH_YES;
2231
2232 syntax:
2233 gfc_syntax_error (ST_FORALL);
2234
2235 cleanup:
2236 gfc_free_forall_iterator (head);
2237 gfc_free_expr (mask);
2238 gfc_free_statements (c);
2239 return MATCH_NO;
2240 }
2241
2242
2243 /* Match a DO statement. */
2244
2245 match
2246 gfc_match_do (void)
2247 {
2248 gfc_iterator iter, *ip;
2249 locus old_loc;
2250 gfc_st_label *label;
2251 match m;
2252
2253 old_loc = gfc_current_locus;
2254
2255 label = NULL;
2256 iter.var = iter.start = iter.end = iter.step = NULL;
2257
2258 m = gfc_match_label ();
2259 if (m == MATCH_ERROR)
2260 return m;
2261
2262 if (gfc_match (" do") != MATCH_YES)
2263 return MATCH_NO;
2264
2265 m = gfc_match_st_label (&label);
2266 if (m == MATCH_ERROR)
2267 goto cleanup;
2268
2269 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2270
2271 if (gfc_match_eos () == MATCH_YES)
2272 {
2273 iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
2274 new_st.op = EXEC_DO_WHILE;
2275 goto done;
2276 }
2277
2278 /* Match an optional comma, if no comma is found, a space is obligatory. */
2279 if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
2280 return MATCH_NO;
2281
2282 /* Check for balanced parens. */
2283
2284 if (gfc_match_parens () == MATCH_ERROR)
2285 return MATCH_ERROR;
2286
2287 if (gfc_match (" concurrent") == MATCH_YES)
2288 {
2289 gfc_forall_iterator *head;
2290 gfc_expr *mask;
2291
2292 if (!gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT construct at %C"))
2293 return MATCH_ERROR;
2294
2295
2296 mask = NULL;
2297 head = NULL;
2298 m = match_forall_header (&head, &mask);
2299
2300 if (m == MATCH_NO)
2301 return m;
2302 if (m == MATCH_ERROR)
2303 goto concurr_cleanup;
2304
2305 if (gfc_match_eos () != MATCH_YES)
2306 goto concurr_cleanup;
2307
2308 if (label != NULL
2309 && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
2310 goto concurr_cleanup;
2311
2312 new_st.label1 = label;
2313 new_st.op = EXEC_DO_CONCURRENT;
2314 new_st.expr1 = mask;
2315 new_st.ext.forall_iterator = head;
2316
2317 return MATCH_YES;
2318
2319 concurr_cleanup:
2320 gfc_syntax_error (ST_DO);
2321 gfc_free_expr (mask);
2322 gfc_free_forall_iterator (head);
2323 return MATCH_ERROR;
2324 }
2325
2326 /* See if we have a DO WHILE. */
2327 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
2328 {
2329 new_st.op = EXEC_DO_WHILE;
2330 goto done;
2331 }
2332
2333 /* The abortive DO WHILE may have done something to the symbol
2334 table, so we start over. */
2335 gfc_undo_symbols ();
2336 gfc_current_locus = old_loc;
2337
2338 gfc_match_label (); /* This won't error. */
2339 gfc_match (" do "); /* This will work. */
2340
2341 gfc_match_st_label (&label); /* Can't error out. */
2342 gfc_match_char (','); /* Optional comma. */
2343
2344 m = gfc_match_iterator (&iter, 0);
2345 if (m == MATCH_NO)
2346 return MATCH_NO;
2347 if (m == MATCH_ERROR)
2348 goto cleanup;
2349
2350 iter.var->symtree->n.sym->attr.implied_index = 0;
2351 gfc_check_do_variable (iter.var->symtree);
2352
2353 if (gfc_match_eos () != MATCH_YES)
2354 {
2355 gfc_syntax_error (ST_DO);
2356 goto cleanup;
2357 }
2358
2359 new_st.op = EXEC_DO;
2360
2361 done:
2362 if (label != NULL
2363 && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
2364 goto cleanup;
2365
2366 new_st.label1 = label;
2367
2368 if (new_st.op == EXEC_DO_WHILE)
2369 new_st.expr1 = iter.end;
2370 else
2371 {
2372 new_st.ext.iterator = ip = gfc_get_iterator ();
2373 *ip = iter;
2374 }
2375
2376 return MATCH_YES;
2377
2378 cleanup:
2379 gfc_free_iterator (&iter, 0);
2380
2381 return MATCH_ERROR;
2382 }
2383
2384
2385 /* Match an EXIT or CYCLE statement. */
2386
2387 static match
2388 match_exit_cycle (gfc_statement st, gfc_exec_op op)
2389 {
2390 gfc_state_data *p, *o;
2391 gfc_symbol *sym;
2392 match m;
2393 int cnt;
2394
2395 if (gfc_match_eos () == MATCH_YES)
2396 sym = NULL;
2397 else
2398 {
2399 char name[GFC_MAX_SYMBOL_LEN + 1];
2400 gfc_symtree* stree;
2401
2402 m = gfc_match ("% %n%t", name);
2403 if (m == MATCH_ERROR)
2404 return MATCH_ERROR;
2405 if (m == MATCH_NO)
2406 {
2407 gfc_syntax_error (st);
2408 return MATCH_ERROR;
2409 }
2410
2411 /* Find the corresponding symbol. If there's a BLOCK statement
2412 between here and the label, it is not in gfc_current_ns but a parent
2413 namespace! */
2414 stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
2415 if (!stree)
2416 {
2417 gfc_error ("Name %qs in %s statement at %C is unknown",
2418 name, gfc_ascii_statement (st));
2419 return MATCH_ERROR;
2420 }
2421
2422 sym = stree->n.sym;
2423 if (sym->attr.flavor != FL_LABEL)
2424 {
2425 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2426 name, gfc_ascii_statement (st));
2427 return MATCH_ERROR;
2428 }
2429 }
2430
2431 /* Find the loop specified by the label (or lack of a label). */
2432 for (o = NULL, p = gfc_state_stack; p; p = p->previous)
2433 if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
2434 o = p;
2435 else if (p->state == COMP_CRITICAL)
2436 {
2437 gfc_error("%s statement at %C leaves CRITICAL construct",
2438 gfc_ascii_statement (st));
2439 return MATCH_ERROR;
2440 }
2441 else if (p->state == COMP_DO_CONCURRENT
2442 && (op == EXEC_EXIT || (sym && sym != p->sym)))
2443 {
2444 /* F2008, C821 & C845. */
2445 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2446 gfc_ascii_statement (st));
2447 return MATCH_ERROR;
2448 }
2449 else if ((sym && sym == p->sym)
2450 || (!sym && (p->state == COMP_DO
2451 || p->state == COMP_DO_CONCURRENT)))
2452 break;
2453
2454 if (p == NULL)
2455 {
2456 if (sym == NULL)
2457 gfc_error ("%s statement at %C is not within a construct",
2458 gfc_ascii_statement (st));
2459 else
2460 gfc_error ("%s statement at %C is not within construct %qs",
2461 gfc_ascii_statement (st), sym->name);
2462
2463 return MATCH_ERROR;
2464 }
2465
2466 /* Special checks for EXIT from non-loop constructs. */
2467 switch (p->state)
2468 {
2469 case COMP_DO:
2470 case COMP_DO_CONCURRENT:
2471 break;
2472
2473 case COMP_CRITICAL:
2474 /* This is already handled above. */
2475 gcc_unreachable ();
2476
2477 case COMP_ASSOCIATE:
2478 case COMP_BLOCK:
2479 case COMP_IF:
2480 case COMP_SELECT:
2481 case COMP_SELECT_TYPE:
2482 gcc_assert (sym);
2483 if (op == EXEC_CYCLE)
2484 {
2485 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2486 " construct %qs", sym->name);
2487 return MATCH_ERROR;
2488 }
2489 gcc_assert (op == EXEC_EXIT);
2490 if (!gfc_notify_std (GFC_STD_F2008, "EXIT statement with no"
2491 " do-construct-name at %C"))
2492 return MATCH_ERROR;
2493 break;
2494
2495 default:
2496 gfc_error ("%s statement at %C is not applicable to construct %qs",
2497 gfc_ascii_statement (st), sym->name);
2498 return MATCH_ERROR;
2499 }
2500
2501 if (o != NULL)
2502 {
2503 gfc_error (is_oacc (p)
2504 ? "%s statement at %C leaving OpenACC structured block"
2505 : "%s statement at %C leaving OpenMP structured block",
2506 gfc_ascii_statement (st));
2507 return MATCH_ERROR;
2508 }
2509
2510 for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++)
2511 o = o->previous;
2512 if (cnt > 0
2513 && o != NULL
2514 && o->state == COMP_OMP_STRUCTURED_BLOCK
2515 && (o->head->op == EXEC_OACC_LOOP
2516 || o->head->op == EXEC_OACC_PARALLEL_LOOP))
2517 {
2518 int collapse = 1;
2519 gcc_assert (o->head->next != NULL
2520 && (o->head->next->op == EXEC_DO
2521 || o->head->next->op == EXEC_DO_WHILE)
2522 && o->previous != NULL
2523 && o->previous->tail->op == o->head->op);
2524 if (o->previous->tail->ext.omp_clauses != NULL
2525 && o->previous->tail->ext.omp_clauses->collapse > 1)
2526 collapse = o->previous->tail->ext.omp_clauses->collapse;
2527 if (st == ST_EXIT && cnt <= collapse)
2528 {
2529 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2530 return MATCH_ERROR;
2531 }
2532 if (st == ST_CYCLE && cnt < collapse)
2533 {
2534 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2535 " !$ACC LOOP loop");
2536 return MATCH_ERROR;
2537 }
2538 }
2539 if (cnt > 0
2540 && o != NULL
2541 && (o->state == COMP_OMP_STRUCTURED_BLOCK)
2542 && (o->head->op == EXEC_OMP_DO
2543 || o->head->op == EXEC_OMP_PARALLEL_DO
2544 || o->head->op == EXEC_OMP_SIMD
2545 || o->head->op == EXEC_OMP_DO_SIMD
2546 || o->head->op == EXEC_OMP_PARALLEL_DO_SIMD))
2547 {
2548 int collapse = 1;
2549 gcc_assert (o->head->next != NULL
2550 && (o->head->next->op == EXEC_DO
2551 || o->head->next->op == EXEC_DO_WHILE)
2552 && o->previous != NULL
2553 && o->previous->tail->op == o->head->op);
2554 if (o->previous->tail->ext.omp_clauses != NULL
2555 && o->previous->tail->ext.omp_clauses->collapse > 1)
2556 collapse = o->previous->tail->ext.omp_clauses->collapse;
2557 if (st == ST_EXIT && cnt <= collapse)
2558 {
2559 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2560 return MATCH_ERROR;
2561 }
2562 if (st == ST_CYCLE && cnt < collapse)
2563 {
2564 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2565 " !$OMP DO loop");
2566 return MATCH_ERROR;
2567 }
2568 }
2569
2570 /* Save the first statement in the construct - needed by the backend. */
2571 new_st.ext.which_construct = p->construct;
2572
2573 new_st.op = op;
2574
2575 return MATCH_YES;
2576 }
2577
2578
2579 /* Match the EXIT statement. */
2580
2581 match
2582 gfc_match_exit (void)
2583 {
2584 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
2585 }
2586
2587
2588 /* Match the CYCLE statement. */
2589
2590 match
2591 gfc_match_cycle (void)
2592 {
2593 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
2594 }
2595
2596
2597 /* Match a number or character constant after an (ERROR) STOP or PAUSE
2598 statement. */
2599
2600 static match
2601 gfc_match_stopcode (gfc_statement st)
2602 {
2603 gfc_expr *e;
2604 match m;
2605
2606 e = NULL;
2607
2608 if (gfc_match_eos () != MATCH_YES)
2609 {
2610 m = gfc_match_init_expr (&e);
2611 if (m == MATCH_ERROR)
2612 goto cleanup;
2613 if (m == MATCH_NO)
2614 goto syntax;
2615
2616 if (gfc_match_eos () != MATCH_YES)
2617 goto syntax;
2618 }
2619
2620 if (gfc_pure (NULL))
2621 {
2622 if (st == ST_ERROR_STOP)
2623 {
2624 if (!gfc_notify_std (GFC_STD_F2015, "%s statement at %C in PURE "
2625 "procedure", gfc_ascii_statement (st)))
2626 goto cleanup;
2627 }
2628 else
2629 {
2630 gfc_error ("%s statement not allowed in PURE procedure at %C",
2631 gfc_ascii_statement (st));
2632 goto cleanup;
2633 }
2634 }
2635
2636 gfc_unset_implicit_pure (NULL);
2637
2638 if (st == ST_STOP && gfc_find_state (COMP_CRITICAL))
2639 {
2640 gfc_error ("Image control statement STOP at %C in CRITICAL block");
2641 goto cleanup;
2642 }
2643 if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT))
2644 {
2645 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
2646 goto cleanup;
2647 }
2648
2649 if (e != NULL)
2650 {
2651 if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
2652 {
2653 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2654 &e->where);
2655 goto cleanup;
2656 }
2657
2658 if (e->rank != 0)
2659 {
2660 gfc_error ("STOP code at %L must be scalar",
2661 &e->where);
2662 goto cleanup;
2663 }
2664
2665 if (e->ts.type == BT_CHARACTER
2666 && e->ts.kind != gfc_default_character_kind)
2667 {
2668 gfc_error ("STOP code at %L must be default character KIND=%d",
2669 &e->where, (int) gfc_default_character_kind);
2670 goto cleanup;
2671 }
2672
2673 if (e->ts.type == BT_INTEGER
2674 && e->ts.kind != gfc_default_integer_kind)
2675 {
2676 gfc_error ("STOP code at %L must be default integer KIND=%d",
2677 &e->where, (int) gfc_default_integer_kind);
2678 goto cleanup;
2679 }
2680 }
2681
2682 switch (st)
2683 {
2684 case ST_STOP:
2685 new_st.op = EXEC_STOP;
2686 break;
2687 case ST_ERROR_STOP:
2688 new_st.op = EXEC_ERROR_STOP;
2689 break;
2690 case ST_PAUSE:
2691 new_st.op = EXEC_PAUSE;
2692 break;
2693 default:
2694 gcc_unreachable ();
2695 }
2696
2697 new_st.expr1 = e;
2698 new_st.ext.stop_code = -1;
2699
2700 return MATCH_YES;
2701
2702 syntax:
2703 gfc_syntax_error (st);
2704
2705 cleanup:
2706
2707 gfc_free_expr (e);
2708 return MATCH_ERROR;
2709 }
2710
2711
2712 /* Match the (deprecated) PAUSE statement. */
2713
2714 match
2715 gfc_match_pause (void)
2716 {
2717 match m;
2718
2719 m = gfc_match_stopcode (ST_PAUSE);
2720 if (m == MATCH_YES)
2721 {
2722 if (!gfc_notify_std (GFC_STD_F95_DEL, "PAUSE statement at %C"))
2723 m = MATCH_ERROR;
2724 }
2725 return m;
2726 }
2727
2728
2729 /* Match the STOP statement. */
2730
2731 match
2732 gfc_match_stop (void)
2733 {
2734 return gfc_match_stopcode (ST_STOP);
2735 }
2736
2737
2738 /* Match the ERROR STOP statement. */
2739
2740 match
2741 gfc_match_error_stop (void)
2742 {
2743 if (!gfc_notify_std (GFC_STD_F2008, "ERROR STOP statement at %C"))
2744 return MATCH_ERROR;
2745
2746 return gfc_match_stopcode (ST_ERROR_STOP);
2747 }
2748
2749
2750 /* Match LOCK/UNLOCK statement. Syntax:
2751 LOCK ( lock-variable [ , lock-stat-list ] )
2752 UNLOCK ( lock-variable [ , sync-stat-list ] )
2753 where lock-stat is ACQUIRED_LOCK or sync-stat
2754 and sync-stat is STAT= or ERRMSG=. */
2755
2756 static match
2757 lock_unlock_statement (gfc_statement st)
2758 {
2759 match m;
2760 gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg;
2761 bool saw_acq_lock, saw_stat, saw_errmsg;
2762
2763 tmp = lockvar = acq_lock = stat = errmsg = NULL;
2764 saw_acq_lock = saw_stat = saw_errmsg = false;
2765
2766 if (gfc_pure (NULL))
2767 {
2768 gfc_error ("Image control statement %s at %C in PURE procedure",
2769 st == ST_LOCK ? "LOCK" : "UNLOCK");
2770 return MATCH_ERROR;
2771 }
2772
2773 gfc_unset_implicit_pure (NULL);
2774
2775 if (flag_coarray == GFC_FCOARRAY_NONE)
2776 {
2777 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2778 return MATCH_ERROR;
2779 }
2780
2781 if (gfc_find_state (COMP_CRITICAL))
2782 {
2783 gfc_error ("Image control statement %s at %C in CRITICAL block",
2784 st == ST_LOCK ? "LOCK" : "UNLOCK");
2785 return MATCH_ERROR;
2786 }
2787
2788 if (gfc_find_state (COMP_DO_CONCURRENT))
2789 {
2790 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
2791 st == ST_LOCK ? "LOCK" : "UNLOCK");
2792 return MATCH_ERROR;
2793 }
2794
2795 if (gfc_match_char ('(') != MATCH_YES)
2796 goto syntax;
2797
2798 if (gfc_match ("%e", &lockvar) != MATCH_YES)
2799 goto syntax;
2800 m = gfc_match_char (',');
2801 if (m == MATCH_ERROR)
2802 goto syntax;
2803 if (m == MATCH_NO)
2804 {
2805 m = gfc_match_char (')');
2806 if (m == MATCH_YES)
2807 goto done;
2808 goto syntax;
2809 }
2810
2811 for (;;)
2812 {
2813 m = gfc_match (" stat = %v", &tmp);
2814 if (m == MATCH_ERROR)
2815 goto syntax;
2816 if (m == MATCH_YES)
2817 {
2818 if (saw_stat)
2819 {
2820 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2821 goto cleanup;
2822 }
2823 stat = tmp;
2824 saw_stat = true;
2825
2826 m = gfc_match_char (',');
2827 if (m == MATCH_YES)
2828 continue;
2829
2830 tmp = NULL;
2831 break;
2832 }
2833
2834 m = gfc_match (" errmsg = %v", &tmp);
2835 if (m == MATCH_ERROR)
2836 goto syntax;
2837 if (m == MATCH_YES)
2838 {
2839 if (saw_errmsg)
2840 {
2841 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2842 goto cleanup;
2843 }
2844 errmsg = tmp;
2845 saw_errmsg = true;
2846
2847 m = gfc_match_char (',');
2848 if (m == MATCH_YES)
2849 continue;
2850
2851 tmp = NULL;
2852 break;
2853 }
2854
2855 m = gfc_match (" acquired_lock = %v", &tmp);
2856 if (m == MATCH_ERROR || st == ST_UNLOCK)
2857 goto syntax;
2858 if (m == MATCH_YES)
2859 {
2860 if (saw_acq_lock)
2861 {
2862 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
2863 &tmp->where);
2864 goto cleanup;
2865 }
2866 acq_lock = tmp;
2867 saw_acq_lock = true;
2868
2869 m = gfc_match_char (',');
2870 if (m == MATCH_YES)
2871 continue;
2872
2873 tmp = NULL;
2874 break;
2875 }
2876
2877 break;
2878 }
2879
2880 if (m == MATCH_ERROR)
2881 goto syntax;
2882
2883 if (gfc_match (" )%t") != MATCH_YES)
2884 goto syntax;
2885
2886 done:
2887 switch (st)
2888 {
2889 case ST_LOCK:
2890 new_st.op = EXEC_LOCK;
2891 break;
2892 case ST_UNLOCK:
2893 new_st.op = EXEC_UNLOCK;
2894 break;
2895 default:
2896 gcc_unreachable ();
2897 }
2898
2899 new_st.expr1 = lockvar;
2900 new_st.expr2 = stat;
2901 new_st.expr3 = errmsg;
2902 new_st.expr4 = acq_lock;
2903
2904 return MATCH_YES;
2905
2906 syntax:
2907 gfc_syntax_error (st);
2908
2909 cleanup:
2910 if (acq_lock != tmp)
2911 gfc_free_expr (acq_lock);
2912 if (errmsg != tmp)
2913 gfc_free_expr (errmsg);
2914 if (stat != tmp)
2915 gfc_free_expr (stat);
2916
2917 gfc_free_expr (tmp);
2918 gfc_free_expr (lockvar);
2919
2920 return MATCH_ERROR;
2921 }
2922
2923
2924 match
2925 gfc_match_lock (void)
2926 {
2927 if (!gfc_notify_std (GFC_STD_F2008, "LOCK statement at %C"))
2928 return MATCH_ERROR;
2929
2930 return lock_unlock_statement (ST_LOCK);
2931 }
2932
2933
2934 match
2935 gfc_match_unlock (void)
2936 {
2937 if (!gfc_notify_std (GFC_STD_F2008, "UNLOCK statement at %C"))
2938 return MATCH_ERROR;
2939
2940 return lock_unlock_statement (ST_UNLOCK);
2941 }
2942
2943
2944 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
2945 SYNC ALL [(sync-stat-list)]
2946 SYNC MEMORY [(sync-stat-list)]
2947 SYNC IMAGES (image-set [, sync-stat-list] )
2948 with sync-stat is int-expr or *. */
2949
2950 static match
2951 sync_statement (gfc_statement st)
2952 {
2953 match m;
2954 gfc_expr *tmp, *imageset, *stat, *errmsg;
2955 bool saw_stat, saw_errmsg;
2956
2957 tmp = imageset = stat = errmsg = NULL;
2958 saw_stat = saw_errmsg = false;
2959
2960 if (gfc_pure (NULL))
2961 {
2962 gfc_error ("Image control statement SYNC at %C in PURE procedure");
2963 return MATCH_ERROR;
2964 }
2965
2966 gfc_unset_implicit_pure (NULL);
2967
2968 if (!gfc_notify_std (GFC_STD_F2008, "SYNC statement at %C"))
2969 return MATCH_ERROR;
2970
2971 if (flag_coarray == GFC_FCOARRAY_NONE)
2972 {
2973 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
2974 "enable");
2975 return MATCH_ERROR;
2976 }
2977
2978 if (gfc_find_state (COMP_CRITICAL))
2979 {
2980 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
2981 return MATCH_ERROR;
2982 }
2983
2984 if (gfc_find_state (COMP_DO_CONCURRENT))
2985 {
2986 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
2987 return MATCH_ERROR;
2988 }
2989
2990 if (gfc_match_eos () == MATCH_YES)
2991 {
2992 if (st == ST_SYNC_IMAGES)
2993 goto syntax;
2994 goto done;
2995 }
2996
2997 if (gfc_match_char ('(') != MATCH_YES)
2998 goto syntax;
2999
3000 if (st == ST_SYNC_IMAGES)
3001 {
3002 /* Denote '*' as imageset == NULL. */
3003 m = gfc_match_char ('*');
3004 if (m == MATCH_ERROR)
3005 goto syntax;
3006 if (m == MATCH_NO)
3007 {
3008 if (gfc_match ("%e", &imageset) != MATCH_YES)
3009 goto syntax;
3010 }
3011 m = gfc_match_char (',');
3012 if (m == MATCH_ERROR)
3013 goto syntax;
3014 if (m == MATCH_NO)
3015 {
3016 m = gfc_match_char (')');
3017 if (m == MATCH_YES)
3018 goto done;
3019 goto syntax;
3020 }
3021 }
3022
3023 for (;;)
3024 {
3025 m = gfc_match (" stat = %v", &tmp);
3026 if (m == MATCH_ERROR)
3027 goto syntax;
3028 if (m == MATCH_YES)
3029 {
3030 if (saw_stat)
3031 {
3032 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3033 goto cleanup;
3034 }
3035 stat = tmp;
3036 saw_stat = true;
3037
3038 if (gfc_match_char (',') == MATCH_YES)
3039 continue;
3040
3041 tmp = NULL;
3042 break;
3043 }
3044
3045 m = gfc_match (" errmsg = %v", &tmp);
3046 if (m == MATCH_ERROR)
3047 goto syntax;
3048 if (m == MATCH_YES)
3049 {
3050 if (saw_errmsg)
3051 {
3052 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3053 goto cleanup;
3054 }
3055 errmsg = tmp;
3056 saw_errmsg = true;
3057
3058 if (gfc_match_char (',') == MATCH_YES)
3059 continue;
3060
3061 tmp = NULL;
3062 break;
3063 }
3064
3065 break;
3066 }
3067
3068 if (gfc_match (" )%t") != MATCH_YES)
3069 goto syntax;
3070
3071 done:
3072 switch (st)
3073 {
3074 case ST_SYNC_ALL:
3075 new_st.op = EXEC_SYNC_ALL;
3076 break;
3077 case ST_SYNC_IMAGES:
3078 new_st.op = EXEC_SYNC_IMAGES;
3079 break;
3080 case ST_SYNC_MEMORY:
3081 new_st.op = EXEC_SYNC_MEMORY;
3082 break;
3083 default:
3084 gcc_unreachable ();
3085 }
3086
3087 new_st.expr1 = imageset;
3088 new_st.expr2 = stat;
3089 new_st.expr3 = errmsg;
3090
3091 return MATCH_YES;
3092
3093 syntax:
3094 gfc_syntax_error (st);
3095
3096 cleanup:
3097 if (stat != tmp)
3098 gfc_free_expr (stat);
3099 if (errmsg != tmp)
3100 gfc_free_expr (errmsg);
3101
3102 gfc_free_expr (tmp);
3103 gfc_free_expr (imageset);
3104
3105 return MATCH_ERROR;
3106 }
3107
3108
3109 /* Match SYNC ALL statement. */
3110
3111 match
3112 gfc_match_sync_all (void)
3113 {
3114 return sync_statement (ST_SYNC_ALL);
3115 }
3116
3117
3118 /* Match SYNC IMAGES statement. */
3119
3120 match
3121 gfc_match_sync_images (void)
3122 {
3123 return sync_statement (ST_SYNC_IMAGES);
3124 }
3125
3126
3127 /* Match SYNC MEMORY statement. */
3128
3129 match
3130 gfc_match_sync_memory (void)
3131 {
3132 return sync_statement (ST_SYNC_MEMORY);
3133 }
3134
3135
3136 /* Match a CONTINUE statement. */
3137
3138 match
3139 gfc_match_continue (void)
3140 {
3141 if (gfc_match_eos () != MATCH_YES)
3142 {
3143 gfc_syntax_error (ST_CONTINUE);
3144 return MATCH_ERROR;
3145 }
3146
3147 new_st.op = EXEC_CONTINUE;
3148 return MATCH_YES;
3149 }
3150
3151
3152 /* Match the (deprecated) ASSIGN statement. */
3153
3154 match
3155 gfc_match_assign (void)
3156 {
3157 gfc_expr *expr;
3158 gfc_st_label *label;
3159
3160 if (gfc_match (" %l", &label) == MATCH_YES)
3161 {
3162 if (!gfc_reference_st_label (label, ST_LABEL_UNKNOWN))
3163 return MATCH_ERROR;
3164 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
3165 {
3166 if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGN statement at %C"))
3167 return MATCH_ERROR;
3168
3169 expr->symtree->n.sym->attr.assign = 1;
3170
3171 new_st.op = EXEC_LABEL_ASSIGN;
3172 new_st.label1 = label;
3173 new_st.expr1 = expr;
3174 return MATCH_YES;
3175 }
3176 }
3177 return MATCH_NO;
3178 }
3179
3180
3181 /* Match the GO TO statement. As a computed GOTO statement is
3182 matched, it is transformed into an equivalent SELECT block. No
3183 tree is necessary, and the resulting jumps-to-jumps are
3184 specifically optimized away by the back end. */
3185
3186 match
3187 gfc_match_goto (void)
3188 {
3189 gfc_code *head, *tail;
3190 gfc_expr *expr;
3191 gfc_case *cp;
3192 gfc_st_label *label;
3193 int i;
3194 match m;
3195
3196 if (gfc_match (" %l%t", &label) == MATCH_YES)
3197 {
3198 if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
3199 return MATCH_ERROR;
3200
3201 new_st.op = EXEC_GOTO;
3202 new_st.label1 = label;
3203 return MATCH_YES;
3204 }
3205
3206 /* The assigned GO TO statement. */
3207
3208 if (gfc_match_variable (&expr, 0) == MATCH_YES)
3209 {
3210 if (!gfc_notify_std (GFC_STD_F95_DEL, "Assigned GOTO statement at %C"))
3211 return MATCH_ERROR;
3212
3213 new_st.op = EXEC_GOTO;
3214 new_st.expr1 = expr;
3215
3216 if (gfc_match_eos () == MATCH_YES)
3217 return MATCH_YES;
3218
3219 /* Match label list. */
3220 gfc_match_char (',');
3221 if (gfc_match_char ('(') != MATCH_YES)
3222 {
3223 gfc_syntax_error (ST_GOTO);
3224 return MATCH_ERROR;
3225 }
3226 head = tail = NULL;
3227
3228 do
3229 {
3230 m = gfc_match_st_label (&label);
3231 if (m != MATCH_YES)
3232 goto syntax;
3233
3234 if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
3235 goto cleanup;
3236
3237 if (head == NULL)
3238 head = tail = gfc_get_code (EXEC_GOTO);
3239 else
3240 {
3241 tail->block = gfc_get_code (EXEC_GOTO);
3242 tail = tail->block;
3243 }
3244
3245 tail->label1 = label;
3246 }
3247 while (gfc_match_char (',') == MATCH_YES);
3248
3249 if (gfc_match (")%t") != MATCH_YES)
3250 goto syntax;
3251
3252 if (head == NULL)
3253 {
3254 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3255 goto syntax;
3256 }
3257 new_st.block = head;
3258
3259 return MATCH_YES;
3260 }
3261
3262 /* Last chance is a computed GO TO statement. */
3263 if (gfc_match_char ('(') != MATCH_YES)
3264 {
3265 gfc_syntax_error (ST_GOTO);
3266 return MATCH_ERROR;
3267 }
3268
3269 head = tail = NULL;
3270 i = 1;
3271
3272 do
3273 {
3274 m = gfc_match_st_label (&label);
3275 if (m != MATCH_YES)
3276 goto syntax;
3277
3278 if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
3279 goto cleanup;
3280
3281 if (head == NULL)
3282 head = tail = gfc_get_code (EXEC_SELECT);
3283 else
3284 {
3285 tail->block = gfc_get_code (EXEC_SELECT);
3286 tail = tail->block;
3287 }
3288
3289 cp = gfc_get_case ();
3290 cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
3291 NULL, i++);
3292
3293 tail->ext.block.case_list = cp;
3294
3295 tail->next = gfc_get_code (EXEC_GOTO);
3296 tail->next->label1 = label;
3297 }
3298 while (gfc_match_char (',') == MATCH_YES);
3299
3300 if (gfc_match_char (')') != MATCH_YES)
3301 goto syntax;
3302
3303 if (head == NULL)
3304 {
3305 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3306 goto syntax;
3307 }
3308
3309 /* Get the rest of the statement. */
3310 gfc_match_char (',');
3311
3312 if (gfc_match (" %e%t", &expr) != MATCH_YES)
3313 goto syntax;
3314
3315 if (!gfc_notify_std (GFC_STD_F95_OBS, "Computed GOTO at %C"))
3316 return MATCH_ERROR;
3317
3318 /* At this point, a computed GOTO has been fully matched and an
3319 equivalent SELECT statement constructed. */
3320
3321 new_st.op = EXEC_SELECT;
3322 new_st.expr1 = NULL;
3323
3324 /* Hack: For a "real" SELECT, the expression is in expr. We put
3325 it in expr2 so we can distinguish then and produce the correct
3326 diagnostics. */
3327 new_st.expr2 = expr;
3328 new_st.block = head;
3329 return MATCH_YES;
3330
3331 syntax:
3332 gfc_syntax_error (ST_GOTO);
3333 cleanup:
3334 gfc_free_statements (head);
3335 return MATCH_ERROR;
3336 }
3337
3338
3339 /* Frees a list of gfc_alloc structures. */
3340
3341 void
3342 gfc_free_alloc_list (gfc_alloc *p)
3343 {
3344 gfc_alloc *q;
3345
3346 for (; p; p = q)
3347 {
3348 q = p->next;
3349 gfc_free_expr (p->expr);
3350 free (p);
3351 }
3352 }
3353
3354
3355 /* Match an ALLOCATE statement. */
3356
3357 match
3358 gfc_match_allocate (void)
3359 {
3360 gfc_alloc *head, *tail;
3361 gfc_expr *stat, *errmsg, *tmp, *source, *mold;
3362 gfc_typespec ts;
3363 gfc_symbol *sym;
3364 match m;
3365 locus old_locus, deferred_locus;
3366 bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
3367 bool saw_unlimited = false;
3368
3369 head = tail = NULL;
3370 stat = errmsg = source = mold = tmp = NULL;
3371 saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
3372
3373 if (gfc_match_char ('(') != MATCH_YES)
3374 goto syntax;
3375
3376 /* Match an optional type-spec. */
3377 old_locus = gfc_current_locus;
3378 m = gfc_match_type_spec (&ts);
3379 if (m == MATCH_ERROR)
3380 goto cleanup;
3381 else if (m == MATCH_NO)
3382 {
3383 char name[GFC_MAX_SYMBOL_LEN + 3];
3384
3385 if (gfc_match ("%n :: ", name) == MATCH_YES)
3386 {
3387 gfc_error ("Error in type-spec at %L", &old_locus);
3388 goto cleanup;
3389 }
3390
3391 ts.type = BT_UNKNOWN;
3392 }
3393 else
3394 {
3395 if (gfc_match (" :: ") == MATCH_YES)
3396 {
3397 if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L",
3398 &old_locus))
3399 goto cleanup;
3400
3401 if (ts.deferred)
3402 {
3403 gfc_error ("Type-spec at %L cannot contain a deferred "
3404 "type parameter", &old_locus);
3405 goto cleanup;
3406 }
3407
3408 if (ts.type == BT_CHARACTER)
3409 ts.u.cl->length_from_typespec = true;
3410 }
3411 else
3412 {
3413 ts.type = BT_UNKNOWN;
3414 gfc_current_locus = old_locus;
3415 }
3416 }
3417
3418 for (;;)
3419 {
3420 if (head == NULL)
3421 head = tail = gfc_get_alloc ();
3422 else
3423 {
3424 tail->next = gfc_get_alloc ();
3425 tail = tail->next;
3426 }
3427
3428 m = gfc_match_variable (&tail->expr, 0);
3429 if (m == MATCH_NO)
3430 goto syntax;
3431 if (m == MATCH_ERROR)
3432 goto cleanup;
3433
3434 if (gfc_check_do_variable (tail->expr->symtree))
3435 goto cleanup;
3436
3437 bool impure = gfc_impure_variable (tail->expr->symtree->n.sym);
3438 if (impure && gfc_pure (NULL))
3439 {
3440 gfc_error ("Bad allocate-object at %C for a PURE procedure");
3441 goto cleanup;
3442 }
3443
3444 if (impure)
3445 gfc_unset_implicit_pure (NULL);
3446
3447 if (tail->expr->ts.deferred)
3448 {
3449 saw_deferred = true;
3450 deferred_locus = tail->expr->where;
3451 }
3452
3453 if (gfc_find_state (COMP_DO_CONCURRENT)
3454 || gfc_find_state (COMP_CRITICAL))
3455 {
3456 gfc_ref *ref;
3457 bool coarray = tail->expr->symtree->n.sym->attr.codimension;
3458 for (ref = tail->expr->ref; ref; ref = ref->next)
3459 if (ref->type == REF_COMPONENT)
3460 coarray = ref->u.c.component->attr.codimension;
3461
3462 if (coarray && gfc_find_state (COMP_DO_CONCURRENT))
3463 {
3464 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
3465 goto cleanup;
3466 }
3467 if (coarray && gfc_find_state (COMP_CRITICAL))
3468 {
3469 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
3470 goto cleanup;
3471 }
3472 }
3473
3474 /* Check for F08:C628. */
3475 sym = tail->expr->symtree->n.sym;
3476 b1 = !(tail->expr->ref
3477 && (tail->expr->ref->type == REF_COMPONENT
3478 || tail->expr->ref->type == REF_ARRAY));
3479 if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok)
3480 b2 = !(CLASS_DATA (sym)->attr.allocatable
3481 || CLASS_DATA (sym)->attr.class_pointer);
3482 else
3483 b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
3484 || sym->attr.proc_pointer);
3485 b3 = sym && sym->ns && sym->ns->proc_name
3486 && (sym->ns->proc_name->attr.allocatable
3487 || sym->ns->proc_name->attr.pointer
3488 || sym->ns->proc_name->attr.proc_pointer);
3489 if (b1 && b2 && !b3)
3490 {
3491 gfc_error ("Allocate-object at %L is neither a data pointer "
3492 "nor an allocatable variable", &tail->expr->where);
3493 goto cleanup;
3494 }
3495
3496 /* The ALLOCATE statement had an optional typespec. Check the
3497 constraints. */
3498 if (ts.type != BT_UNKNOWN)
3499 {
3500 /* Enforce F03:C624. */
3501 if (!gfc_type_compatible (&tail->expr->ts, &ts))
3502 {
3503 gfc_error ("Type of entity at %L is type incompatible with "
3504 "typespec", &tail->expr->where);
3505 goto cleanup;
3506 }
3507
3508 /* Enforce F03:C627. */
3509 if (ts.kind != tail->expr->ts.kind && !UNLIMITED_POLY (tail->expr))
3510 {
3511 gfc_error ("Kind type parameter for entity at %L differs from "
3512 "the kind type parameter of the typespec",
3513 &tail->expr->where);
3514 goto cleanup;
3515 }
3516 }
3517
3518 if (tail->expr->ts.type == BT_DERIVED)
3519 tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
3520
3521 saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr);
3522
3523 if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
3524 {
3525 gfc_error ("Shape specification for allocatable scalar at %C");
3526 goto cleanup;
3527 }
3528
3529 if (gfc_match_char (',') != MATCH_YES)
3530 break;
3531
3532 alloc_opt_list:
3533
3534 m = gfc_match (" stat = %v", &tmp);
3535 if (m == MATCH_ERROR)
3536 goto cleanup;
3537 if (m == MATCH_YES)
3538 {
3539 /* Enforce C630. */
3540 if (saw_stat)
3541 {
3542 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3543 goto cleanup;
3544 }
3545
3546 stat = tmp;
3547 tmp = NULL;
3548 saw_stat = true;
3549
3550 if (gfc_check_do_variable (stat->symtree))
3551 goto cleanup;
3552
3553 if (gfc_match_char (',') == MATCH_YES)
3554 goto alloc_opt_list;
3555 }
3556
3557 m = gfc_match (" errmsg = %v", &tmp);
3558 if (m == MATCH_ERROR)
3559 goto cleanup;
3560 if (m == MATCH_YES)
3561 {
3562 if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG tag at %L", &tmp->where))
3563 goto cleanup;
3564
3565 /* Enforce C630. */
3566 if (saw_errmsg)
3567 {
3568 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3569 goto cleanup;
3570 }
3571
3572 errmsg = tmp;
3573 tmp = NULL;
3574 saw_errmsg = true;
3575
3576 if (gfc_match_char (',') == MATCH_YES)
3577 goto alloc_opt_list;
3578 }
3579
3580 m = gfc_match (" source = %e", &tmp);
3581 if (m == MATCH_ERROR)
3582 goto cleanup;
3583 if (m == MATCH_YES)
3584 {
3585 if (!gfc_notify_std (GFC_STD_F2003, "SOURCE tag at %L", &tmp->where))
3586 goto cleanup;
3587
3588 /* Enforce C630. */
3589 if (saw_source)
3590 {
3591 gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
3592 goto cleanup;
3593 }
3594
3595 /* The next 2 conditionals check C631. */
3596 if (ts.type != BT_UNKNOWN)
3597 {
3598 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
3599 &tmp->where, &old_locus);
3600 goto cleanup;
3601 }
3602
3603 if (head->next
3604 && !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L"
3605 " with more than a single allocate object",
3606 &tmp->where))
3607 goto cleanup;
3608
3609 source = tmp;
3610 tmp = NULL;
3611 saw_source = true;
3612
3613 if (gfc_match_char (',') == MATCH_YES)
3614 goto alloc_opt_list;
3615 }
3616
3617 m = gfc_match (" mold = %e", &tmp);
3618 if (m == MATCH_ERROR)
3619 goto cleanup;
3620 if (m == MATCH_YES)
3621 {
3622 if (!gfc_notify_std (GFC_STD_F2008, "MOLD tag at %L", &tmp->where))
3623 goto cleanup;
3624
3625 /* Check F08:C636. */
3626 if (saw_mold)
3627 {
3628 gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
3629 goto cleanup;
3630 }
3631
3632 /* Check F08:C637. */
3633 if (ts.type != BT_UNKNOWN)
3634 {
3635 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
3636 &tmp->where, &old_locus);
3637 goto cleanup;
3638 }
3639
3640 mold = tmp;
3641 tmp = NULL;
3642 saw_mold = true;
3643 mold->mold = 1;
3644
3645 if (gfc_match_char (',') == MATCH_YES)
3646 goto alloc_opt_list;
3647 }
3648
3649 gfc_gobble_whitespace ();
3650
3651 if (gfc_peek_char () == ')')
3652 break;
3653 }
3654
3655 if (gfc_match (" )%t") != MATCH_YES)
3656 goto syntax;
3657
3658 /* Check F08:C637. */
3659 if (source && mold)
3660 {
3661 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
3662 &mold->where, &source->where);
3663 goto cleanup;
3664 }
3665
3666 /* Check F03:C623, */
3667 if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold)
3668 {
3669 gfc_error ("Allocate-object at %L with a deferred type parameter "
3670 "requires either a type-spec or SOURCE tag or a MOLD tag",
3671 &deferred_locus);
3672 goto cleanup;
3673 }
3674
3675 /* Check F03:C625, */
3676 if (saw_unlimited && ts.type == BT_UNKNOWN && !source && !mold)
3677 {
3678 for (tail = head; tail; tail = tail->next)
3679 {
3680 if (UNLIMITED_POLY (tail->expr))
3681 gfc_error ("Unlimited polymorphic allocate-object at %L "
3682 "requires either a type-spec or SOURCE tag "
3683 "or a MOLD tag", &tail->expr->where);
3684 }
3685 goto cleanup;
3686 }
3687
3688 new_st.op = EXEC_ALLOCATE;
3689 new_st.expr1 = stat;
3690 new_st.expr2 = errmsg;
3691 if (source)
3692 new_st.expr3 = source;
3693 else
3694 new_st.expr3 = mold;
3695 new_st.ext.alloc.list = head;
3696 new_st.ext.alloc.ts = ts;
3697
3698 return MATCH_YES;
3699
3700 syntax:
3701 gfc_syntax_error (ST_ALLOCATE);
3702
3703 cleanup:
3704 gfc_free_expr (errmsg);
3705 gfc_free_expr (source);
3706 gfc_free_expr (stat);
3707 gfc_free_expr (mold);
3708 if (tmp && tmp->expr_type) gfc_free_expr (tmp);
3709 gfc_free_alloc_list (head);
3710 return MATCH_ERROR;
3711 }
3712
3713
3714 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
3715 a set of pointer assignments to intrinsic NULL(). */
3716
3717 match
3718 gfc_match_nullify (void)
3719 {
3720 gfc_code *tail;
3721 gfc_expr *e, *p;
3722 match m;
3723
3724 tail = NULL;
3725
3726 if (gfc_match_char ('(') != MATCH_YES)
3727 goto syntax;
3728
3729 for (;;)
3730 {
3731 m = gfc_match_variable (&p, 0);
3732 if (m == MATCH_ERROR)
3733 goto cleanup;
3734 if (m == MATCH_NO)
3735 goto syntax;
3736
3737 if (gfc_check_do_variable (p->symtree))
3738 goto cleanup;
3739
3740 /* F2008, C1242. */
3741 if (gfc_is_coindexed (p))
3742 {
3743 gfc_error ("Pointer object at %C shall not be coindexed");
3744 goto cleanup;
3745 }
3746
3747 /* build ' => NULL() '. */
3748 e = gfc_get_null_expr (&gfc_current_locus);
3749
3750 /* Chain to list. */
3751 if (tail == NULL)
3752 {
3753 tail = &new_st;
3754 tail->op = EXEC_POINTER_ASSIGN;
3755 }
3756 else
3757 {
3758 tail->next = gfc_get_code (EXEC_POINTER_ASSIGN);
3759 tail = tail->next;
3760 }
3761
3762 tail->expr1 = p;
3763 tail->expr2 = e;
3764
3765 if (gfc_match (" )%t") == MATCH_YES)
3766 break;
3767 if (gfc_match_char (',') != MATCH_YES)
3768 goto syntax;
3769 }
3770
3771 return MATCH_YES;
3772
3773 syntax:
3774 gfc_syntax_error (ST_NULLIFY);
3775
3776 cleanup:
3777 gfc_free_statements (new_st.next);
3778 new_st.next = NULL;
3779 gfc_free_expr (new_st.expr1);
3780 new_st.expr1 = NULL;
3781 gfc_free_expr (new_st.expr2);
3782 new_st.expr2 = NULL;
3783 return MATCH_ERROR;
3784 }
3785
3786
3787 /* Match a DEALLOCATE statement. */
3788
3789 match
3790 gfc_match_deallocate (void)
3791 {
3792 gfc_alloc *head, *tail;
3793 gfc_expr *stat, *errmsg, *tmp;
3794 gfc_symbol *sym;
3795 match m;
3796 bool saw_stat, saw_errmsg, b1, b2;
3797
3798 head = tail = NULL;
3799 stat = errmsg = tmp = NULL;
3800 saw_stat = saw_errmsg = false;
3801
3802 if (gfc_match_char ('(') != MATCH_YES)
3803 goto syntax;
3804
3805 for (;;)
3806 {
3807 if (head == NULL)
3808 head = tail = gfc_get_alloc ();
3809 else
3810 {
3811 tail->next = gfc_get_alloc ();
3812 tail = tail->next;
3813 }
3814
3815 m = gfc_match_variable (&tail->expr, 0);
3816 if (m == MATCH_ERROR)
3817 goto cleanup;
3818 if (m == MATCH_NO)
3819 goto syntax;
3820
3821 if (gfc_check_do_variable (tail->expr->symtree))
3822 goto cleanup;
3823
3824 sym = tail->expr->symtree->n.sym;
3825
3826 bool impure = gfc_impure_variable (sym);
3827 if (impure && gfc_pure (NULL))
3828 {
3829 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3830 goto cleanup;
3831 }
3832
3833 if (impure)
3834 gfc_unset_implicit_pure (NULL);
3835
3836 if (gfc_is_coarray (tail->expr)
3837 && gfc_find_state (COMP_DO_CONCURRENT))
3838 {
3839 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
3840 goto cleanup;
3841 }
3842
3843 if (gfc_is_coarray (tail->expr)
3844 && gfc_find_state (COMP_CRITICAL))
3845 {
3846 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
3847 goto cleanup;
3848 }
3849
3850 /* FIXME: disable the checking on derived types. */
3851 b1 = !(tail->expr->ref
3852 && (tail->expr->ref->type == REF_COMPONENT
3853 || tail->expr->ref->type == REF_ARRAY));
3854 if (sym && sym->ts.type == BT_CLASS)
3855 b2 = !(CLASS_DATA (sym)->attr.allocatable
3856 || CLASS_DATA (sym)->attr.class_pointer);
3857 else
3858 b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
3859 || sym->attr.proc_pointer);
3860 if (b1 && b2)
3861 {
3862 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3863 "nor an allocatable variable");
3864 goto cleanup;
3865 }
3866
3867 if (gfc_match_char (',') != MATCH_YES)
3868 break;
3869
3870 dealloc_opt_list:
3871
3872 m = gfc_match (" stat = %v", &tmp);
3873 if (m == MATCH_ERROR)
3874 goto cleanup;
3875 if (m == MATCH_YES)
3876 {
3877 if (saw_stat)
3878 {
3879 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3880 gfc_free_expr (tmp);
3881 goto cleanup;
3882 }
3883
3884 stat = tmp;
3885 saw_stat = true;
3886
3887 if (gfc_check_do_variable (stat->symtree))
3888 goto cleanup;
3889
3890 if (gfc_match_char (',') == MATCH_YES)
3891 goto dealloc_opt_list;
3892 }
3893
3894 m = gfc_match (" errmsg = %v", &tmp);
3895 if (m == MATCH_ERROR)
3896 goto cleanup;
3897 if (m == MATCH_YES)
3898 {
3899 if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG at %L", &tmp->where))
3900 goto cleanup;
3901
3902 if (saw_errmsg)
3903 {
3904 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3905 gfc_free_expr (tmp);
3906 goto cleanup;
3907 }
3908
3909 errmsg = tmp;
3910 saw_errmsg = true;
3911
3912 if (gfc_match_char (',') == MATCH_YES)
3913 goto dealloc_opt_list;
3914 }
3915
3916 gfc_gobble_whitespace ();
3917
3918 if (gfc_peek_char () == ')')
3919 break;
3920 }
3921
3922 if (gfc_match (" )%t") != MATCH_YES)
3923 goto syntax;
3924
3925 new_st.op = EXEC_DEALLOCATE;
3926 new_st.expr1 = stat;
3927 new_st.expr2 = errmsg;
3928 new_st.ext.alloc.list = head;
3929
3930 return MATCH_YES;
3931
3932 syntax:
3933 gfc_syntax_error (ST_DEALLOCATE);
3934
3935 cleanup:
3936 gfc_free_expr (errmsg);
3937 gfc_free_expr (stat);
3938 gfc_free_alloc_list (head);
3939 return MATCH_ERROR;
3940 }
3941
3942
3943 /* Match a RETURN statement. */
3944
3945 match
3946 gfc_match_return (void)
3947 {
3948 gfc_expr *e;
3949 match m;
3950 gfc_compile_state s;
3951
3952 e = NULL;
3953
3954 if (gfc_find_state (COMP_CRITICAL))
3955 {
3956 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
3957 return MATCH_ERROR;
3958 }
3959
3960 if (gfc_find_state (COMP_DO_CONCURRENT))
3961 {
3962 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
3963 return MATCH_ERROR;
3964 }
3965
3966 if (gfc_match_eos () == MATCH_YES)
3967 goto done;
3968
3969 if (!gfc_find_state (COMP_SUBROUTINE))
3970 {
3971 gfc_error ("Alternate RETURN statement at %C is only allowed within "
3972 "a SUBROUTINE");
3973 goto cleanup;
3974 }
3975
3976 if (gfc_current_form == FORM_FREE)
3977 {
3978 /* The following are valid, so we can't require a blank after the
3979 RETURN keyword:
3980 return+1
3981 return(1) */
3982 char c = gfc_peek_ascii_char ();
3983 if (ISALPHA (c) || ISDIGIT (c))
3984 return MATCH_NO;
3985 }
3986
3987 m = gfc_match (" %e%t", &e);
3988 if (m == MATCH_YES)
3989 goto done;
3990 if (m == MATCH_ERROR)
3991 goto cleanup;
3992
3993 gfc_syntax_error (ST_RETURN);
3994
3995 cleanup:
3996 gfc_free_expr (e);
3997 return MATCH_ERROR;
3998
3999 done:
4000 gfc_enclosing_unit (&s);
4001 if (s == COMP_PROGRAM
4002 && !gfc_notify_std (GFC_STD_GNU, "RETURN statement in "
4003 "main program at %C"))
4004 return MATCH_ERROR;
4005
4006 new_st.op = EXEC_RETURN;
4007 new_st.expr1 = e;
4008
4009 return MATCH_YES;
4010 }
4011
4012
4013 /* Match the call of a type-bound procedure, if CALL%var has already been
4014 matched and var found to be a derived-type variable. */
4015
4016 static match
4017 match_typebound_call (gfc_symtree* varst)
4018 {
4019 gfc_expr* base;
4020 match m;
4021
4022 base = gfc_get_expr ();
4023 base->expr_type = EXPR_VARIABLE;
4024 base->symtree = varst;
4025 base->where = gfc_current_locus;
4026 gfc_set_sym_referenced (varst->n.sym);
4027
4028 m = gfc_match_varspec (base, 0, true, true);
4029 if (m == MATCH_NO)
4030 gfc_error ("Expected component reference at %C");
4031 if (m != MATCH_YES)
4032 {
4033 gfc_free_expr (base);
4034 return MATCH_ERROR;
4035 }
4036
4037 if (gfc_match_eos () != MATCH_YES)
4038 {
4039 gfc_error ("Junk after CALL at %C");
4040 gfc_free_expr (base);
4041 return MATCH_ERROR;
4042 }
4043
4044 if (base->expr_type == EXPR_COMPCALL)
4045 new_st.op = EXEC_COMPCALL;
4046 else if (base->expr_type == EXPR_PPC)
4047 new_st.op = EXEC_CALL_PPC;
4048 else
4049 {
4050 gfc_error ("Expected type-bound procedure or procedure pointer component "
4051 "at %C");
4052 gfc_free_expr (base);
4053 return MATCH_ERROR;
4054 }
4055 new_st.expr1 = base;
4056
4057 return MATCH_YES;
4058 }
4059
4060
4061 /* Match a CALL statement. The tricky part here are possible
4062 alternate return specifiers. We handle these by having all
4063 "subroutines" actually return an integer via a register that gives
4064 the return number. If the call specifies alternate returns, we
4065 generate code for a SELECT statement whose case clauses contain
4066 GOTOs to the various labels. */
4067
4068 match
4069 gfc_match_call (void)
4070 {
4071 char name[GFC_MAX_SYMBOL_LEN + 1];
4072 gfc_actual_arglist *a, *arglist;
4073 gfc_case *new_case;
4074 gfc_symbol *sym;
4075 gfc_symtree *st;
4076 gfc_code *c;
4077 match m;
4078 int i;
4079
4080 arglist = NULL;
4081
4082 m = gfc_match ("% %n", name);
4083 if (m == MATCH_NO)
4084 goto syntax;
4085 if (m != MATCH_YES)
4086 return m;
4087
4088 if (gfc_get_ha_sym_tree (name, &st))
4089 return MATCH_ERROR;
4090
4091 sym = st->n.sym;
4092
4093 /* If this is a variable of derived-type, it probably starts a type-bound
4094 procedure call. */
4095 if ((sym->attr.flavor != FL_PROCEDURE
4096 || gfc_is_function_return_value (sym, gfc_current_ns))
4097 && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
4098 return match_typebound_call (st);
4099
4100 /* If it does not seem to be callable (include functions so that the
4101 right association is made. They are thrown out in resolution.)
4102 ... */
4103 if (!sym->attr.generic
4104 && !sym->attr.subroutine
4105 && !sym->attr.function)
4106 {
4107 if (!(sym->attr.external && !sym->attr.referenced))
4108 {
4109 /* ...create a symbol in this scope... */
4110 if (sym->ns != gfc_current_ns
4111 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
4112 return MATCH_ERROR;
4113
4114 if (sym != st->n.sym)
4115 sym = st->n.sym;
4116 }
4117
4118 /* ...and then to try to make the symbol into a subroutine. */
4119 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
4120 return MATCH_ERROR;
4121 }
4122
4123 gfc_set_sym_referenced (sym);
4124
4125 if (gfc_match_eos () != MATCH_YES)
4126 {
4127 m = gfc_match_actual_arglist (1, &arglist);
4128 if (m == MATCH_NO)
4129 goto syntax;
4130 if (m == MATCH_ERROR)
4131 goto cleanup;
4132
4133 if (gfc_match_eos () != MATCH_YES)
4134 goto syntax;
4135 }
4136
4137 /* If any alternate return labels were found, construct a SELECT
4138 statement that will jump to the right place. */
4139
4140 i = 0;
4141 for (a = arglist; a; a = a->next)
4142 if (a->expr == NULL)
4143 {
4144 i = 1;
4145 break;
4146 }
4147
4148 if (i)
4149 {
4150 gfc_symtree *select_st;
4151 gfc_symbol *select_sym;
4152 char name[GFC_MAX_SYMBOL_LEN + 1];
4153
4154 new_st.next = c = gfc_get_code (EXEC_SELECT);
4155 sprintf (name, "_result_%s", sym->name);
4156 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
4157
4158 select_sym = select_st->n.sym;
4159 select_sym->ts.type = BT_INTEGER;
4160 select_sym->ts.kind = gfc_default_integer_kind;
4161 gfc_set_sym_referenced (select_sym);
4162 c->expr1 = gfc_get_expr ();
4163 c->expr1->expr_type = EXPR_VARIABLE;
4164 c->expr1->symtree = select_st;
4165 c->expr1->ts = select_sym->ts;
4166 c->expr1->where = gfc_current_locus;
4167
4168 i = 0;
4169 for (a = arglist; a; a = a->next)
4170 {
4171 if (a->expr != NULL)
4172 continue;
4173
4174 if (!gfc_reference_st_label (a->label, ST_LABEL_TARGET))
4175 continue;
4176
4177 i++;
4178
4179 c->block = gfc_get_code (EXEC_SELECT);
4180 c = c->block;
4181
4182 new_case = gfc_get_case ();
4183 new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
4184 new_case->low = new_case->high;
4185 c->ext.block.case_list = new_case;
4186
4187 c->next = gfc_get_code (EXEC_GOTO);
4188 c->next->label1 = a->label;
4189 }
4190 }
4191
4192 new_st.op = EXEC_CALL;
4193 new_st.symtree = st;
4194 new_st.ext.actual = arglist;
4195
4196 return MATCH_YES;
4197
4198 syntax:
4199 gfc_syntax_error (ST_CALL);
4200
4201 cleanup:
4202 gfc_free_actual_arglist (arglist);
4203 return MATCH_ERROR;
4204 }
4205
4206
4207 /* Given a name, return a pointer to the common head structure,
4208 creating it if it does not exist. If FROM_MODULE is nonzero, we
4209 mangle the name so that it doesn't interfere with commons defined
4210 in the using namespace.
4211 TODO: Add to global symbol tree. */
4212
4213 gfc_common_head *
4214 gfc_get_common (const char *name, int from_module)
4215 {
4216 gfc_symtree *st;
4217 static int serial = 0;
4218 char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
4219
4220 if (from_module)
4221 {
4222 /* A use associated common block is only needed to correctly layout
4223 the variables it contains. */
4224 snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
4225 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
4226 }
4227 else
4228 {
4229 st = gfc_find_symtree (gfc_current_ns->common_root, name);
4230
4231 if (st == NULL)
4232 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
4233 }
4234
4235 if (st->n.common == NULL)
4236 {
4237 st->n.common = gfc_get_common_head ();
4238 st->n.common->where = gfc_current_locus;
4239 strcpy (st->n.common->name, name);
4240 }
4241
4242 return st->n.common;
4243 }
4244
4245
4246 /* Match a common block name. */
4247
4248 match match_common_name (char *name)
4249 {
4250 match m;
4251
4252 if (gfc_match_char ('/') == MATCH_NO)
4253 {
4254 name[0] = '\0';
4255 return MATCH_YES;
4256 }
4257
4258 if (gfc_match_char ('/') == MATCH_YES)
4259 {
4260 name[0] = '\0';
4261 return MATCH_YES;
4262 }
4263
4264 m = gfc_match_name (name);
4265
4266 if (m == MATCH_ERROR)
4267 return MATCH_ERROR;
4268 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
4269 return MATCH_YES;
4270
4271 gfc_error ("Syntax error in common block name at %C");
4272 return MATCH_ERROR;
4273 }
4274
4275
4276 /* Match a COMMON statement. */
4277
4278 match
4279 gfc_match_common (void)
4280 {
4281 gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
4282 char name[GFC_MAX_SYMBOL_LEN + 1];
4283 gfc_common_head *t;
4284 gfc_array_spec *as;
4285 gfc_equiv *e1, *e2;
4286 match m;
4287
4288 old_blank_common = gfc_current_ns->blank_common.head;
4289 if (old_blank_common)
4290 {
4291 while (old_blank_common->common_next)
4292 old_blank_common = old_blank_common->common_next;
4293 }
4294
4295 as = NULL;
4296
4297 for (;;)
4298 {
4299 m = match_common_name (name);
4300 if (m == MATCH_ERROR)
4301 goto cleanup;
4302
4303 if (name[0] == '\0')
4304 {
4305 t = &gfc_current_ns->blank_common;
4306 if (t->head == NULL)
4307 t->where = gfc_current_locus;
4308 }
4309 else
4310 {
4311 t = gfc_get_common (name, 0);
4312 }
4313 head = &t->head;
4314
4315 if (*head == NULL)
4316 tail = NULL;
4317 else
4318 {
4319 tail = *head;
4320 while (tail->common_next)
4321 tail = tail->common_next;
4322 }
4323
4324 /* Grab the list of symbols. */
4325 for (;;)
4326 {
4327 m = gfc_match_symbol (&sym, 0);
4328 if (m == MATCH_ERROR)
4329 goto cleanup;
4330 if (m == MATCH_NO)
4331 goto syntax;
4332
4333 /* Store a ref to the common block for error checking. */
4334 sym->common_block = t;
4335 sym->common_block->refs++;
4336
4337 /* See if we know the current common block is bind(c), and if
4338 so, then see if we can check if the symbol is (which it'll
4339 need to be). This can happen if the bind(c) attr stmt was
4340 applied to the common block, and the variable(s) already
4341 defined, before declaring the common block. */
4342 if (t->is_bind_c == 1)
4343 {
4344 if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
4345 {
4346 /* If we find an error, just print it and continue,
4347 cause it's just semantic, and we can see if there
4348 are more errors. */
4349 gfc_error_now ("Variable %qs at %L in common block %qs "
4350 "at %C must be declared with a C "
4351 "interoperable kind since common block "
4352 "%qs is bind(c)",
4353 sym->name, &(sym->declared_at), t->name,
4354 t->name);
4355 }
4356
4357 if (sym->attr.is_bind_c == 1)
4358 gfc_error_now ("Variable %qs in common block %qs at %C can not "
4359 "be bind(c) since it is not global", sym->name,
4360 t->name);
4361 }
4362
4363 if (sym->attr.in_common)
4364 {
4365 gfc_error ("Symbol %qs at %C is already in a COMMON block",
4366 sym->name);
4367 goto cleanup;
4368 }
4369
4370 if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
4371 || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
4372 {
4373 if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol %qs at "
4374 "%C can only be COMMON in BLOCK DATA",
4375 sym->name))
4376 goto cleanup;
4377 }
4378
4379 if (!gfc_add_in_common (&sym->attr, sym->name, NULL))
4380 goto cleanup;
4381
4382 if (tail != NULL)
4383 tail->common_next = sym;
4384 else
4385 *head = sym;
4386
4387 tail = sym;
4388
4389 /* Deal with an optional array specification after the
4390 symbol name. */
4391 m = gfc_match_array_spec (&as, true, true);
4392 if (m == MATCH_ERROR)
4393 goto cleanup;
4394
4395 if (m == MATCH_YES)
4396 {
4397 if (as->type != AS_EXPLICIT)
4398 {
4399 gfc_error ("Array specification for symbol %qs in COMMON "
4400 "at %C must be explicit", sym->name);
4401 goto cleanup;
4402 }
4403
4404 if (!gfc_add_dimension (&sym->attr, sym->name, NULL))
4405 goto cleanup;
4406
4407 if (sym->attr.pointer)
4408 {
4409 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
4410 "POINTER array", sym->name);
4411 goto cleanup;
4412 }
4413
4414 sym->as = as;
4415 as = NULL;
4416
4417 }
4418
4419 sym->common_head = t;
4420
4421 /* Check to see if the symbol is already in an equivalence group.
4422 If it is, set the other members as being in common. */
4423 if (sym->attr.in_equivalence)
4424 {
4425 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
4426 {
4427 for (e2 = e1; e2; e2 = e2->eq)
4428 if (e2->expr->symtree->n.sym == sym)
4429 goto equiv_found;
4430
4431 continue;
4432
4433 equiv_found:
4434
4435 for (e2 = e1; e2; e2 = e2->eq)
4436 {
4437 other = e2->expr->symtree->n.sym;
4438 if (other->common_head
4439 && other->common_head != sym->common_head)
4440 {
4441 gfc_error ("Symbol %qs, in COMMON block %qs at "
4442 "%C is being indirectly equivalenced to "
4443 "another COMMON block %qs",
4444 sym->name, sym->common_head->name,
4445 other->common_head->name);
4446 goto cleanup;
4447 }
4448 other->attr.in_common = 1;
4449 other->common_head = t;
4450 }
4451 }
4452 }
4453
4454
4455 gfc_gobble_whitespace ();
4456 if (gfc_match_eos () == MATCH_YES)
4457 goto done;
4458 if (gfc_peek_ascii_char () == '/')
4459 break;
4460 if (gfc_match_char (',') != MATCH_YES)
4461 goto syntax;
4462 gfc_gobble_whitespace ();
4463 if (gfc_peek_ascii_char () == '/')
4464 break;
4465 }
4466 }
4467
4468 done:
4469 return MATCH_YES;
4470
4471 syntax:
4472 gfc_syntax_error (ST_COMMON);
4473
4474 cleanup:
4475 gfc_free_array_spec (as);
4476 return MATCH_ERROR;
4477 }
4478
4479
4480 /* Match a BLOCK DATA program unit. */
4481
4482 match
4483 gfc_match_block_data (void)
4484 {
4485 char name[GFC_MAX_SYMBOL_LEN + 1];
4486 gfc_symbol *sym;
4487 match m;
4488
4489 if (gfc_match_eos () == MATCH_YES)
4490 {
4491 gfc_new_block = NULL;
4492 return MATCH_YES;
4493 }
4494
4495 m = gfc_match ("% %n%t", name);
4496 if (m != MATCH_YES)
4497 return MATCH_ERROR;
4498
4499 if (gfc_get_symbol (name, NULL, &sym))
4500 return MATCH_ERROR;
4501
4502 if (!gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL))
4503 return MATCH_ERROR;
4504
4505 gfc_new_block = sym;
4506
4507 return MATCH_YES;
4508 }
4509
4510
4511 /* Free a namelist structure. */
4512
4513 void
4514 gfc_free_namelist (gfc_namelist *name)
4515 {
4516 gfc_namelist *n;
4517
4518 for (; name; name = n)
4519 {
4520 n = name->next;
4521 free (name);
4522 }
4523 }
4524
4525
4526 /* Free an OpenMP namelist structure. */
4527
4528 void
4529 gfc_free_omp_namelist (gfc_omp_namelist *name)
4530 {
4531 gfc_omp_namelist *n;
4532
4533 for (; name; name = n)
4534 {
4535 gfc_free_expr (name->expr);
4536 if (name->udr)
4537 {
4538 if (name->udr->combiner)
4539 gfc_free_statement (name->udr->combiner);
4540 if (name->udr->initializer)
4541 gfc_free_statement (name->udr->initializer);
4542 free (name->udr);
4543 }
4544 n = name->next;
4545 free (name);
4546 }
4547 }
4548
4549
4550 /* Match a NAMELIST statement. */
4551
4552 match
4553 gfc_match_namelist (void)
4554 {
4555 gfc_symbol *group_name, *sym;
4556 gfc_namelist *nl;
4557 match m, m2;
4558
4559 m = gfc_match (" / %s /", &group_name);
4560 if (m == MATCH_NO)
4561 goto syntax;
4562 if (m == MATCH_ERROR)
4563 goto error;
4564
4565 for (;;)
4566 {
4567 if (group_name->ts.type != BT_UNKNOWN)
4568 {
4569 gfc_error ("Namelist group name %qs at %C already has a basic "
4570 "type of %s", group_name->name,
4571 gfc_typename (&group_name->ts));
4572 return MATCH_ERROR;
4573 }
4574
4575 if (group_name->attr.flavor == FL_NAMELIST
4576 && group_name->attr.use_assoc
4577 && !gfc_notify_std (GFC_STD_GNU, "Namelist group name %qs "
4578 "at %C already is USE associated and can"
4579 "not be respecified.", group_name->name))
4580 return MATCH_ERROR;
4581
4582 if (group_name->attr.flavor != FL_NAMELIST
4583 && !gfc_add_flavor (&group_name->attr, FL_NAMELIST,
4584 group_name->name, NULL))
4585 return MATCH_ERROR;
4586
4587 for (;;)
4588 {
4589 m = gfc_match_symbol (&sym, 1);
4590 if (m == MATCH_NO)
4591 goto syntax;
4592 if (m == MATCH_ERROR)
4593 goto error;
4594
4595 if (sym->attr.in_namelist == 0
4596 && !gfc_add_in_namelist (&sym->attr, sym->name, NULL))
4597 goto error;
4598
4599 /* Use gfc_error_check here, rather than goto error, so that
4600 these are the only errors for the next two lines. */
4601 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
4602 {
4603 gfc_error ("Assumed size array %qs in namelist %qs at "
4604 "%C is not allowed", sym->name, group_name->name);
4605 gfc_error_check ();
4606 }
4607
4608 nl = gfc_get_namelist ();
4609 nl->sym = sym;
4610 sym->refs++;
4611
4612 if (group_name->namelist == NULL)
4613 group_name->namelist = group_name->namelist_tail = nl;
4614 else
4615 {
4616 group_name->namelist_tail->next = nl;
4617 group_name->namelist_tail = nl;
4618 }
4619
4620 if (gfc_match_eos () == MATCH_YES)
4621 goto done;
4622
4623 m = gfc_match_char (',');
4624
4625 if (gfc_match_char ('/') == MATCH_YES)
4626 {
4627 m2 = gfc_match (" %s /", &group_name);
4628 if (m2 == MATCH_YES)
4629 break;
4630 if (m2 == MATCH_ERROR)
4631 goto error;
4632 goto syntax;
4633 }
4634
4635 if (m != MATCH_YES)
4636 goto syntax;
4637 }
4638 }
4639
4640 done:
4641 return MATCH_YES;
4642
4643 syntax:
4644 gfc_syntax_error (ST_NAMELIST);
4645
4646 error:
4647 return MATCH_ERROR;
4648 }
4649
4650
4651 /* Match a MODULE statement. */
4652
4653 match
4654 gfc_match_module (void)
4655 {
4656 match m;
4657
4658 m = gfc_match (" %s%t", &gfc_new_block);
4659 if (m != MATCH_YES)
4660 return m;
4661
4662 if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
4663 gfc_new_block->name, NULL))
4664 return MATCH_ERROR;
4665
4666 return MATCH_YES;
4667 }
4668
4669
4670 /* Free equivalence sets and lists. Recursively is the easiest way to
4671 do this. */
4672
4673 void
4674 gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop)
4675 {
4676 if (eq == stop)
4677 return;
4678
4679 gfc_free_equiv (eq->eq);
4680 gfc_free_equiv_until (eq->next, stop);
4681 gfc_free_expr (eq->expr);
4682 free (eq);
4683 }
4684
4685
4686 void
4687 gfc_free_equiv (gfc_equiv *eq)
4688 {
4689 gfc_free_equiv_until (eq, NULL);
4690 }
4691
4692
4693 /* Match an EQUIVALENCE statement. */
4694
4695 match
4696 gfc_match_equivalence (void)
4697 {
4698 gfc_equiv *eq, *set, *tail;
4699 gfc_ref *ref;
4700 gfc_symbol *sym;
4701 match m;
4702 gfc_common_head *common_head = NULL;
4703 bool common_flag;
4704 int cnt;
4705
4706 tail = NULL;
4707
4708 for (;;)
4709 {
4710 eq = gfc_get_equiv ();
4711 if (tail == NULL)
4712 tail = eq;
4713
4714 eq->next = gfc_current_ns->equiv;
4715 gfc_current_ns->equiv = eq;
4716
4717 if (gfc_match_char ('(') != MATCH_YES)
4718 goto syntax;
4719
4720 set = eq;
4721 common_flag = FALSE;
4722 cnt = 0;
4723
4724 for (;;)
4725 {
4726 m = gfc_match_equiv_variable (&set->expr);
4727 if (m == MATCH_ERROR)
4728 goto cleanup;
4729 if (m == MATCH_NO)
4730 goto syntax;
4731
4732 /* count the number of objects. */
4733 cnt++;
4734
4735 if (gfc_match_char ('%') == MATCH_YES)
4736 {
4737 gfc_error ("Derived type component %C is not a "
4738 "permitted EQUIVALENCE member");
4739 goto cleanup;
4740 }
4741
4742 for (ref = set->expr->ref; ref; ref = ref->next)
4743 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
4744 {
4745 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
4746 "be an array section");
4747 goto cleanup;
4748 }
4749
4750 sym = set->expr->symtree->n.sym;
4751
4752 if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL))
4753 goto cleanup;
4754
4755 if (sym->attr.in_common)
4756 {
4757 common_flag = TRUE;
4758 common_head = sym->common_head;
4759 }
4760
4761 if (gfc_match_char (')') == MATCH_YES)
4762 break;
4763
4764 if (gfc_match_char (',') != MATCH_YES)
4765 goto syntax;
4766
4767 set->eq = gfc_get_equiv ();
4768 set = set->eq;
4769 }
4770
4771 if (cnt < 2)
4772 {
4773 gfc_error ("EQUIVALENCE at %C requires two or more objects");
4774 goto cleanup;
4775 }
4776
4777 /* If one of the members of an equivalence is in common, then
4778 mark them all as being in common. Before doing this, check
4779 that members of the equivalence group are not in different
4780 common blocks. */
4781 if (common_flag)
4782 for (set = eq; set; set = set->eq)
4783 {
4784 sym = set->expr->symtree->n.sym;
4785 if (sym->common_head && sym->common_head != common_head)
4786 {
4787 gfc_error ("Attempt to indirectly overlap COMMON "
4788 "blocks %s and %s by EQUIVALENCE at %C",
4789 sym->common_head->name, common_head->name);
4790 goto cleanup;
4791 }
4792 sym->attr.in_common = 1;
4793 sym->common_head = common_head;
4794 }
4795
4796 if (gfc_match_eos () == MATCH_YES)
4797 break;
4798 if (gfc_match_char (',') != MATCH_YES)
4799 {
4800 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
4801 goto cleanup;
4802 }
4803 }
4804
4805 return MATCH_YES;
4806
4807 syntax:
4808 gfc_syntax_error (ST_EQUIVALENCE);
4809
4810 cleanup:
4811 eq = tail->next;
4812 tail->next = NULL;
4813
4814 gfc_free_equiv (gfc_current_ns->equiv);
4815 gfc_current_ns->equiv = eq;
4816
4817 return MATCH_ERROR;
4818 }
4819
4820
4821 /* Check that a statement function is not recursive. This is done by looking
4822 for the statement function symbol(sym) by looking recursively through its
4823 expression(e). If a reference to sym is found, true is returned.
4824 12.5.4 requires that any variable of function that is implicitly typed
4825 shall have that type confirmed by any subsequent type declaration. The
4826 implicit typing is conveniently done here. */
4827 static bool
4828 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
4829
4830 static bool
4831 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
4832 {
4833
4834 if (e == NULL)
4835 return false;
4836
4837 switch (e->expr_type)
4838 {
4839 case EXPR_FUNCTION:
4840 if (e->symtree == NULL)
4841 return false;
4842
4843 /* Check the name before testing for nested recursion! */
4844 if (sym->name == e->symtree->n.sym->name)
4845 return true;
4846
4847 /* Catch recursion via other statement functions. */
4848 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
4849 && e->symtree->n.sym->value
4850 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
4851 return true;
4852
4853 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4854 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4855
4856 break;
4857
4858 case EXPR_VARIABLE:
4859 if (e->symtree && sym->name == e->symtree->n.sym->name)
4860 return true;
4861
4862 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4863 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4864 break;
4865
4866 default:
4867 break;
4868 }
4869
4870 return false;
4871 }
4872
4873
4874 static bool
4875 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
4876 {
4877 return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
4878 }
4879
4880
4881 /* Match a statement function declaration. It is so easy to match
4882 non-statement function statements with a MATCH_ERROR as opposed to
4883 MATCH_NO that we suppress error message in most cases. */
4884
4885 match
4886 gfc_match_st_function (void)
4887 {
4888 gfc_error_buffer old_error;
4889
4890 gfc_symbol *sym;
4891 gfc_expr *expr;
4892 match m;
4893
4894 m = gfc_match_symbol (&sym, 0);
4895 if (m != MATCH_YES)
4896 return m;
4897
4898 gfc_push_error (&old_error);
4899
4900 if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL))
4901 goto undo_error;
4902
4903 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
4904 goto undo_error;
4905
4906 m = gfc_match (" = %e%t", &expr);
4907 if (m == MATCH_NO)
4908 goto undo_error;
4909
4910 gfc_free_error (&old_error);
4911
4912 if (m == MATCH_ERROR)
4913 return m;
4914
4915 if (recursive_stmt_fcn (expr, sym))
4916 {
4917 gfc_error ("Statement function at %L is recursive", &expr->where);
4918 return MATCH_ERROR;
4919 }
4920
4921 sym->value = expr;
4922
4923 if (!gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C"))
4924 return MATCH_ERROR;
4925
4926 return MATCH_YES;
4927
4928 undo_error:
4929 gfc_pop_error (&old_error);
4930 return MATCH_NO;
4931 }
4932
4933
4934 /***************** SELECT CASE subroutines ******************/
4935
4936 /* Free a single case structure. */
4937
4938 static void
4939 free_case (gfc_case *p)
4940 {
4941 if (p->low == p->high)
4942 p->high = NULL;
4943 gfc_free_expr (p->low);
4944 gfc_free_expr (p->high);
4945 free (p);
4946 }
4947
4948
4949 /* Free a list of case structures. */
4950
4951 void
4952 gfc_free_case_list (gfc_case *p)
4953 {
4954 gfc_case *q;
4955
4956 for (; p; p = q)
4957 {
4958 q = p->next;
4959 free_case (p);
4960 }
4961 }
4962
4963
4964 /* Match a single case selector. */
4965
4966 static match
4967 match_case_selector (gfc_case **cp)
4968 {
4969 gfc_case *c;
4970 match m;
4971
4972 c = gfc_get_case ();
4973 c->where = gfc_current_locus;
4974
4975 if (gfc_match_char (':') == MATCH_YES)
4976 {
4977 m = gfc_match_init_expr (&c->high);
4978 if (m == MATCH_NO)
4979 goto need_expr;
4980 if (m == MATCH_ERROR)
4981 goto cleanup;
4982 }
4983 else
4984 {
4985 m = gfc_match_init_expr (&c->low);
4986 if (m == MATCH_ERROR)
4987 goto cleanup;
4988 if (m == MATCH_NO)
4989 goto need_expr;
4990
4991 /* If we're not looking at a ':' now, make a range out of a single
4992 target. Else get the upper bound for the case range. */
4993 if (gfc_match_char (':') != MATCH_YES)
4994 c->high = c->low;
4995 else
4996 {
4997 m = gfc_match_init_expr (&c->high);
4998 if (m == MATCH_ERROR)
4999 goto cleanup;
5000 /* MATCH_NO is fine. It's OK if nothing is there! */
5001 }
5002 }
5003
5004 *cp = c;
5005 return MATCH_YES;
5006
5007 need_expr:
5008 gfc_error ("Expected initialization expression in CASE at %C");
5009
5010 cleanup:
5011 free_case (c);
5012 return MATCH_ERROR;
5013 }
5014
5015
5016 /* Match the end of a case statement. */
5017
5018 static match
5019 match_case_eos (void)
5020 {
5021 char name[GFC_MAX_SYMBOL_LEN + 1];
5022 match m;
5023
5024 if (gfc_match_eos () == MATCH_YES)
5025 return MATCH_YES;
5026
5027 /* If the case construct doesn't have a case-construct-name, we
5028 should have matched the EOS. */
5029 if (!gfc_current_block ())
5030 return MATCH_NO;
5031
5032 gfc_gobble_whitespace ();
5033
5034 m = gfc_match_name (name);
5035 if (m != MATCH_YES)
5036 return m;
5037
5038 if (strcmp (name, gfc_current_block ()->name) != 0)
5039 {
5040 gfc_error ("Expected block name %qs of SELECT construct at %C",
5041 gfc_current_block ()->name);
5042 return MATCH_ERROR;
5043 }
5044
5045 return gfc_match_eos ();
5046 }
5047
5048
5049 /* Match a SELECT statement. */
5050
5051 match
5052 gfc_match_select (void)
5053 {
5054 gfc_expr *expr;
5055 match m;
5056
5057 m = gfc_match_label ();
5058 if (m == MATCH_ERROR)
5059 return m;
5060
5061 m = gfc_match (" select case ( %e )%t", &expr);
5062 if (m != MATCH_YES)
5063 return m;
5064
5065 new_st.op = EXEC_SELECT;
5066 new_st.expr1 = expr;
5067
5068 return MATCH_YES;
5069 }
5070
5071
5072 /* Transfer the selector typespec to the associate name. */
5073
5074 static void
5075 copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
5076 {
5077 gfc_ref *ref;
5078 gfc_symbol *assoc_sym;
5079
5080 assoc_sym = associate->symtree->n.sym;
5081
5082 /* At this stage the expression rank and arrayspec dimensions have
5083 not been completely sorted out. We must get the expr2->rank
5084 right here, so that the correct class container is obtained. */
5085 ref = selector->ref;
5086 while (ref && ref->next)
5087 ref = ref->next;
5088
5089 if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as
5090 && ref && ref->type == REF_ARRAY)
5091 {
5092 /* Ensure that the array reference type is set. We cannot use
5093 gfc_resolve_expr at this point, so the usable parts of
5094 resolve.c(resolve_array_ref) are employed to do it. */
5095 if (ref->u.ar.type == AR_UNKNOWN)
5096 {
5097 ref->u.ar.type = AR_ELEMENT;
5098 for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
5099 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5100 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR
5101 || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
5102 && ref->u.ar.start[i] && ref->u.ar.start[i]->rank))
5103 {
5104 ref->u.ar.type = AR_SECTION;
5105 break;
5106 }
5107 }
5108
5109 if (ref->u.ar.type == AR_FULL)
5110 selector->rank = CLASS_DATA (selector)->as->rank;
5111 else if (ref->u.ar.type == AR_SECTION)
5112 selector->rank = ref->u.ar.dimen;
5113 else
5114 selector->rank = 0;
5115 }
5116
5117 if (selector->rank)
5118 {
5119 assoc_sym->attr.dimension = 1;
5120 assoc_sym->as = gfc_get_array_spec ();
5121 assoc_sym->as->rank = selector->rank;
5122 assoc_sym->as->type = AS_DEFERRED;
5123 }
5124 else
5125 assoc_sym->as = NULL;
5126
5127 if (selector->ts.type == BT_CLASS)
5128 {
5129 /* The correct class container has to be available. */
5130 assoc_sym->ts.type = BT_CLASS;
5131 assoc_sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
5132 assoc_sym->attr.pointer = 1;
5133 gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
5134 }
5135 }
5136
5137
5138 /* Push the current selector onto the SELECT TYPE stack. */
5139
5140 static void
5141 select_type_push (gfc_symbol *sel)
5142 {
5143 gfc_select_type_stack *top = gfc_get_select_type_stack ();
5144 top->selector = sel;
5145 top->tmp = NULL;
5146 top->prev = select_type_stack;
5147
5148 select_type_stack = top;
5149 }
5150
5151
5152 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
5153
5154 static gfc_symtree *
5155 select_intrinsic_set_tmp (gfc_typespec *ts)
5156 {
5157 char name[GFC_MAX_SYMBOL_LEN];
5158 gfc_symtree *tmp;
5159 int charlen = 0;
5160
5161 if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
5162 return NULL;
5163
5164 if (select_type_stack->selector->ts.type == BT_CLASS
5165 && !select_type_stack->selector->attr.class_ok)
5166 return NULL;
5167
5168 if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
5169 && ts->u.cl->length->expr_type == EXPR_CONSTANT)
5170 charlen = mpz_get_si (ts->u.cl->length->value.integer);
5171
5172 if (ts->type != BT_CHARACTER)
5173 sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
5174 ts->kind);
5175 else
5176 sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (ts->type),
5177 charlen, ts->kind);
5178
5179 gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
5180 gfc_add_type (tmp->n.sym, ts, NULL);
5181
5182 /* Copy across the array spec to the selector. */
5183 if (select_type_stack->selector->ts.type == BT_CLASS
5184 && (CLASS_DATA (select_type_stack->selector)->attr.dimension
5185 || CLASS_DATA (select_type_stack->selector)->attr.codimension))
5186 {
5187 tmp->n.sym->attr.pointer = 1;
5188 tmp->n.sym->attr.dimension
5189 = CLASS_DATA (select_type_stack->selector)->attr.dimension;
5190 tmp->n.sym->attr.codimension
5191 = CLASS_DATA (select_type_stack->selector)->attr.codimension;
5192 tmp->n.sym->as
5193 = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
5194 }
5195
5196 gfc_set_sym_referenced (tmp->n.sym);
5197 gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
5198 tmp->n.sym->attr.select_type_temporary = 1;
5199
5200 return tmp;
5201 }
5202
5203
5204 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
5205
5206 static void
5207 select_type_set_tmp (gfc_typespec *ts)
5208 {
5209 char name[GFC_MAX_SYMBOL_LEN];
5210 gfc_symtree *tmp = NULL;
5211
5212 if (!ts)
5213 {
5214 select_type_stack->tmp = NULL;
5215 return;
5216 }
5217
5218 tmp = select_intrinsic_set_tmp (ts);
5219
5220 if (tmp == NULL)
5221 {
5222 if (!ts->u.derived)
5223 return;
5224
5225 if (ts->type == BT_CLASS)
5226 sprintf (name, "__tmp_class_%s", ts->u.derived->name);
5227 else
5228 sprintf (name, "__tmp_type_%s", ts->u.derived->name);
5229 gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
5230 gfc_add_type (tmp->n.sym, ts, NULL);
5231
5232 if (select_type_stack->selector->ts.type == BT_CLASS
5233 && select_type_stack->selector->attr.class_ok)
5234 {
5235 tmp->n.sym->attr.pointer
5236 = CLASS_DATA (select_type_stack->selector)->attr.class_pointer;
5237
5238 /* Copy across the array spec to the selector. */
5239 if (CLASS_DATA (select_type_stack->selector)->attr.dimension
5240 || CLASS_DATA (select_type_stack->selector)->attr.codimension)
5241 {
5242 tmp->n.sym->attr.dimension
5243 = CLASS_DATA (select_type_stack->selector)->attr.dimension;
5244 tmp->n.sym->attr.codimension
5245 = CLASS_DATA (select_type_stack->selector)->attr.codimension;
5246 tmp->n.sym->as
5247 = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
5248 }
5249 }
5250
5251 gfc_set_sym_referenced (tmp->n.sym);
5252 gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
5253 tmp->n.sym->attr.select_type_temporary = 1;
5254
5255 if (ts->type == BT_CLASS)
5256 gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
5257 &tmp->n.sym->as);
5258 }
5259
5260 /* Add an association for it, so the rest of the parser knows it is
5261 an associate-name. The target will be set during resolution. */
5262 tmp->n.sym->assoc = gfc_get_association_list ();
5263 tmp->n.sym->assoc->dangling = 1;
5264 tmp->n.sym->assoc->st = tmp;
5265
5266 select_type_stack->tmp = tmp;
5267 }
5268
5269
5270 /* Match a SELECT TYPE statement. */
5271
5272 match
5273 gfc_match_select_type (void)
5274 {
5275 gfc_expr *expr1, *expr2 = NULL;
5276 match m;
5277 char name[GFC_MAX_SYMBOL_LEN];
5278 bool class_array;
5279 gfc_symbol *sym;
5280
5281 m = gfc_match_label ();
5282 if (m == MATCH_ERROR)
5283 return m;
5284
5285 m = gfc_match (" select type ( ");
5286 if (m != MATCH_YES)
5287 return m;
5288
5289 m = gfc_match (" %n => %e", name, &expr2);
5290 if (m == MATCH_YES)
5291 {
5292 expr1 = gfc_get_expr();
5293 expr1->expr_type = EXPR_VARIABLE;
5294 if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
5295 {
5296 m = MATCH_ERROR;
5297 goto cleanup;
5298 }
5299
5300 sym = expr1->symtree->n.sym;
5301 if (expr2->ts.type == BT_UNKNOWN)
5302 sym->attr.untyped = 1;
5303 else
5304 copy_ts_from_selector_to_associate (expr1, expr2);
5305
5306 sym->attr.flavor = FL_VARIABLE;
5307 sym->attr.referenced = 1;
5308 sym->attr.class_ok = 1;
5309 }
5310 else
5311 {
5312 m = gfc_match (" %e ", &expr1);
5313 if (m != MATCH_YES)
5314 return m;
5315 }
5316
5317 m = gfc_match (" )%t");
5318 if (m != MATCH_YES)
5319 {
5320 gfc_error ("parse error in SELECT TYPE statement at %C");
5321 goto cleanup;
5322 }
5323
5324 /* This ghastly expression seems to be needed to distinguish a CLASS
5325 array, which can have a reference, from other expressions that
5326 have references, such as derived type components, and are not
5327 allowed by the standard.
5328 TODO: see if it is sufficient to exclude component and substring
5329 references. */
5330 class_array = expr1->expr_type == EXPR_VARIABLE
5331 && expr1->ts.type == BT_CLASS
5332 && CLASS_DATA (expr1)
5333 && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0)
5334 && (CLASS_DATA (expr1)->attr.dimension
5335 || CLASS_DATA (expr1)->attr.codimension)
5336 && expr1->ref
5337 && expr1->ref->type == REF_ARRAY
5338 && expr1->ref->next == NULL;
5339
5340 /* Check for F03:C811. */
5341 if (!expr2 && (expr1->expr_type != EXPR_VARIABLE
5342 || (!class_array && expr1->ref != NULL)))
5343 {
5344 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
5345 "use associate-name=>");
5346 m = MATCH_ERROR;
5347 goto cleanup;
5348 }
5349
5350 new_st.op = EXEC_SELECT_TYPE;
5351 new_st.expr1 = expr1;
5352 new_st.expr2 = expr2;
5353 new_st.ext.block.ns = gfc_current_ns;
5354
5355 select_type_push (expr1->symtree->n.sym);
5356
5357 return MATCH_YES;
5358
5359 cleanup:
5360 gfc_free_expr (expr1);
5361 gfc_free_expr (expr2);
5362 return m;
5363 }
5364
5365
5366 /* Match a CASE statement. */
5367
5368 match
5369 gfc_match_case (void)
5370 {
5371 gfc_case *c, *head, *tail;
5372 match m;
5373
5374 head = tail = NULL;
5375
5376 if (gfc_current_state () != COMP_SELECT)
5377 {
5378 gfc_error ("Unexpected CASE statement at %C");
5379 return MATCH_ERROR;
5380 }
5381
5382 if (gfc_match ("% default") == MATCH_YES)
5383 {
5384 m = match_case_eos ();
5385 if (m == MATCH_NO)
5386 goto syntax;
5387 if (m == MATCH_ERROR)
5388 goto cleanup;
5389
5390 new_st.op = EXEC_SELECT;
5391 c = gfc_get_case ();
5392 c->where = gfc_current_locus;
5393 new_st.ext.block.case_list = c;
5394 return MATCH_YES;
5395 }
5396
5397 if (gfc_match_char ('(') != MATCH_YES)
5398 goto syntax;
5399
5400 for (;;)
5401 {
5402 if (match_case_selector (&c) == MATCH_ERROR)
5403 goto cleanup;
5404
5405 if (head == NULL)
5406 head = c;
5407 else
5408 tail->next = c;
5409
5410 tail = c;
5411
5412 if (gfc_match_char (')') == MATCH_YES)
5413 break;
5414 if (gfc_match_char (',') != MATCH_YES)
5415 goto syntax;
5416 }
5417
5418 m = match_case_eos ();
5419 if (m == MATCH_NO)
5420 goto syntax;
5421 if (m == MATCH_ERROR)
5422 goto cleanup;
5423
5424 new_st.op = EXEC_SELECT;
5425 new_st.ext.block.case_list = head;
5426
5427 return MATCH_YES;
5428
5429 syntax:
5430 gfc_error ("Syntax error in CASE specification at %C");
5431
5432 cleanup:
5433 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
5434 return MATCH_ERROR;
5435 }
5436
5437
5438 /* Match a TYPE IS statement. */
5439
5440 match
5441 gfc_match_type_is (void)
5442 {
5443 gfc_case *c = NULL;
5444 match m;
5445
5446 if (gfc_current_state () != COMP_SELECT_TYPE)
5447 {
5448 gfc_error ("Unexpected TYPE IS statement at %C");
5449 return MATCH_ERROR;
5450 }
5451
5452 if (gfc_match_char ('(') != MATCH_YES)
5453 goto syntax;
5454
5455 c = gfc_get_case ();
5456 c->where = gfc_current_locus;
5457
5458 m = gfc_match_type_spec (&c->ts);
5459 if (m == MATCH_NO)
5460 goto syntax;
5461 if (m == MATCH_ERROR)
5462 goto cleanup;
5463
5464 if (gfc_match_char (')') != MATCH_YES)
5465 goto syntax;
5466
5467 m = match_case_eos ();
5468 if (m == MATCH_NO)
5469 goto syntax;
5470 if (m == MATCH_ERROR)
5471 goto cleanup;
5472
5473 new_st.op = EXEC_SELECT_TYPE;
5474 new_st.ext.block.case_list = c;
5475
5476 if (c->ts.type == BT_DERIVED && c->ts.u.derived
5477 && (c->ts.u.derived->attr.sequence
5478 || c->ts.u.derived->attr.is_bind_c))
5479 {
5480 gfc_error ("The type-spec shall not specify a sequence derived "
5481 "type or a type with the BIND attribute in SELECT "
5482 "TYPE at %C [F2003:C815]");
5483 return MATCH_ERROR;
5484 }
5485
5486 /* Create temporary variable. */
5487 select_type_set_tmp (&c->ts);
5488
5489 return MATCH_YES;
5490
5491 syntax:
5492 gfc_error ("Syntax error in TYPE IS specification at %C");
5493
5494 cleanup:
5495 if (c != NULL)
5496 gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
5497 return MATCH_ERROR;
5498 }
5499
5500
5501 /* Match a CLASS IS or CLASS DEFAULT statement. */
5502
5503 match
5504 gfc_match_class_is (void)
5505 {
5506 gfc_case *c = NULL;
5507 match m;
5508
5509 if (gfc_current_state () != COMP_SELECT_TYPE)
5510 return MATCH_NO;
5511
5512 if (gfc_match ("% default") == MATCH_YES)
5513 {
5514 m = match_case_eos ();
5515 if (m == MATCH_NO)
5516 goto syntax;
5517 if (m == MATCH_ERROR)
5518 goto cleanup;
5519
5520 new_st.op = EXEC_SELECT_TYPE;
5521 c = gfc_get_case ();
5522 c->where = gfc_current_locus;
5523 c->ts.type = BT_UNKNOWN;
5524 new_st.ext.block.case_list = c;
5525 select_type_set_tmp (NULL);
5526 return MATCH_YES;
5527 }
5528
5529 m = gfc_match ("% is");
5530 if (m == MATCH_NO)
5531 goto syntax;
5532 if (m == MATCH_ERROR)
5533 goto cleanup;
5534
5535 if (gfc_match_char ('(') != MATCH_YES)
5536 goto syntax;
5537
5538 c = gfc_get_case ();
5539 c->where = gfc_current_locus;
5540
5541 m = match_derived_type_spec (&c->ts);
5542 if (m == MATCH_NO)
5543 goto syntax;
5544 if (m == MATCH_ERROR)
5545 goto cleanup;
5546
5547 if (c->ts.type == BT_DERIVED)
5548 c->ts.type = BT_CLASS;
5549
5550 if (gfc_match_char (')') != MATCH_YES)
5551 goto syntax;
5552
5553 m = match_case_eos ();
5554 if (m == MATCH_NO)
5555 goto syntax;
5556 if (m == MATCH_ERROR)
5557 goto cleanup;
5558
5559 new_st.op = EXEC_SELECT_TYPE;
5560 new_st.ext.block.case_list = c;
5561
5562 /* Create temporary variable. */
5563 select_type_set_tmp (&c->ts);
5564
5565 return MATCH_YES;
5566
5567 syntax:
5568 gfc_error ("Syntax error in CLASS IS specification at %C");
5569
5570 cleanup:
5571 if (c != NULL)
5572 gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
5573 return MATCH_ERROR;
5574 }
5575
5576
5577 /********************* WHERE subroutines ********************/
5578
5579 /* Match the rest of a simple WHERE statement that follows an IF statement.
5580 */
5581
5582 static match
5583 match_simple_where (void)
5584 {
5585 gfc_expr *expr;
5586 gfc_code *c;
5587 match m;
5588
5589 m = gfc_match (" ( %e )", &expr);
5590 if (m != MATCH_YES)
5591 return m;
5592
5593 m = gfc_match_assignment ();
5594 if (m == MATCH_NO)
5595 goto syntax;
5596 if (m == MATCH_ERROR)
5597 goto cleanup;
5598
5599 if (gfc_match_eos () != MATCH_YES)
5600 goto syntax;
5601
5602 c = gfc_get_code (EXEC_WHERE);
5603 c->expr1 = expr;
5604
5605 c->next = XCNEW (gfc_code);
5606 *c->next = new_st;
5607 gfc_clear_new_st ();
5608
5609 new_st.op = EXEC_WHERE;
5610 new_st.block = c;
5611
5612 return MATCH_YES;
5613
5614 syntax:
5615 gfc_syntax_error (ST_WHERE);
5616
5617 cleanup:
5618 gfc_free_expr (expr);
5619 return MATCH_ERROR;
5620 }
5621
5622
5623 /* Match a WHERE statement. */
5624
5625 match
5626 gfc_match_where (gfc_statement *st)
5627 {
5628 gfc_expr *expr;
5629 match m0, m;
5630 gfc_code *c;
5631
5632 m0 = gfc_match_label ();
5633 if (m0 == MATCH_ERROR)
5634 return m0;
5635
5636 m = gfc_match (" where ( %e )", &expr);
5637 if (m != MATCH_YES)
5638 return m;
5639
5640 if (gfc_match_eos () == MATCH_YES)
5641 {
5642 *st = ST_WHERE_BLOCK;
5643 new_st.op = EXEC_WHERE;
5644 new_st.expr1 = expr;
5645 return MATCH_YES;
5646 }
5647
5648 m = gfc_match_assignment ();
5649 if (m == MATCH_NO)
5650 gfc_syntax_error (ST_WHERE);
5651
5652 if (m != MATCH_YES)
5653 {
5654 gfc_free_expr (expr);
5655 return MATCH_ERROR;
5656 }
5657
5658 /* We've got a simple WHERE statement. */
5659 *st = ST_WHERE;
5660 c = gfc_get_code (EXEC_WHERE);
5661 c->expr1 = expr;
5662
5663 c->next = XCNEW (gfc_code);
5664 *c->next = new_st;
5665 gfc_clear_new_st ();
5666
5667 new_st.op = EXEC_WHERE;
5668 new_st.block = c;
5669
5670 return MATCH_YES;
5671 }
5672
5673
5674 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
5675 new_st if successful. */
5676
5677 match
5678 gfc_match_elsewhere (void)
5679 {
5680 char name[GFC_MAX_SYMBOL_LEN + 1];
5681 gfc_expr *expr;
5682 match m;
5683
5684 if (gfc_current_state () != COMP_WHERE)
5685 {
5686 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
5687 return MATCH_ERROR;
5688 }
5689
5690 expr = NULL;
5691
5692 if (gfc_match_char ('(') == MATCH_YES)
5693 {
5694 m = gfc_match_expr (&expr);
5695 if (m == MATCH_NO)
5696 goto syntax;
5697 if (m == MATCH_ERROR)
5698 return MATCH_ERROR;
5699
5700 if (gfc_match_char (')') != MATCH_YES)
5701 goto syntax;
5702 }
5703
5704 if (gfc_match_eos () != MATCH_YES)
5705 {
5706 /* Only makes sense if we have a where-construct-name. */
5707 if (!gfc_current_block ())
5708 {
5709 m = MATCH_ERROR;
5710 goto cleanup;
5711 }
5712 /* Better be a name at this point. */
5713 m = gfc_match_name (name);
5714 if (m == MATCH_NO)
5715 goto syntax;
5716 if (m == MATCH_ERROR)
5717 goto cleanup;
5718
5719 if (gfc_match_eos () != MATCH_YES)
5720 goto syntax;
5721
5722 if (strcmp (name, gfc_current_block ()->name) != 0)
5723 {
5724 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
5725 name, gfc_current_block ()->name);
5726 goto cleanup;
5727 }
5728 }
5729
5730 new_st.op = EXEC_WHERE;
5731 new_st.expr1 = expr;
5732 return MATCH_YES;
5733
5734 syntax:
5735 gfc_syntax_error (ST_ELSEWHERE);
5736
5737 cleanup:
5738 gfc_free_expr (expr);
5739 return MATCH_ERROR;
5740 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org