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