?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2015-03-03 Andrew Sutton <andrew.n.sutton@gmail.com>
[official-gcc.git] / gcc / fortran / match.c
blob84e2764e1312897aba85049bcd7ccf2a015f5bf6
1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000-2014 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 '%s' 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 '%s' 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 == '_' && gfc_option.flag_allow_leading_underscore)))
534 {
535 if (gfc_error_flag_test () == 0 && 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 == '_' || (gfc_option.flag_dollar_ok && c == '$'));
557
558 if (c == '$' && !gfc_option.flag_dollar_ok)
559 {
560 gfc_fatal_error ("Invalid character '$' at %L. Use -fdollar-ok to allow "
561 "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 () == 0)
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 '%s' at %C doesn't match IF label '%s'",
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 '%s' at %C doesn't match IF label '%s'",
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 (gfc_option.coarray == GFC_FCOARRAY_NONE)
1667 {
1668 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
1669 return MATCH_ERROR;
1670 }
1671
1672 if (gfc_find_state (COMP_CRITICAL))
1673 {
1674 gfc_error ("Nested CRITICAL block at %C");
1675 return MATCH_ERROR;
1676 }
1677
1678 new_st.op = EXEC_CRITICAL;
1679
1680 if (label != NULL
1681 && !gfc_reference_st_label (label, ST_LABEL_TARGET))
1682 return MATCH_ERROR;
1683
1684 return MATCH_YES;
1685 }
1686
1687
1688 /* Match a BLOCK statement. */
1689
1690 match
1691 gfc_match_block (void)
1692 {
1693 match m;
1694
1695 if (gfc_match_label () == MATCH_ERROR)
1696 return MATCH_ERROR;
1697
1698 if (gfc_match (" block") != MATCH_YES)
1699 return MATCH_NO;
1700
1701 /* For this to be a correct BLOCK statement, the line must end now. */
1702 m = gfc_match_eos ();
1703 if (m == MATCH_ERROR)
1704 return MATCH_ERROR;
1705 if (m == MATCH_NO)
1706 return MATCH_NO;
1707
1708 return MATCH_YES;
1709 }
1710
1711
1712 /* Match an ASSOCIATE statement. */
1713
1714 match
1715 gfc_match_associate (void)
1716 {
1717 if (gfc_match_label () == MATCH_ERROR)
1718 return MATCH_ERROR;
1719
1720 if (gfc_match (" associate") != MATCH_YES)
1721 return MATCH_NO;
1722
1723 /* Match the association list. */
1724 if (gfc_match_char ('(') != MATCH_YES)
1725 {
1726 gfc_error ("Expected association list at %C");
1727 return MATCH_ERROR;
1728 }
1729 new_st.ext.block.assoc = NULL;
1730 while (true)
1731 {
1732 gfc_association_list* newAssoc = gfc_get_association_list ();
1733 gfc_association_list* a;
1734
1735 /* Match the next association. */
1736 if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
1737 != MATCH_YES)
1738 {
1739 gfc_error ("Expected association at %C");
1740 goto assocListError;
1741 }
1742 newAssoc->where = gfc_current_locus;
1743
1744 /* Check that the current name is not yet in the list. */
1745 for (a = new_st.ext.block.assoc; a; a = a->next)
1746 if (!strcmp (a->name, newAssoc->name))
1747 {
1748 gfc_error ("Duplicate name '%s' in association at %C",
1749 newAssoc->name);
1750 goto assocListError;
1751 }
1752
1753 /* The target expression must not be coindexed. */
1754 if (gfc_is_coindexed (newAssoc->target))
1755 {
1756 gfc_error ("Association target at %C must not be coindexed");
1757 goto assocListError;
1758 }
1759
1760 /* The `variable' field is left blank for now; because the target is not
1761 yet resolved, we can't use gfc_has_vector_subscript to determine it
1762 for now. This is set during resolution. */
1763
1764 /* Put it into the list. */
1765 newAssoc->next = new_st.ext.block.assoc;
1766 new_st.ext.block.assoc = newAssoc;
1767
1768 /* Try next one or end if closing parenthesis is found. */
1769 gfc_gobble_whitespace ();
1770 if (gfc_peek_char () == ')')
1771 break;
1772 if (gfc_match_char (',') != MATCH_YES)
1773 {
1774 gfc_error ("Expected ')' or ',' at %C");
1775 return MATCH_ERROR;
1776 }
1777
1778 continue;
1779
1780 assocListError:
1781 free (newAssoc);
1782 goto error;
1783 }
1784 if (gfc_match_char (')') != MATCH_YES)
1785 {
1786 /* This should never happen as we peek above. */
1787 gcc_unreachable ();
1788 }
1789
1790 if (gfc_match_eos () != MATCH_YES)
1791 {
1792 gfc_error ("Junk after ASSOCIATE statement at %C");
1793 goto error;
1794 }
1795
1796 return MATCH_YES;
1797
1798 error:
1799 gfc_free_association_list (new_st.ext.block.assoc);
1800 return MATCH_ERROR;
1801 }
1802
1803
1804 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1805 an accessible derived type. */
1806
1807 static match
1808 match_derived_type_spec (gfc_typespec *ts)
1809 {
1810 char name[GFC_MAX_SYMBOL_LEN + 1];
1811 locus old_locus;
1812 gfc_symbol *derived;
1813
1814 old_locus = gfc_current_locus;
1815
1816 if (gfc_match ("%n", name) != MATCH_YES)
1817 {
1818 gfc_current_locus = old_locus;
1819 return MATCH_NO;
1820 }
1821
1822 gfc_find_symbol (name, NULL, 1, &derived);
1823
1824 if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
1825 derived = gfc_find_dt_in_generic (derived);
1826
1827 if (derived && derived->attr.flavor == FL_DERIVED)
1828 {
1829 ts->type = BT_DERIVED;
1830 ts->u.derived = derived;
1831 return MATCH_YES;
1832 }
1833
1834 gfc_current_locus = old_locus;
1835 return MATCH_NO;
1836 }
1837
1838
1839 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
1840 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
1841 It only includes the intrinsic types from the Fortran 2003 standard
1842 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
1843 the implicit_flag is not needed, so it was removed. Derived types are
1844 identified by their name alone. */
1845
1846 match
1847 gfc_match_type_spec (gfc_typespec *ts)
1848 {
1849 match m;
1850 locus old_locus;
1851
1852 gfc_clear_ts (ts);
1853 gfc_gobble_whitespace ();
1854 old_locus = gfc_current_locus;
1855
1856 if (match_derived_type_spec (ts) == MATCH_YES)
1857 {
1858 /* Enforce F03:C401. */
1859 if (ts->u.derived->attr.abstract)
1860 {
1861 gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
1862 ts->u.derived->name, &old_locus);
1863 return MATCH_ERROR;
1864 }
1865 return MATCH_YES;
1866 }
1867
1868 if (gfc_match ("integer") == MATCH_YES)
1869 {
1870 ts->type = BT_INTEGER;
1871 ts->kind = gfc_default_integer_kind;
1872 goto kind_selector;
1873 }
1874
1875 if (gfc_match ("real") == MATCH_YES)
1876 {
1877 ts->type = BT_REAL;
1878 ts->kind = gfc_default_real_kind;
1879 goto kind_selector;
1880 }
1881
1882 if (gfc_match ("double precision") == MATCH_YES)
1883 {
1884 ts->type = BT_REAL;
1885 ts->kind = gfc_default_double_kind;
1886 return MATCH_YES;
1887 }
1888
1889 if (gfc_match ("complex") == MATCH_YES)
1890 {
1891 ts->type = BT_COMPLEX;
1892 ts->kind = gfc_default_complex_kind;
1893 goto kind_selector;
1894 }
1895
1896 if (gfc_match ("character") == MATCH_YES)
1897 {
1898 ts->type = BT_CHARACTER;
1899
1900 m = gfc_match_char_spec (ts);
1901
1902 if (m == MATCH_NO)
1903 m = MATCH_YES;
1904
1905 return m;
1906 }
1907
1908 if (gfc_match ("logical") == MATCH_YES)
1909 {
1910 ts->type = BT_LOGICAL;
1911 ts->kind = gfc_default_logical_kind;
1912 goto kind_selector;
1913 }
1914
1915 /* If a type is not matched, simply return MATCH_NO. */
1916 gfc_current_locus = old_locus;
1917 return MATCH_NO;
1918
1919 kind_selector:
1920
1921 gfc_gobble_whitespace ();
1922 if (gfc_peek_ascii_char () == '*')
1923 {
1924 gfc_error ("Invalid type-spec at %C");
1925 return MATCH_ERROR;
1926 }
1927
1928 m = gfc_match_kind_spec (ts, false);
1929
1930 if (m == MATCH_NO)
1931 m = MATCH_YES; /* No kind specifier found. */
1932
1933 return m;
1934 }
1935
1936
1937 /******************** FORALL subroutines ********************/
1938
1939 /* Free a list of FORALL iterators. */
1940
1941 void
1942 gfc_free_forall_iterator (gfc_forall_iterator *iter)
1943 {
1944 gfc_forall_iterator *next;
1945
1946 while (iter)
1947 {
1948 next = iter->next;
1949 gfc_free_expr (iter->var);
1950 gfc_free_expr (iter->start);
1951 gfc_free_expr (iter->end);
1952 gfc_free_expr (iter->stride);
1953 free (iter);
1954 iter = next;
1955 }
1956 }
1957
1958
1959 /* Match an iterator as part of a FORALL statement. The format is:
1960
1961 <var> = <start>:<end>[:<stride>]
1962
1963 On MATCH_NO, the caller tests for the possibility that there is a
1964 scalar mask expression. */
1965
1966 static match
1967 match_forall_iterator (gfc_forall_iterator **result)
1968 {
1969 gfc_forall_iterator *iter;
1970 locus where;
1971 match m;
1972
1973 where = gfc_current_locus;
1974 iter = XCNEW (gfc_forall_iterator);
1975
1976 m = gfc_match_expr (&iter->var);
1977 if (m != MATCH_YES)
1978 goto cleanup;
1979
1980 if (gfc_match_char ('=') != MATCH_YES
1981 || iter->var->expr_type != EXPR_VARIABLE)
1982 {
1983 m = MATCH_NO;
1984 goto cleanup;
1985 }
1986
1987 m = gfc_match_expr (&iter->start);
1988 if (m != MATCH_YES)
1989 goto cleanup;
1990
1991 if (gfc_match_char (':') != MATCH_YES)
1992 goto syntax;
1993
1994 m = gfc_match_expr (&iter->end);
1995 if (m == MATCH_NO)
1996 goto syntax;
1997 if (m == MATCH_ERROR)
1998 goto cleanup;
1999
2000 if (gfc_match_char (':') == MATCH_NO)
2001 iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
2002 else
2003 {
2004 m = gfc_match_expr (&iter->stride);
2005 if (m == MATCH_NO)
2006 goto syntax;
2007 if (m == MATCH_ERROR)
2008 goto cleanup;
2009 }
2010
2011 /* Mark the iteration variable's symbol as used as a FORALL index. */
2012 iter->var->symtree->n.sym->forall_index = true;
2013
2014 *result = iter;
2015 return MATCH_YES;
2016
2017 syntax:
2018 gfc_error ("Syntax error in FORALL iterator at %C");
2019 m = MATCH_ERROR;
2020
2021 cleanup:
2022
2023 gfc_current_locus = where;
2024 gfc_free_forall_iterator (iter);
2025 return m;
2026 }
2027
2028
2029 /* Match the header of a FORALL statement. */
2030
2031 static match
2032 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
2033 {
2034 gfc_forall_iterator *head, *tail, *new_iter;
2035 gfc_expr *msk;
2036 match m;
2037
2038 gfc_gobble_whitespace ();
2039
2040 head = tail = NULL;
2041 msk = NULL;
2042
2043 if (gfc_match_char ('(') != MATCH_YES)
2044 return MATCH_NO;
2045
2046 m = match_forall_iterator (&new_iter);
2047 if (m == MATCH_ERROR)
2048 goto cleanup;
2049 if (m == MATCH_NO)
2050 goto syntax;
2051
2052 head = tail = new_iter;
2053
2054 for (;;)
2055 {
2056 if (gfc_match_char (',') != MATCH_YES)
2057 break;
2058
2059 m = match_forall_iterator (&new_iter);
2060 if (m == MATCH_ERROR)
2061 goto cleanup;
2062
2063 if (m == MATCH_YES)
2064 {
2065 tail->next = new_iter;
2066 tail = new_iter;
2067 continue;
2068 }
2069
2070 /* Have to have a mask expression. */
2071
2072 m = gfc_match_expr (&msk);
2073 if (m == MATCH_NO)
2074 goto syntax;
2075 if (m == MATCH_ERROR)
2076 goto cleanup;
2077
2078 break;
2079 }
2080
2081 if (gfc_match_char (')') == MATCH_NO)
2082 goto syntax;
2083
2084 *phead = head;
2085 *mask = msk;
2086 return MATCH_YES;
2087
2088 syntax:
2089 gfc_syntax_error (ST_FORALL);
2090
2091 cleanup:
2092 gfc_free_expr (msk);
2093 gfc_free_forall_iterator (head);
2094
2095 return MATCH_ERROR;
2096 }
2097
2098 /* Match the rest of a simple FORALL statement that follows an
2099 IF statement. */
2100
2101 static match
2102 match_simple_forall (void)
2103 {
2104 gfc_forall_iterator *head;
2105 gfc_expr *mask;
2106 gfc_code *c;
2107 match m;
2108
2109 mask = NULL;
2110 head = NULL;
2111 c = NULL;
2112
2113 m = match_forall_header (&head, &mask);
2114
2115 if (m == MATCH_NO)
2116 goto syntax;
2117 if (m != MATCH_YES)
2118 goto cleanup;
2119
2120 m = gfc_match_assignment ();
2121
2122 if (m == MATCH_ERROR)
2123 goto cleanup;
2124 if (m == MATCH_NO)
2125 {
2126 m = gfc_match_pointer_assignment ();
2127 if (m == MATCH_ERROR)
2128 goto cleanup;
2129 if (m == MATCH_NO)
2130 goto syntax;
2131 }
2132
2133 c = XCNEW (gfc_code);
2134 *c = new_st;
2135 c->loc = gfc_current_locus;
2136
2137 if (gfc_match_eos () != MATCH_YES)
2138 goto syntax;
2139
2140 gfc_clear_new_st ();
2141 new_st.op = EXEC_FORALL;
2142 new_st.expr1 = mask;
2143 new_st.ext.forall_iterator = head;
2144 new_st.block = gfc_get_code (EXEC_FORALL);
2145 new_st.block->next = c;
2146
2147 return MATCH_YES;
2148
2149 syntax:
2150 gfc_syntax_error (ST_FORALL);
2151
2152 cleanup:
2153 gfc_free_forall_iterator (head);
2154 gfc_free_expr (mask);
2155
2156 return MATCH_ERROR;
2157 }
2158
2159
2160 /* Match a FORALL statement. */
2161
2162 match
2163 gfc_match_forall (gfc_statement *st)
2164 {
2165 gfc_forall_iterator *head;
2166 gfc_expr *mask;
2167 gfc_code *c;
2168 match m0, m;
2169
2170 head = NULL;
2171 mask = NULL;
2172 c = NULL;
2173
2174 m0 = gfc_match_label ();
2175 if (m0 == MATCH_ERROR)
2176 return MATCH_ERROR;
2177
2178 m = gfc_match (" forall");
2179 if (m != MATCH_YES)
2180 return m;
2181
2182 m = match_forall_header (&head, &mask);
2183 if (m == MATCH_ERROR)
2184 goto cleanup;
2185 if (m == MATCH_NO)
2186 goto syntax;
2187
2188 if (gfc_match_eos () == MATCH_YES)
2189 {
2190 *st = ST_FORALL_BLOCK;
2191 new_st.op = EXEC_FORALL;
2192 new_st.expr1 = mask;
2193 new_st.ext.forall_iterator = head;
2194 return MATCH_YES;
2195 }
2196
2197 m = gfc_match_assignment ();
2198 if (m == MATCH_ERROR)
2199 goto cleanup;
2200 if (m == MATCH_NO)
2201 {
2202 m = gfc_match_pointer_assignment ();
2203 if (m == MATCH_ERROR)
2204 goto cleanup;
2205 if (m == MATCH_NO)
2206 goto syntax;
2207 }
2208
2209 c = XCNEW (gfc_code);
2210 *c = new_st;
2211 c->loc = gfc_current_locus;
2212
2213 gfc_clear_new_st ();
2214 new_st.op = EXEC_FORALL;
2215 new_st.expr1 = mask;
2216 new_st.ext.forall_iterator = head;
2217 new_st.block = gfc_get_code (EXEC_FORALL);
2218 new_st.block->next = c;
2219
2220 *st = ST_FORALL;
2221 return MATCH_YES;
2222
2223 syntax:
2224 gfc_syntax_error (ST_FORALL);
2225
2226 cleanup:
2227 gfc_free_forall_iterator (head);
2228 gfc_free_expr (mask);
2229 gfc_free_statements (c);
2230 return MATCH_NO;
2231 }
2232
2233
2234 /* Match a DO statement. */
2235
2236 match
2237 gfc_match_do (void)
2238 {
2239 gfc_iterator iter, *ip;
2240 locus old_loc;
2241 gfc_st_label *label;
2242 match m;
2243
2244 old_loc = gfc_current_locus;
2245
2246 label = NULL;
2247 iter.var = iter.start = iter.end = iter.step = NULL;
2248
2249 m = gfc_match_label ();
2250 if (m == MATCH_ERROR)
2251 return m;
2252
2253 if (gfc_match (" do") != MATCH_YES)
2254 return MATCH_NO;
2255
2256 m = gfc_match_st_label (&label);
2257 if (m == MATCH_ERROR)
2258 goto cleanup;
2259
2260 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2261
2262 if (gfc_match_eos () == MATCH_YES)
2263 {
2264 iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
2265 new_st.op = EXEC_DO_WHILE;
2266 goto done;
2267 }
2268
2269 /* Match an optional comma, if no comma is found, a space is obligatory. */
2270 if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
2271 return MATCH_NO;
2272
2273 /* Check for balanced parens. */
2274
2275 if (gfc_match_parens () == MATCH_ERROR)
2276 return MATCH_ERROR;
2277
2278 if (gfc_match (" concurrent") == MATCH_YES)
2279 {
2280 gfc_forall_iterator *head;
2281 gfc_expr *mask;
2282
2283 if (!gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT construct at %C"))
2284 return MATCH_ERROR;
2285
2286
2287 mask = NULL;
2288 head = NULL;
2289 m = match_forall_header (&head, &mask);
2290
2291 if (m == MATCH_NO)
2292 return m;
2293 if (m == MATCH_ERROR)
2294 goto concurr_cleanup;
2295
2296 if (gfc_match_eos () != MATCH_YES)
2297 goto concurr_cleanup;
2298
2299 if (label != NULL
2300 && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
2301 goto concurr_cleanup;
2302
2303 new_st.label1 = label;
2304 new_st.op = EXEC_DO_CONCURRENT;
2305 new_st.expr1 = mask;
2306 new_st.ext.forall_iterator = head;
2307
2308 return MATCH_YES;
2309
2310 concurr_cleanup:
2311 gfc_syntax_error (ST_DO);
2312 gfc_free_expr (mask);
2313 gfc_free_forall_iterator (head);
2314 return MATCH_ERROR;
2315 }
2316
2317 /* See if we have a DO WHILE. */
2318 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
2319 {
2320 new_st.op = EXEC_DO_WHILE;
2321 goto done;
2322 }
2323
2324 /* The abortive DO WHILE may have done something to the symbol
2325 table, so we start over. */
2326 gfc_undo_symbols ();
2327 gfc_current_locus = old_loc;
2328
2329 gfc_match_label (); /* This won't error. */
2330 gfc_match (" do "); /* This will work. */
2331
2332 gfc_match_st_label (&label); /* Can't error out. */
2333 gfc_match_char (','); /* Optional comma. */
2334
2335 m = gfc_match_iterator (&iter, 0);
2336 if (m == MATCH_NO)
2337 return MATCH_NO;
2338 if (m == MATCH_ERROR)
2339 goto cleanup;
2340
2341 iter.var->symtree->n.sym->attr.implied_index = 0;
2342 gfc_check_do_variable (iter.var->symtree);
2343
2344 if (gfc_match_eos () != MATCH_YES)
2345 {
2346 gfc_syntax_error (ST_DO);
2347 goto cleanup;
2348 }
2349
2350 new_st.op = EXEC_DO;
2351
2352 done:
2353 if (label != NULL
2354 && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
2355 goto cleanup;
2356
2357 new_st.label1 = label;
2358
2359 if (new_st.op == EXEC_DO_WHILE)
2360 new_st.expr1 = iter.end;
2361 else
2362 {
2363 new_st.ext.iterator = ip = gfc_get_iterator ();
2364 *ip = iter;
2365 }
2366
2367 return MATCH_YES;
2368
2369 cleanup:
2370 gfc_free_iterator (&iter, 0);
2371
2372 return MATCH_ERROR;
2373 }
2374
2375
2376 /* Match an EXIT or CYCLE statement. */
2377
2378 static match
2379 match_exit_cycle (gfc_statement st, gfc_exec_op op)
2380 {
2381 gfc_state_data *p, *o;
2382 gfc_symbol *sym;
2383 match m;
2384 int cnt;
2385
2386 if (gfc_match_eos () == MATCH_YES)
2387 sym = NULL;
2388 else
2389 {
2390 char name[GFC_MAX_SYMBOL_LEN + 1];
2391 gfc_symtree* stree;
2392
2393 m = gfc_match ("% %n%t", name);
2394 if (m == MATCH_ERROR)
2395 return MATCH_ERROR;
2396 if (m == MATCH_NO)
2397 {
2398 gfc_syntax_error (st);
2399 return MATCH_ERROR;
2400 }
2401
2402 /* Find the corresponding symbol. If there's a BLOCK statement
2403 between here and the label, it is not in gfc_current_ns but a parent
2404 namespace! */
2405 stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
2406 if (!stree)
2407 {
2408 gfc_error ("Name '%s' in %s statement at %C is unknown",
2409 name, gfc_ascii_statement (st));
2410 return MATCH_ERROR;
2411 }
2412
2413 sym = stree->n.sym;
2414 if (sym->attr.flavor != FL_LABEL)
2415 {
2416 gfc_error ("Name '%s' in %s statement at %C is not a construct name",
2417 name, gfc_ascii_statement (st));
2418 return MATCH_ERROR;
2419 }
2420 }
2421
2422 /* Find the loop specified by the label (or lack of a label). */
2423 for (o = NULL, p = gfc_state_stack; p; p = p->previous)
2424 if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
2425 o = p;
2426 else if (p->state == COMP_CRITICAL)
2427 {
2428 gfc_error("%s statement at %C leaves CRITICAL construct",
2429 gfc_ascii_statement (st));
2430 return MATCH_ERROR;
2431 }
2432 else if (p->state == COMP_DO_CONCURRENT
2433 && (op == EXEC_EXIT || (sym && sym != p->sym)))
2434 {
2435 /* F2008, C821 & C845. */
2436 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2437 gfc_ascii_statement (st));
2438 return MATCH_ERROR;
2439 }
2440 else if ((sym && sym == p->sym)
2441 || (!sym && (p->state == COMP_DO
2442 || p->state == COMP_DO_CONCURRENT)))
2443 break;
2444
2445 if (p == NULL)
2446 {
2447 if (sym == NULL)
2448 gfc_error ("%s statement at %C is not within a construct",
2449 gfc_ascii_statement (st));
2450 else
2451 gfc_error ("%s statement at %C is not within construct '%s'",
2452 gfc_ascii_statement (st), sym->name);
2453
2454 return MATCH_ERROR;
2455 }
2456
2457 /* Special checks for EXIT from non-loop constructs. */
2458 switch (p->state)
2459 {
2460 case COMP_DO:
2461 case COMP_DO_CONCURRENT:
2462 break;
2463
2464 case COMP_CRITICAL:
2465 /* This is already handled above. */
2466 gcc_unreachable ();
2467
2468 case COMP_ASSOCIATE:
2469 case COMP_BLOCK:
2470 case COMP_IF:
2471 case COMP_SELECT:
2472 case COMP_SELECT_TYPE:
2473 gcc_assert (sym);
2474 if (op == EXEC_CYCLE)
2475 {
2476 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2477 " construct '%s'", sym->name);
2478 return MATCH_ERROR;
2479 }
2480 gcc_assert (op == EXEC_EXIT);
2481 if (!gfc_notify_std (GFC_STD_F2008, "EXIT statement with no"
2482 " do-construct-name at %C"))
2483 return MATCH_ERROR;
2484 break;
2485
2486 default:
2487 gfc_error ("%s statement at %C is not applicable to construct '%s'",
2488 gfc_ascii_statement (st), sym->name);
2489 return MATCH_ERROR;
2490 }
2491
2492 if (o != NULL)
2493 {
2494 gfc_error ("%s statement at %C leaving OpenMP structured block",
2495 gfc_ascii_statement (st));
2496 return MATCH_ERROR;
2497 }
2498
2499 for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++)
2500 o = o->previous;
2501 if (cnt > 0
2502 && o != NULL
2503 && o->state == COMP_OMP_STRUCTURED_BLOCK
2504 && (o->head->op == EXEC_OMP_DO
2505 || o->head->op == EXEC_OMP_PARALLEL_DO
2506 || o->head->op == EXEC_OMP_SIMD
2507 || o->head->op == EXEC_OMP_DO_SIMD
2508 || o->head->op == EXEC_OMP_PARALLEL_DO_SIMD))
2509 {
2510 int collapse = 1;
2511 gcc_assert (o->head->next != NULL
2512 && (o->head->next->op == EXEC_DO
2513 || o->head->next->op == EXEC_DO_WHILE)
2514 && o->previous != NULL
2515 && o->previous->tail->op == o->head->op);
2516 if (o->previous->tail->ext.omp_clauses != NULL
2517 && o->previous->tail->ext.omp_clauses->collapse > 1)
2518 collapse = o->previous->tail->ext.omp_clauses->collapse;
2519 if (st == ST_EXIT && cnt <= collapse)
2520 {
2521 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2522 return MATCH_ERROR;
2523 }
2524 if (st == ST_CYCLE && cnt < collapse)
2525 {
2526 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2527 " !$OMP DO loop");
2528 return MATCH_ERROR;
2529 }
2530 }
2531
2532 /* Save the first statement in the construct - needed by the backend. */
2533 new_st.ext.which_construct = p->construct;
2534
2535 new_st.op = op;
2536
2537 return MATCH_YES;
2538 }
2539
2540
2541 /* Match the EXIT statement. */
2542
2543 match
2544 gfc_match_exit (void)
2545 {
2546 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
2547 }
2548
2549
2550 /* Match the CYCLE statement. */
2551
2552 match
2553 gfc_match_cycle (void)
2554 {
2555 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
2556 }
2557
2558
2559 /* Match a number or character constant after an (ALL) STOP or PAUSE statement. */
2560
2561 static match
2562 gfc_match_stopcode (gfc_statement st)
2563 {
2564 gfc_expr *e;
2565 match m;
2566
2567 e = NULL;
2568
2569 if (gfc_match_eos () != MATCH_YES)
2570 {
2571 m = gfc_match_init_expr (&e);
2572 if (m == MATCH_ERROR)
2573 goto cleanup;
2574 if (m == MATCH_NO)
2575 goto syntax;
2576
2577 if (gfc_match_eos () != MATCH_YES)
2578 goto syntax;
2579 }
2580
2581 if (gfc_pure (NULL))
2582 {
2583 gfc_error ("%s statement not allowed in PURE procedure at %C",
2584 gfc_ascii_statement (st));
2585 goto cleanup;
2586 }
2587
2588 gfc_unset_implicit_pure (NULL);
2589
2590 if (st == ST_STOP && gfc_find_state (COMP_CRITICAL))
2591 {
2592 gfc_error ("Image control statement STOP at %C in CRITICAL block");
2593 goto cleanup;
2594 }
2595 if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT))
2596 {
2597 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
2598 goto cleanup;
2599 }
2600
2601 if (e != NULL)
2602 {
2603 if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
2604 {
2605 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2606 &e->where);
2607 goto cleanup;
2608 }
2609
2610 if (e->rank != 0)
2611 {
2612 gfc_error ("STOP code at %L must be scalar",
2613 &e->where);
2614 goto cleanup;
2615 }
2616
2617 if (e->ts.type == BT_CHARACTER
2618 && e->ts.kind != gfc_default_character_kind)
2619 {
2620 gfc_error ("STOP code at %L must be default character KIND=%d",
2621 &e->where, (int) gfc_default_character_kind);
2622 goto cleanup;
2623 }
2624
2625 if (e->ts.type == BT_INTEGER
2626 && e->ts.kind != gfc_default_integer_kind)
2627 {
2628 gfc_error ("STOP code at %L must be default integer KIND=%d",
2629 &e->where, (int) gfc_default_integer_kind);
2630 goto cleanup;
2631 }
2632 }
2633
2634 switch (st)
2635 {
2636 case ST_STOP:
2637 new_st.op = EXEC_STOP;
2638 break;
2639 case ST_ERROR_STOP:
2640 new_st.op = EXEC_ERROR_STOP;
2641 break;
2642 case ST_PAUSE:
2643 new_st.op = EXEC_PAUSE;
2644 break;
2645 default:
2646 gcc_unreachable ();
2647 }
2648
2649 new_st.expr1 = e;
2650 new_st.ext.stop_code = -1;
2651
2652 return MATCH_YES;
2653
2654 syntax:
2655 gfc_syntax_error (st);
2656
2657 cleanup:
2658
2659 gfc_free_expr (e);
2660 return MATCH_ERROR;
2661 }
2662
2663
2664 /* Match the (deprecated) PAUSE statement. */
2665
2666 match
2667 gfc_match_pause (void)
2668 {
2669 match m;
2670
2671 m = gfc_match_stopcode (ST_PAUSE);
2672 if (m == MATCH_YES)
2673 {
2674 if (!gfc_notify_std (GFC_STD_F95_DEL, "PAUSE statement at %C"))
2675 m = MATCH_ERROR;
2676 }
2677 return m;
2678 }
2679
2680
2681 /* Match the STOP statement. */
2682
2683 match
2684 gfc_match_stop (void)
2685 {
2686 return gfc_match_stopcode (ST_STOP);
2687 }
2688
2689
2690 /* Match the ERROR STOP statement. */
2691
2692 match
2693 gfc_match_error_stop (void)
2694 {
2695 if (!gfc_notify_std (GFC_STD_F2008, "ERROR STOP statement at %C"))
2696 return MATCH_ERROR;
2697
2698 return gfc_match_stopcode (ST_ERROR_STOP);
2699 }
2700
2701
2702 /* Match LOCK/UNLOCK statement. Syntax:
2703 LOCK ( lock-variable [ , lock-stat-list ] )
2704 UNLOCK ( lock-variable [ , sync-stat-list ] )
2705 where lock-stat is ACQUIRED_LOCK or sync-stat
2706 and sync-stat is STAT= or ERRMSG=. */
2707
2708 static match
2709 lock_unlock_statement (gfc_statement st)
2710 {
2711 match m;
2712 gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg;
2713 bool saw_acq_lock, saw_stat, saw_errmsg;
2714
2715 tmp = lockvar = acq_lock = stat = errmsg = NULL;
2716 saw_acq_lock = saw_stat = saw_errmsg = false;
2717
2718 if (gfc_pure (NULL))
2719 {
2720 gfc_error ("Image control statement %s at %C in PURE procedure",
2721 st == ST_LOCK ? "LOCK" : "UNLOCK");
2722 return MATCH_ERROR;
2723 }
2724
2725 gfc_unset_implicit_pure (NULL);
2726
2727 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
2728 {
2729 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2730 return MATCH_ERROR;
2731 }
2732
2733 if (gfc_find_state (COMP_CRITICAL))
2734 {
2735 gfc_error ("Image control statement %s at %C in CRITICAL block",
2736 st == ST_LOCK ? "LOCK" : "UNLOCK");
2737 return MATCH_ERROR;
2738 }
2739
2740 if (gfc_find_state (COMP_DO_CONCURRENT))
2741 {
2742 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
2743 st == ST_LOCK ? "LOCK" : "UNLOCK");
2744 return MATCH_ERROR;
2745 }
2746
2747 if (gfc_match_char ('(') != MATCH_YES)
2748 goto syntax;
2749
2750 if (gfc_match ("%e", &lockvar) != MATCH_YES)
2751 goto syntax;
2752 m = gfc_match_char (',');
2753 if (m == MATCH_ERROR)
2754 goto syntax;
2755 if (m == MATCH_NO)
2756 {
2757 m = gfc_match_char (')');
2758 if (m == MATCH_YES)
2759 goto done;
2760 goto syntax;
2761 }
2762
2763 for (;;)
2764 {
2765 m = gfc_match (" stat = %v", &tmp);
2766 if (m == MATCH_ERROR)
2767 goto syntax;
2768 if (m == MATCH_YES)
2769 {
2770 if (saw_stat)
2771 {
2772 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2773 goto cleanup;
2774 }
2775 stat = tmp;
2776 saw_stat = true;
2777
2778 m = gfc_match_char (',');
2779 if (m == MATCH_YES)
2780 continue;
2781
2782 tmp = NULL;
2783 break;
2784 }
2785
2786 m = gfc_match (" errmsg = %v", &tmp);
2787 if (m == MATCH_ERROR)
2788 goto syntax;
2789 if (m == MATCH_YES)
2790 {
2791 if (saw_errmsg)
2792 {
2793 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2794 goto cleanup;
2795 }
2796 errmsg = tmp;
2797 saw_errmsg = true;
2798
2799 m = gfc_match_char (',');
2800 if (m == MATCH_YES)
2801 continue;
2802
2803 tmp = NULL;
2804 break;
2805 }
2806
2807 m = gfc_match (" acquired_lock = %v", &tmp);
2808 if (m == MATCH_ERROR || st == ST_UNLOCK)
2809 goto syntax;
2810 if (m == MATCH_YES)
2811 {
2812 if (saw_acq_lock)
2813 {
2814 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
2815 &tmp->where);
2816 goto cleanup;
2817 }
2818 acq_lock = tmp;
2819 saw_acq_lock = true;
2820
2821 m = gfc_match_char (',');
2822 if (m == MATCH_YES)
2823 continue;
2824
2825 tmp = NULL;
2826 break;
2827 }
2828
2829 break;
2830 }
2831
2832 if (m == MATCH_ERROR)
2833 goto syntax;
2834
2835 if (gfc_match (" )%t") != MATCH_YES)
2836 goto syntax;
2837
2838 done:
2839 switch (st)
2840 {
2841 case ST_LOCK:
2842 new_st.op = EXEC_LOCK;
2843 break;
2844 case ST_UNLOCK:
2845 new_st.op = EXEC_UNLOCK;
2846 break;
2847 default:
2848 gcc_unreachable ();
2849 }
2850
2851 new_st.expr1 = lockvar;
2852 new_st.expr2 = stat;
2853 new_st.expr3 = errmsg;
2854 new_st.expr4 = acq_lock;
2855
2856 return MATCH_YES;
2857
2858 syntax:
2859 gfc_syntax_error (st);
2860
2861 cleanup:
2862 if (acq_lock != tmp)
2863 gfc_free_expr (acq_lock);
2864 if (errmsg != tmp)
2865 gfc_free_expr (errmsg);
2866 if (stat != tmp)
2867 gfc_free_expr (stat);
2868
2869 gfc_free_expr (tmp);
2870 gfc_free_expr (lockvar);
2871
2872 return MATCH_ERROR;
2873 }
2874
2875
2876 match
2877 gfc_match_lock (void)
2878 {
2879 if (!gfc_notify_std (GFC_STD_F2008, "LOCK statement at %C"))
2880 return MATCH_ERROR;
2881
2882 return lock_unlock_statement (ST_LOCK);
2883 }
2884
2885
2886 match
2887 gfc_match_unlock (void)
2888 {
2889 if (!gfc_notify_std (GFC_STD_F2008, "UNLOCK statement at %C"))
2890 return MATCH_ERROR;
2891
2892 return lock_unlock_statement (ST_UNLOCK);
2893 }
2894
2895
2896 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
2897 SYNC ALL [(sync-stat-list)]
2898 SYNC MEMORY [(sync-stat-list)]
2899 SYNC IMAGES (image-set [, sync-stat-list] )
2900 with sync-stat is int-expr or *. */
2901
2902 static match
2903 sync_statement (gfc_statement st)
2904 {
2905 match m;
2906 gfc_expr *tmp, *imageset, *stat, *errmsg;
2907 bool saw_stat, saw_errmsg;
2908
2909 tmp = imageset = stat = errmsg = NULL;
2910 saw_stat = saw_errmsg = false;
2911
2912 if (gfc_pure (NULL))
2913 {
2914 gfc_error ("Image control statement SYNC at %C in PURE procedure");
2915 return MATCH_ERROR;
2916 }
2917
2918 gfc_unset_implicit_pure (NULL);
2919
2920 if (!gfc_notify_std (GFC_STD_F2008, "SYNC statement at %C"))
2921 return MATCH_ERROR;
2922
2923 if (gfc_option.coarray == GFC_FCOARRAY_NONE)
2924 {
2925 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2926 return MATCH_ERROR;
2927 }
2928
2929 if (gfc_find_state (COMP_CRITICAL))
2930 {
2931 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
2932 return MATCH_ERROR;
2933 }
2934
2935 if (gfc_find_state (COMP_DO_CONCURRENT))
2936 {
2937 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
2938 return MATCH_ERROR;
2939 }
2940
2941 if (gfc_match_eos () == MATCH_YES)
2942 {
2943 if (st == ST_SYNC_IMAGES)
2944 goto syntax;
2945 goto done;
2946 }
2947
2948 if (gfc_match_char ('(') != MATCH_YES)
2949 goto syntax;
2950
2951 if (st == ST_SYNC_IMAGES)
2952 {
2953 /* Denote '*' as imageset == NULL. */
2954 m = gfc_match_char ('*');
2955 if (m == MATCH_ERROR)
2956 goto syntax;
2957 if (m == MATCH_NO)
2958 {
2959 if (gfc_match ("%e", &imageset) != MATCH_YES)
2960 goto syntax;
2961 }
2962 m = gfc_match_char (',');
2963 if (m == MATCH_ERROR)
2964 goto syntax;
2965 if (m == MATCH_NO)
2966 {
2967 m = gfc_match_char (')');
2968 if (m == MATCH_YES)
2969 goto done;
2970 goto syntax;
2971 }
2972 }
2973
2974 for (;;)
2975 {
2976 m = gfc_match (" stat = %v", &tmp);
2977 if (m == MATCH_ERROR)
2978 goto syntax;
2979 if (m == MATCH_YES)
2980 {
2981 if (saw_stat)
2982 {
2983 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2984 goto cleanup;
2985 }
2986 stat = tmp;
2987 saw_stat = true;
2988
2989 if (gfc_match_char (',') == MATCH_YES)
2990 continue;
2991
2992 tmp = NULL;
2993 break;
2994 }
2995
2996 m = gfc_match (" errmsg = %v", &tmp);
2997 if (m == MATCH_ERROR)
2998 goto syntax;
2999 if (m == MATCH_YES)
3000 {
3001 if (saw_errmsg)
3002 {
3003 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3004 goto cleanup;
3005 }
3006 errmsg = tmp;
3007 saw_errmsg = true;
3008
3009 if (gfc_match_char (',') == MATCH_YES)
3010 continue;
3011
3012 tmp = NULL;
3013 break;
3014 }
3015
3016 break;
3017 }
3018
3019 if (gfc_match (" )%t") != MATCH_YES)
3020 goto syntax;
3021
3022 done:
3023 switch (st)
3024 {
3025 case ST_SYNC_ALL:
3026 new_st.op = EXEC_SYNC_ALL;
3027 break;
3028 case ST_SYNC_IMAGES:
3029 new_st.op = EXEC_SYNC_IMAGES;
3030 break;
3031 case ST_SYNC_MEMORY:
3032 new_st.op = EXEC_SYNC_MEMORY;
3033 break;
3034 default:
3035 gcc_unreachable ();
3036 }
3037
3038 new_st.expr1 = imageset;
3039 new_st.expr2 = stat;
3040 new_st.expr3 = errmsg;
3041
3042 return MATCH_YES;
3043
3044 syntax:
3045 gfc_syntax_error (st);
3046
3047 cleanup:
3048 if (stat != tmp)
3049 gfc_free_expr (stat);
3050 if (errmsg != tmp)
3051 gfc_free_expr (errmsg);
3052
3053 gfc_free_expr (tmp);
3054 gfc_free_expr (imageset);
3055
3056 return MATCH_ERROR;
3057 }
3058
3059
3060 /* Match SYNC ALL statement. */
3061
3062 match
3063 gfc_match_sync_all (void)
3064 {
3065 return sync_statement (ST_SYNC_ALL);
3066 }
3067
3068
3069 /* Match SYNC IMAGES statement. */
3070
3071 match
3072 gfc_match_sync_images (void)
3073 {
3074 return sync_statement (ST_SYNC_IMAGES);
3075 }
3076
3077
3078 /* Match SYNC MEMORY statement. */
3079
3080 match
3081 gfc_match_sync_memory (void)
3082 {
3083 return sync_statement (ST_SYNC_MEMORY);
3084 }
3085
3086
3087 /* Match a CONTINUE statement. */
3088
3089 match
3090 gfc_match_continue (void)
3091 {
3092 if (gfc_match_eos () != MATCH_YES)
3093 {
3094 gfc_syntax_error (ST_CONTINUE);
3095 return MATCH_ERROR;
3096 }
3097
3098 new_st.op = EXEC_CONTINUE;
3099 return MATCH_YES;
3100 }
3101
3102
3103 /* Match the (deprecated) ASSIGN statement. */
3104
3105 match
3106 gfc_match_assign (void)
3107 {
3108 gfc_expr *expr;
3109 gfc_st_label *label;
3110
3111 if (gfc_match (" %l", &label) == MATCH_YES)
3112 {
3113 if (!gfc_reference_st_label (label, ST_LABEL_UNKNOWN))
3114 return MATCH_ERROR;
3115 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
3116 {
3117 if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGN statement at %C"))
3118 return MATCH_ERROR;
3119
3120 expr->symtree->n.sym->attr.assign = 1;
3121
3122 new_st.op = EXEC_LABEL_ASSIGN;
3123 new_st.label1 = label;
3124 new_st.expr1 = expr;
3125 return MATCH_YES;
3126 }
3127 }
3128 return MATCH_NO;
3129 }
3130
3131
3132 /* Match the GO TO statement. As a computed GOTO statement is
3133 matched, it is transformed into an equivalent SELECT block. No
3134 tree is necessary, and the resulting jumps-to-jumps are
3135 specifically optimized away by the back end. */
3136
3137 match
3138 gfc_match_goto (void)
3139 {
3140 gfc_code *head, *tail;
3141 gfc_expr *expr;
3142 gfc_case *cp;
3143 gfc_st_label *label;
3144 int i;
3145 match m;
3146
3147 if (gfc_match (" %l%t", &label) == MATCH_YES)
3148 {
3149 if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
3150 return MATCH_ERROR;
3151
3152 new_st.op = EXEC_GOTO;
3153 new_st.label1 = label;
3154 return MATCH_YES;
3155 }
3156
3157 /* The assigned GO TO statement. */
3158
3159 if (gfc_match_variable (&expr, 0) == MATCH_YES)
3160 {
3161 if (!gfc_notify_std (GFC_STD_F95_DEL, "Assigned GOTO statement at %C"))
3162 return MATCH_ERROR;
3163
3164 new_st.op = EXEC_GOTO;
3165 new_st.expr1 = expr;
3166
3167 if (gfc_match_eos () == MATCH_YES)
3168 return MATCH_YES;
3169
3170 /* Match label list. */
3171 gfc_match_char (',');
3172 if (gfc_match_char ('(') != MATCH_YES)
3173 {
3174 gfc_syntax_error (ST_GOTO);
3175 return MATCH_ERROR;
3176 }
3177 head = tail = NULL;
3178
3179 do
3180 {
3181 m = gfc_match_st_label (&label);
3182 if (m != MATCH_YES)
3183 goto syntax;
3184
3185 if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
3186 goto cleanup;
3187
3188 if (head == NULL)
3189 head = tail = gfc_get_code (EXEC_GOTO);
3190 else
3191 {
3192 tail->block = gfc_get_code (EXEC_GOTO);
3193 tail = tail->block;
3194 }
3195
3196 tail->label1 = label;
3197 }
3198 while (gfc_match_char (',') == MATCH_YES);
3199
3200 if (gfc_match (")%t") != MATCH_YES)
3201 goto syntax;
3202
3203 if (head == NULL)
3204 {
3205 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3206 goto syntax;
3207 }
3208 new_st.block = head;
3209
3210 return MATCH_YES;
3211 }
3212
3213 /* Last chance is a computed GO TO statement. */
3214 if (gfc_match_char ('(') != MATCH_YES)
3215 {
3216 gfc_syntax_error (ST_GOTO);
3217 return MATCH_ERROR;
3218 }
3219
3220 head = tail = NULL;
3221 i = 1;
3222
3223 do
3224 {
3225 m = gfc_match_st_label (&label);
3226 if (m != MATCH_YES)
3227 goto syntax;
3228
3229 if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
3230 goto cleanup;
3231
3232 if (head == NULL)
3233 head = tail = gfc_get_code (EXEC_SELECT);
3234 else
3235 {
3236 tail->block = gfc_get_code (EXEC_SELECT);
3237 tail = tail->block;
3238 }
3239
3240 cp = gfc_get_case ();
3241 cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
3242 NULL, i++);
3243
3244 tail->ext.block.case_list = cp;
3245
3246 tail->next = gfc_get_code (EXEC_GOTO);
3247 tail->next->label1 = label;
3248 }
3249 while (gfc_match_char (',') == MATCH_YES);
3250
3251 if (gfc_match_char (')') != MATCH_YES)
3252 goto syntax;
3253
3254 if (head == NULL)
3255 {
3256 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3257 goto syntax;
3258 }
3259
3260 /* Get the rest of the statement. */
3261 gfc_match_char (',');
3262
3263 if (gfc_match (" %e%t", &expr) != MATCH_YES)
3264 goto syntax;
3265
3266 if (!gfc_notify_std (GFC_STD_F95_OBS, "Computed GOTO at %C"))
3267 return MATCH_ERROR;
3268
3269 /* At this point, a computed GOTO has been fully matched and an
3270 equivalent SELECT statement constructed. */
3271
3272 new_st.op = EXEC_SELECT;
3273 new_st.expr1 = NULL;
3274
3275 /* Hack: For a "real" SELECT, the expression is in expr. We put
3276 it in expr2 so we can distinguish then and produce the correct
3277 diagnostics. */
3278 new_st.expr2 = expr;
3279 new_st.block = head;
3280 return MATCH_YES;
3281
3282 syntax:
3283 gfc_syntax_error (ST_GOTO);
3284 cleanup:
3285 gfc_free_statements (head);
3286 return MATCH_ERROR;
3287 }
3288
3289
3290 /* Frees a list of gfc_alloc structures. */
3291
3292 void
3293 gfc_free_alloc_list (gfc_alloc *p)
3294 {
3295 gfc_alloc *q;
3296
3297 for (; p; p = q)
3298 {
3299 q = p->next;
3300 gfc_free_expr (p->expr);
3301 free (p);
3302 }
3303 }
3304
3305
3306 /* Match an ALLOCATE statement. */
3307
3308 match
3309 gfc_match_allocate (void)
3310 {
3311 gfc_alloc *head, *tail;
3312 gfc_expr *stat, *errmsg, *tmp, *source, *mold;
3313 gfc_typespec ts;
3314 gfc_symbol *sym;
3315 match m;
3316 locus old_locus, deferred_locus;
3317 bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
3318 bool saw_unlimited = false;
3319
3320 head = tail = NULL;
3321 stat = errmsg = source = mold = tmp = NULL;
3322 saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
3323
3324 if (gfc_match_char ('(') != MATCH_YES)
3325 goto syntax;
3326
3327 /* Match an optional type-spec. */
3328 old_locus = gfc_current_locus;
3329 m = gfc_match_type_spec (&ts);
3330 if (m == MATCH_ERROR)
3331 goto cleanup;
3332 else if (m == MATCH_NO)
3333 {
3334 char name[GFC_MAX_SYMBOL_LEN + 3];
3335
3336 if (gfc_match ("%n :: ", name) == MATCH_YES)
3337 {
3338 gfc_error ("Error in type-spec at %L", &old_locus);
3339 goto cleanup;
3340 }
3341
3342 ts.type = BT_UNKNOWN;
3343 }
3344 else
3345 {
3346 if (gfc_match (" :: ") == MATCH_YES)
3347 {
3348 if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L",
3349 &old_locus))
3350 goto cleanup;
3351
3352 if (ts.deferred)
3353 {
3354 gfc_error ("Type-spec at %L cannot contain a deferred "
3355 "type parameter", &old_locus);
3356 goto cleanup;
3357 }
3358
3359 if (ts.type == BT_CHARACTER)
3360 ts.u.cl->length_from_typespec = true;
3361 }
3362 else
3363 {
3364 ts.type = BT_UNKNOWN;
3365 gfc_current_locus = old_locus;
3366 }
3367 }
3368
3369 for (;;)
3370 {
3371 if (head == NULL)
3372 head = tail = gfc_get_alloc ();
3373 else
3374 {
3375 tail->next = gfc_get_alloc ();
3376 tail = tail->next;
3377 }
3378
3379 m = gfc_match_variable (&tail->expr, 0);
3380 if (m == MATCH_NO)
3381 goto syntax;
3382 if (m == MATCH_ERROR)
3383 goto cleanup;
3384
3385 if (gfc_check_do_variable (tail->expr->symtree))
3386 goto cleanup;
3387
3388 bool impure = gfc_impure_variable (tail->expr->symtree->n.sym);
3389 if (impure && gfc_pure (NULL))
3390 {
3391 gfc_error ("Bad allocate-object at %C for a PURE procedure");
3392 goto cleanup;
3393 }
3394
3395 if (impure)
3396 gfc_unset_implicit_pure (NULL);
3397
3398 if (tail->expr->ts.deferred)
3399 {
3400 saw_deferred = true;
3401 deferred_locus = tail->expr->where;
3402 }
3403
3404 if (gfc_find_state (COMP_DO_CONCURRENT)
3405 || gfc_find_state (COMP_CRITICAL))
3406 {
3407 gfc_ref *ref;
3408 bool coarray = tail->expr->symtree->n.sym->attr.codimension;
3409 for (ref = tail->expr->ref; ref; ref = ref->next)
3410 if (ref->type == REF_COMPONENT)
3411 coarray = ref->u.c.component->attr.codimension;
3412
3413 if (coarray && gfc_find_state (COMP_DO_CONCURRENT))
3414 {
3415 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
3416 goto cleanup;
3417 }
3418 if (coarray && gfc_find_state (COMP_CRITICAL))
3419 {
3420 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
3421 goto cleanup;
3422 }
3423 }
3424
3425 /* Check for F08:C628. */
3426 sym = tail->expr->symtree->n.sym;
3427 b1 = !(tail->expr->ref
3428 && (tail->expr->ref->type == REF_COMPONENT
3429 || tail->expr->ref->type == REF_ARRAY));
3430 if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok)
3431 b2 = !(CLASS_DATA (sym)->attr.allocatable
3432 || CLASS_DATA (sym)->attr.class_pointer);
3433 else
3434 b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
3435 || sym->attr.proc_pointer);
3436 b3 = sym && sym->ns && sym->ns->proc_name
3437 && (sym->ns->proc_name->attr.allocatable
3438 || sym->ns->proc_name->attr.pointer
3439 || sym->ns->proc_name->attr.proc_pointer);
3440 if (b1 && b2 && !b3)
3441 {
3442 gfc_error ("Allocate-object at %L is neither a data pointer "
3443 "nor an allocatable variable", &tail->expr->where);
3444 goto cleanup;
3445 }
3446
3447 /* The ALLOCATE statement had an optional typespec. Check the
3448 constraints. */
3449 if (ts.type != BT_UNKNOWN)
3450 {
3451 /* Enforce F03:C624. */
3452 if (!gfc_type_compatible (&tail->expr->ts, &ts))
3453 {
3454 gfc_error ("Type of entity at %L is type incompatible with "
3455 "typespec", &tail->expr->where);
3456 goto cleanup;
3457 }
3458
3459 /* Enforce F03:C627. */
3460 if (ts.kind != tail->expr->ts.kind && !UNLIMITED_POLY (tail->expr))
3461 {
3462 gfc_error ("Kind type parameter for entity at %L differs from "
3463 "the kind type parameter of the typespec",
3464 &tail->expr->where);
3465 goto cleanup;
3466 }
3467 }
3468
3469 if (tail->expr->ts.type == BT_DERIVED)
3470 tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
3471
3472 saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr);
3473
3474 if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
3475 {
3476 gfc_error ("Shape specification for allocatable scalar at %C");
3477 goto cleanup;
3478 }
3479
3480 if (gfc_match_char (',') != MATCH_YES)
3481 break;
3482
3483 alloc_opt_list:
3484
3485 m = gfc_match (" stat = %v", &tmp);
3486 if (m == MATCH_ERROR)
3487 goto cleanup;
3488 if (m == MATCH_YES)
3489 {
3490 /* Enforce C630. */
3491 if (saw_stat)
3492 {
3493 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3494 goto cleanup;
3495 }
3496
3497 stat = tmp;
3498 tmp = NULL;
3499 saw_stat = true;
3500
3501 if (gfc_check_do_variable (stat->symtree))
3502 goto cleanup;
3503
3504 if (gfc_match_char (',') == MATCH_YES)
3505 goto alloc_opt_list;
3506 }
3507
3508 m = gfc_match (" errmsg = %v", &tmp);
3509 if (m == MATCH_ERROR)
3510 goto cleanup;
3511 if (m == MATCH_YES)
3512 {
3513 if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG tag at %L", &tmp->where))
3514 goto cleanup;
3515
3516 /* Enforce C630. */
3517 if (saw_errmsg)
3518 {
3519 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3520 goto cleanup;
3521 }
3522
3523 errmsg = tmp;
3524 tmp = NULL;
3525 saw_errmsg = true;
3526
3527 if (gfc_match_char (',') == MATCH_YES)
3528 goto alloc_opt_list;
3529 }
3530
3531 m = gfc_match (" source = %e", &tmp);
3532 if (m == MATCH_ERROR)
3533 goto cleanup;
3534 if (m == MATCH_YES)
3535 {
3536 if (!gfc_notify_std (GFC_STD_F2003, "SOURCE tag at %L", &tmp->where))
3537 goto cleanup;
3538
3539 /* Enforce C630. */
3540 if (saw_source)
3541 {
3542 gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
3543 goto cleanup;
3544 }
3545
3546 /* The next 2 conditionals check C631. */
3547 if (ts.type != BT_UNKNOWN)
3548 {
3549 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
3550 &tmp->where, &old_locus);
3551 goto cleanup;
3552 }
3553
3554 if (head->next
3555 && !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L"
3556 " with more than a single allocate object",
3557 &tmp->where))
3558 goto cleanup;
3559
3560 source = tmp;
3561 tmp = NULL;
3562 saw_source = true;
3563
3564 if (gfc_match_char (',') == MATCH_YES)
3565 goto alloc_opt_list;
3566 }
3567
3568 m = gfc_match (" mold = %e", &tmp);
3569 if (m == MATCH_ERROR)
3570 goto cleanup;
3571 if (m == MATCH_YES)
3572 {
3573 if (!gfc_notify_std (GFC_STD_F2008, "MOLD tag at %L", &tmp->where))
3574 goto cleanup;
3575
3576 /* Check F08:C636. */
3577 if (saw_mold)
3578 {
3579 gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
3580 goto cleanup;
3581 }
3582
3583 /* Check F08:C637. */
3584 if (ts.type != BT_UNKNOWN)
3585 {
3586 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
3587 &tmp->where, &old_locus);
3588 goto cleanup;
3589 }
3590
3591 mold = tmp;
3592 tmp = NULL;
3593 saw_mold = true;
3594 mold->mold = 1;
3595
3596 if (gfc_match_char (',') == MATCH_YES)
3597 goto alloc_opt_list;
3598 }
3599
3600 gfc_gobble_whitespace ();
3601
3602 if (gfc_peek_char () == ')')
3603 break;
3604 }
3605
3606 if (gfc_match (" )%t") != MATCH_YES)
3607 goto syntax;
3608
3609 /* Check F08:C637. */
3610 if (source && mold)
3611 {
3612 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
3613 &mold->where, &source->where);
3614 goto cleanup;
3615 }
3616
3617 /* Check F03:C623, */
3618 if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold)
3619 {
3620 gfc_error ("Allocate-object at %L with a deferred type parameter "
3621 "requires either a type-spec or SOURCE tag or a MOLD tag",
3622 &deferred_locus);
3623 goto cleanup;
3624 }
3625
3626 /* Check F03:C625, */
3627 if (saw_unlimited && ts.type == BT_UNKNOWN && !source && !mold)
3628 {
3629 for (tail = head; tail; tail = tail->next)
3630 {
3631 if (UNLIMITED_POLY (tail->expr))
3632 gfc_error ("Unlimited polymorphic allocate-object at %L "
3633 "requires either a type-spec or SOURCE tag "
3634 "or a MOLD tag", &tail->expr->where);
3635 }
3636 goto cleanup;
3637 }
3638
3639 new_st.op = EXEC_ALLOCATE;
3640 new_st.expr1 = stat;
3641 new_st.expr2 = errmsg;
3642 if (source)
3643 new_st.expr3 = source;
3644 else
3645 new_st.expr3 = mold;
3646 new_st.ext.alloc.list = head;
3647 new_st.ext.alloc.ts = ts;
3648
3649 return MATCH_YES;
3650
3651 syntax:
3652 gfc_syntax_error (ST_ALLOCATE);
3653
3654 cleanup:
3655 gfc_free_expr (errmsg);
3656 gfc_free_expr (source);
3657 gfc_free_expr (stat);
3658 gfc_free_expr (mold);
3659 if (tmp && tmp->expr_type) gfc_free_expr (tmp);
3660 gfc_free_alloc_list (head);
3661 return MATCH_ERROR;
3662 }
3663
3664
3665 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
3666 a set of pointer assignments to intrinsic NULL(). */
3667
3668 match
3669 gfc_match_nullify (void)
3670 {
3671 gfc_code *tail;
3672 gfc_expr *e, *p;
3673 match m;
3674
3675 tail = NULL;
3676
3677 if (gfc_match_char ('(') != MATCH_YES)
3678 goto syntax;
3679
3680 for (;;)
3681 {
3682 m = gfc_match_variable (&p, 0);
3683 if (m == MATCH_ERROR)
3684 goto cleanup;
3685 if (m == MATCH_NO)
3686 goto syntax;
3687
3688 if (gfc_check_do_variable (p->symtree))
3689 goto cleanup;
3690
3691 /* F2008, C1242. */
3692 if (gfc_is_coindexed (p))
3693 {
3694 gfc_error ("Pointer object at %C shall not be coindexed");
3695 goto cleanup;
3696 }
3697
3698 /* build ' => NULL() '. */
3699 e = gfc_get_null_expr (&gfc_current_locus);
3700
3701 /* Chain to list. */
3702 if (tail == NULL)
3703 {
3704 tail = &new_st;
3705 tail->op = EXEC_POINTER_ASSIGN;
3706 }
3707 else
3708 {
3709 tail->next = gfc_get_code (EXEC_POINTER_ASSIGN);
3710 tail = tail->next;
3711 }
3712
3713 tail->expr1 = p;
3714 tail->expr2 = e;
3715
3716 if (gfc_match (" )%t") == MATCH_YES)
3717 break;
3718 if (gfc_match_char (',') != MATCH_YES)
3719 goto syntax;
3720 }
3721
3722 return MATCH_YES;
3723
3724 syntax:
3725 gfc_syntax_error (ST_NULLIFY);
3726
3727 cleanup:
3728 gfc_free_statements (new_st.next);
3729 new_st.next = NULL;
3730 gfc_free_expr (new_st.expr1);
3731 new_st.expr1 = NULL;
3732 gfc_free_expr (new_st.expr2);
3733 new_st.expr2 = NULL;
3734 return MATCH_ERROR;
3735 }
3736
3737
3738 /* Match a DEALLOCATE statement. */
3739
3740 match
3741 gfc_match_deallocate (void)
3742 {
3743 gfc_alloc *head, *tail;
3744 gfc_expr *stat, *errmsg, *tmp;
3745 gfc_symbol *sym;
3746 match m;
3747 bool saw_stat, saw_errmsg, b1, b2;
3748
3749 head = tail = NULL;
3750 stat = errmsg = tmp = NULL;
3751 saw_stat = saw_errmsg = false;
3752
3753 if (gfc_match_char ('(') != MATCH_YES)
3754 goto syntax;
3755
3756 for (;;)
3757 {
3758 if (head == NULL)
3759 head = tail = gfc_get_alloc ();
3760 else
3761 {
3762 tail->next = gfc_get_alloc ();
3763 tail = tail->next;
3764 }
3765
3766 m = gfc_match_variable (&tail->expr, 0);
3767 if (m == MATCH_ERROR)
3768 goto cleanup;
3769 if (m == MATCH_NO)
3770 goto syntax;
3771
3772 if (gfc_check_do_variable (tail->expr->symtree))
3773 goto cleanup;
3774
3775 sym = tail->expr->symtree->n.sym;
3776
3777 bool impure = gfc_impure_variable (sym);
3778 if (impure && gfc_pure (NULL))
3779 {
3780 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3781 goto cleanup;
3782 }
3783
3784 if (impure)
3785 gfc_unset_implicit_pure (NULL);
3786
3787 if (gfc_is_coarray (tail->expr)
3788 && gfc_find_state (COMP_DO_CONCURRENT))
3789 {
3790 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
3791 goto cleanup;
3792 }
3793
3794 if (gfc_is_coarray (tail->expr)
3795 && gfc_find_state (COMP_CRITICAL))
3796 {
3797 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
3798 goto cleanup;
3799 }
3800
3801 /* FIXME: disable the checking on derived types. */
3802 b1 = !(tail->expr->ref
3803 && (tail->expr->ref->type == REF_COMPONENT
3804 || tail->expr->ref->type == REF_ARRAY));
3805 if (sym && sym->ts.type == BT_CLASS)
3806 b2 = !(CLASS_DATA (sym)->attr.allocatable
3807 || CLASS_DATA (sym)->attr.class_pointer);
3808 else
3809 b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
3810 || sym->attr.proc_pointer);
3811 if (b1 && b2)
3812 {
3813 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3814 "nor an allocatable variable");
3815 goto cleanup;
3816 }
3817
3818 if (gfc_match_char (',') != MATCH_YES)
3819 break;
3820
3821 dealloc_opt_list:
3822
3823 m = gfc_match (" stat = %v", &tmp);
3824 if (m == MATCH_ERROR)
3825 goto cleanup;
3826 if (m == MATCH_YES)
3827 {
3828 if (saw_stat)
3829 {
3830 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3831 gfc_free_expr (tmp);
3832 goto cleanup;
3833 }
3834
3835 stat = tmp;
3836 saw_stat = true;
3837
3838 if (gfc_check_do_variable (stat->symtree))
3839 goto cleanup;
3840
3841 if (gfc_match_char (',') == MATCH_YES)
3842 goto dealloc_opt_list;
3843 }
3844
3845 m = gfc_match (" errmsg = %v", &tmp);
3846 if (m == MATCH_ERROR)
3847 goto cleanup;
3848 if (m == MATCH_YES)
3849 {
3850 if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG at %L", &tmp->where))
3851 goto cleanup;
3852
3853 if (saw_errmsg)
3854 {
3855 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3856 gfc_free_expr (tmp);
3857 goto cleanup;
3858 }
3859
3860 errmsg = tmp;
3861 saw_errmsg = true;
3862
3863 if (gfc_match_char (',') == MATCH_YES)
3864 goto dealloc_opt_list;
3865 }
3866
3867 gfc_gobble_whitespace ();
3868
3869 if (gfc_peek_char () == ')')
3870 break;
3871 }
3872
3873 if (gfc_match (" )%t") != MATCH_YES)
3874 goto syntax;
3875
3876 new_st.op = EXEC_DEALLOCATE;
3877 new_st.expr1 = stat;
3878 new_st.expr2 = errmsg;
3879 new_st.ext.alloc.list = head;
3880
3881 return MATCH_YES;
3882
3883 syntax:
3884 gfc_syntax_error (ST_DEALLOCATE);
3885
3886 cleanup:
3887 gfc_free_expr (errmsg);
3888 gfc_free_expr (stat);
3889 gfc_free_alloc_list (head);
3890 return MATCH_ERROR;
3891 }
3892
3893
3894 /* Match a RETURN statement. */
3895
3896 match
3897 gfc_match_return (void)
3898 {
3899 gfc_expr *e;
3900 match m;
3901 gfc_compile_state s;
3902
3903 e = NULL;
3904
3905 if (gfc_find_state (COMP_CRITICAL))
3906 {
3907 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
3908 return MATCH_ERROR;
3909 }
3910
3911 if (gfc_find_state (COMP_DO_CONCURRENT))
3912 {
3913 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
3914 return MATCH_ERROR;
3915 }
3916
3917 if (gfc_match_eos () == MATCH_YES)
3918 goto done;
3919
3920 if (!gfc_find_state (COMP_SUBROUTINE))
3921 {
3922 gfc_error ("Alternate RETURN statement at %C is only allowed within "
3923 "a SUBROUTINE");
3924 goto cleanup;
3925 }
3926
3927 if (gfc_current_form == FORM_FREE)
3928 {
3929 /* The following are valid, so we can't require a blank after the
3930 RETURN keyword:
3931 return+1
3932 return(1) */
3933 char c = gfc_peek_ascii_char ();
3934 if (ISALPHA (c) || ISDIGIT (c))
3935 return MATCH_NO;
3936 }
3937
3938 m = gfc_match (" %e%t", &e);
3939 if (m == MATCH_YES)
3940 goto done;
3941 if (m == MATCH_ERROR)
3942 goto cleanup;
3943
3944 gfc_syntax_error (ST_RETURN);
3945
3946 cleanup:
3947 gfc_free_expr (e);
3948 return MATCH_ERROR;
3949
3950 done:
3951 gfc_enclosing_unit (&s);
3952 if (s == COMP_PROGRAM
3953 && !gfc_notify_std (GFC_STD_GNU, "RETURN statement in "
3954 "main program at %C"))
3955 return MATCH_ERROR;
3956
3957 new_st.op = EXEC_RETURN;
3958 new_st.expr1 = e;
3959
3960 return MATCH_YES;
3961 }
3962
3963
3964 /* Match the call of a type-bound procedure, if CALL%var has already been
3965 matched and var found to be a derived-type variable. */
3966
3967 static match
3968 match_typebound_call (gfc_symtree* varst)
3969 {
3970 gfc_expr* base;
3971 match m;
3972
3973 base = gfc_get_expr ();
3974 base->expr_type = EXPR_VARIABLE;
3975 base->symtree = varst;
3976 base->where = gfc_current_locus;
3977 gfc_set_sym_referenced (varst->n.sym);
3978
3979 m = gfc_match_varspec (base, 0, true, true);
3980 if (m == MATCH_NO)
3981 gfc_error ("Expected component reference at %C");
3982 if (m != MATCH_YES)
3983 {
3984 gfc_free_expr (base);
3985 return MATCH_ERROR;
3986 }
3987
3988 if (gfc_match_eos () != MATCH_YES)
3989 {
3990 gfc_error ("Junk after CALL at %C");
3991 gfc_free_expr (base);
3992 return MATCH_ERROR;
3993 }
3994
3995 if (base->expr_type == EXPR_COMPCALL)
3996 new_st.op = EXEC_COMPCALL;
3997 else if (base->expr_type == EXPR_PPC)
3998 new_st.op = EXEC_CALL_PPC;
3999 else
4000 {
4001 gfc_error ("Expected type-bound procedure or procedure pointer component "
4002 "at %C");
4003 gfc_free_expr (base);
4004 return MATCH_ERROR;
4005 }
4006 new_st.expr1 = base;
4007
4008 return MATCH_YES;
4009 }
4010
4011
4012 /* Match a CALL statement. The tricky part here are possible
4013 alternate return specifiers. We handle these by having all
4014 "subroutines" actually return an integer via a register that gives
4015 the return number. If the call specifies alternate returns, we
4016 generate code for a SELECT statement whose case clauses contain
4017 GOTOs to the various labels. */
4018
4019 match
4020 gfc_match_call (void)
4021 {
4022 char name[GFC_MAX_SYMBOL_LEN + 1];
4023 gfc_actual_arglist *a, *arglist;
4024 gfc_case *new_case;
4025 gfc_symbol *sym;
4026 gfc_symtree *st;
4027 gfc_code *c;
4028 match m;
4029 int i;
4030
4031 arglist = NULL;
4032
4033 m = gfc_match ("% %n", name);
4034 if (m == MATCH_NO)
4035 goto syntax;
4036 if (m != MATCH_YES)
4037 return m;
4038
4039 if (gfc_get_ha_sym_tree (name, &st))
4040 return MATCH_ERROR;
4041
4042 sym = st->n.sym;
4043
4044 /* If this is a variable of derived-type, it probably starts a type-bound
4045 procedure call. */
4046 if ((sym->attr.flavor != FL_PROCEDURE
4047 || gfc_is_function_return_value (sym, gfc_current_ns))
4048 && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
4049 return match_typebound_call (st);
4050
4051 /* If it does not seem to be callable (include functions so that the
4052 right association is made. They are thrown out in resolution.)
4053 ... */
4054 if (!sym->attr.generic
4055 && !sym->attr.subroutine
4056 && !sym->attr.function)
4057 {
4058 if (!(sym->attr.external && !sym->attr.referenced))
4059 {
4060 /* ...create a symbol in this scope... */
4061 if (sym->ns != gfc_current_ns
4062 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
4063 return MATCH_ERROR;
4064
4065 if (sym != st->n.sym)
4066 sym = st->n.sym;
4067 }
4068
4069 /* ...and then to try to make the symbol into a subroutine. */
4070 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
4071 return MATCH_ERROR;
4072 }
4073
4074 gfc_set_sym_referenced (sym);
4075
4076 if (gfc_match_eos () != MATCH_YES)
4077 {
4078 m = gfc_match_actual_arglist (1, &arglist);
4079 if (m == MATCH_NO)
4080 goto syntax;
4081 if (m == MATCH_ERROR)
4082 goto cleanup;
4083
4084 if (gfc_match_eos () != MATCH_YES)
4085 goto syntax;
4086 }
4087
4088 /* If any alternate return labels were found, construct a SELECT
4089 statement that will jump to the right place. */
4090
4091 i = 0;
4092 for (a = arglist; a; a = a->next)
4093 if (a->expr == NULL)
4094 {
4095 i = 1;
4096 break;
4097 }
4098
4099 if (i)
4100 {
4101 gfc_symtree *select_st;
4102 gfc_symbol *select_sym;
4103 char name[GFC_MAX_SYMBOL_LEN + 1];
4104
4105 new_st.next = c = gfc_get_code (EXEC_SELECT);
4106 sprintf (name, "_result_%s", sym->name);
4107 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
4108
4109 select_sym = select_st->n.sym;
4110 select_sym->ts.type = BT_INTEGER;
4111 select_sym->ts.kind = gfc_default_integer_kind;
4112 gfc_set_sym_referenced (select_sym);
4113 c->expr1 = gfc_get_expr ();
4114 c->expr1->expr_type = EXPR_VARIABLE;
4115 c->expr1->symtree = select_st;
4116 c->expr1->ts = select_sym->ts;
4117 c->expr1->where = gfc_current_locus;
4118
4119 i = 0;
4120 for (a = arglist; a; a = a->next)
4121 {
4122 if (a->expr != NULL)
4123 continue;
4124
4125 if (!gfc_reference_st_label (a->label, ST_LABEL_TARGET))
4126 continue;
4127
4128 i++;
4129
4130 c->block = gfc_get_code (EXEC_SELECT);
4131 c = c->block;
4132
4133 new_case = gfc_get_case ();
4134 new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
4135 new_case->low = new_case->high;
4136 c->ext.block.case_list = new_case;
4137
4138 c->next = gfc_get_code (EXEC_GOTO);
4139 c->next->label1 = a->label;
4140 }
4141 }
4142
4143 new_st.op = EXEC_CALL;
4144 new_st.symtree = st;
4145 new_st.ext.actual = arglist;
4146
4147 return MATCH_YES;
4148
4149 syntax:
4150 gfc_syntax_error (ST_CALL);
4151
4152 cleanup:
4153 gfc_free_actual_arglist (arglist);
4154 return MATCH_ERROR;
4155 }
4156
4157
4158 /* Given a name, return a pointer to the common head structure,
4159 creating it if it does not exist. If FROM_MODULE is nonzero, we
4160 mangle the name so that it doesn't interfere with commons defined
4161 in the using namespace.
4162 TODO: Add to global symbol tree. */
4163
4164 gfc_common_head *
4165 gfc_get_common (const char *name, int from_module)
4166 {
4167 gfc_symtree *st;
4168 static int serial = 0;
4169 char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
4170
4171 if (from_module)
4172 {
4173 /* A use associated common block is only needed to correctly layout
4174 the variables it contains. */
4175 snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
4176 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
4177 }
4178 else
4179 {
4180 st = gfc_find_symtree (gfc_current_ns->common_root, name);
4181
4182 if (st == NULL)
4183 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
4184 }
4185
4186 if (st->n.common == NULL)
4187 {
4188 st->n.common = gfc_get_common_head ();
4189 st->n.common->where = gfc_current_locus;
4190 strcpy (st->n.common->name, name);
4191 }
4192
4193 return st->n.common;
4194 }
4195
4196
4197 /* Match a common block name. */
4198
4199 match match_common_name (char *name)
4200 {
4201 match m;
4202
4203 if (gfc_match_char ('/') == MATCH_NO)
4204 {
4205 name[0] = '\0';
4206 return MATCH_YES;
4207 }
4208
4209 if (gfc_match_char ('/') == MATCH_YES)
4210 {
4211 name[0] = '\0';
4212 return MATCH_YES;
4213 }
4214
4215 m = gfc_match_name (name);
4216
4217 if (m == MATCH_ERROR)
4218 return MATCH_ERROR;
4219 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
4220 return MATCH_YES;
4221
4222 gfc_error ("Syntax error in common block name at %C");
4223 return MATCH_ERROR;
4224 }
4225
4226
4227 /* Match a COMMON statement. */
4228
4229 match
4230 gfc_match_common (void)
4231 {
4232 gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
4233 char name[GFC_MAX_SYMBOL_LEN + 1];
4234 gfc_common_head *t;
4235 gfc_array_spec *as;
4236 gfc_equiv *e1, *e2;
4237 match m;
4238
4239 old_blank_common = gfc_current_ns->blank_common.head;
4240 if (old_blank_common)
4241 {
4242 while (old_blank_common->common_next)
4243 old_blank_common = old_blank_common->common_next;
4244 }
4245
4246 as = NULL;
4247
4248 for (;;)
4249 {
4250 m = match_common_name (name);
4251 if (m == MATCH_ERROR)
4252 goto cleanup;
4253
4254 if (name[0] == '\0')
4255 {
4256 t = &gfc_current_ns->blank_common;
4257 if (t->head == NULL)
4258 t->where = gfc_current_locus;
4259 }
4260 else
4261 {
4262 t = gfc_get_common (name, 0);
4263 }
4264 head = &t->head;
4265
4266 if (*head == NULL)
4267 tail = NULL;
4268 else
4269 {
4270 tail = *head;
4271 while (tail->common_next)
4272 tail = tail->common_next;
4273 }
4274
4275 /* Grab the list of symbols. */
4276 for (;;)
4277 {
4278 m = gfc_match_symbol (&sym, 0);
4279 if (m == MATCH_ERROR)
4280 goto cleanup;
4281 if (m == MATCH_NO)
4282 goto syntax;
4283
4284 /* Store a ref to the common block for error checking. */
4285 sym->common_block = t;
4286 sym->common_block->refs++;
4287
4288 /* See if we know the current common block is bind(c), and if
4289 so, then see if we can check if the symbol is (which it'll
4290 need to be). This can happen if the bind(c) attr stmt was
4291 applied to the common block, and the variable(s) already
4292 defined, before declaring the common block. */
4293 if (t->is_bind_c == 1)
4294 {
4295 if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
4296 {
4297 /* If we find an error, just print it and continue,
4298 cause it's just semantic, and we can see if there
4299 are more errors. */
4300 gfc_error_now ("Variable '%s' at %L in common block '%s' "
4301 "at %C must be declared with a C "
4302 "interoperable kind since common block "
4303 "'%s' is bind(c)",
4304 sym->name, &(sym->declared_at), t->name,
4305 t->name);
4306 }
4307
4308 if (sym->attr.is_bind_c == 1)
4309 gfc_error_now ("Variable '%s' in common block "
4310 "'%s' at %C can not be bind(c) since "
4311 "it is not global", sym->name, t->name);
4312 }
4313
4314 if (sym->attr.in_common)
4315 {
4316 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
4317 sym->name);
4318 goto cleanup;
4319 }
4320
4321 if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
4322 || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
4323 {
4324 if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at "
4325 "%C can only be COMMON in BLOCK DATA",
4326 sym->name))
4327 goto cleanup;
4328 }
4329
4330 if (!gfc_add_in_common (&sym->attr, sym->name, NULL))
4331 goto cleanup;
4332
4333 if (tail != NULL)
4334 tail->common_next = sym;
4335 else
4336 *head = sym;
4337
4338 tail = sym;
4339
4340 /* Deal with an optional array specification after the
4341 symbol name. */
4342 m = gfc_match_array_spec (&as, true, true);
4343 if (m == MATCH_ERROR)
4344 goto cleanup;
4345
4346 if (m == MATCH_YES)
4347 {
4348 if (as->type != AS_EXPLICIT)
4349 {
4350 gfc_error ("Array specification for symbol '%s' in COMMON "
4351 "at %C must be explicit", sym->name);
4352 goto cleanup;
4353 }
4354
4355 if (!gfc_add_dimension (&sym->attr, sym->name, NULL))
4356 goto cleanup;
4357
4358 if (sym->attr.pointer)
4359 {
4360 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
4361 "POINTER array", sym->name);
4362 goto cleanup;
4363 }
4364
4365 sym->as = as;
4366 as = NULL;
4367
4368 }
4369
4370 sym->common_head = t;
4371
4372 /* Check to see if the symbol is already in an equivalence group.
4373 If it is, set the other members as being in common. */
4374 if (sym->attr.in_equivalence)
4375 {
4376 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
4377 {
4378 for (e2 = e1; e2; e2 = e2->eq)
4379 if (e2->expr->symtree->n.sym == sym)
4380 goto equiv_found;
4381
4382 continue;
4383
4384 equiv_found:
4385
4386 for (e2 = e1; e2; e2 = e2->eq)
4387 {
4388 other = e2->expr->symtree->n.sym;
4389 if (other->common_head
4390 && other->common_head != sym->common_head)
4391 {
4392 gfc_error ("Symbol '%s', in COMMON block '%s' at "
4393 "%C is being indirectly equivalenced to "
4394 "another COMMON block '%s'",
4395 sym->name, sym->common_head->name,
4396 other->common_head->name);
4397 goto cleanup;
4398 }
4399 other->attr.in_common = 1;
4400 other->common_head = t;
4401 }
4402 }
4403 }
4404
4405
4406 gfc_gobble_whitespace ();
4407 if (gfc_match_eos () == MATCH_YES)
4408 goto done;
4409 if (gfc_peek_ascii_char () == '/')
4410 break;
4411 if (gfc_match_char (',') != MATCH_YES)
4412 goto syntax;
4413 gfc_gobble_whitespace ();
4414 if (gfc_peek_ascii_char () == '/')
4415 break;
4416 }
4417 }
4418
4419 done:
4420 return MATCH_YES;
4421
4422 syntax:
4423 gfc_syntax_error (ST_COMMON);
4424
4425 cleanup:
4426 gfc_free_array_spec (as);
4427 return MATCH_ERROR;
4428 }
4429
4430
4431 /* Match a BLOCK DATA program unit. */
4432
4433 match
4434 gfc_match_block_data (void)
4435 {
4436 char name[GFC_MAX_SYMBOL_LEN + 1];
4437 gfc_symbol *sym;
4438 match m;
4439
4440 if (gfc_match_eos () == MATCH_YES)
4441 {
4442 gfc_new_block = NULL;
4443 return MATCH_YES;
4444 }
4445
4446 m = gfc_match ("% %n%t", name);
4447 if (m != MATCH_YES)
4448 return MATCH_ERROR;
4449
4450 if (gfc_get_symbol (name, NULL, &sym))
4451 return MATCH_ERROR;
4452
4453 if (!gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL))
4454 return MATCH_ERROR;
4455
4456 gfc_new_block = sym;
4457
4458 return MATCH_YES;
4459 }
4460
4461
4462 /* Free a namelist structure. */
4463
4464 void
4465 gfc_free_namelist (gfc_namelist *name)
4466 {
4467 gfc_namelist *n;
4468
4469 for (; name; name = n)
4470 {
4471 n = name->next;
4472 free (name);
4473 }
4474 }
4475
4476
4477 /* Free an OpenMP namelist structure. */
4478
4479 void
4480 gfc_free_omp_namelist (gfc_omp_namelist *name)
4481 {
4482 gfc_omp_namelist *n;
4483
4484 for (; name; name = n)
4485 {
4486 gfc_free_expr (name->expr);
4487 if (name->udr)
4488 {
4489 if (name->udr->combiner)
4490 gfc_free_statement (name->udr->combiner);
4491 if (name->udr->initializer)
4492 gfc_free_statement (name->udr->initializer);
4493 free (name->udr);
4494 }
4495 n = name->next;
4496 free (name);
4497 }
4498 }
4499
4500
4501 /* Match a NAMELIST statement. */
4502
4503 match
4504 gfc_match_namelist (void)
4505 {
4506 gfc_symbol *group_name, *sym;
4507 gfc_namelist *nl;
4508 match m, m2;
4509
4510 m = gfc_match (" / %s /", &group_name);
4511 if (m == MATCH_NO)
4512 goto syntax;
4513 if (m == MATCH_ERROR)
4514 goto error;
4515
4516 for (;;)
4517 {
4518 if (group_name->ts.type != BT_UNKNOWN)
4519 {
4520 gfc_error ("Namelist group name '%s' at %C already has a basic "
4521 "type of %s", group_name->name,
4522 gfc_typename (&group_name->ts));
4523 return MATCH_ERROR;
4524 }
4525
4526 if (group_name->attr.flavor == FL_NAMELIST
4527 && group_name->attr.use_assoc
4528 && !gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
4529 "at %C already is USE associated and can"
4530 "not be respecified.", group_name->name))
4531 return MATCH_ERROR;
4532
4533 if (group_name->attr.flavor != FL_NAMELIST
4534 && !gfc_add_flavor (&group_name->attr, FL_NAMELIST,
4535 group_name->name, NULL))
4536 return MATCH_ERROR;
4537
4538 for (;;)
4539 {
4540 m = gfc_match_symbol (&sym, 1);
4541 if (m == MATCH_NO)
4542 goto syntax;
4543 if (m == MATCH_ERROR)
4544 goto error;
4545
4546 if (sym->attr.in_namelist == 0
4547 && !gfc_add_in_namelist (&sym->attr, sym->name, NULL))
4548 goto error;
4549
4550 /* Use gfc_error_check here, rather than goto error, so that
4551 these are the only errors for the next two lines. */
4552 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
4553 {
4554 gfc_error ("Assumed size array '%s' in namelist '%s' at "
4555 "%C is not allowed", sym->name, group_name->name);
4556 gfc_error_check ();
4557 }
4558
4559 nl = gfc_get_namelist ();
4560 nl->sym = sym;
4561 sym->refs++;
4562
4563 if (group_name->namelist == NULL)
4564 group_name->namelist = group_name->namelist_tail = nl;
4565 else
4566 {
4567 group_name->namelist_tail->next = nl;
4568 group_name->namelist_tail = nl;
4569 }
4570
4571 if (gfc_match_eos () == MATCH_YES)
4572 goto done;
4573
4574 m = gfc_match_char (',');
4575
4576 if (gfc_match_char ('/') == MATCH_YES)
4577 {
4578 m2 = gfc_match (" %s /", &group_name);
4579 if (m2 == MATCH_YES)
4580 break;
4581 if (m2 == MATCH_ERROR)
4582 goto error;
4583 goto syntax;
4584 }
4585
4586 if (m != MATCH_YES)
4587 goto syntax;
4588 }
4589 }
4590
4591 done:
4592 return MATCH_YES;
4593
4594 syntax:
4595 gfc_syntax_error (ST_NAMELIST);
4596
4597 error:
4598 return MATCH_ERROR;
4599 }
4600
4601
4602 /* Match a MODULE statement. */
4603
4604 match
4605 gfc_match_module (void)
4606 {
4607 match m;
4608
4609 m = gfc_match (" %s%t", &gfc_new_block);
4610 if (m != MATCH_YES)
4611 return m;
4612
4613 if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
4614 gfc_new_block->name, NULL))
4615 return MATCH_ERROR;
4616
4617 return MATCH_YES;
4618 }
4619
4620
4621 /* Free equivalence sets and lists. Recursively is the easiest way to
4622 do this. */
4623
4624 void
4625 gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop)
4626 {
4627 if (eq == stop)
4628 return;
4629
4630 gfc_free_equiv (eq->eq);
4631 gfc_free_equiv_until (eq->next, stop);
4632 gfc_free_expr (eq->expr);
4633 free (eq);
4634 }
4635
4636
4637 void
4638 gfc_free_equiv (gfc_equiv *eq)
4639 {
4640 gfc_free_equiv_until (eq, NULL);
4641 }
4642
4643
4644 /* Match an EQUIVALENCE statement. */
4645
4646 match
4647 gfc_match_equivalence (void)
4648 {
4649 gfc_equiv *eq, *set, *tail;
4650 gfc_ref *ref;
4651 gfc_symbol *sym;
4652 match m;
4653 gfc_common_head *common_head = NULL;
4654 bool common_flag;
4655 int cnt;
4656
4657 tail = NULL;
4658
4659 for (;;)
4660 {
4661 eq = gfc_get_equiv ();
4662 if (tail == NULL)
4663 tail = eq;
4664
4665 eq->next = gfc_current_ns->equiv;
4666 gfc_current_ns->equiv = eq;
4667
4668 if (gfc_match_char ('(') != MATCH_YES)
4669 goto syntax;
4670
4671 set = eq;
4672 common_flag = FALSE;
4673 cnt = 0;
4674
4675 for (;;)
4676 {
4677 m = gfc_match_equiv_variable (&set->expr);
4678 if (m == MATCH_ERROR)
4679 goto cleanup;
4680 if (m == MATCH_NO)
4681 goto syntax;
4682
4683 /* count the number of objects. */
4684 cnt++;
4685
4686 if (gfc_match_char ('%') == MATCH_YES)
4687 {
4688 gfc_error ("Derived type component %C is not a "
4689 "permitted EQUIVALENCE member");
4690 goto cleanup;
4691 }
4692
4693 for (ref = set->expr->ref; ref; ref = ref->next)
4694 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
4695 {
4696 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
4697 "be an array section");
4698 goto cleanup;
4699 }
4700
4701 sym = set->expr->symtree->n.sym;
4702
4703 if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL))
4704 goto cleanup;
4705
4706 if (sym->attr.in_common)
4707 {
4708 common_flag = TRUE;
4709 common_head = sym->common_head;
4710 }
4711
4712 if (gfc_match_char (')') == MATCH_YES)
4713 break;
4714
4715 if (gfc_match_char (',') != MATCH_YES)
4716 goto syntax;
4717
4718 set->eq = gfc_get_equiv ();
4719 set = set->eq;
4720 }
4721
4722 if (cnt < 2)
4723 {
4724 gfc_error ("EQUIVALENCE at %C requires two or more objects");
4725 goto cleanup;
4726 }
4727
4728 /* If one of the members of an equivalence is in common, then
4729 mark them all as being in common. Before doing this, check
4730 that members of the equivalence group are not in different
4731 common blocks. */
4732 if (common_flag)
4733 for (set = eq; set; set = set->eq)
4734 {
4735 sym = set->expr->symtree->n.sym;
4736 if (sym->common_head && sym->common_head != common_head)
4737 {
4738 gfc_error ("Attempt to indirectly overlap COMMON "
4739 "blocks %s and %s by EQUIVALENCE at %C",
4740 sym->common_head->name, common_head->name);
4741 goto cleanup;
4742 }
4743 sym->attr.in_common = 1;
4744 sym->common_head = common_head;
4745 }
4746
4747 if (gfc_match_eos () == MATCH_YES)
4748 break;
4749 if (gfc_match_char (',') != MATCH_YES)
4750 {
4751 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
4752 goto cleanup;
4753 }
4754 }
4755
4756 return MATCH_YES;
4757
4758 syntax:
4759 gfc_syntax_error (ST_EQUIVALENCE);
4760
4761 cleanup:
4762 eq = tail->next;
4763 tail->next = NULL;
4764
4765 gfc_free_equiv (gfc_current_ns->equiv);
4766 gfc_current_ns->equiv = eq;
4767
4768 return MATCH_ERROR;
4769 }
4770
4771
4772 /* Check that a statement function is not recursive. This is done by looking
4773 for the statement function symbol(sym) by looking recursively through its
4774 expression(e). If a reference to sym is found, true is returned.
4775 12.5.4 requires that any variable of function that is implicitly typed
4776 shall have that type confirmed by any subsequent type declaration. The
4777 implicit typing is conveniently done here. */
4778 static bool
4779 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
4780
4781 static bool
4782 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
4783 {
4784
4785 if (e == NULL)
4786 return false;
4787
4788 switch (e->expr_type)
4789 {
4790 case EXPR_FUNCTION:
4791 if (e->symtree == NULL)
4792 return false;
4793
4794 /* Check the name before testing for nested recursion! */
4795 if (sym->name == e->symtree->n.sym->name)
4796 return true;
4797
4798 /* Catch recursion via other statement functions. */
4799 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
4800 && e->symtree->n.sym->value
4801 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
4802 return true;
4803
4804 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4805 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4806
4807 break;
4808
4809 case EXPR_VARIABLE:
4810 if (e->symtree && sym->name == e->symtree->n.sym->name)
4811 return true;
4812
4813 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
4814 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
4815 break;
4816
4817 default:
4818 break;
4819 }
4820
4821 return false;
4822 }
4823
4824
4825 static bool
4826 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
4827 {
4828 return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
4829 }
4830
4831
4832 /* Match a statement function declaration. It is so easy to match
4833 non-statement function statements with a MATCH_ERROR as opposed to
4834 MATCH_NO that we suppress error message in most cases. */
4835
4836 match
4837 gfc_match_st_function (void)
4838 {
4839 gfc_error_buf old_error;
4840 gfc_symbol *sym;
4841 gfc_expr *expr;
4842 match m;
4843
4844 m = gfc_match_symbol (&sym, 0);
4845 if (m != MATCH_YES)
4846 return m;
4847
4848 gfc_push_error (&old_error);
4849
4850 if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL))
4851 goto undo_error;
4852
4853 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
4854 goto undo_error;
4855
4856 m = gfc_match (" = %e%t", &expr);
4857 if (m == MATCH_NO)
4858 goto undo_error;
4859
4860 gfc_free_error (&old_error);
4861 if (m == MATCH_ERROR)
4862 return m;
4863
4864 if (recursive_stmt_fcn (expr, sym))
4865 {
4866 gfc_error ("Statement function at %L is recursive", &expr->where);
4867 return MATCH_ERROR;
4868 }
4869
4870 sym->value = expr;
4871
4872 if (!gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C"))
4873 return MATCH_ERROR;
4874
4875 return MATCH_YES;
4876
4877 undo_error:
4878 gfc_pop_error (&old_error);
4879 return MATCH_NO;
4880 }
4881
4882
4883 /***************** SELECT CASE subroutines ******************/
4884
4885 /* Free a single case structure. */
4886
4887 static void
4888 free_case (gfc_case *p)
4889 {
4890 if (p->low == p->high)
4891 p->high = NULL;
4892 gfc_free_expr (p->low);
4893 gfc_free_expr (p->high);
4894 free (p);
4895 }
4896
4897
4898 /* Free a list of case structures. */
4899
4900 void
4901 gfc_free_case_list (gfc_case *p)
4902 {
4903 gfc_case *q;
4904
4905 for (; p; p = q)
4906 {
4907 q = p->next;
4908 free_case (p);
4909 }
4910 }
4911
4912
4913 /* Match a single case selector. */
4914
4915 static match
4916 match_case_selector (gfc_case **cp)
4917 {
4918 gfc_case *c;
4919 match m;
4920
4921 c = gfc_get_case ();
4922 c->where = gfc_current_locus;
4923
4924 if (gfc_match_char (':') == MATCH_YES)
4925 {
4926 m = gfc_match_init_expr (&c->high);
4927 if (m == MATCH_NO)
4928 goto need_expr;
4929 if (m == MATCH_ERROR)
4930 goto cleanup;
4931 }
4932 else
4933 {
4934 m = gfc_match_init_expr (&c->low);
4935 if (m == MATCH_ERROR)
4936 goto cleanup;
4937 if (m == MATCH_NO)
4938 goto need_expr;
4939
4940 /* If we're not looking at a ':' now, make a range out of a single
4941 target. Else get the upper bound for the case range. */
4942 if (gfc_match_char (':') != MATCH_YES)
4943 c->high = c->low;
4944 else
4945 {
4946 m = gfc_match_init_expr (&c->high);
4947 if (m == MATCH_ERROR)
4948 goto cleanup;
4949 /* MATCH_NO is fine. It's OK if nothing is there! */
4950 }
4951 }
4952
4953 *cp = c;
4954 return MATCH_YES;
4955
4956 need_expr:
4957 gfc_error ("Expected initialization expression in CASE at %C");
4958
4959 cleanup:
4960 free_case (c);
4961 return MATCH_ERROR;
4962 }
4963
4964
4965 /* Match the end of a case statement. */
4966
4967 static match
4968 match_case_eos (void)
4969 {
4970 char name[GFC_MAX_SYMBOL_LEN + 1];
4971 match m;
4972
4973 if (gfc_match_eos () == MATCH_YES)
4974 return MATCH_YES;
4975
4976 /* If the case construct doesn't have a case-construct-name, we
4977 should have matched the EOS. */
4978 if (!gfc_current_block ())
4979 return MATCH_NO;
4980
4981 gfc_gobble_whitespace ();
4982
4983 m = gfc_match_name (name);
4984 if (m != MATCH_YES)
4985 return m;
4986
4987 if (strcmp (name, gfc_current_block ()->name) != 0)
4988 {
4989 gfc_error ("Expected block name '%s' of SELECT construct at %C",
4990 gfc_current_block ()->name);
4991 return MATCH_ERROR;
4992 }
4993
4994 return gfc_match_eos ();
4995 }
4996
4997
4998 /* Match a SELECT statement. */
4999
5000 match
5001 gfc_match_select (void)
5002 {
5003 gfc_expr *expr;
5004 match m;
5005
5006 m = gfc_match_label ();
5007 if (m == MATCH_ERROR)
5008 return m;
5009
5010 m = gfc_match (" select case ( %e )%t", &expr);
5011 if (m != MATCH_YES)
5012 return m;
5013
5014 new_st.op = EXEC_SELECT;
5015 new_st.expr1 = expr;
5016
5017 return MATCH_YES;
5018 }
5019
5020
5021 /* Transfer the selector typespec to the associate name. */
5022
5023 static void
5024 copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
5025 {
5026 gfc_ref *ref;
5027 gfc_symbol *assoc_sym;
5028
5029 assoc_sym = associate->symtree->n.sym;
5030
5031 /* At this stage the expression rank and arrayspec dimensions have
5032 not been completely sorted out. We must get the expr2->rank
5033 right here, so that the correct class container is obtained. */
5034 ref = selector->ref;
5035 while (ref && ref->next)
5036 ref = ref->next;
5037
5038 if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as
5039 && ref && ref->type == REF_ARRAY)
5040 {
5041 /* Ensure that the array reference type is set. We cannot use
5042 gfc_resolve_expr at this point, so the usable parts of
5043 resolve.c(resolve_array_ref) are employed to do it. */
5044 if (ref->u.ar.type == AR_UNKNOWN)
5045 {
5046 ref->u.ar.type = AR_ELEMENT;
5047 for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
5048 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5049 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR
5050 || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
5051 && ref->u.ar.start[i] && ref->u.ar.start[i]->rank))
5052 {
5053 ref->u.ar.type = AR_SECTION;
5054 break;
5055 }
5056 }
5057
5058 if (ref->u.ar.type == AR_FULL)
5059 selector->rank = CLASS_DATA (selector)->as->rank;
5060 else if (ref->u.ar.type == AR_SECTION)
5061 selector->rank = ref->u.ar.dimen;
5062 else
5063 selector->rank = 0;
5064 }
5065
5066 if (selector->rank)
5067 {
5068 assoc_sym->attr.dimension = 1;
5069 assoc_sym->as = gfc_get_array_spec ();
5070 assoc_sym->as->rank = selector->rank;
5071 assoc_sym->as->type = AS_DEFERRED;
5072 }
5073 else
5074 assoc_sym->as = NULL;
5075
5076 if (selector->ts.type == BT_CLASS)
5077 {
5078 /* The correct class container has to be available. */
5079 assoc_sym->ts.type = BT_CLASS;
5080 assoc_sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
5081 assoc_sym->attr.pointer = 1;
5082 gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
5083 }
5084 }
5085
5086
5087 /* Push the current selector onto the SELECT TYPE stack. */
5088
5089 static void
5090 select_type_push (gfc_symbol *sel)
5091 {
5092 gfc_select_type_stack *top = gfc_get_select_type_stack ();
5093 top->selector = sel;
5094 top->tmp = NULL;
5095 top->prev = select_type_stack;
5096
5097 select_type_stack = top;
5098 }
5099
5100
5101 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
5102
5103 static gfc_symtree *
5104 select_intrinsic_set_tmp (gfc_typespec *ts)
5105 {
5106 char name[GFC_MAX_SYMBOL_LEN];
5107 gfc_symtree *tmp;
5108 int charlen = 0;
5109
5110 if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
5111 return NULL;
5112
5113 if (select_type_stack->selector->ts.type == BT_CLASS
5114 && !select_type_stack->selector->attr.class_ok)
5115 return NULL;
5116
5117 if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
5118 && ts->u.cl->length->expr_type == EXPR_CONSTANT)
5119 charlen = mpz_get_si (ts->u.cl->length->value.integer);
5120
5121 if (ts->type != BT_CHARACTER)
5122 sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
5123 ts->kind);
5124 else
5125 sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (ts->type),
5126 charlen, ts->kind);
5127
5128 gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
5129 gfc_add_type (tmp->n.sym, ts, NULL);
5130
5131 /* Copy across the array spec to the selector. */
5132 if (select_type_stack->selector->ts.type == BT_CLASS
5133 && (CLASS_DATA (select_type_stack->selector)->attr.dimension
5134 || CLASS_DATA (select_type_stack->selector)->attr.codimension))
5135 {
5136 tmp->n.sym->attr.pointer = 1;
5137 tmp->n.sym->attr.dimension
5138 = CLASS_DATA (select_type_stack->selector)->attr.dimension;
5139 tmp->n.sym->attr.codimension
5140 = CLASS_DATA (select_type_stack->selector)->attr.codimension;
5141 tmp->n.sym->as
5142 = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
5143 }
5144
5145 gfc_set_sym_referenced (tmp->n.sym);
5146 gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
5147 tmp->n.sym->attr.select_type_temporary = 1;
5148
5149 return tmp;
5150 }
5151
5152
5153 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
5154
5155 static void
5156 select_type_set_tmp (gfc_typespec *ts)
5157 {
5158 char name[GFC_MAX_SYMBOL_LEN];
5159 gfc_symtree *tmp = NULL;
5160
5161 if (!ts)
5162 {
5163 select_type_stack->tmp = NULL;
5164 return;
5165 }
5166
5167 tmp = select_intrinsic_set_tmp (ts);
5168
5169 if (tmp == NULL)
5170 {
5171 if (!ts->u.derived)
5172 return;
5173
5174 if (ts->type == BT_CLASS)
5175 sprintf (name, "__tmp_class_%s", ts->u.derived->name);
5176 else
5177 sprintf (name, "__tmp_type_%s", ts->u.derived->name);
5178 gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
5179 gfc_add_type (tmp->n.sym, ts, NULL);
5180
5181 if (select_type_stack->selector->ts.type == BT_CLASS
5182 && select_type_stack->selector->attr.class_ok)
5183 {
5184 tmp->n.sym->attr.pointer
5185 = CLASS_DATA (select_type_stack->selector)->attr.class_pointer;
5186
5187 /* Copy across the array spec to the selector. */
5188 if (CLASS_DATA (select_type_stack->selector)->attr.dimension
5189 || CLASS_DATA (select_type_stack->selector)->attr.codimension)
5190 {
5191 tmp->n.sym->attr.dimension
5192 = CLASS_DATA (select_type_stack->selector)->attr.dimension;
5193 tmp->n.sym->attr.codimension
5194 = CLASS_DATA (select_type_stack->selector)->attr.codimension;
5195 tmp->n.sym->as
5196 = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
5197 }
5198 }
5199
5200 gfc_set_sym_referenced (tmp->n.sym);
5201 gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
5202 tmp->n.sym->attr.select_type_temporary = 1;
5203
5204 if (ts->type == BT_CLASS)
5205 gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
5206 &tmp->n.sym->as);
5207 }
5208
5209 /* Add an association for it, so the rest of the parser knows it is
5210 an associate-name. The target will be set during resolution. */
5211 tmp->n.sym->assoc = gfc_get_association_list ();
5212 tmp->n.sym->assoc->dangling = 1;
5213 tmp->n.sym->assoc->st = tmp;
5214
5215 select_type_stack->tmp = tmp;
5216 }
5217
5218
5219 /* Match a SELECT TYPE statement. */
5220
5221 match
5222 gfc_match_select_type (void)
5223 {
5224 gfc_expr *expr1, *expr2 = NULL;
5225 match m;
5226 char name[GFC_MAX_SYMBOL_LEN];
5227 bool class_array;
5228 gfc_symbol *sym;
5229
5230 m = gfc_match_label ();
5231 if (m == MATCH_ERROR)
5232 return m;
5233
5234 m = gfc_match (" select type ( ");
5235 if (m != MATCH_YES)
5236 return m;
5237
5238 m = gfc_match (" %n => %e", name, &expr2);
5239 if (m == MATCH_YES)
5240 {
5241 expr1 = gfc_get_expr();
5242 expr1->expr_type = EXPR_VARIABLE;
5243 if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
5244 {
5245 m = MATCH_ERROR;
5246 goto cleanup;
5247 }
5248
5249 sym = expr1->symtree->n.sym;
5250 if (expr2->ts.type == BT_UNKNOWN)
5251 sym->attr.untyped = 1;
5252 else
5253 copy_ts_from_selector_to_associate (expr1, expr2);
5254
5255 sym->attr.flavor = FL_VARIABLE;
5256 sym->attr.referenced = 1;
5257 sym->attr.class_ok = 1;
5258 }
5259 else
5260 {
5261 m = gfc_match (" %e ", &expr1);
5262 if (m != MATCH_YES)
5263 return m;
5264 }
5265
5266 m = gfc_match (" )%t");
5267 if (m != MATCH_YES)
5268 {
5269 gfc_error ("parse error in SELECT TYPE statement at %C");
5270 goto cleanup;
5271 }
5272
5273 /* This ghastly expression seems to be needed to distinguish a CLASS
5274 array, which can have a reference, from other expressions that
5275 have references, such as derived type components, and are not
5276 allowed by the standard.
5277 TODO: see if it is sufficient to exclude component and substring
5278 references. */
5279 class_array = expr1->expr_type == EXPR_VARIABLE
5280 && expr1->ts.type == BT_CLASS
5281 && CLASS_DATA (expr1)
5282 && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0)
5283 && (CLASS_DATA (expr1)->attr.dimension
5284 || CLASS_DATA (expr1)->attr.codimension)
5285 && expr1->ref
5286 && expr1->ref->type == REF_ARRAY
5287 && expr1->ref->next == NULL;
5288
5289 /* Check for F03:C811. */
5290 if (!expr2 && (expr1->expr_type != EXPR_VARIABLE
5291 || (!class_array && expr1->ref != NULL)))
5292 {
5293 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
5294 "use associate-name=>");
5295 m = MATCH_ERROR;
5296 goto cleanup;
5297 }
5298
5299 new_st.op = EXEC_SELECT_TYPE;
5300 new_st.expr1 = expr1;
5301 new_st.expr2 = expr2;
5302 new_st.ext.block.ns = gfc_current_ns;
5303
5304 select_type_push (expr1->symtree->n.sym);
5305
5306 return MATCH_YES;
5307
5308 cleanup:
5309 gfc_free_expr (expr1);
5310 gfc_free_expr (expr2);
5311 return m;
5312 }
5313
5314
5315 /* Match a CASE statement. */
5316
5317 match
5318 gfc_match_case (void)
5319 {
5320 gfc_case *c, *head, *tail;
5321 match m;
5322
5323 head = tail = NULL;
5324
5325 if (gfc_current_state () != COMP_SELECT)
5326 {
5327 gfc_error ("Unexpected CASE statement at %C");
5328 return MATCH_ERROR;
5329 }
5330
5331 if (gfc_match ("% default") == MATCH_YES)
5332 {
5333 m = match_case_eos ();
5334 if (m == MATCH_NO)
5335 goto syntax;
5336 if (m == MATCH_ERROR)
5337 goto cleanup;
5338
5339 new_st.op = EXEC_SELECT;
5340 c = gfc_get_case ();
5341 c->where = gfc_current_locus;
5342 new_st.ext.block.case_list = c;
5343 return MATCH_YES;
5344 }
5345
5346 if (gfc_match_char ('(') != MATCH_YES)
5347 goto syntax;
5348
5349 for (;;)
5350 {
5351 if (match_case_selector (&c) == MATCH_ERROR)
5352 goto cleanup;
5353
5354 if (head == NULL)
5355 head = c;
5356 else
5357 tail->next = c;
5358
5359 tail = c;
5360
5361 if (gfc_match_char (')') == MATCH_YES)
5362 break;
5363 if (gfc_match_char (',') != MATCH_YES)
5364 goto syntax;
5365 }
5366
5367 m = match_case_eos ();
5368 if (m == MATCH_NO)
5369 goto syntax;
5370 if (m == MATCH_ERROR)
5371 goto cleanup;
5372
5373 new_st.op = EXEC_SELECT;
5374 new_st.ext.block.case_list = head;
5375
5376 return MATCH_YES;
5377
5378 syntax:
5379 gfc_error ("Syntax error in CASE specification at %C");
5380
5381 cleanup:
5382 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
5383 return MATCH_ERROR;
5384 }
5385
5386
5387 /* Match a TYPE IS statement. */
5388
5389 match
5390 gfc_match_type_is (void)
5391 {
5392 gfc_case *c = NULL;
5393 match m;
5394
5395 if (gfc_current_state () != COMP_SELECT_TYPE)
5396 {
5397 gfc_error ("Unexpected TYPE IS statement at %C");
5398 return MATCH_ERROR;
5399 }
5400
5401 if (gfc_match_char ('(') != MATCH_YES)
5402 goto syntax;
5403
5404 c = gfc_get_case ();
5405 c->where = gfc_current_locus;
5406
5407 if (gfc_match_type_spec (&c->ts) == MATCH_ERROR)
5408 goto cleanup;
5409
5410 if (gfc_match_char (')') != MATCH_YES)
5411 goto syntax;
5412
5413 m = match_case_eos ();
5414 if (m == MATCH_NO)
5415 goto syntax;
5416 if (m == MATCH_ERROR)
5417 goto cleanup;
5418
5419 new_st.op = EXEC_SELECT_TYPE;
5420 new_st.ext.block.case_list = c;
5421
5422 if (c->ts.type == BT_DERIVED && c->ts.u.derived
5423 && (c->ts.u.derived->attr.sequence
5424 || c->ts.u.derived->attr.is_bind_c))
5425 {
5426 gfc_error ("The type-spec shall not specify a sequence derived "
5427 "type or a type with the BIND attribute in SELECT "
5428 "TYPE at %C [F2003:C815]");
5429 return MATCH_ERROR;
5430 }
5431
5432 /* Create temporary variable. */
5433 select_type_set_tmp (&c->ts);
5434
5435 return MATCH_YES;
5436
5437 syntax:
5438 gfc_error ("Syntax error in TYPE IS specification at %C");
5439
5440 cleanup:
5441 if (c != NULL)
5442 gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
5443 return MATCH_ERROR;
5444 }
5445
5446
5447 /* Match a CLASS IS or CLASS DEFAULT statement. */
5448
5449 match
5450 gfc_match_class_is (void)
5451 {
5452 gfc_case *c = NULL;
5453 match m;
5454
5455 if (gfc_current_state () != COMP_SELECT_TYPE)
5456 return MATCH_NO;
5457
5458 if (gfc_match ("% default") == MATCH_YES)
5459 {
5460 m = match_case_eos ();
5461 if (m == MATCH_NO)
5462 goto syntax;
5463 if (m == MATCH_ERROR)
5464 goto cleanup;
5465
5466 new_st.op = EXEC_SELECT_TYPE;
5467 c = gfc_get_case ();
5468 c->where = gfc_current_locus;
5469 c->ts.type = BT_UNKNOWN;
5470 new_st.ext.block.case_list = c;
5471 select_type_set_tmp (NULL);
5472 return MATCH_YES;
5473 }
5474
5475 m = gfc_match ("% is");
5476 if (m == MATCH_NO)
5477 goto syntax;
5478 if (m == MATCH_ERROR)
5479 goto cleanup;
5480
5481 if (gfc_match_char ('(') != MATCH_YES)
5482 goto syntax;
5483
5484 c = gfc_get_case ();
5485 c->where = gfc_current_locus;
5486
5487 if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
5488 goto cleanup;
5489
5490 if (c->ts.type == BT_DERIVED)
5491 c->ts.type = BT_CLASS;
5492
5493 if (gfc_match_char (')') != MATCH_YES)
5494 goto syntax;
5495
5496 m = match_case_eos ();
5497 if (m == MATCH_NO)
5498 goto syntax;
5499 if (m == MATCH_ERROR)
5500 goto cleanup;
5501
5502 new_st.op = EXEC_SELECT_TYPE;
5503 new_st.ext.block.case_list = c;
5504
5505 /* Create temporary variable. */
5506 select_type_set_tmp (&c->ts);
5507
5508 return MATCH_YES;
5509
5510 syntax:
5511 gfc_error ("Syntax error in CLASS IS specification at %C");
5512
5513 cleanup:
5514 if (c != NULL)
5515 gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
5516 return MATCH_ERROR;
5517 }
5518
5519
5520 /********************* WHERE subroutines ********************/
5521
5522 /* Match the rest of a simple WHERE statement that follows an IF statement.
5523 */
5524
5525 static match
5526 match_simple_where (void)
5527 {
5528 gfc_expr *expr;
5529 gfc_code *c;
5530 match m;
5531
5532 m = gfc_match (" ( %e )", &expr);
5533 if (m != MATCH_YES)
5534 return m;
5535
5536 m = gfc_match_assignment ();
5537 if (m == MATCH_NO)
5538 goto syntax;
5539 if (m == MATCH_ERROR)
5540 goto cleanup;
5541
5542 if (gfc_match_eos () != MATCH_YES)
5543 goto syntax;
5544
5545 c = gfc_get_code (EXEC_WHERE);
5546 c->expr1 = expr;
5547
5548 c->next = XCNEW (gfc_code);
5549 *c->next = new_st;
5550 gfc_clear_new_st ();
5551
5552 new_st.op = EXEC_WHERE;
5553 new_st.block = c;
5554
5555 return MATCH_YES;
5556
5557 syntax:
5558 gfc_syntax_error (ST_WHERE);
5559
5560 cleanup:
5561 gfc_free_expr (expr);
5562 return MATCH_ERROR;
5563 }
5564
5565
5566 /* Match a WHERE statement. */
5567
5568 match
5569 gfc_match_where (gfc_statement *st)
5570 {
5571 gfc_expr *expr;
5572 match m0, m;
5573 gfc_code *c;
5574
5575 m0 = gfc_match_label ();
5576 if (m0 == MATCH_ERROR)
5577 return m0;
5578
5579 m = gfc_match (" where ( %e )", &expr);
5580 if (m != MATCH_YES)
5581 return m;
5582
5583 if (gfc_match_eos () == MATCH_YES)
5584 {
5585 *st = ST_WHERE_BLOCK;
5586 new_st.op = EXEC_WHERE;
5587 new_st.expr1 = expr;
5588 return MATCH_YES;
5589 }
5590
5591 m = gfc_match_assignment ();
5592 if (m == MATCH_NO)
5593 gfc_syntax_error (ST_WHERE);
5594
5595 if (m != MATCH_YES)
5596 {
5597 gfc_free_expr (expr);
5598 return MATCH_ERROR;
5599 }
5600
5601 /* We've got a simple WHERE statement. */
5602 *st = ST_WHERE;
5603 c = gfc_get_code (EXEC_WHERE);
5604 c->expr1 = expr;
5605
5606 c->next = XCNEW (gfc_code);
5607 *c->next = new_st;
5608 gfc_clear_new_st ();
5609
5610 new_st.op = EXEC_WHERE;
5611 new_st.block = c;
5612
5613 return MATCH_YES;
5614 }
5615
5616
5617 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
5618 new_st if successful. */
5619
5620 match
5621 gfc_match_elsewhere (void)
5622 {
5623 char name[GFC_MAX_SYMBOL_LEN + 1];
5624 gfc_expr *expr;
5625 match m;
5626
5627 if (gfc_current_state () != COMP_WHERE)
5628 {
5629 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
5630 return MATCH_ERROR;
5631 }
5632
5633 expr = NULL;
5634
5635 if (gfc_match_char ('(') == MATCH_YES)
5636 {
5637 m = gfc_match_expr (&expr);
5638 if (m == MATCH_NO)
5639 goto syntax;
5640 if (m == MATCH_ERROR)
5641 return MATCH_ERROR;
5642
5643 if (gfc_match_char (')') != MATCH_YES)
5644 goto syntax;
5645 }
5646
5647 if (gfc_match_eos () != MATCH_YES)
5648 {
5649 /* Only makes sense if we have a where-construct-name. */
5650 if (!gfc_current_block ())
5651 {
5652 m = MATCH_ERROR;
5653 goto cleanup;
5654 }
5655 /* Better be a name at this point. */
5656 m = gfc_match_name (name);
5657 if (m == MATCH_NO)
5658 goto syntax;
5659 if (m == MATCH_ERROR)
5660 goto cleanup;
5661
5662 if (gfc_match_eos () != MATCH_YES)
5663 goto syntax;
5664
5665 if (strcmp (name, gfc_current_block ()->name) != 0)
5666 {
5667 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
5668 name, gfc_current_block ()->name);
5669 goto cleanup;
5670 }
5671 }
5672
5673 new_st.op = EXEC_WHERE;
5674 new_st.expr1 = expr;
5675 return MATCH_YES;
5676
5677 syntax:
5678 gfc_syntax_error (ST_ELSEWHERE);
5679
5680 cleanup:
5681 gfc_free_expr (expr);
5682 return MATCH_ERROR;
5683 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org