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