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