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