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