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