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