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