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