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