?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
re PR fortran/83548 (Compilation Error using logical function in parameter)
[official-gcc.git] / gcc / fortran / match.c
blobd251a4d8cd8a41810d8cec468fd96240d9278b3d
1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000-2017 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 *
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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 ("close", gfc_match_close, ST_CLOSE)
1600 match ("continue", gfc_match_continue, ST_CONTINUE)
1601 match ("cycle", gfc_match_cycle, ST_CYCLE)
1602 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1603 match ("end file", gfc_match_endfile, ST_END_FILE)
1604 match ("error stop", gfc_match_error_stop, ST_ERROR_STOP)
1605 match ("event post", gfc_match_event_post, ST_EVENT_POST)
1606 match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT)
1607 match ("exit", gfc_match_exit, ST_EXIT)
1608 match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE)
1609 match ("flush", gfc_match_flush, ST_FLUSH)
1610 match ("forall", match_simple_forall, ST_FORALL)
1611 match ("go to", gfc_match_goto, ST_GOTO)
1612 match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1613 match ("inquire", gfc_match_inquire, ST_INQUIRE)
1614 match ("lock", gfc_match_lock, ST_LOCK)
1615 match ("nullify", gfc_match_nullify, ST_NULLIFY)
1616 match ("open", gfc_match_open, ST_OPEN)
1617 match ("pause", gfc_match_pause, ST_NONE)
1618 match ("print", gfc_match_print, ST_WRITE)
1619 match ("read", gfc_match_read, ST_READ)
1620 match ("return", gfc_match_return, ST_RETURN)
1621 match ("rewind", gfc_match_rewind, ST_REWIND)
1622 match ("stop", gfc_match_stop, ST_STOP)
1623 match ("wait", gfc_match_wait, ST_WAIT)
1624 match ("sync all", gfc_match_sync_all, ST_SYNC_CALL);
1625 match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
1626 match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
1627 match ("unlock", gfc_match_unlock, ST_UNLOCK)
1628 match ("where", match_simple_where, ST_WHERE)
1629 match ("write", gfc_match_write, ST_WRITE)
1630
1631 if (flag_dec)
1632 match ("type", gfc_match_print, ST_WRITE)
1633
1634 /* The gfc_match_assignment() above may have returned a MATCH_NO
1635 where the assignment was to a named constant. Check that
1636 special case here. */
1637 m = gfc_match_assignment ();
1638 if (m == MATCH_NO)
1639 {
1640 gfc_error ("Cannot assign to a named constant at %C");
1641 gfc_free_expr (expr);
1642 gfc_undo_symbols ();
1643 gfc_current_locus = old_loc;
1644 return MATCH_ERROR;
1645 }
1646
1647 /* All else has failed, so give up. See if any of the matchers has
1648 stored an error message of some sort. */
1649 if (!gfc_error_check ())
1650 gfc_error ("Unclassifiable statement in IF-clause at %C");
1651
1652 gfc_free_expr (expr);
1653 return MATCH_ERROR;
1654
1655 got_match:
1656 if (m == MATCH_NO)
1657 gfc_error ("Syntax error in IF-clause at %C");
1658 if (m != MATCH_YES)
1659 {
1660 gfc_free_expr (expr);
1661 return MATCH_ERROR;
1662 }
1663
1664 /* At this point, we've matched the single IF and the action clause
1665 is in new_st. Rearrange things so that the IF statement appears
1666 in new_st. */
1667
1668 p = gfc_get_code (EXEC_IF);
1669 p->next = XCNEW (gfc_code);
1670 *p->next = new_st;
1671 p->next->loc = gfc_current_locus;
1672
1673 p->expr1 = expr;
1674
1675 gfc_clear_new_st ();
1676
1677 new_st.op = EXEC_IF;
1678 new_st.block = p;
1679
1680 return MATCH_YES;
1681 }
1682
1683 #undef match
1684
1685
1686 /* Match an ELSE statement. */
1687
1688 match
1689 gfc_match_else (void)
1690 {
1691 char name[GFC_MAX_SYMBOL_LEN + 1];
1692
1693 if (gfc_match_eos () == MATCH_YES)
1694 return MATCH_YES;
1695
1696 if (gfc_match_name (name) != MATCH_YES
1697 || gfc_current_block () == NULL
1698 || gfc_match_eos () != MATCH_YES)
1699 {
1700 gfc_error ("Unexpected junk after ELSE statement at %C");
1701 return MATCH_ERROR;
1702 }
1703
1704 if (strcmp (name, gfc_current_block ()->name) != 0)
1705 {
1706 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1707 name, gfc_current_block ()->name);
1708 return MATCH_ERROR;
1709 }
1710
1711 return MATCH_YES;
1712 }
1713
1714
1715 /* Match an ELSE IF statement. */
1716
1717 match
1718 gfc_match_elseif (void)
1719 {
1720 char name[GFC_MAX_SYMBOL_LEN + 1];
1721 gfc_expr *expr;
1722 match m;
1723
1724 m = gfc_match (" ( %e ) then", &expr);
1725 if (m != MATCH_YES)
1726 return m;
1727
1728 if (gfc_match_eos () == MATCH_YES)
1729 goto done;
1730
1731 if (gfc_match_name (name) != MATCH_YES
1732 || gfc_current_block () == NULL
1733 || gfc_match_eos () != MATCH_YES)
1734 {
1735 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1736 goto cleanup;
1737 }
1738
1739 if (strcmp (name, gfc_current_block ()->name) != 0)
1740 {
1741 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1742 name, gfc_current_block ()->name);
1743 goto cleanup;
1744 }
1745
1746 done:
1747 new_st.op = EXEC_IF;
1748 new_st.expr1 = expr;
1749 return MATCH_YES;
1750
1751 cleanup:
1752 gfc_free_expr (expr);
1753 return MATCH_ERROR;
1754 }
1755
1756
1757 /* Free a gfc_iterator structure. */
1758
1759 void
1760 gfc_free_iterator (gfc_iterator *iter, int flag)
1761 {
1762
1763 if (iter == NULL)
1764 return;
1765
1766 gfc_free_expr (iter->var);
1767 gfc_free_expr (iter->start);
1768 gfc_free_expr (iter->end);
1769 gfc_free_expr (iter->step);
1770
1771 if (flag)
1772 free (iter);
1773 }
1774
1775
1776 /* Match a CRITICAL statement. */
1777 match
1778 gfc_match_critical (void)
1779 {
1780 gfc_st_label *label = NULL;
1781
1782 if (gfc_match_label () == MATCH_ERROR)
1783 return MATCH_ERROR;
1784
1785 if (gfc_match (" critical") != MATCH_YES)
1786 return MATCH_NO;
1787
1788 if (gfc_match_st_label (&label) == MATCH_ERROR)
1789 return MATCH_ERROR;
1790
1791 if (gfc_match_eos () != MATCH_YES)
1792 {
1793 gfc_syntax_error (ST_CRITICAL);
1794 return MATCH_ERROR;
1795 }
1796
1797 if (gfc_pure (NULL))
1798 {
1799 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1800 return MATCH_ERROR;
1801 }
1802
1803 if (gfc_find_state (COMP_DO_CONCURRENT))
1804 {
1805 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1806 "block");
1807 return MATCH_ERROR;
1808 }
1809
1810 gfc_unset_implicit_pure (NULL);
1811
1812 if (!gfc_notify_std (GFC_STD_F2008, "CRITICAL statement at %C"))
1813 return MATCH_ERROR;
1814
1815 if (flag_coarray == GFC_FCOARRAY_NONE)
1816 {
1817 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1818 "enable");
1819 return MATCH_ERROR;
1820 }
1821
1822 if (gfc_find_state (COMP_CRITICAL))
1823 {
1824 gfc_error ("Nested CRITICAL block at %C");
1825 return MATCH_ERROR;
1826 }
1827
1828 new_st.op = EXEC_CRITICAL;
1829
1830 if (label != NULL
1831 && !gfc_reference_st_label (label, ST_LABEL_TARGET))
1832 return MATCH_ERROR;
1833
1834 return MATCH_YES;
1835 }
1836
1837
1838 /* Match a BLOCK statement. */
1839
1840 match
1841 gfc_match_block (void)
1842 {
1843 match m;
1844
1845 if (gfc_match_label () == MATCH_ERROR)
1846 return MATCH_ERROR;
1847
1848 if (gfc_match (" block") != MATCH_YES)
1849 return MATCH_NO;
1850
1851 /* For this to be a correct BLOCK statement, the line must end now. */
1852 m = gfc_match_eos ();
1853 if (m == MATCH_ERROR)
1854 return MATCH_ERROR;
1855 if (m == MATCH_NO)
1856 return MATCH_NO;
1857
1858 return MATCH_YES;
1859 }
1860
1861
1862 /* Match an ASSOCIATE statement. */
1863
1864 match
1865 gfc_match_associate (void)
1866 {
1867 if (gfc_match_label () == MATCH_ERROR)
1868 return MATCH_ERROR;
1869
1870 if (gfc_match (" associate") != MATCH_YES)
1871 return MATCH_NO;
1872
1873 /* Match the association list. */
1874 if (gfc_match_char ('(') != MATCH_YES)
1875 {
1876 gfc_error ("Expected association list at %C");
1877 return MATCH_ERROR;
1878 }
1879 new_st.ext.block.assoc = NULL;
1880 while (true)
1881 {
1882 gfc_association_list* newAssoc = gfc_get_association_list ();
1883 gfc_association_list* a;
1884
1885 /* Match the next association. */
1886 if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
1887 != MATCH_YES)
1888 {
1889 /* Have another go, allowing for procedure pointer selectors. */
1890 gfc_matching_procptr_assignment = 1;
1891 if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
1892 != MATCH_YES)
1893 {
1894 gfc_error ("Expected association at %C");
1895 goto assocListError;
1896 }
1897 gfc_matching_procptr_assignment = 0;
1898 }
1899 newAssoc->where = gfc_current_locus;
1900
1901 /* Check that the current name is not yet in the list. */
1902 for (a = new_st.ext.block.assoc; a; a = a->next)
1903 if (!strcmp (a->name, newAssoc->name))
1904 {
1905 gfc_error ("Duplicate name %qs in association at %C",
1906 newAssoc->name);
1907 goto assocListError;
1908 }
1909
1910 /* The target expression must not be coindexed. */
1911 if (gfc_is_coindexed (newAssoc->target))
1912 {
1913 gfc_error ("Association target at %C must not be coindexed");
1914 goto assocListError;
1915 }
1916
1917 /* The `variable' field is left blank for now; because the target is not
1918 yet resolved, we can't use gfc_has_vector_subscript to determine it
1919 for now. This is set during resolution. */
1920
1921 /* Put it into the list. */
1922 newAssoc->next = new_st.ext.block.assoc;
1923 new_st.ext.block.assoc = newAssoc;
1924
1925 /* Try next one or end if closing parenthesis is found. */
1926 gfc_gobble_whitespace ();
1927 if (gfc_peek_char () == ')')
1928 break;
1929 if (gfc_match_char (',') != MATCH_YES)
1930 {
1931 gfc_error ("Expected %<)%> or %<,%> at %C");
1932 return MATCH_ERROR;
1933 }
1934
1935 continue;
1936
1937 assocListError:
1938 free (newAssoc);
1939 goto error;
1940 }
1941 if (gfc_match_char (')') != MATCH_YES)
1942 {
1943 /* This should never happen as we peek above. */
1944 gcc_unreachable ();
1945 }
1946
1947 if (gfc_match_eos () != MATCH_YES)
1948 {
1949 gfc_error ("Junk after ASSOCIATE statement at %C");
1950 goto error;
1951 }
1952
1953 return MATCH_YES;
1954
1955 error:
1956 gfc_free_association_list (new_st.ext.block.assoc);
1957 return MATCH_ERROR;
1958 }
1959
1960
1961 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1962 an accessible derived type. */
1963
1964 static match
1965 match_derived_type_spec (gfc_typespec *ts)
1966 {
1967 char name[GFC_MAX_SYMBOL_LEN + 1];
1968 locus old_locus;
1969 gfc_symbol *derived, *der_type;
1970 match m = MATCH_YES;
1971 gfc_actual_arglist *decl_type_param_list = NULL;
1972 bool is_pdt_template = false;
1973
1974 old_locus = gfc_current_locus;
1975
1976 if (gfc_match ("%n", name) != MATCH_YES)
1977 {
1978 gfc_current_locus = old_locus;
1979 return MATCH_NO;
1980 }
1981
1982 gfc_find_symbol (name, NULL, 1, &derived);
1983
1984 /* Match the PDT spec list, if there. */
1985 if (derived && derived->attr.flavor == FL_PROCEDURE)
1986 {
1987 gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &der_type);
1988 is_pdt_template = der_type
1989 && der_type->attr.flavor == FL_DERIVED
1990 && der_type->attr.pdt_template;
1991 }
1992
1993 if (is_pdt_template)
1994 m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
1995
1996 if (m == MATCH_ERROR)
1997 {
1998 gfc_free_actual_arglist (decl_type_param_list);
1999 return m;
2000 }
2001
2002 if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
2003 derived = gfc_find_dt_in_generic (derived);
2004
2005 /* If this is a PDT, find the specific instance. */
2006 if (m == MATCH_YES && is_pdt_template)
2007 {
2008 gfc_namespace *old_ns;
2009
2010 old_ns = gfc_current_ns;
2011 while (gfc_current_ns && gfc_current_ns->parent)
2012 gfc_current_ns = gfc_current_ns->parent;
2013
2014 if (type_param_spec_list)
2015 gfc_free_actual_arglist (type_param_spec_list);
2016 m = gfc_get_pdt_instance (decl_type_param_list, &der_type,
2017 &type_param_spec_list);
2018 gfc_free_actual_arglist (decl_type_param_list);
2019
2020 if (m != MATCH_YES)
2021 return m;
2022 derived = der_type;
2023 gcc_assert (!derived->attr.pdt_template && derived->attr.pdt_type);
2024 gfc_set_sym_referenced (derived);
2025
2026 gfc_current_ns = old_ns;
2027 }
2028
2029 if (derived && derived->attr.flavor == FL_DERIVED)
2030 {
2031 ts->type = BT_DERIVED;
2032 ts->u.derived = derived;
2033 return MATCH_YES;
2034 }
2035
2036 gfc_current_locus = old_locus;
2037 return MATCH_NO;
2038 }
2039
2040
2041 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2042 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2043 It only includes the intrinsic types from the Fortran 2003 standard
2044 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2045 the implicit_flag is not needed, so it was removed. Derived types are
2046 identified by their name alone. */
2047
2048 match
2049 gfc_match_type_spec (gfc_typespec *ts)
2050 {
2051 match m;
2052 locus old_locus;
2053 char name[GFC_MAX_SYMBOL_LEN + 1];
2054
2055 gfc_clear_ts (ts);
2056 gfc_gobble_whitespace ();
2057 old_locus = gfc_current_locus;
2058 type_param_spec_list = NULL;
2059
2060 if (match_derived_type_spec (ts) == MATCH_YES)
2061 {
2062 /* Enforce F03:C401. */
2063 if (ts->u.derived->attr.abstract)
2064 {
2065 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
2066 ts->u.derived->name, &old_locus);
2067 return MATCH_ERROR;
2068 }
2069 return MATCH_YES;
2070 }
2071
2072 if (gfc_match ("integer") == MATCH_YES)
2073 {
2074 ts->type = BT_INTEGER;
2075 ts->kind = gfc_default_integer_kind;
2076 goto kind_selector;
2077 }
2078
2079 if (gfc_match ("double precision") == MATCH_YES)
2080 {
2081 ts->type = BT_REAL;
2082 ts->kind = gfc_default_double_kind;
2083 return MATCH_YES;
2084 }
2085
2086 if (gfc_match ("complex") == MATCH_YES)
2087 {
2088 ts->type = BT_COMPLEX;
2089 ts->kind = gfc_default_complex_kind;
2090 goto kind_selector;
2091 }
2092
2093 if (gfc_match ("character") == MATCH_YES)
2094 {
2095 ts->type = BT_CHARACTER;
2096
2097 m = gfc_match_char_spec (ts);
2098
2099 if (m == MATCH_NO)
2100 m = MATCH_YES;
2101
2102 return m;
2103 }
2104
2105 /* REAL is a real pain because it can be a type, intrinsic subprogram,
2106 or list item in a type-list of an OpenMP reduction clause. Need to
2107 differentiate REAL([KIND]=scalar-int-initialization-expr) from
2108 REAL(A,[KIND]) and REAL(KIND,A). Logically, when this code was
2109 written the use of LOGICAL as a type-spec or intrinsic subprogram
2110 was overlooked. */
2111
2112 m = gfc_match (" %n", name);
2113 if (m == MATCH_YES
2114 && (strcmp (name, "real") == 0 || strcmp (name, "logical") == 0))
2115 {
2116 char c;
2117 gfc_expr *e;
2118 locus where;
2119
2120 if (*name == 'r')
2121 {
2122 ts->type = BT_REAL;
2123 ts->kind = gfc_default_real_kind;
2124 }
2125 else
2126 {
2127 ts->type = BT_LOGICAL;
2128 ts->kind = gfc_default_logical_kind;
2129 }
2130
2131 gfc_gobble_whitespace ();
2132
2133 /* Prevent REAL*4, etc. */
2134 c = gfc_peek_ascii_char ();
2135 if (c == '*')
2136 {
2137 gfc_error ("Invalid type-spec at %C");
2138 return MATCH_ERROR;
2139 }
2140
2141 /* Found leading colon in REAL::, a trailing ')' in for example
2142 TYPE IS (REAL), or REAL, for an OpenMP list-item. */
2143 if (c == ':' || c == ')' || (flag_openmp && c == ','))
2144 return MATCH_YES;
2145
2146 /* Found something other than the opening '(' in REAL(... */
2147 if (c != '(')
2148 return MATCH_NO;
2149 else
2150 gfc_next_char (); /* Burn the '('. */
2151
2152 /* Look for the optional KIND=. */
2153 where = gfc_current_locus;
2154 m = gfc_match ("%n", name);
2155 if (m == MATCH_YES)
2156 {
2157 gfc_gobble_whitespace ();
2158 c = gfc_next_char ();
2159 if (c == '=')
2160 {
2161 if (strcmp(name, "a") == 0 || strcmp(name, "l") == 0)
2162 return MATCH_NO;
2163 else if (strcmp(name, "kind") == 0)
2164 goto found;
2165 else
2166 return MATCH_ERROR;
2167 }
2168 else
2169 gfc_current_locus = where;
2170 }
2171 else
2172 gfc_current_locus = where;
2173
2174 found:
2175
2176 m = gfc_match_init_expr (&e);
2177 if (m == MATCH_NO || m == MATCH_ERROR)
2178 return MATCH_NO;
2179
2180 /* If a comma appears, it is an intrinsic subprogram. */
2181 gfc_gobble_whitespace ();
2182 c = gfc_peek_ascii_char ();
2183 if (c == ',')
2184 {
2185 gfc_free_expr (e);
2186 return MATCH_NO;
2187 }
2188
2189 /* If ')' appears, we have REAL(initialization-expr), here check for
2190 a scalar integer initialization-expr and valid kind parameter. */
2191 if (c == ')')
2192 {
2193 if (e->ts.type != BT_INTEGER || e->rank > 0)
2194 {
2195 gfc_free_expr (e);
2196 return MATCH_NO;
2197 }
2198
2199 gfc_next_char (); /* Burn the ')'. */
2200 ts->kind = (int) mpz_get_si (e->value.integer);
2201 if (gfc_validate_kind (ts->type, ts->kind , true) == -1)
2202 {
2203 gfc_error ("Invalid type-spec at %C");
2204 return MATCH_ERROR;
2205 }
2206
2207 gfc_free_expr (e);
2208
2209 return MATCH_YES;
2210 }
2211 }
2212
2213 /* If a type is not matched, simply return MATCH_NO. */
2214 gfc_current_locus = old_locus;
2215 return MATCH_NO;
2216
2217 kind_selector:
2218
2219 gfc_gobble_whitespace ();
2220
2221 /* This prevents INTEGER*4, etc. */
2222 if (gfc_peek_ascii_char () == '*')
2223 {
2224 gfc_error ("Invalid type-spec at %C");
2225 return MATCH_ERROR;
2226 }
2227
2228 m = gfc_match_kind_spec (ts, false);
2229
2230 /* No kind specifier found. */
2231 if (m == MATCH_NO)
2232 m = MATCH_YES;
2233
2234 return m;
2235 }
2236
2237
2238 /******************** FORALL subroutines ********************/
2239
2240 /* Free a list of FORALL iterators. */
2241
2242 void
2243 gfc_free_forall_iterator (gfc_forall_iterator *iter)
2244 {
2245 gfc_forall_iterator *next;
2246
2247 while (iter)
2248 {
2249 next = iter->next;
2250 gfc_free_expr (iter->var);
2251 gfc_free_expr (iter->start);
2252 gfc_free_expr (iter->end);
2253 gfc_free_expr (iter->stride);
2254 free (iter);
2255 iter = next;
2256 }
2257 }
2258
2259
2260 /* Match an iterator as part of a FORALL statement. The format is:
2261
2262 <var> = <start>:<end>[:<stride>]
2263
2264 On MATCH_NO, the caller tests for the possibility that there is a
2265 scalar mask expression. */
2266
2267 static match
2268 match_forall_iterator (gfc_forall_iterator **result)
2269 {
2270 gfc_forall_iterator *iter;
2271 locus where;
2272 match m;
2273
2274 where = gfc_current_locus;
2275 iter = XCNEW (gfc_forall_iterator);
2276
2277 m = gfc_match_expr (&iter->var);
2278 if (m != MATCH_YES)
2279 goto cleanup;
2280
2281 if (gfc_match_char ('=') != MATCH_YES
2282 || iter->var->expr_type != EXPR_VARIABLE)
2283 {
2284 m = MATCH_NO;
2285 goto cleanup;
2286 }
2287
2288 m = gfc_match_expr (&iter->start);
2289 if (m != MATCH_YES)
2290 goto cleanup;
2291
2292 if (gfc_match_char (':') != MATCH_YES)
2293 goto syntax;
2294
2295 m = gfc_match_expr (&iter->end);
2296 if (m == MATCH_NO)
2297 goto syntax;
2298 if (m == MATCH_ERROR)
2299 goto cleanup;
2300
2301 if (gfc_match_char (':') == MATCH_NO)
2302 iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
2303 else
2304 {
2305 m = gfc_match_expr (&iter->stride);
2306 if (m == MATCH_NO)
2307 goto syntax;
2308 if (m == MATCH_ERROR)
2309 goto cleanup;
2310 }
2311
2312 /* Mark the iteration variable's symbol as used as a FORALL index. */
2313 iter->var->symtree->n.sym->forall_index = true;
2314
2315 *result = iter;
2316 return MATCH_YES;
2317
2318 syntax:
2319 gfc_error ("Syntax error in FORALL iterator at %C");
2320 m = MATCH_ERROR;
2321
2322 cleanup:
2323
2324 gfc_current_locus = where;
2325 gfc_free_forall_iterator (iter);
2326 return m;
2327 }
2328
2329
2330 /* Match the header of a FORALL statement. */
2331
2332 static match
2333 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
2334 {
2335 gfc_forall_iterator *head, *tail, *new_iter;
2336 gfc_expr *msk;
2337 match m;
2338
2339 gfc_gobble_whitespace ();
2340
2341 head = tail = NULL;
2342 msk = NULL;
2343
2344 if (gfc_match_char ('(') != MATCH_YES)
2345 return MATCH_NO;
2346
2347 m = match_forall_iterator (&new_iter);
2348 if (m == MATCH_ERROR)
2349 goto cleanup;
2350 if (m == MATCH_NO)
2351 goto syntax;
2352
2353 head = tail = new_iter;
2354
2355 for (;;)
2356 {
2357 if (gfc_match_char (',') != MATCH_YES)
2358 break;
2359
2360 m = match_forall_iterator (&new_iter);
2361 if (m == MATCH_ERROR)
2362 goto cleanup;
2363
2364 if (m == MATCH_YES)
2365 {
2366 tail->next = new_iter;
2367 tail = new_iter;
2368 continue;
2369 }
2370
2371 /* Have to have a mask expression. */
2372
2373 m = gfc_match_expr (&msk);
2374 if (m == MATCH_NO)
2375 goto syntax;
2376 if (m == MATCH_ERROR)
2377 goto cleanup;
2378
2379 break;
2380 }
2381
2382 if (gfc_match_char (')') == MATCH_NO)
2383 goto syntax;
2384
2385 *phead = head;
2386 *mask = msk;
2387 return MATCH_YES;
2388
2389 syntax:
2390 gfc_syntax_error (ST_FORALL);
2391
2392 cleanup:
2393 gfc_free_expr (msk);
2394 gfc_free_forall_iterator (head);
2395
2396 return MATCH_ERROR;
2397 }
2398
2399 /* Match the rest of a simple FORALL statement that follows an
2400 IF statement. */
2401
2402 static match
2403 match_simple_forall (void)
2404 {
2405 gfc_forall_iterator *head;
2406 gfc_expr *mask;
2407 gfc_code *c;
2408 match m;
2409
2410 mask = NULL;
2411 head = NULL;
2412 c = NULL;
2413
2414 m = match_forall_header (&head, &mask);
2415
2416 if (m == MATCH_NO)
2417 goto syntax;
2418 if (m != MATCH_YES)
2419 goto cleanup;
2420
2421 m = gfc_match_assignment ();
2422
2423 if (m == MATCH_ERROR)
2424 goto cleanup;
2425 if (m == MATCH_NO)
2426 {
2427 m = gfc_match_pointer_assignment ();
2428 if (m == MATCH_ERROR)
2429 goto cleanup;
2430 if (m == MATCH_NO)
2431 goto syntax;
2432 }
2433
2434 c = XCNEW (gfc_code);
2435 *c = new_st;
2436 c->loc = gfc_current_locus;
2437
2438 if (gfc_match_eos () != MATCH_YES)
2439 goto syntax;
2440
2441 gfc_clear_new_st ();
2442 new_st.op = EXEC_FORALL;
2443 new_st.expr1 = mask;
2444 new_st.ext.forall_iterator = head;
2445 new_st.block = gfc_get_code (EXEC_FORALL);
2446 new_st.block->next = c;
2447
2448 return MATCH_YES;
2449
2450 syntax:
2451 gfc_syntax_error (ST_FORALL);
2452
2453 cleanup:
2454 gfc_free_forall_iterator (head);
2455 gfc_free_expr (mask);
2456
2457 return MATCH_ERROR;
2458 }
2459
2460
2461 /* Match a FORALL statement. */
2462
2463 match
2464 gfc_match_forall (gfc_statement *st)
2465 {
2466 gfc_forall_iterator *head;
2467 gfc_expr *mask;
2468 gfc_code *c;
2469 match m0, m;
2470
2471 head = NULL;
2472 mask = NULL;
2473 c = NULL;
2474
2475 m0 = gfc_match_label ();
2476 if (m0 == MATCH_ERROR)
2477 return MATCH_ERROR;
2478
2479 m = gfc_match (" forall");
2480 if (m != MATCH_YES)
2481 return m;
2482
2483 m = match_forall_header (&head, &mask);
2484 if (m == MATCH_ERROR)
2485 goto cleanup;
2486 if (m == MATCH_NO)
2487 goto syntax;
2488
2489 if (gfc_match_eos () == MATCH_YES)
2490 {
2491 *st = ST_FORALL_BLOCK;
2492 new_st.op = EXEC_FORALL;
2493 new_st.expr1 = mask;
2494 new_st.ext.forall_iterator = head;
2495 return MATCH_YES;
2496 }
2497
2498 m = gfc_match_assignment ();
2499 if (m == MATCH_ERROR)
2500 goto cleanup;
2501 if (m == MATCH_NO)
2502 {
2503 m = gfc_match_pointer_assignment ();
2504 if (m == MATCH_ERROR)
2505 goto cleanup;
2506 if (m == MATCH_NO)
2507 goto syntax;
2508 }
2509
2510 c = XCNEW (gfc_code);
2511 *c = new_st;
2512 c->loc = gfc_current_locus;
2513
2514 gfc_clear_new_st ();
2515 new_st.op = EXEC_FORALL;
2516 new_st.expr1 = mask;
2517 new_st.ext.forall_iterator = head;
2518 new_st.block = gfc_get_code (EXEC_FORALL);
2519 new_st.block->next = c;
2520
2521 *st = ST_FORALL;
2522 return MATCH_YES;
2523
2524 syntax:
2525 gfc_syntax_error (ST_FORALL);
2526
2527 cleanup:
2528 gfc_free_forall_iterator (head);
2529 gfc_free_expr (mask);
2530 gfc_free_statements (c);
2531 return MATCH_NO;
2532 }
2533
2534
2535 /* Match a DO statement. */
2536
2537 match
2538 gfc_match_do (void)
2539 {
2540 gfc_iterator iter, *ip;
2541 locus old_loc;
2542 gfc_st_label *label;
2543 match m;
2544
2545 old_loc = gfc_current_locus;
2546
2547 memset (&iter, '\0', sizeof (gfc_iterator));
2548 label = NULL;
2549
2550 m = gfc_match_label ();
2551 if (m == MATCH_ERROR)
2552 return m;
2553
2554 if (gfc_match (" do") != MATCH_YES)
2555 return MATCH_NO;
2556
2557 m = gfc_match_st_label (&label);
2558 if (m == MATCH_ERROR)
2559 goto cleanup;
2560
2561 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2562
2563 if (gfc_match_eos () == MATCH_YES)
2564 {
2565 iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
2566 new_st.op = EXEC_DO_WHILE;
2567 goto done;
2568 }
2569
2570 /* Match an optional comma, if no comma is found, a space is obligatory. */
2571 if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
2572 return MATCH_NO;
2573
2574 /* Check for balanced parens. */
2575
2576 if (gfc_match_parens () == MATCH_ERROR)
2577 return MATCH_ERROR;
2578
2579 if (gfc_match (" concurrent") == MATCH_YES)
2580 {
2581 gfc_forall_iterator *head;
2582 gfc_expr *mask;
2583
2584 if (!gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT construct at %C"))
2585 return MATCH_ERROR;
2586
2587
2588 mask = NULL;
2589 head = NULL;
2590 m = match_forall_header (&head, &mask);
2591
2592 if (m == MATCH_NO)
2593 return m;
2594 if (m == MATCH_ERROR)
2595 goto concurr_cleanup;
2596
2597 if (gfc_match_eos () != MATCH_YES)
2598 goto concurr_cleanup;
2599
2600 if (label != NULL
2601 && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
2602 goto concurr_cleanup;
2603
2604 new_st.label1 = label;
2605 new_st.op = EXEC_DO_CONCURRENT;
2606 new_st.expr1 = mask;
2607 new_st.ext.forall_iterator = head;
2608
2609 return MATCH_YES;
2610
2611 concurr_cleanup:
2612 gfc_syntax_error (ST_DO);
2613 gfc_free_expr (mask);
2614 gfc_free_forall_iterator (head);
2615 return MATCH_ERROR;
2616 }
2617
2618 /* See if we have a DO WHILE. */
2619 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
2620 {
2621 new_st.op = EXEC_DO_WHILE;
2622 goto done;
2623 }
2624
2625 /* The abortive DO WHILE may have done something to the symbol
2626 table, so we start over. */
2627 gfc_undo_symbols ();
2628 gfc_current_locus = old_loc;
2629
2630 gfc_match_label (); /* This won't error. */
2631 gfc_match (" do "); /* This will work. */
2632
2633 gfc_match_st_label (&label); /* Can't error out. */
2634 gfc_match_char (','); /* Optional comma. */
2635
2636 m = gfc_match_iterator (&iter, 0);
2637 if (m == MATCH_NO)
2638 return MATCH_NO;
2639 if (m == MATCH_ERROR)
2640 goto cleanup;
2641
2642 iter.var->symtree->n.sym->attr.implied_index = 0;
2643 gfc_check_do_variable (iter.var->symtree);
2644
2645 if (gfc_match_eos () != MATCH_YES)
2646 {
2647 gfc_syntax_error (ST_DO);
2648 goto cleanup;
2649 }
2650
2651 new_st.op = EXEC_DO;
2652
2653 done:
2654 if (label != NULL
2655 && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
2656 goto cleanup;
2657
2658 new_st.label1 = label;
2659
2660 if (new_st.op == EXEC_DO_WHILE)
2661 new_st.expr1 = iter.end;
2662 else
2663 {
2664 new_st.ext.iterator = ip = gfc_get_iterator ();
2665 *ip = iter;
2666 }
2667
2668 return MATCH_YES;
2669
2670 cleanup:
2671 gfc_free_iterator (&iter, 0);
2672
2673 return MATCH_ERROR;
2674 }
2675
2676
2677 /* Match an EXIT or CYCLE statement. */
2678
2679 static match
2680 match_exit_cycle (gfc_statement st, gfc_exec_op op)
2681 {
2682 gfc_state_data *p, *o;
2683 gfc_symbol *sym;
2684 match m;
2685 int cnt;
2686
2687 if (gfc_match_eos () == MATCH_YES)
2688 sym = NULL;
2689 else
2690 {
2691 char name[GFC_MAX_SYMBOL_LEN + 1];
2692 gfc_symtree* stree;
2693
2694 m = gfc_match ("% %n%t", name);
2695 if (m == MATCH_ERROR)
2696 return MATCH_ERROR;
2697 if (m == MATCH_NO)
2698 {
2699 gfc_syntax_error (st);
2700 return MATCH_ERROR;
2701 }
2702
2703 /* Find the corresponding symbol. If there's a BLOCK statement
2704 between here and the label, it is not in gfc_current_ns but a parent
2705 namespace! */
2706 stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
2707 if (!stree)
2708 {
2709 gfc_error ("Name %qs in %s statement at %C is unknown",
2710 name, gfc_ascii_statement (st));
2711 return MATCH_ERROR;
2712 }
2713
2714 sym = stree->n.sym;
2715 if (sym->attr.flavor != FL_LABEL)
2716 {
2717 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2718 name, gfc_ascii_statement (st));
2719 return MATCH_ERROR;
2720 }
2721 }
2722
2723 /* Find the loop specified by the label (or lack of a label). */
2724 for (o = NULL, p = gfc_state_stack; p; p = p->previous)
2725 if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
2726 o = p;
2727 else if (p->state == COMP_CRITICAL)
2728 {
2729 gfc_error("%s statement at %C leaves CRITICAL construct",
2730 gfc_ascii_statement (st));
2731 return MATCH_ERROR;
2732 }
2733 else if (p->state == COMP_DO_CONCURRENT
2734 && (op == EXEC_EXIT || (sym && sym != p->sym)))
2735 {
2736 /* F2008, C821 & C845. */
2737 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2738 gfc_ascii_statement (st));
2739 return MATCH_ERROR;
2740 }
2741 else if ((sym && sym == p->sym)
2742 || (!sym && (p->state == COMP_DO
2743 || p->state == COMP_DO_CONCURRENT)))
2744 break;
2745
2746 if (p == NULL)
2747 {
2748 if (sym == NULL)
2749 gfc_error ("%s statement at %C is not within a construct",
2750 gfc_ascii_statement (st));
2751 else
2752 gfc_error ("%s statement at %C is not within construct %qs",
2753 gfc_ascii_statement (st), sym->name);
2754
2755 return MATCH_ERROR;
2756 }
2757
2758 /* Special checks for EXIT from non-loop constructs. */
2759 switch (p->state)
2760 {
2761 case COMP_DO:
2762 case COMP_DO_CONCURRENT:
2763 break;
2764
2765 case COMP_CRITICAL:
2766 /* This is already handled above. */
2767 gcc_unreachable ();
2768
2769 case COMP_ASSOCIATE:
2770 case COMP_BLOCK:
2771 case COMP_IF:
2772 case COMP_SELECT:
2773 case COMP_SELECT_TYPE:
2774 gcc_assert (sym);
2775 if (op == EXEC_CYCLE)
2776 {
2777 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2778 " construct %qs", sym->name);
2779 return MATCH_ERROR;
2780 }
2781 gcc_assert (op == EXEC_EXIT);
2782 if (!gfc_notify_std (GFC_STD_F2008, "EXIT statement with no"
2783 " do-construct-name at %C"))
2784 return MATCH_ERROR;
2785 break;
2786
2787 default:
2788 gfc_error ("%s statement at %C is not applicable to construct %qs",
2789 gfc_ascii_statement (st), sym->name);
2790 return MATCH_ERROR;
2791 }
2792
2793 if (o != NULL)
2794 {
2795 gfc_error (is_oacc (p)
2796 ? G_("%s statement at %C leaving OpenACC structured block")
2797 : G_("%s statement at %C leaving OpenMP structured block"),
2798 gfc_ascii_statement (st));
2799 return MATCH_ERROR;
2800 }
2801
2802 for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++)
2803 o = o->previous;
2804 if (cnt > 0
2805 && o != NULL
2806 && o->state == COMP_OMP_STRUCTURED_BLOCK
2807 && (o->head->op == EXEC_OACC_LOOP
2808 || o->head->op == EXEC_OACC_PARALLEL_LOOP))
2809 {
2810 int collapse = 1;
2811 gcc_assert (o->head->next != NULL
2812 && (o->head->next->op == EXEC_DO
2813 || o->head->next->op == EXEC_DO_WHILE)
2814 && o->previous != NULL
2815 && o->previous->tail->op == o->head->op);
2816 if (o->previous->tail->ext.omp_clauses != NULL
2817 && o->previous->tail->ext.omp_clauses->collapse > 1)
2818 collapse = o->previous->tail->ext.omp_clauses->collapse;
2819 if (st == ST_EXIT && cnt <= collapse)
2820 {
2821 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2822 return MATCH_ERROR;
2823 }
2824 if (st == ST_CYCLE && cnt < collapse)
2825 {
2826 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2827 " !$ACC LOOP loop");
2828 return MATCH_ERROR;
2829 }
2830 }
2831 if (cnt > 0
2832 && o != NULL
2833 && (o->state == COMP_OMP_STRUCTURED_BLOCK)
2834 && (o->head->op == EXEC_OMP_DO
2835 || o->head->op == EXEC_OMP_PARALLEL_DO
2836 || o->head->op == EXEC_OMP_SIMD
2837 || o->head->op == EXEC_OMP_DO_SIMD
2838 || o->head->op == EXEC_OMP_PARALLEL_DO_SIMD))
2839 {
2840 int count = 1;
2841 gcc_assert (o->head->next != NULL
2842 && (o->head->next->op == EXEC_DO
2843 || o->head->next->op == EXEC_DO_WHILE)
2844 && o->previous != NULL
2845 && o->previous->tail->op == o->head->op);
2846 if (o->previous->tail->ext.omp_clauses != NULL)
2847 {
2848 if (o->previous->tail->ext.omp_clauses->collapse > 1)
2849 count = o->previous->tail->ext.omp_clauses->collapse;
2850 if (o->previous->tail->ext.omp_clauses->orderedc)
2851 count = o->previous->tail->ext.omp_clauses->orderedc;
2852 }
2853 if (st == ST_EXIT && cnt <= count)
2854 {
2855 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2856 return MATCH_ERROR;
2857 }
2858 if (st == ST_CYCLE && cnt < count)
2859 {
2860 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2861 " !$OMP DO loop");
2862 return MATCH_ERROR;
2863 }
2864 }
2865
2866 /* Save the first statement in the construct - needed by the backend. */
2867 new_st.ext.which_construct = p->construct;
2868
2869 new_st.op = op;
2870
2871 return MATCH_YES;
2872 }
2873
2874
2875 /* Match the EXIT statement. */
2876
2877 match
2878 gfc_match_exit (void)
2879 {
2880 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
2881 }
2882
2883
2884 /* Match the CYCLE statement. */
2885
2886 match
2887 gfc_match_cycle (void)
2888 {
2889 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
2890 }
2891
2892
2893 /* Match a stop-code after an (ERROR) STOP or PAUSE statement. The
2894 requirements for a stop-code differ in the standards.
2895
2896 Fortran 95 has
2897
2898 R840 stop-stmt is STOP [ stop-code ]
2899 R841 stop-code is scalar-char-constant
2900 or digit [ digit [ digit [ digit [ digit ] ] ] ]
2901
2902 Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
2903 Fortran 2008 has
2904
2905 R855 stop-stmt is STOP [ stop-code ]
2906 R856 allstop-stmt is ALL STOP [ stop-code ]
2907 R857 stop-code is scalar-default-char-constant-expr
2908 or scalar-int-constant-expr
2909
2910 For free-form source code, all standards contain a statement of the form:
2911
2912 A blank shall be used to separate names, constants, or labels from
2913 adjacent keywords, names, constants, or labels.
2914
2915 A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003,
2916
2917 STOP123
2918
2919 is valid, but it is invalid Fortran 2008. */
2920
2921 static match
2922 gfc_match_stopcode (gfc_statement st)
2923 {
2924 gfc_expr *e = NULL;
2925 match m;
2926 bool f95, f03;
2927
2928 /* Set f95 for -std=f95. */
2929 f95 = gfc_option.allow_std == (GFC_STD_F95_OBS | GFC_STD_F95 | GFC_STD_F77
2930 | GFC_STD_F2008_OBS);
2931
2932 /* Set f03 for -std=f2003. */
2933 f03 = gfc_option.allow_std == (GFC_STD_F95_OBS | GFC_STD_F95 | GFC_STD_F77
2934 | GFC_STD_F2008_OBS | GFC_STD_F2003);
2935
2936 /* Look for a blank between STOP and the stop-code for F2008 or later. */
2937 if (gfc_current_form != FORM_FIXED && !(f95 || f03))
2938 {
2939 char c = gfc_peek_ascii_char ();
2940
2941 /* Look for end-of-statement. There is no stop-code. */
2942 if (c == '\n' || c == '!' || c == ';')
2943 goto done;
2944
2945 if (c != ' ')
2946 {
2947 gfc_error ("Blank required in %s statement near %C",
2948 gfc_ascii_statement (st));
2949 return MATCH_ERROR;
2950 }
2951 }
2952
2953 if (gfc_match_eos () != MATCH_YES)
2954 {
2955 int stopcode;
2956 locus old_locus;
2957
2958 /* First look for the F95 or F2003 digit [...] construct. */
2959 old_locus = gfc_current_locus;
2960 m = gfc_match_small_int (&stopcode);
2961 if (m == MATCH_YES && (f95 || f03))
2962 {
2963 if (stopcode < 0)
2964 {
2965 gfc_error ("STOP code at %C cannot be negative");
2966 return MATCH_ERROR;
2967 }
2968
2969 if (stopcode > 99999)
2970 {
2971 gfc_error ("STOP code at %C contains too many digits");
2972 return MATCH_ERROR;
2973 }
2974 }
2975
2976 /* Reset the locus and now load gfc_expr. */
2977 gfc_current_locus = old_locus;
2978 m = gfc_match_expr (&e);
2979 if (m == MATCH_ERROR)
2980 goto cleanup;
2981 if (m == MATCH_NO)
2982 goto syntax;
2983
2984 if (gfc_match_eos () != MATCH_YES)
2985 goto syntax;
2986 }
2987
2988 if (gfc_pure (NULL))
2989 {
2990 if (st == ST_ERROR_STOP)
2991 {
2992 if (!gfc_notify_std (GFC_STD_F2018, "%s statement at %C in PURE "
2993 "procedure", gfc_ascii_statement (st)))
2994 goto cleanup;
2995 }
2996 else
2997 {
2998 gfc_error ("%s statement not allowed in PURE procedure at %C",
2999 gfc_ascii_statement (st));
3000 goto cleanup;
3001 }
3002 }
3003
3004 gfc_unset_implicit_pure (NULL);
3005
3006 if (st == ST_STOP && gfc_find_state (COMP_CRITICAL))
3007 {
3008 gfc_error ("Image control statement STOP at %C in CRITICAL block");
3009 goto cleanup;
3010 }
3011 if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT))
3012 {
3013 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
3014 goto cleanup;
3015 }
3016
3017 if (e != NULL)
3018 {
3019 gfc_simplify_expr (e, 0);
3020
3021 /* Test for F95 and F2003 style STOP stop-code. */
3022 if (e->expr_type != EXPR_CONSTANT && (f95 || f03))
3023 {
3024 gfc_error ("STOP code at %L must be a scalar CHARACTER constant or "
3025 "digit[digit[digit[digit[digit]]]]", &e->where);
3026 goto cleanup;
3027 }
3028
3029 /* Use the machinery for an initialization expression to reduce the
3030 stop-code to a constant. */
3031 gfc_init_expr_flag = true;
3032 gfc_reduce_init_expr (e);
3033 gfc_init_expr_flag = false;
3034
3035 if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
3036 {
3037 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
3038 &e->where);
3039 goto cleanup;
3040 }
3041
3042 if (e->rank != 0)
3043 {
3044 gfc_error ("STOP code at %L must be scalar", &e->where);
3045 goto cleanup;
3046 }
3047
3048 if (e->ts.type == BT_CHARACTER
3049 && e->ts.kind != gfc_default_character_kind)
3050 {
3051 gfc_error ("STOP code at %L must be default character KIND=%d",
3052 &e->where, (int) gfc_default_character_kind);
3053 goto cleanup;
3054 }
3055
3056 if (e->ts.type == BT_INTEGER && e->ts.kind != gfc_default_integer_kind)
3057 {
3058 gfc_error ("STOP code at %L must be default integer KIND=%d",
3059 &e->where, (int) gfc_default_integer_kind);
3060 goto cleanup;
3061 }
3062 }
3063
3064 done:
3065
3066 switch (st)
3067 {
3068 case ST_STOP:
3069 new_st.op = EXEC_STOP;
3070 break;
3071 case ST_ERROR_STOP:
3072 new_st.op = EXEC_ERROR_STOP;
3073 break;
3074 case ST_PAUSE:
3075 new_st.op = EXEC_PAUSE;
3076 break;
3077 default:
3078 gcc_unreachable ();
3079 }
3080
3081 new_st.expr1 = e;
3082 new_st.ext.stop_code = -1;
3083
3084 return MATCH_YES;
3085
3086 syntax:
3087 gfc_syntax_error (st);
3088
3089 cleanup:
3090
3091 gfc_free_expr (e);
3092 return MATCH_ERROR;
3093 }
3094
3095
3096 /* Match the (deprecated) PAUSE statement. */
3097
3098 match
3099 gfc_match_pause (void)
3100 {
3101 match m;
3102
3103 m = gfc_match_stopcode (ST_PAUSE);
3104 if (m == MATCH_YES)
3105 {
3106 if (!gfc_notify_std (GFC_STD_F95_DEL, "PAUSE statement at %C"))
3107 m = MATCH_ERROR;
3108 }
3109 return m;
3110 }
3111
3112
3113 /* Match the STOP statement. */
3114
3115 match
3116 gfc_match_stop (void)
3117 {
3118 return gfc_match_stopcode (ST_STOP);
3119 }
3120
3121
3122 /* Match the ERROR STOP statement. */
3123
3124 match
3125 gfc_match_error_stop (void)
3126 {
3127 if (!gfc_notify_std (GFC_STD_F2008, "ERROR STOP statement at %C"))
3128 return MATCH_ERROR;
3129
3130 return gfc_match_stopcode (ST_ERROR_STOP);
3131 }
3132
3133 /* Match EVENT POST/WAIT statement. Syntax:
3134 EVENT POST ( event-variable [, sync-stat-list] )
3135 EVENT WAIT ( event-variable [, wait-spec-list] )
3136 with
3137 wait-spec-list is sync-stat-list or until-spec
3138 until-spec is UNTIL_COUNT = scalar-int-expr
3139 sync-stat is STAT= or ERRMSG=. */
3140
3141 static match
3142 event_statement (gfc_statement st)
3143 {
3144 match m;
3145 gfc_expr *tmp, *eventvar, *until_count, *stat, *errmsg;
3146 bool saw_until_count, saw_stat, saw_errmsg;
3147
3148 tmp = eventvar = until_count = stat = errmsg = NULL;
3149 saw_until_count = saw_stat = saw_errmsg = false;
3150
3151 if (gfc_pure (NULL))
3152 {
3153 gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
3154 st == ST_EVENT_POST ? "POST" : "WAIT");
3155 return MATCH_ERROR;
3156 }
3157
3158 gfc_unset_implicit_pure (NULL);
3159
3160 if (flag_coarray == GFC_FCOARRAY_NONE)
3161 {
3162 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3163 return MATCH_ERROR;
3164 }
3165
3166 if (gfc_find_state (COMP_CRITICAL))
3167 {
3168 gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
3169 st == ST_EVENT_POST ? "POST" : "WAIT");
3170 return MATCH_ERROR;
3171 }
3172
3173 if (gfc_find_state (COMP_DO_CONCURRENT))
3174 {
3175 gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
3176 "block", st == ST_EVENT_POST ? "POST" : "WAIT");
3177 return MATCH_ERROR;
3178 }
3179
3180 if (gfc_match_char ('(') != MATCH_YES)
3181 goto syntax;
3182
3183 if (gfc_match ("%e", &eventvar) != MATCH_YES)
3184 goto syntax;
3185 m = gfc_match_char (',');
3186 if (m == MATCH_ERROR)
3187 goto syntax;
3188 if (m == MATCH_NO)
3189 {
3190 m = gfc_match_char (')');
3191 if (m == MATCH_YES)
3192 goto done;
3193 goto syntax;
3194 }
3195
3196 for (;;)
3197 {
3198 m = gfc_match (" stat = %v", &tmp);
3199 if (m == MATCH_ERROR)
3200 goto syntax;
3201 if (m == MATCH_YES)
3202 {
3203 if (saw_stat)
3204 {
3205 gfc_error ("Redundant STAT tag found at %L", &tmp->where);
3206 goto cleanup;
3207 }
3208 stat = tmp;
3209 saw_stat = true;
3210
3211 m = gfc_match_char (',');
3212 if (m == MATCH_YES)
3213 continue;
3214
3215 tmp = NULL;
3216 break;
3217 }
3218
3219 m = gfc_match (" errmsg = %v", &tmp);
3220 if (m == MATCH_ERROR)
3221 goto syntax;
3222 if (m == MATCH_YES)
3223 {
3224 if (saw_errmsg)
3225 {
3226 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
3227 goto cleanup;
3228 }
3229 errmsg = tmp;
3230 saw_errmsg = true;
3231
3232 m = gfc_match_char (',');
3233 if (m == MATCH_YES)
3234 continue;
3235
3236 tmp = NULL;
3237 break;
3238 }
3239
3240 m = gfc_match (" until_count = %e", &tmp);
3241 if (m == MATCH_ERROR || st == ST_EVENT_POST)
3242 goto syntax;
3243 if (m == MATCH_YES)
3244 {
3245 if (saw_until_count)
3246 {
3247 gfc_error ("Redundant UNTIL_COUNT tag found at %L",
3248 &tmp->where);
3249 goto cleanup;
3250 }
3251 until_count = tmp;
3252 saw_until_count = true;
3253
3254 m = gfc_match_char (',');
3255 if (m == MATCH_YES)
3256 continue;
3257
3258 tmp = NULL;
3259 break;
3260 }
3261
3262 break;
3263 }
3264
3265 if (m == MATCH_ERROR)
3266 goto syntax;
3267
3268 if (gfc_match (" )%t") != MATCH_YES)
3269 goto syntax;
3270
3271 done:
3272 switch (st)
3273 {
3274 case ST_EVENT_POST:
3275 new_st.op = EXEC_EVENT_POST;
3276 break;
3277 case ST_EVENT_WAIT:
3278 new_st.op = EXEC_EVENT_WAIT;
3279 break;
3280 default:
3281 gcc_unreachable ();
3282 }
3283
3284 new_st.expr1 = eventvar;
3285 new_st.expr2 = stat;
3286 new_st.expr3 = errmsg;
3287 new_st.expr4 = until_count;
3288
3289 return MATCH_YES;
3290
3291 syntax:
3292 gfc_syntax_error (st);
3293
3294 cleanup:
3295 if (until_count != tmp)
3296 gfc_free_expr (until_count);
3297 if (errmsg != tmp)
3298 gfc_free_expr (errmsg);
3299 if (stat != tmp)
3300 gfc_free_expr (stat);
3301
3302 gfc_free_expr (tmp);
3303 gfc_free_expr (eventvar);
3304
3305 return MATCH_ERROR;
3306
3307 }
3308
3309
3310 match
3311 gfc_match_event_post (void)
3312 {
3313 if (!gfc_notify_std (GFC_STD_F2008_TS, "EVENT POST statement at %C"))
3314 return MATCH_ERROR;
3315
3316 return event_statement (ST_EVENT_POST);
3317 }
3318
3319
3320 match
3321 gfc_match_event_wait (void)
3322 {
3323 if (!gfc_notify_std (GFC_STD_F2008_TS, "EVENT WAIT statement at %C"))
3324 return MATCH_ERROR;
3325
3326 return event_statement (ST_EVENT_WAIT);
3327 }
3328
3329
3330 /* Match a FAIL IMAGE statement. */
3331
3332 match
3333 gfc_match_fail_image (void)
3334 {
3335 if (!gfc_notify_std (GFC_STD_F2008_TS, "FAIL IMAGE statement at %C"))
3336 return MATCH_ERROR;
3337
3338 if (gfc_match_char ('(') == MATCH_YES)
3339 goto syntax;
3340
3341 new_st.op = EXEC_FAIL_IMAGE;
3342
3343 return MATCH_YES;
3344
3345 syntax:
3346 gfc_syntax_error (ST_FAIL_IMAGE);
3347
3348 return MATCH_ERROR;
3349 }
3350
3351
3352 /* Match LOCK/UNLOCK statement. Syntax:
3353 LOCK ( lock-variable [ , lock-stat-list ] )
3354 UNLOCK ( lock-variable [ , sync-stat-list ] )
3355 where lock-stat is ACQUIRED_LOCK or sync-stat
3356 and sync-stat is STAT= or ERRMSG=. */
3357
3358 static match
3359 lock_unlock_statement (gfc_statement st)
3360 {
3361 match m;
3362 gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg;
3363 bool saw_acq_lock, saw_stat, saw_errmsg;
3364
3365 tmp = lockvar = acq_lock = stat = errmsg = NULL;
3366 saw_acq_lock = saw_stat = saw_errmsg = false;
3367
3368 if (gfc_pure (NULL))
3369 {
3370 gfc_error ("Image control statement %s at %C in PURE procedure",
3371 st == ST_LOCK ? "LOCK" : "UNLOCK");
3372 return MATCH_ERROR;
3373 }
3374
3375 gfc_unset_implicit_pure (NULL);
3376
3377 if (flag_coarray == GFC_FCOARRAY_NONE)
3378 {
3379 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3380 return MATCH_ERROR;
3381 }
3382
3383 if (gfc_find_state (COMP_CRITICAL))
3384 {
3385 gfc_error ("Image control statement %s at %C in CRITICAL block",
3386 st == ST_LOCK ? "LOCK" : "UNLOCK");
3387 return MATCH_ERROR;
3388 }
3389
3390 if (gfc_find_state (COMP_DO_CONCURRENT))
3391 {
3392 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
3393 st == ST_LOCK ? "LOCK" : "UNLOCK");
3394 return MATCH_ERROR;
3395 }
3396
3397 if (gfc_match_char ('(') != MATCH_YES)
3398 goto syntax;
3399
3400 if (gfc_match ("%e", &lockvar) != MATCH_YES)
3401 goto syntax;
3402 m = gfc_match_char (',');
3403 if (m == MATCH_ERROR)
3404 goto syntax;
3405 if (m == MATCH_NO)
3406 {
3407 m = gfc_match_char (')');
3408 if (m == MATCH_YES)
3409 goto done;
3410 goto syntax;
3411 }
3412
3413 for (;;)
3414 {
3415 m = gfc_match (" stat = %v", &tmp);
3416 if (m == MATCH_ERROR)
3417 goto syntax;
3418 if (m == MATCH_YES)
3419 {
3420 if (saw_stat)
3421 {
3422 gfc_error ("Redundant STAT tag found at %L", &tmp->where);
3423 goto cleanup;
3424 }
3425 stat = tmp;
3426 saw_stat = true;
3427
3428 m = gfc_match_char (',');
3429 if (m == MATCH_YES)
3430 continue;
3431
3432 tmp = NULL;
3433 break;
3434 }
3435
3436 m = gfc_match (" errmsg = %v", &tmp);
3437 if (m == MATCH_ERROR)
3438 goto syntax;
3439 if (m == MATCH_YES)
3440 {
3441 if (saw_errmsg)
3442 {
3443 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
3444 goto cleanup;
3445 }
3446 errmsg = tmp;
3447 saw_errmsg = true;
3448
3449 m = gfc_match_char (',');
3450 if (m == MATCH_YES)
3451 continue;
3452
3453 tmp = NULL;
3454 break;
3455 }
3456
3457 m = gfc_match (" acquired_lock = %v", &tmp);
3458 if (m == MATCH_ERROR || st == ST_UNLOCK)
3459 goto syntax;
3460 if (m == MATCH_YES)
3461 {
3462 if (saw_acq_lock)
3463 {
3464 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L",
3465 &tmp->where);
3466 goto cleanup;
3467 }
3468 acq_lock = tmp;
3469 saw_acq_lock = true;
3470
3471 m = gfc_match_char (',');
3472 if (m == MATCH_YES)
3473 continue;
3474
3475 tmp = NULL;
3476 break;
3477 }
3478
3479 break;
3480 }
3481
3482 if (m == MATCH_ERROR)
3483 goto syntax;
3484
3485 if (gfc_match (" )%t") != MATCH_YES)
3486 goto syntax;
3487
3488 done:
3489 switch (st)
3490 {
3491 case ST_LOCK:
3492 new_st.op = EXEC_LOCK;
3493 break;
3494 case ST_UNLOCK:
3495 new_st.op = EXEC_UNLOCK;
3496 break;
3497 default:
3498 gcc_unreachable ();
3499 }
3500
3501 new_st.expr1 = lockvar;
3502 new_st.expr2 = stat;
3503 new_st.expr3 = errmsg;
3504 new_st.expr4 = acq_lock;
3505
3506 return MATCH_YES;
3507
3508 syntax:
3509 gfc_syntax_error (st);
3510
3511 cleanup:
3512 if (acq_lock != tmp)
3513 gfc_free_expr (acq_lock);
3514 if (errmsg != tmp)
3515 gfc_free_expr (errmsg);
3516 if (stat != tmp)
3517 gfc_free_expr (stat);
3518
3519 gfc_free_expr (tmp);
3520 gfc_free_expr (lockvar);
3521
3522 return MATCH_ERROR;
3523 }
3524
3525
3526 match
3527 gfc_match_lock (void)
3528 {
3529 if (!gfc_notify_std (GFC_STD_F2008, "LOCK statement at %C"))
3530 return MATCH_ERROR;
3531
3532 return lock_unlock_statement (ST_LOCK);
3533 }
3534
3535
3536 match
3537 gfc_match_unlock (void)
3538 {
3539 if (!gfc_notify_std (GFC_STD_F2008, "UNLOCK statement at %C"))
3540 return MATCH_ERROR;
3541
3542 return lock_unlock_statement (ST_UNLOCK);
3543 }
3544
3545
3546 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
3547 SYNC ALL [(sync-stat-list)]
3548 SYNC MEMORY [(sync-stat-list)]
3549 SYNC IMAGES (image-set [, sync-stat-list] )
3550 with sync-stat is int-expr or *. */
3551
3552 static match
3553 sync_statement (gfc_statement st)
3554 {
3555 match m;
3556 gfc_expr *tmp, *imageset, *stat, *errmsg;
3557 bool saw_stat, saw_errmsg;
3558
3559 tmp = imageset = stat = errmsg = NULL;
3560 saw_stat = saw_errmsg = false;
3561
3562 if (gfc_pure (NULL))
3563 {
3564 gfc_error ("Image control statement SYNC at %C in PURE procedure");
3565 return MATCH_ERROR;
3566 }
3567
3568 gfc_unset_implicit_pure (NULL);
3569
3570 if (!gfc_notify_std (GFC_STD_F2008, "SYNC statement at %C"))
3571 return MATCH_ERROR;
3572
3573 if (flag_coarray == GFC_FCOARRAY_NONE)
3574 {
3575 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
3576 "enable");
3577 return MATCH_ERROR;
3578 }
3579
3580 if (gfc_find_state (COMP_CRITICAL))
3581 {
3582 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3583 return MATCH_ERROR;
3584 }
3585
3586 if (gfc_find_state (COMP_DO_CONCURRENT))
3587 {
3588 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3589 return MATCH_ERROR;
3590 }
3591
3592 if (gfc_match_eos () == MATCH_YES)
3593 {
3594 if (st == ST_SYNC_IMAGES)
3595 goto syntax;
3596 goto done;
3597 }
3598
3599 if (gfc_match_char ('(') != MATCH_YES)
3600 goto syntax;
3601
3602 if (st == ST_SYNC_IMAGES)
3603 {
3604 /* Denote '*' as imageset == NULL. */
3605 m = gfc_match_char ('*');
3606 if (m == MATCH_ERROR)
3607 goto syntax;
3608 if (m == MATCH_NO)
3609 {
3610 if (gfc_match ("%e", &imageset) != MATCH_YES)
3611 goto syntax;
3612 }
3613 m = gfc_match_char (',');
3614 if (m == MATCH_ERROR)
3615 goto syntax;
3616 if (m == MATCH_NO)
3617 {
3618 m = gfc_match_char (')');
3619 if (m == MATCH_YES)
3620 goto done;
3621 goto syntax;
3622 }
3623 }
3624
3625 for (;;)
3626 {
3627 m = gfc_match (" stat = %v", &tmp);
3628 if (m == MATCH_ERROR)
3629 goto syntax;
3630 if (m == MATCH_YES)
3631 {
3632 if (saw_stat)
3633 {
3634 gfc_error ("Redundant STAT tag found at %L", &tmp->where);
3635 goto cleanup;
3636 }
3637 stat = tmp;
3638 saw_stat = true;
3639
3640 if (gfc_match_char (',') == MATCH_YES)
3641 continue;
3642
3643 tmp = NULL;
3644 break;
3645 }
3646
3647 m = gfc_match (" errmsg = %v", &tmp);
3648 if (m == MATCH_ERROR)
3649 goto syntax;
3650 if (m == MATCH_YES)
3651 {
3652 if (saw_errmsg)
3653 {
3654 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
3655 goto cleanup;
3656 }
3657 errmsg = tmp;
3658 saw_errmsg = true;
3659
3660 if (gfc_match_char (',') == MATCH_YES)
3661 continue;
3662
3663 tmp = NULL;
3664 break;
3665 }
3666
3667 break;
3668 }
3669
3670 if (gfc_match (" )%t") != MATCH_YES)
3671 goto syntax;
3672
3673 done:
3674 switch (st)
3675 {
3676 case ST_SYNC_ALL:
3677 new_st.op = EXEC_SYNC_ALL;
3678 break;
3679 case ST_SYNC_IMAGES:
3680 new_st.op = EXEC_SYNC_IMAGES;
3681 break;
3682 case ST_SYNC_MEMORY:
3683 new_st.op = EXEC_SYNC_MEMORY;
3684 break;
3685 default:
3686 gcc_unreachable ();
3687 }
3688
3689 new_st.expr1 = imageset;
3690 new_st.expr2 = stat;
3691 new_st.expr3 = errmsg;
3692
3693 return MATCH_YES;
3694
3695 syntax:
3696 gfc_syntax_error (st);
3697
3698 cleanup:
3699 if (stat != tmp)
3700 gfc_free_expr (stat);
3701 if (errmsg != tmp)
3702 gfc_free_expr (errmsg);
3703
3704 gfc_free_expr (tmp);
3705 gfc_free_expr (imageset);
3706
3707 return MATCH_ERROR;
3708 }
3709
3710
3711 /* Match SYNC ALL statement. */
3712
3713 match
3714 gfc_match_sync_all (void)
3715 {
3716 return sync_statement (ST_SYNC_ALL);
3717 }
3718
3719
3720 /* Match SYNC IMAGES statement. */
3721
3722 match
3723 gfc_match_sync_images (void)
3724 {
3725 return sync_statement (ST_SYNC_IMAGES);
3726 }
3727
3728
3729 /* Match SYNC MEMORY statement. */
3730
3731 match
3732 gfc_match_sync_memory (void)
3733 {
3734 return sync_statement (ST_SYNC_MEMORY);
3735 }
3736
3737
3738 /* Match a CONTINUE statement. */
3739
3740 match
3741 gfc_match_continue (void)
3742 {
3743 if (gfc_match_eos () != MATCH_YES)
3744 {
3745 gfc_syntax_error (ST_CONTINUE);
3746 return MATCH_ERROR;
3747 }
3748
3749 new_st.op = EXEC_CONTINUE;
3750 return MATCH_YES;
3751 }
3752
3753
3754 /* Match the (deprecated) ASSIGN statement. */
3755
3756 match
3757 gfc_match_assign (void)
3758 {
3759 gfc_expr *expr;
3760 gfc_st_label *label;
3761
3762 if (gfc_match (" %l", &label) == MATCH_YES)
3763 {
3764 if (!gfc_reference_st_label (label, ST_LABEL_UNKNOWN))
3765 return MATCH_ERROR;
3766 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
3767 {
3768 if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGN statement at %C"))
3769 return MATCH_ERROR;
3770
3771 expr->symtree->n.sym->attr.assign = 1;
3772
3773 new_st.op = EXEC_LABEL_ASSIGN;
3774 new_st.label1 = label;
3775 new_st.expr1 = expr;
3776 return MATCH_YES;
3777 }
3778 }
3779 return MATCH_NO;
3780 }
3781
3782
3783 /* Match the GO TO statement. As a computed GOTO statement is
3784 matched, it is transformed into an equivalent SELECT block. No
3785 tree is necessary, and the resulting jumps-to-jumps are
3786 specifically optimized away by the back end. */
3787
3788 match
3789 gfc_match_goto (void)
3790 {
3791 gfc_code *head, *tail;
3792 gfc_expr *expr;
3793 gfc_case *cp;
3794 gfc_st_label *label;
3795 int i;
3796 match m;
3797
3798 if (gfc_match (" %l%t", &label) == MATCH_YES)
3799 {
3800 if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
3801 return MATCH_ERROR;
3802
3803 new_st.op = EXEC_GOTO;
3804 new_st.label1 = label;
3805 return MATCH_YES;
3806 }
3807
3808 /* The assigned GO TO statement. */
3809
3810 if (gfc_match_variable (&expr, 0) == MATCH_YES)
3811 {
3812 if (!gfc_notify_std (GFC_STD_F95_DEL, "Assigned GOTO statement at %C"))
3813 return MATCH_ERROR;
3814
3815 new_st.op = EXEC_GOTO;
3816 new_st.expr1 = expr;
3817
3818 if (gfc_match_eos () == MATCH_YES)
3819 return MATCH_YES;
3820
3821 /* Match label list. */
3822 gfc_match_char (',');
3823 if (gfc_match_char ('(') != MATCH_YES)
3824 {
3825 gfc_syntax_error (ST_GOTO);
3826 return MATCH_ERROR;
3827 }
3828 head = tail = NULL;
3829
3830 do
3831 {
3832 m = gfc_match_st_label (&label);
3833 if (m != MATCH_YES)
3834 goto syntax;
3835
3836 if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
3837 goto cleanup;
3838
3839 if (head == NULL)
3840 head = tail = gfc_get_code (EXEC_GOTO);
3841 else
3842 {
3843 tail->block = gfc_get_code (EXEC_GOTO);
3844 tail = tail->block;
3845 }
3846
3847 tail->label1 = label;
3848 }
3849 while (gfc_match_char (',') == MATCH_YES);
3850
3851 if (gfc_match (")%t") != MATCH_YES)
3852 goto syntax;
3853
3854 if (head == NULL)
3855 {
3856 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3857 goto syntax;
3858 }
3859 new_st.block = head;
3860
3861 return MATCH_YES;
3862 }
3863
3864 /* Last chance is a computed GO TO statement. */
3865 if (gfc_match_char ('(') != MATCH_YES)
3866 {
3867 gfc_syntax_error (ST_GOTO);
3868 return MATCH_ERROR;
3869 }
3870
3871 head = tail = NULL;
3872 i = 1;
3873
3874 do
3875 {
3876 m = gfc_match_st_label (&label);
3877 if (m != MATCH_YES)
3878 goto syntax;
3879
3880 if (!gfc_reference_st_label (label, ST_LABEL_TARGET))
3881 goto cleanup;
3882
3883 if (head == NULL)
3884 head = tail = gfc_get_code (EXEC_SELECT);
3885 else
3886 {
3887 tail->block = gfc_get_code (EXEC_SELECT);
3888 tail = tail->block;
3889 }
3890
3891 cp = gfc_get_case ();
3892 cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
3893 NULL, i++);
3894
3895 tail->ext.block.case_list = cp;
3896
3897 tail->next = gfc_get_code (EXEC_GOTO);
3898 tail->next->label1 = label;
3899 }
3900 while (gfc_match_char (',') == MATCH_YES);
3901
3902 if (gfc_match_char (')') != MATCH_YES)
3903 goto syntax;
3904
3905 if (head == NULL)
3906 {
3907 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3908 goto syntax;
3909 }
3910
3911 /* Get the rest of the statement. */
3912 gfc_match_char (',');
3913
3914 if (gfc_match (" %e%t", &expr) != MATCH_YES)
3915 goto syntax;
3916
3917 if (!gfc_notify_std (GFC_STD_F95_OBS, "Computed GOTO at %C"))
3918 return MATCH_ERROR;
3919
3920 /* At this point, a computed GOTO has been fully matched and an
3921 equivalent SELECT statement constructed. */
3922
3923 new_st.op = EXEC_SELECT;
3924 new_st.expr1 = NULL;
3925
3926 /* Hack: For a "real" SELECT, the expression is in expr. We put
3927 it in expr2 so we can distinguish then and produce the correct
3928 diagnostics. */
3929 new_st.expr2 = expr;
3930 new_st.block = head;
3931 return MATCH_YES;
3932
3933 syntax:
3934 gfc_syntax_error (ST_GOTO);
3935 cleanup:
3936 gfc_free_statements (head);
3937 return MATCH_ERROR;
3938 }
3939
3940
3941 /* Frees a list of gfc_alloc structures. */
3942
3943 void
3944 gfc_free_alloc_list (gfc_alloc *p)
3945 {
3946 gfc_alloc *q;
3947
3948 for (; p; p = q)
3949 {
3950 q = p->next;
3951 gfc_free_expr (p->expr);
3952 free (p);
3953 }
3954 }
3955
3956
3957 /* Match an ALLOCATE statement. */
3958
3959 match
3960 gfc_match_allocate (void)
3961 {
3962 gfc_alloc *head, *tail;
3963 gfc_expr *stat, *errmsg, *tmp, *source, *mold;
3964 gfc_typespec ts;
3965 gfc_symbol *sym;
3966 match m;
3967 locus old_locus, deferred_locus, assumed_locus;
3968 bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
3969 bool saw_unlimited = false, saw_assumed = false;
3970
3971 head = tail = NULL;
3972 stat = errmsg = source = mold = tmp = NULL;
3973 saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
3974
3975 if (gfc_match_char ('(') != MATCH_YES)
3976 {
3977 gfc_syntax_error (ST_ALLOCATE);
3978 return MATCH_ERROR;
3979 }
3980
3981 /* Match an optional type-spec. */
3982 old_locus = gfc_current_locus;
3983 m = gfc_match_type_spec (&ts);
3984 if (m == MATCH_ERROR)
3985 goto cleanup;
3986 else if (m == MATCH_NO)
3987 {
3988 char name[GFC_MAX_SYMBOL_LEN + 3];
3989
3990 if (gfc_match ("%n :: ", name) == MATCH_YES)
3991 {
3992 gfc_error ("Error in type-spec at %L", &old_locus);
3993 goto cleanup;
3994 }
3995
3996 ts.type = BT_UNKNOWN;
3997 }
3998 else
3999 {
4000 /* Needed for the F2008:C631 check below. */
4001 assumed_locus = gfc_current_locus;
4002
4003 if (gfc_match (" :: ") == MATCH_YES)
4004 {
4005 if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L",
4006 &old_locus))
4007 goto cleanup;
4008
4009 if (ts.deferred)
4010 {
4011 gfc_error ("Type-spec at %L cannot contain a deferred "
4012 "type parameter", &old_locus);
4013 goto cleanup;
4014 }
4015
4016 if (ts.type == BT_CHARACTER)
4017 {
4018 if (!ts.u.cl->length)
4019 saw_assumed = true;
4020 else
4021 ts.u.cl->length_from_typespec = true;
4022 }
4023
4024 if (type_param_spec_list
4025 && gfc_spec_list_type (type_param_spec_list, NULL)
4026 == SPEC_DEFERRED)
4027 {
4028 gfc_error ("The type parameter spec list in the type-spec at "
4029 "%L cannot contain DEFERRED parameters", &old_locus);
4030 goto cleanup;
4031 }
4032 }
4033 else
4034 {
4035 ts.type = BT_UNKNOWN;
4036 gfc_current_locus = old_locus;
4037 }
4038 }
4039
4040 for (;;)
4041 {
4042 if (head == NULL)
4043 head = tail = gfc_get_alloc ();
4044 else
4045 {
4046 tail->next = gfc_get_alloc ();
4047 tail = tail->next;
4048 }
4049
4050 m = gfc_match_variable (&tail->expr, 0);
4051 if (m == MATCH_NO)
4052 goto syntax;
4053 if (m == MATCH_ERROR)
4054 goto cleanup;
4055
4056 if (gfc_check_do_variable (tail->expr->symtree))
4057 goto cleanup;
4058
4059 bool impure = gfc_impure_variable (tail->expr->symtree->n.sym);
4060 if (impure && gfc_pure (NULL))
4061 {
4062 gfc_error ("Bad allocate-object at %C for a PURE procedure");
4063 goto cleanup;
4064 }
4065
4066 if (impure)
4067 gfc_unset_implicit_pure (NULL);
4068
4069 /* F2008:C631 (R626) A type-param-value in a type-spec shall be an
4070 asterisk if and only if each allocate-object is a dummy argument
4071 for which the corresponding type parameter is assumed. */
4072 if (saw_assumed
4073 && (tail->expr->ts.deferred
4074 || tail->expr->ts.u.cl->length
4075 || tail->expr->symtree->n.sym->attr.dummy == 0))
4076 {
4077 gfc_error ("Incompatible allocate-object at %C for CHARACTER "
4078 "type-spec at %L", &assumed_locus);
4079 goto cleanup;
4080 }
4081
4082 if (tail->expr->ts.deferred)
4083 {
4084 saw_deferred = true;
4085 deferred_locus = tail->expr->where;
4086 }
4087
4088 if (gfc_find_state (COMP_DO_CONCURRENT)
4089 || gfc_find_state (COMP_CRITICAL))
4090 {
4091 gfc_ref *ref;
4092 bool coarray = tail->expr->symtree->n.sym->attr.codimension;
4093 for (ref = tail->expr->ref; ref; ref = ref->next)
4094 if (ref->type == REF_COMPONENT)
4095 coarray = ref->u.c.component->attr.codimension;
4096
4097 if (coarray && gfc_find_state (COMP_DO_CONCURRENT))
4098 {
4099 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
4100 goto cleanup;
4101 }
4102 if (coarray && gfc_find_state (COMP_CRITICAL))
4103 {
4104 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
4105 goto cleanup;
4106 }
4107 }
4108
4109 /* Check for F08:C628. */
4110 sym = tail->expr->symtree->n.sym;
4111 b1 = !(tail->expr->ref
4112 && (tail->expr->ref->type == REF_COMPONENT
4113 || tail->expr->ref->type == REF_ARRAY));
4114 if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok)
4115 b2 = !(CLASS_DATA (sym)->attr.allocatable
4116 || CLASS_DATA (sym)->attr.class_pointer);
4117 else
4118 b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
4119 || sym->attr.proc_pointer);
4120 b3 = sym && sym->ns && sym->ns->proc_name
4121 && (sym->ns->proc_name->attr.allocatable
4122 || sym->ns->proc_name->attr.pointer
4123 || sym->ns->proc_name->attr.proc_pointer);
4124 if (b1 && b2 && !b3)
4125 {
4126 gfc_error ("Allocate-object at %L is neither a data pointer "
4127 "nor an allocatable variable", &tail->expr->where);
4128 goto cleanup;
4129 }
4130
4131 /* The ALLOCATE statement had an optional typespec. Check the
4132 constraints. */
4133 if (ts.type != BT_UNKNOWN)
4134 {
4135 /* Enforce F03:C624. */
4136 if (!gfc_type_compatible (&tail->expr->ts, &ts))
4137 {
4138 gfc_error ("Type of entity at %L is type incompatible with "
4139 "typespec", &tail->expr->where);
4140 goto cleanup;
4141 }
4142
4143 /* Enforce F03:C627. */
4144 if (ts.kind != tail->expr->ts.kind && !UNLIMITED_POLY (tail->expr))
4145 {
4146 gfc_error ("Kind type parameter for entity at %L differs from "
4147 "the kind type parameter of the typespec",
4148 &tail->expr->where);
4149 goto cleanup;
4150 }
4151 }
4152
4153 if (tail->expr->ts.type == BT_DERIVED)
4154 tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
4155
4156 if (type_param_spec_list)
4157 tail->expr->param_list = gfc_copy_actual_arglist (type_param_spec_list);
4158
4159 saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr);
4160
4161 if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
4162 {
4163 gfc_error ("Shape specification for allocatable scalar at %C");
4164 goto cleanup;
4165 }
4166
4167 if (gfc_match_char (',') != MATCH_YES)
4168 break;
4169
4170 alloc_opt_list:
4171
4172 m = gfc_match (" stat = %v", &tmp);
4173 if (m == MATCH_ERROR)
4174 goto cleanup;
4175 if (m == MATCH_YES)
4176 {
4177 /* Enforce C630. */
4178 if (saw_stat)
4179 {
4180 gfc_error ("Redundant STAT tag found at %L", &tmp->where);
4181 goto cleanup;
4182 }
4183
4184 stat = tmp;
4185 tmp = NULL;
4186 saw_stat = true;
4187
4188 if (gfc_check_do_variable (stat->symtree))
4189 goto cleanup;
4190
4191 if (gfc_match_char (',') == MATCH_YES)
4192 goto alloc_opt_list;
4193 }
4194
4195 m = gfc_match (" errmsg = %v", &tmp);
4196 if (m == MATCH_ERROR)
4197 goto cleanup;
4198 if (m == MATCH_YES)
4199 {
4200 if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG tag at %L", &tmp->where))
4201 goto cleanup;
4202
4203 /* Enforce C630. */
4204 if (saw_errmsg)
4205 {
4206 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
4207 goto cleanup;
4208 }
4209
4210 errmsg = tmp;
4211 tmp = NULL;
4212 saw_errmsg = true;
4213
4214 if (gfc_match_char (',') == MATCH_YES)
4215 goto alloc_opt_list;
4216 }
4217
4218 m = gfc_match (" source = %e", &tmp);
4219 if (m == MATCH_ERROR)
4220 goto cleanup;
4221 if (m == MATCH_YES)
4222 {
4223 if (!gfc_notify_std (GFC_STD_F2003, "SOURCE tag at %L", &tmp->where))
4224 goto cleanup;
4225
4226 /* Enforce C630. */
4227 if (saw_source)
4228 {
4229 gfc_error ("Redundant SOURCE tag found at %L", &tmp->where);
4230 goto cleanup;
4231 }
4232
4233 /* The next 2 conditionals check C631. */
4234 if (ts.type != BT_UNKNOWN)
4235 {
4236 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
4237 &tmp->where, &old_locus);
4238 goto cleanup;
4239 }
4240
4241 if (head->next
4242 && !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L"
4243 " with more than a single allocate object",
4244 &tmp->where))
4245 goto cleanup;
4246
4247 source = tmp;
4248 tmp = NULL;
4249 saw_source = true;
4250
4251 if (gfc_match_char (',') == MATCH_YES)
4252 goto alloc_opt_list;
4253 }
4254
4255 m = gfc_match (" mold = %e", &tmp);
4256 if (m == MATCH_ERROR)
4257 goto cleanup;
4258 if (m == MATCH_YES)
4259 {
4260 if (!gfc_notify_std (GFC_STD_F2008, "MOLD tag at %L", &tmp->where))
4261 goto cleanup;
4262
4263 /* Check F08:C636. */
4264 if (saw_mold)
4265 {
4266 gfc_error ("Redundant MOLD tag found at %L", &tmp->where);
4267 goto cleanup;
4268 }
4269
4270 /* Check F08:C637. */
4271 if (ts.type != BT_UNKNOWN)
4272 {
4273 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
4274 &tmp->where, &old_locus);
4275 goto cleanup;
4276 }
4277
4278 mold = tmp;
4279 tmp = NULL;
4280 saw_mold = true;
4281 mold->mold = 1;
4282
4283 if (gfc_match_char (',') == MATCH_YES)
4284 goto alloc_opt_list;
4285 }
4286
4287 gfc_gobble_whitespace ();
4288
4289 if (gfc_peek_char () == ')')
4290 break;
4291 }
4292
4293 if (gfc_match (" )%t") != MATCH_YES)
4294 goto syntax;
4295
4296 /* Check F08:C637. */
4297 if (source && mold)
4298 {
4299 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
4300 &mold->where, &source->where);
4301 goto cleanup;
4302 }
4303
4304 /* Check F03:C623, */
4305 if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold)
4306 {
4307 gfc_error ("Allocate-object at %L with a deferred type parameter "
4308 "requires either a type-spec or SOURCE tag or a MOLD tag",
4309 &deferred_locus);
4310 goto cleanup;
4311 }
4312
4313 /* Check F03:C625, */
4314 if (saw_unlimited && ts.type == BT_UNKNOWN && !source && !mold)
4315 {
4316 for (tail = head; tail; tail = tail->next)
4317 {
4318 if (UNLIMITED_POLY (tail->expr))
4319 gfc_error ("Unlimited polymorphic allocate-object at %L "
4320 "requires either a type-spec or SOURCE tag "
4321 "or a MOLD tag", &tail->expr->where);
4322 }
4323 goto cleanup;
4324 }
4325
4326 new_st.op = EXEC_ALLOCATE;
4327 new_st.expr1 = stat;
4328 new_st.expr2 = errmsg;
4329 if (source)
4330 new_st.expr3 = source;
4331 else
4332 new_st.expr3 = mold;
4333 new_st.ext.alloc.list = head;
4334 new_st.ext.alloc.ts = ts;
4335
4336 if (type_param_spec_list)
4337 gfc_free_actual_arglist (type_param_spec_list);
4338
4339 return MATCH_YES;
4340
4341 syntax:
4342 gfc_syntax_error (ST_ALLOCATE);
4343
4344 cleanup:
4345 gfc_free_expr (errmsg);
4346 gfc_free_expr (source);
4347 gfc_free_expr (stat);
4348 gfc_free_expr (mold);
4349 if (tmp && tmp->expr_type) gfc_free_expr (tmp);
4350 gfc_free_alloc_list (head);
4351 if (type_param_spec_list)
4352 gfc_free_actual_arglist (type_param_spec_list);
4353 return MATCH_ERROR;
4354 }
4355
4356
4357 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
4358 a set of pointer assignments to intrinsic NULL(). */
4359
4360 match
4361 gfc_match_nullify (void)
4362 {
4363 gfc_code *tail;
4364 gfc_expr *e, *p;
4365 match m;
4366
4367 tail = NULL;
4368
4369 if (gfc_match_char ('(') != MATCH_YES)
4370 goto syntax;
4371
4372 for (;;)
4373 {
4374 m = gfc_match_variable (&p, 0);
4375 if (m == MATCH_ERROR)
4376 goto cleanup;
4377 if (m == MATCH_NO)
4378 goto syntax;
4379
4380 if (gfc_check_do_variable (p->symtree))
4381 goto cleanup;
4382
4383 /* F2008, C1242. */
4384 if (gfc_is_coindexed (p))
4385 {
4386 gfc_error ("Pointer object at %C shall not be coindexed");
4387 goto cleanup;
4388 }
4389
4390 /* build ' => NULL() '. */
4391 e = gfc_get_null_expr (&gfc_current_locus);
4392
4393 /* Chain to list. */
4394 if (tail == NULL)
4395 {
4396 tail = &new_st;
4397 tail->op = EXEC_POINTER_ASSIGN;
4398 }
4399 else
4400 {
4401 tail->next = gfc_get_code (EXEC_POINTER_ASSIGN);
4402 tail = tail->next;
4403 }
4404
4405 tail->expr1 = p;
4406 tail->expr2 = e;
4407
4408 if (gfc_match (" )%t") == MATCH_YES)
4409 break;
4410 if (gfc_match_char (',') != MATCH_YES)
4411 goto syntax;
4412 }
4413
4414 return MATCH_YES;
4415
4416 syntax:
4417 gfc_syntax_error (ST_NULLIFY);
4418
4419 cleanup:
4420 gfc_free_statements (new_st.next);
4421 new_st.next = NULL;
4422 gfc_free_expr (new_st.expr1);
4423 new_st.expr1 = NULL;
4424 gfc_free_expr (new_st.expr2);
4425 new_st.expr2 = NULL;
4426 return MATCH_ERROR;
4427 }
4428
4429
4430 /* Match a DEALLOCATE statement. */
4431
4432 match
4433 gfc_match_deallocate (void)
4434 {
4435 gfc_alloc *head, *tail;
4436 gfc_expr *stat, *errmsg, *tmp;
4437 gfc_symbol *sym;
4438 match m;
4439 bool saw_stat, saw_errmsg, b1, b2;
4440
4441 head = tail = NULL;
4442 stat = errmsg = tmp = NULL;
4443 saw_stat = saw_errmsg = false;
4444
4445 if (gfc_match_char ('(') != MATCH_YES)
4446 goto syntax;
4447
4448 for (;;)
4449 {
4450 if (head == NULL)
4451 head = tail = gfc_get_alloc ();
4452 else
4453 {
4454 tail->next = gfc_get_alloc ();
4455 tail = tail->next;
4456 }
4457
4458 m = gfc_match_variable (&tail->expr, 0);
4459 if (m == MATCH_ERROR)
4460 goto cleanup;
4461 if (m == MATCH_NO)
4462 goto syntax;
4463
4464 if (gfc_check_do_variable (tail->expr->symtree))
4465 goto cleanup;
4466
4467 sym = tail->expr->symtree->n.sym;
4468
4469 bool impure = gfc_impure_variable (sym);
4470 if (impure && gfc_pure (NULL))
4471 {
4472 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
4473 goto cleanup;
4474 }
4475
4476 if (impure)
4477 gfc_unset_implicit_pure (NULL);
4478
4479 if (gfc_is_coarray (tail->expr)
4480 && gfc_find_state (COMP_DO_CONCURRENT))
4481 {
4482 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
4483 goto cleanup;
4484 }
4485
4486 if (gfc_is_coarray (tail->expr)
4487 && gfc_find_state (COMP_CRITICAL))
4488 {
4489 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
4490 goto cleanup;
4491 }
4492
4493 /* FIXME: disable the checking on derived types. */
4494 b1 = !(tail->expr->ref
4495 && (tail->expr->ref->type == REF_COMPONENT
4496 || tail->expr->ref->type == REF_ARRAY));
4497 if (sym && sym->ts.type == BT_CLASS)
4498 b2 = !(CLASS_DATA (sym)->attr.allocatable
4499 || CLASS_DATA (sym)->attr.class_pointer);
4500 else
4501 b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
4502 || sym->attr.proc_pointer);
4503 if (b1 && b2)
4504 {
4505 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
4506 "nor an allocatable variable");
4507 goto cleanup;
4508 }
4509
4510 if (gfc_match_char (',') != MATCH_YES)
4511 break;
4512
4513 dealloc_opt_list:
4514
4515 m = gfc_match (" stat = %v", &tmp);
4516 if (m == MATCH_ERROR)
4517 goto cleanup;
4518 if (m == MATCH_YES)
4519 {
4520 if (saw_stat)
4521 {
4522 gfc_error ("Redundant STAT tag found at %L", &tmp->where);
4523 gfc_free_expr (tmp);
4524 goto cleanup;
4525 }
4526
4527 stat = tmp;
4528 saw_stat = true;
4529
4530 if (gfc_check_do_variable (stat->symtree))
4531 goto cleanup;
4532
4533 if (gfc_match_char (',') == MATCH_YES)
4534 goto dealloc_opt_list;
4535 }
4536
4537 m = gfc_match (" errmsg = %v", &tmp);
4538 if (m == MATCH_ERROR)
4539 goto cleanup;
4540 if (m == MATCH_YES)
4541 {
4542 if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG at %L", &tmp->where))
4543 goto cleanup;
4544
4545 if (saw_errmsg)
4546 {
4547 gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
4548 gfc_free_expr (tmp);
4549 goto cleanup;
4550 }
4551
4552 errmsg = tmp;
4553 saw_errmsg = true;
4554
4555 if (gfc_match_char (',') == MATCH_YES)
4556 goto dealloc_opt_list;
4557 }
4558
4559 gfc_gobble_whitespace ();
4560
4561 if (gfc_peek_char () == ')')
4562 break;
4563 }
4564
4565 if (gfc_match (" )%t") != MATCH_YES)
4566 goto syntax;
4567
4568 new_st.op = EXEC_DEALLOCATE;
4569 new_st.expr1 = stat;
4570 new_st.expr2 = errmsg;
4571 new_st.ext.alloc.list = head;
4572
4573 return MATCH_YES;
4574
4575 syntax:
4576 gfc_syntax_error (ST_DEALLOCATE);
4577
4578 cleanup:
4579 gfc_free_expr (errmsg);
4580 gfc_free_expr (stat);
4581 gfc_free_alloc_list (head);
4582 return MATCH_ERROR;
4583 }
4584
4585
4586 /* Match a RETURN statement. */
4587
4588 match
4589 gfc_match_return (void)
4590 {
4591 gfc_expr *e;
4592 match m;
4593 gfc_compile_state s;
4594
4595 e = NULL;
4596
4597 if (gfc_find_state (COMP_CRITICAL))
4598 {
4599 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4600 return MATCH_ERROR;
4601 }
4602
4603 if (gfc_find_state (COMP_DO_CONCURRENT))
4604 {
4605 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4606 return MATCH_ERROR;
4607 }
4608
4609 if (gfc_match_eos () == MATCH_YES)
4610 goto done;
4611
4612 if (!gfc_find_state (COMP_SUBROUTINE))
4613 {
4614 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4615 "a SUBROUTINE");
4616 goto cleanup;
4617 }
4618
4619 if (gfc_current_form == FORM_FREE)
4620 {
4621 /* The following are valid, so we can't require a blank after the
4622 RETURN keyword:
4623 return+1
4624 return(1) */
4625 char c = gfc_peek_ascii_char ();
4626 if (ISALPHA (c) || ISDIGIT (c))
4627 return MATCH_NO;
4628 }
4629
4630 m = gfc_match (" %e%t", &e);
4631 if (m == MATCH_YES)
4632 goto done;
4633 if (m == MATCH_ERROR)
4634 goto cleanup;
4635
4636 gfc_syntax_error (ST_RETURN);
4637
4638 cleanup:
4639 gfc_free_expr (e);
4640 return MATCH_ERROR;
4641
4642 done:
4643 gfc_enclosing_unit (&s);
4644 if (s == COMP_PROGRAM
4645 && !gfc_notify_std (GFC_STD_GNU, "RETURN statement in "
4646 "main program at %C"))
4647 return MATCH_ERROR;
4648
4649 new_st.op = EXEC_RETURN;
4650 new_st.expr1 = e;
4651
4652 return MATCH_YES;
4653 }
4654
4655
4656 /* Match the call of a type-bound procedure, if CALL%var has already been
4657 matched and var found to be a derived-type variable. */
4658
4659 static match
4660 match_typebound_call (gfc_symtree* varst)
4661 {
4662 gfc_expr* base;
4663 match m;
4664
4665 base = gfc_get_expr ();
4666 base->expr_type = EXPR_VARIABLE;
4667 base->symtree = varst;
4668 base->where = gfc_current_locus;
4669 gfc_set_sym_referenced (varst->n.sym);
4670
4671 m = gfc_match_varspec (base, 0, true, true);
4672 if (m == MATCH_NO)
4673 gfc_error ("Expected component reference at %C");
4674 if (m != MATCH_YES)
4675 {
4676 gfc_free_expr (base);
4677 return MATCH_ERROR;
4678 }
4679
4680 if (gfc_match_eos () != MATCH_YES)
4681 {
4682 gfc_error ("Junk after CALL at %C");
4683 gfc_free_expr (base);
4684 return MATCH_ERROR;
4685 }
4686
4687 if (base->expr_type == EXPR_COMPCALL)
4688 new_st.op = EXEC_COMPCALL;
4689 else if (base->expr_type == EXPR_PPC)
4690 new_st.op = EXEC_CALL_PPC;
4691 else
4692 {
4693 gfc_error ("Expected type-bound procedure or procedure pointer component "
4694 "at %C");
4695 gfc_free_expr (base);
4696 return MATCH_ERROR;
4697 }
4698 new_st.expr1 = base;
4699
4700 return MATCH_YES;
4701 }
4702
4703
4704 /* Match a CALL statement. The tricky part here are possible
4705 alternate return specifiers. We handle these by having all
4706 "subroutines" actually return an integer via a register that gives
4707 the return number. If the call specifies alternate returns, we
4708 generate code for a SELECT statement whose case clauses contain
4709 GOTOs to the various labels. */
4710
4711 match
4712 gfc_match_call (void)
4713 {
4714 char name[GFC_MAX_SYMBOL_LEN + 1];
4715 gfc_actual_arglist *a, *arglist;
4716 gfc_case *new_case;
4717 gfc_symbol *sym;
4718 gfc_symtree *st;
4719 gfc_code *c;
4720 match m;
4721 int i;
4722
4723 arglist = NULL;
4724
4725 m = gfc_match ("% %n", name);
4726 if (m == MATCH_NO)
4727 goto syntax;
4728 if (m != MATCH_YES)
4729 return m;
4730
4731 if (gfc_get_ha_sym_tree (name, &st))
4732 return MATCH_ERROR;
4733
4734 sym = st->n.sym;
4735
4736 /* If this is a variable of derived-type, it probably starts a type-bound
4737 procedure call. */
4738 if ((sym->attr.flavor != FL_PROCEDURE
4739 || gfc_is_function_return_value (sym, gfc_current_ns))
4740 && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
4741 return match_typebound_call (st);
4742
4743 /* If it does not seem to be callable (include functions so that the
4744 right association is made. They are thrown out in resolution.)
4745 ... */
4746 if (!sym->attr.generic
4747 && !sym->attr.subroutine
4748 && !sym->attr.function)
4749 {
4750 if (!(sym->attr.external && !sym->attr.referenced))
4751 {
4752 /* ...create a symbol in this scope... */
4753 if (sym->ns != gfc_current_ns
4754 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
4755 return MATCH_ERROR;
4756
4757 if (sym != st->n.sym)
4758 sym = st->n.sym;
4759 }
4760
4761 /* ...and then to try to make the symbol into a subroutine. */
4762 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
4763 return MATCH_ERROR;
4764 }
4765
4766 gfc_set_sym_referenced (sym);
4767
4768 if (gfc_match_eos () != MATCH_YES)
4769 {
4770 m = gfc_match_actual_arglist (1, &arglist);
4771 if (m == MATCH_NO)
4772 goto syntax;
4773 if (m == MATCH_ERROR)
4774 goto cleanup;
4775
4776 if (gfc_match_eos () != MATCH_YES)
4777 goto syntax;
4778 }
4779
4780 /* If any alternate return labels were found, construct a SELECT
4781 statement that will jump to the right place. */
4782
4783 i = 0;
4784 for (a = arglist; a; a = a->next)
4785 if (a->expr == NULL)
4786 {
4787 i = 1;
4788 break;
4789 }
4790
4791 if (i)
4792 {
4793 gfc_symtree *select_st;
4794 gfc_symbol *select_sym;
4795 char name[GFC_MAX_SYMBOL_LEN + 1];
4796
4797 new_st.next = c = gfc_get_code (EXEC_SELECT);
4798 sprintf (name, "_result_%s", sym->name);
4799 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
4800
4801 select_sym = select_st->n.sym;
4802 select_sym->ts.type = BT_INTEGER;
4803 select_sym->ts.kind = gfc_default_integer_kind;
4804 gfc_set_sym_referenced (select_sym);
4805 c->expr1 = gfc_get_expr ();
4806 c->expr1->expr_type = EXPR_VARIABLE;
4807 c->expr1->symtree = select_st;
4808 c->expr1->ts = select_sym->ts;
4809 c->expr1->where = gfc_current_locus;
4810
4811 i = 0;
4812 for (a = arglist; a; a = a->next)
4813 {
4814 if (a->expr != NULL)
4815 continue;
4816
4817 if (!gfc_reference_st_label (a->label, ST_LABEL_TARGET))
4818 continue;
4819
4820 i++;
4821
4822 c->block = gfc_get_code (EXEC_SELECT);
4823 c = c->block;
4824
4825 new_case = gfc_get_case ();
4826 new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
4827 new_case->low = new_case->high;
4828 c->ext.block.case_list = new_case;
4829
4830 c->next = gfc_get_code (EXEC_GOTO);
4831 c->next->label1 = a->label;
4832 }
4833 }
4834
4835 new_st.op = EXEC_CALL;
4836 new_st.symtree = st;
4837 new_st.ext.actual = arglist;
4838
4839 return MATCH_YES;
4840
4841 syntax:
4842 gfc_syntax_error (ST_CALL);
4843
4844 cleanup:
4845 gfc_free_actual_arglist (arglist);
4846 return MATCH_ERROR;
4847 }
4848
4849
4850 /* Given a name, return a pointer to the common head structure,
4851 creating it if it does not exist. If FROM_MODULE is nonzero, we
4852 mangle the name so that it doesn't interfere with commons defined
4853 in the using namespace.
4854 TODO: Add to global symbol tree. */
4855
4856 gfc_common_head *
4857 gfc_get_common (const char *name, int from_module)
4858 {
4859 gfc_symtree *st;
4860 static int serial = 0;
4861 char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
4862
4863 if (from_module)
4864 {
4865 /* A use associated common block is only needed to correctly layout
4866 the variables it contains. */
4867 snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
4868 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
4869 }
4870 else
4871 {
4872 st = gfc_find_symtree (gfc_current_ns->common_root, name);
4873
4874 if (st == NULL)
4875 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
4876 }
4877
4878 if (st->n.common == NULL)
4879 {
4880 st->n.common = gfc_get_common_head ();
4881 st->n.common->where = gfc_current_locus;
4882 strcpy (st->n.common->name, name);
4883 }
4884
4885 return st->n.common;
4886 }
4887
4888
4889 /* Match a common block name. */
4890
4891 match match_common_name (char *name)
4892 {
4893 match m;
4894
4895 if (gfc_match_char ('/') == MATCH_NO)
4896 {
4897 name[0] = '\0';
4898 return MATCH_YES;
4899 }
4900
4901 if (gfc_match_char ('/') == MATCH_YES)
4902 {
4903 name[0] = '\0';
4904 return MATCH_YES;
4905 }
4906
4907 m = gfc_match_name (name);
4908
4909 if (m == MATCH_ERROR)
4910 return MATCH_ERROR;
4911 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
4912 return MATCH_YES;
4913
4914 gfc_error ("Syntax error in common block name at %C");
4915 return MATCH_ERROR;
4916 }
4917
4918
4919 /* Match a COMMON statement. */
4920
4921 match
4922 gfc_match_common (void)
4923 {
4924 gfc_symbol *sym, **head, *tail, *other;
4925 char name[GFC_MAX_SYMBOL_LEN + 1];
4926 gfc_common_head *t;
4927 gfc_array_spec *as;
4928 gfc_equiv *e1, *e2;
4929 match m;
4930
4931 as = NULL;
4932
4933 for (;;)
4934 {
4935 m = match_common_name (name);
4936 if (m == MATCH_ERROR)
4937 goto cleanup;
4938
4939 if (name[0] == '\0')
4940 {
4941 t = &gfc_current_ns->blank_common;
4942 if (t->head == NULL)
4943 t->where = gfc_current_locus;
4944 }
4945 else
4946 {
4947 t = gfc_get_common (name, 0);
4948 }
4949 head = &t->head;
4950
4951 if (*head == NULL)
4952 tail = NULL;
4953 else
4954 {
4955 tail = *head;
4956 while (tail->common_next)
4957 tail = tail->common_next;
4958 }
4959
4960 /* Grab the list of symbols. */
4961 for (;;)
4962 {
4963 m = gfc_match_symbol (&sym, 0);
4964 if (m == MATCH_ERROR)
4965 goto cleanup;
4966 if (m == MATCH_NO)
4967 goto syntax;
4968
4969 /* See if we know the current common block is bind(c), and if
4970 so, then see if we can check if the symbol is (which it'll
4971 need to be). This can happen if the bind(c) attr stmt was
4972 applied to the common block, and the variable(s) already
4973 defined, before declaring the common block. */
4974 if (t->is_bind_c == 1)
4975 {
4976 if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
4977 {
4978 /* If we find an error, just print it and continue,
4979 cause it's just semantic, and we can see if there
4980 are more errors. */
4981 gfc_error_now ("Variable %qs at %L in common block %qs "
4982 "at %C must be declared with a C "
4983 "interoperable kind since common block "
4984 "%qs is bind(c)",
4985 sym->name, &(sym->declared_at), t->name,
4986 t->name);
4987 }
4988
4989 if (sym->attr.is_bind_c == 1)
4990 gfc_error_now ("Variable %qs in common block %qs at %C can not "
4991 "be bind(c) since it is not global", sym->name,
4992 t->name);
4993 }
4994
4995 if (sym->attr.in_common)
4996 {
4997 gfc_error ("Symbol %qs at %C is already in a COMMON block",
4998 sym->name);
4999 goto cleanup;
5000 }
5001
5002 if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
5003 || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
5004 {
5005 if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol %qs at "
5006 "%C can only be COMMON in BLOCK DATA",
5007 sym->name))
5008 goto cleanup;
5009 }
5010
5011 /* Deal with an optional array specification after the
5012 symbol name. */
5013 m = gfc_match_array_spec (&as, true, true);
5014 if (m == MATCH_ERROR)
5015 goto cleanup;
5016
5017 if (m == MATCH_YES)
5018 {
5019 if (as->type != AS_EXPLICIT)
5020 {
5021 gfc_error ("Array specification for symbol %qs in COMMON "
5022 "at %C must be explicit", sym->name);
5023 goto cleanup;
5024 }
5025
5026 if (!gfc_add_dimension (&sym->attr, sym->name, NULL))
5027 goto cleanup;
5028
5029 if (sym->attr.pointer)
5030 {
5031 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
5032 "POINTER array", sym->name);
5033 goto cleanup;
5034 }
5035
5036 sym->as = as;
5037 as = NULL;
5038
5039 }
5040
5041 /* Add the in_common attribute, but ignore the reported errors
5042 if any, and continue matching. */
5043 gfc_add_in_common (&sym->attr, sym->name, NULL);
5044
5045 sym->common_block = t;
5046 sym->common_block->refs++;
5047
5048 if (tail != NULL)
5049 tail->common_next = sym;
5050 else
5051 *head = sym;
5052
5053 tail = sym;
5054
5055 sym->common_head = t;
5056
5057 /* Check to see if the symbol is already in an equivalence group.
5058 If it is, set the other members as being in common. */
5059 if (sym->attr.in_equivalence)
5060 {
5061 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
5062 {
5063 for (e2 = e1; e2; e2 = e2->eq)
5064 if (e2->expr->symtree->n.sym == sym)
5065 goto equiv_found;
5066
5067 continue;
5068
5069 equiv_found:
5070
5071 for (e2 = e1; e2; e2 = e2->eq)
5072 {
5073 other = e2->expr->symtree->n.sym;
5074 if (other->common_head
5075 && other->common_head != sym->common_head)
5076 {
5077 gfc_error ("Symbol %qs, in COMMON block %qs at "
5078 "%C is being indirectly equivalenced to "
5079 "another COMMON block %qs",
5080 sym->name, sym->common_head->name,
5081 other->common_head->name);
5082 goto cleanup;
5083 }
5084 other->attr.in_common = 1;
5085 other->common_head = t;
5086 }
5087 }
5088 }
5089
5090
5091 gfc_gobble_whitespace ();
5092 if (gfc_match_eos () == MATCH_YES)
5093 goto done;
5094 if (gfc_peek_ascii_char () == '/')
5095 break;
5096 if (gfc_match_char (',') != MATCH_YES)
5097 goto syntax;
5098 gfc_gobble_whitespace ();
5099 if (gfc_peek_ascii_char () == '/')
5100 break;
5101 }
5102 }
5103
5104 done:
5105 return MATCH_YES;
5106
5107 syntax:
5108 gfc_syntax_error (ST_COMMON);
5109
5110 cleanup:
5111 gfc_free_array_spec (as);
5112 return MATCH_ERROR;
5113 }
5114
5115
5116 /* Match a BLOCK DATA program unit. */
5117
5118 match
5119 gfc_match_block_data (void)
5120 {
5121 char name[GFC_MAX_SYMBOL_LEN + 1];
5122 gfc_symbol *sym;
5123 match m;
5124
5125 if (gfc_match_eos () == MATCH_YES)
5126 {
5127 gfc_new_block = NULL;
5128 return MATCH_YES;
5129 }
5130
5131 m = gfc_match ("% %n%t", name);
5132 if (m != MATCH_YES)
5133 return MATCH_ERROR;
5134
5135 if (gfc_get_symbol (name, NULL, &sym))
5136 return MATCH_ERROR;
5137
5138 if (!gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL))
5139 return MATCH_ERROR;
5140
5141 gfc_new_block = sym;
5142
5143 return MATCH_YES;
5144 }
5145
5146
5147 /* Free a namelist structure. */
5148
5149 void
5150 gfc_free_namelist (gfc_namelist *name)
5151 {
5152 gfc_namelist *n;
5153
5154 for (; name; name = n)
5155 {
5156 n = name->next;
5157 free (name);
5158 }
5159 }
5160
5161
5162 /* Free an OpenMP namelist structure. */
5163
5164 void
5165 gfc_free_omp_namelist (gfc_omp_namelist *name)
5166 {
5167 gfc_omp_namelist *n;
5168
5169 for (; name; name = n)
5170 {
5171 gfc_free_expr (name->expr);
5172 if (name->udr)
5173 {
5174 if (name->udr->combiner)
5175 gfc_free_statement (name->udr->combiner);
5176 if (name->udr->initializer)
5177 gfc_free_statement (name->udr->initializer);
5178 free (name->udr);
5179 }
5180 n = name->next;
5181 free (name);
5182 }
5183 }
5184
5185
5186 /* Match a NAMELIST statement. */
5187
5188 match
5189 gfc_match_namelist (void)
5190 {
5191 gfc_symbol *group_name, *sym;
5192 gfc_namelist *nl;
5193 match m, m2;
5194
5195 m = gfc_match (" / %s /", &group_name);
5196 if (m == MATCH_NO)
5197 goto syntax;
5198 if (m == MATCH_ERROR)
5199 goto error;
5200
5201 for (;;)
5202 {
5203 if (group_name->ts.type != BT_UNKNOWN)
5204 {
5205 gfc_error ("Namelist group name %qs at %C already has a basic "
5206 "type of %s", group_name->name,
5207 gfc_typename (&group_name->ts));
5208 return MATCH_ERROR;
5209 }
5210
5211 if (group_name->attr.flavor == FL_NAMELIST
5212 && group_name->attr.use_assoc
5213 && !gfc_notify_std (GFC_STD_GNU, "Namelist group name %qs "
5214 "at %C already is USE associated and can"
5215 "not be respecified.", group_name->name))
5216 return MATCH_ERROR;
5217
5218 if (group_name->attr.flavor != FL_NAMELIST
5219 && !gfc_add_flavor (&group_name->attr, FL_NAMELIST,
5220 group_name->name, NULL))
5221 return MATCH_ERROR;
5222
5223 for (;;)
5224 {
5225 m = gfc_match_symbol (&sym, 1);
5226 if (m == MATCH_NO)
5227 goto syntax;
5228 if (m == MATCH_ERROR)
5229 goto error;
5230
5231 if (sym->attr.in_namelist == 0
5232 && !gfc_add_in_namelist (&sym->attr, sym->name, NULL))
5233 goto error;
5234
5235 /* Use gfc_error_check here, rather than goto error, so that
5236 these are the only errors for the next two lines. */
5237 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
5238 {
5239 gfc_error ("Assumed size array %qs in namelist %qs at "
5240 "%C is not allowed", sym->name, group_name->name);
5241 gfc_error_check ();
5242 }
5243
5244 nl = gfc_get_namelist ();
5245 nl->sym = sym;
5246 sym->refs++;
5247
5248 if (group_name->namelist == NULL)
5249 group_name->namelist = group_name->namelist_tail = nl;
5250 else
5251 {
5252 group_name->namelist_tail->next = nl;
5253 group_name->namelist_tail = nl;
5254 }
5255
5256 if (gfc_match_eos () == MATCH_YES)
5257 goto done;
5258
5259 m = gfc_match_char (',');
5260
5261 if (gfc_match_char ('/') == MATCH_YES)
5262 {
5263 m2 = gfc_match (" %s /", &group_name);
5264 if (m2 == MATCH_YES)
5265 break;
5266 if (m2 == MATCH_ERROR)
5267 goto error;
5268 goto syntax;
5269 }
5270
5271 if (m != MATCH_YES)
5272 goto syntax;
5273 }
5274 }
5275
5276 done:
5277 return MATCH_YES;
5278
5279 syntax:
5280 gfc_syntax_error (ST_NAMELIST);
5281
5282 error:
5283 return MATCH_ERROR;
5284 }
5285
5286
5287 /* Match a MODULE statement. */
5288
5289 match
5290 gfc_match_module (void)
5291 {
5292 match m;
5293
5294 m = gfc_match (" %s%t", &gfc_new_block);
5295 if (m != MATCH_YES)
5296 return m;
5297
5298 if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
5299 gfc_new_block->name, NULL))
5300 return MATCH_ERROR;
5301
5302 return MATCH_YES;
5303 }
5304
5305
5306 /* Free equivalence sets and lists. Recursively is the easiest way to
5307 do this. */
5308
5309 void
5310 gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop)
5311 {
5312 if (eq == stop)
5313 return;
5314
5315 gfc_free_equiv (eq->eq);
5316 gfc_free_equiv_until (eq->next, stop);
5317 gfc_free_expr (eq->expr);
5318 free (eq);
5319 }
5320
5321
5322 void
5323 gfc_free_equiv (gfc_equiv *eq)
5324 {
5325 gfc_free_equiv_until (eq, NULL);
5326 }
5327
5328
5329 /* Match an EQUIVALENCE statement. */
5330
5331 match
5332 gfc_match_equivalence (void)
5333 {
5334 gfc_equiv *eq, *set, *tail;
5335 gfc_ref *ref;
5336 gfc_symbol *sym;
5337 match m;
5338 gfc_common_head *common_head = NULL;
5339 bool common_flag;
5340 int cnt;
5341
5342 tail = NULL;
5343
5344 for (;;)
5345 {
5346 eq = gfc_get_equiv ();
5347 if (tail == NULL)
5348 tail = eq;
5349
5350 eq->next = gfc_current_ns->equiv;
5351 gfc_current_ns->equiv = eq;
5352
5353 if (gfc_match_char ('(') != MATCH_YES)
5354 goto syntax;
5355
5356 set = eq;
5357 common_flag = FALSE;
5358 cnt = 0;
5359
5360 for (;;)
5361 {
5362 m = gfc_match_equiv_variable (&set->expr);
5363 if (m == MATCH_ERROR)
5364 goto cleanup;
5365 if (m == MATCH_NO)
5366 goto syntax;
5367
5368 /* count the number of objects. */
5369 cnt++;
5370
5371 if (gfc_match_char ('%') == MATCH_YES)
5372 {
5373 gfc_error ("Derived type component %C is not a "
5374 "permitted EQUIVALENCE member");
5375 goto cleanup;
5376 }
5377
5378 for (ref = set->expr->ref; ref; ref = ref->next)
5379 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
5380 {
5381 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
5382 "be an array section");
5383 goto cleanup;
5384 }
5385
5386 sym = set->expr->symtree->n.sym;
5387
5388 if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL))
5389 goto cleanup;
5390
5391 if (sym->attr.in_common)
5392 {
5393 common_flag = TRUE;
5394 common_head = sym->common_head;
5395 }
5396
5397 if (gfc_match_char (')') == MATCH_YES)
5398 break;
5399
5400 if (gfc_match_char (',') != MATCH_YES)
5401 goto syntax;
5402
5403 set->eq = gfc_get_equiv ();
5404 set = set->eq;
5405 }
5406
5407 if (cnt < 2)
5408 {
5409 gfc_error ("EQUIVALENCE at %C requires two or more objects");
5410 goto cleanup;
5411 }
5412
5413 /* If one of the members of an equivalence is in common, then
5414 mark them all as being in common. Before doing this, check
5415 that members of the equivalence group are not in different
5416 common blocks. */
5417 if (common_flag)
5418 for (set = eq; set; set = set->eq)
5419 {
5420 sym = set->expr->symtree->n.sym;
5421 if (sym->common_head && sym->common_head != common_head)
5422 {
5423 gfc_error ("Attempt to indirectly overlap COMMON "
5424 "blocks %s and %s by EQUIVALENCE at %C",
5425 sym->common_head->name, common_head->name);
5426 goto cleanup;
5427 }
5428 sym->attr.in_common = 1;
5429 sym->common_head = common_head;
5430 }
5431
5432 if (gfc_match_eos () == MATCH_YES)
5433 break;
5434 if (gfc_match_char (',') != MATCH_YES)
5435 {
5436 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
5437 goto cleanup;
5438 }
5439 }
5440
5441 return MATCH_YES;
5442
5443 syntax:
5444 gfc_syntax_error (ST_EQUIVALENCE);
5445
5446 cleanup:
5447 eq = tail->next;
5448 tail->next = NULL;
5449
5450 gfc_free_equiv (gfc_current_ns->equiv);
5451 gfc_current_ns->equiv = eq;
5452
5453 return MATCH_ERROR;
5454 }
5455
5456
5457 /* Check that a statement function is not recursive. This is done by looking
5458 for the statement function symbol(sym) by looking recursively through its
5459 expression(e). If a reference to sym is found, true is returned.
5460 12.5.4 requires that any variable of function that is implicitly typed
5461 shall have that type confirmed by any subsequent type declaration. The
5462 implicit typing is conveniently done here. */
5463 static bool
5464 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
5465
5466 static bool
5467 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
5468 {
5469
5470 if (e == NULL)
5471 return false;
5472
5473 switch (e->expr_type)
5474 {
5475 case EXPR_FUNCTION:
5476 if (e->symtree == NULL)
5477 return false;
5478
5479 /* Check the name before testing for nested recursion! */
5480 if (sym->name == e->symtree->n.sym->name)
5481 return true;
5482
5483 /* Catch recursion via other statement functions. */
5484 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
5485 && e->symtree->n.sym->value
5486 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
5487 return true;
5488
5489 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
5490 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
5491
5492 break;
5493
5494 case EXPR_VARIABLE:
5495 if (e->symtree && sym->name == e->symtree->n.sym->name)
5496 return true;
5497
5498 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
5499 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
5500 break;
5501
5502 default:
5503 break;
5504 }
5505
5506 return false;
5507 }
5508
5509
5510 static bool
5511 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
5512 {
5513 return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
5514 }
5515
5516
5517 /* Match a statement function declaration. It is so easy to match
5518 non-statement function statements with a MATCH_ERROR as opposed to
5519 MATCH_NO that we suppress error message in most cases. */
5520
5521 match
5522 gfc_match_st_function (void)
5523 {
5524 gfc_error_buffer old_error;
5525 gfc_symbol *sym;
5526 gfc_expr *expr;
5527 match m;
5528
5529 m = gfc_match_symbol (&sym, 0);
5530 if (m != MATCH_YES)
5531 return m;
5532
5533 gfc_push_error (&old_error);
5534
5535 if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL))
5536 goto undo_error;
5537
5538 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
5539 goto undo_error;
5540
5541 m = gfc_match (" = %e%t", &expr);
5542 if (m == MATCH_NO)
5543 goto undo_error;
5544
5545 gfc_free_error (&old_error);
5546
5547 if (m == MATCH_ERROR)
5548 return m;
5549
5550 if (recursive_stmt_fcn (expr, sym))
5551 {
5552 gfc_error ("Statement function at %L is recursive", &expr->where);
5553 return MATCH_ERROR;
5554 }
5555
5556 sym->value = expr;
5557
5558 if ((gfc_current_state () == COMP_FUNCTION
5559 || gfc_current_state () == COMP_SUBROUTINE)
5560 && gfc_state_stack->previous->state == COMP_INTERFACE)
5561 {
5562 gfc_error ("Statement function at %L cannot appear within an INTERFACE",
5563 &expr->where);
5564 return MATCH_ERROR;
5565 }
5566
5567 if (!gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C"))
5568 return MATCH_ERROR;
5569
5570 return MATCH_YES;
5571
5572 undo_error:
5573 gfc_pop_error (&old_error);
5574 return MATCH_NO;
5575 }
5576
5577
5578 /* Match an assignment to a pointer function (F2008). This could, in
5579 general be ambiguous with a statement function. In this implementation
5580 it remains so if it is the first statement after the specification
5581 block. */
5582
5583 match
5584 gfc_match_ptr_fcn_assign (void)
5585 {
5586 gfc_error_buffer old_error;
5587 locus old_loc;
5588 gfc_symbol *sym;
5589 gfc_expr *expr;
5590 match m;
5591 char name[GFC_MAX_SYMBOL_LEN + 1];
5592
5593 old_loc = gfc_current_locus;
5594 m = gfc_match_name (name);
5595 if (m != MATCH_YES)
5596 return m;
5597
5598 gfc_find_symbol (name, NULL, 1, &sym);
5599 if (sym && sym->attr.flavor != FL_PROCEDURE)
5600 return MATCH_NO;
5601
5602 gfc_push_error (&old_error);
5603
5604 if (sym && sym->attr.function)
5605 goto match_actual_arglist;
5606
5607 gfc_current_locus = old_loc;
5608 m = gfc_match_symbol (&sym, 0);
5609 if (m != MATCH_YES)
5610 return m;
5611
5612 if (!gfc_add_procedure (&sym->attr, PROC_UNKNOWN, sym->name, NULL))
5613 goto undo_error;
5614
5615 match_actual_arglist:
5616 gfc_current_locus = old_loc;
5617 m = gfc_match (" %e", &expr);
5618 if (m != MATCH_YES)
5619 goto undo_error;
5620
5621 new_st.op = EXEC_ASSIGN;
5622 new_st.expr1 = expr;
5623 expr = NULL;
5624
5625 m = gfc_match (" = %e%t", &expr);
5626 if (m != MATCH_YES)
5627 goto undo_error;
5628
5629 new_st.expr2 = expr;
5630 return MATCH_YES;
5631
5632 undo_error:
5633 gfc_pop_error (&old_error);
5634 return MATCH_NO;
5635 }
5636
5637
5638 /***************** SELECT CASE subroutines ******************/
5639
5640 /* Free a single case structure. */
5641
5642 static void
5643 free_case (gfc_case *p)
5644 {
5645 if (p->low == p->high)
5646 p->high = NULL;
5647 gfc_free_expr (p->low);
5648 gfc_free_expr (p->high);
5649 free (p);
5650 }
5651
5652
5653 /* Free a list of case structures. */
5654
5655 void
5656 gfc_free_case_list (gfc_case *p)
5657 {
5658 gfc_case *q;
5659
5660 for (; p; p = q)
5661 {
5662 q = p->next;
5663 free_case (p);
5664 }
5665 }
5666
5667
5668 /* Match a single case selector. Combining the requirements of F08:C830
5669 and F08:C832 (R838) means that the case-value must have either CHARACTER,
5670 INTEGER, or LOGICAL type. */
5671
5672 static match
5673 match_case_selector (gfc_case **cp)
5674 {
5675 gfc_case *c;
5676 match m;
5677
5678 c = gfc_get_case ();
5679 c->where = gfc_current_locus;
5680
5681 if (gfc_match_char (':') == MATCH_YES)
5682 {
5683 m = gfc_match_init_expr (&c->high);
5684 if (m == MATCH_NO)
5685 goto need_expr;
5686 if (m == MATCH_ERROR)
5687 goto cleanup;
5688
5689 if (c->high->ts.type != BT_LOGICAL && c->high->ts.type != BT_INTEGER
5690 && c->high->ts.type != BT_CHARACTER)
5691 {
5692 gfc_error ("Expression in CASE selector at %L cannot be %s",
5693 &c->high->where, gfc_typename (&c->high->ts));
5694 goto cleanup;
5695 }
5696 }
5697 else
5698 {
5699 m = gfc_match_init_expr (&c->low);
5700 if (m == MATCH_ERROR)
5701 goto cleanup;
5702 if (m == MATCH_NO)
5703 goto need_expr;
5704
5705 if (c->low->ts.type != BT_LOGICAL && c->low->ts.type != BT_INTEGER
5706 && c->low->ts.type != BT_CHARACTER)
5707 {
5708 gfc_error ("Expression in CASE selector at %L cannot be %s",
5709 &c->low->where, gfc_typename (&c->low->ts));
5710 goto cleanup;
5711 }
5712
5713 /* If we're not looking at a ':' now, make a range out of a single
5714 target. Else get the upper bound for the case range. */
5715 if (gfc_match_char (':') != MATCH_YES)
5716 c->high = c->low;
5717 else
5718 {
5719 m = gfc_match_init_expr (&c->high);
5720 if (m == MATCH_ERROR)
5721 goto cleanup;
5722 /* MATCH_NO is fine. It's OK if nothing is there! */
5723 }
5724 }
5725
5726 *cp = c;
5727 return MATCH_YES;
5728
5729 need_expr:
5730 gfc_error ("Expected initialization expression in CASE at %C");
5731
5732 cleanup:
5733 free_case (c);
5734 return MATCH_ERROR;
5735 }
5736
5737
5738 /* Match the end of a case statement. */
5739
5740 static match
5741 match_case_eos (void)
5742 {
5743 char name[GFC_MAX_SYMBOL_LEN + 1];
5744 match m;
5745
5746 if (gfc_match_eos () == MATCH_YES)
5747 return MATCH_YES;
5748
5749 /* If the case construct doesn't have a case-construct-name, we
5750 should have matched the EOS. */
5751 if (!gfc_current_block ())
5752 return MATCH_NO;
5753
5754 gfc_gobble_whitespace ();
5755
5756 m = gfc_match_name (name);
5757 if (m != MATCH_YES)
5758 return m;
5759
5760 if (strcmp (name, gfc_current_block ()->name) != 0)
5761 {
5762 gfc_error ("Expected block name %qs of SELECT construct at %C",
5763 gfc_current_block ()->name);
5764 return MATCH_ERROR;
5765 }
5766
5767 return gfc_match_eos ();
5768 }
5769
5770
5771 /* Match a SELECT statement. */
5772
5773 match
5774 gfc_match_select (void)
5775 {
5776 gfc_expr *expr;
5777 match m;
5778
5779 m = gfc_match_label ();
5780 if (m == MATCH_ERROR)
5781 return m;
5782
5783 m = gfc_match (" select case ( %e )%t", &expr);
5784 if (m != MATCH_YES)
5785 return m;
5786
5787 new_st.op = EXEC_SELECT;
5788 new_st.expr1 = expr;
5789
5790 return MATCH_YES;
5791 }
5792
5793
5794 /* Transfer the selector typespec to the associate name. */
5795
5796 static void
5797 copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
5798 {
5799 gfc_ref *ref;
5800 gfc_symbol *assoc_sym;
5801
5802 assoc_sym = associate->symtree->n.sym;
5803
5804 /* At this stage the expression rank and arrayspec dimensions have
5805 not been completely sorted out. We must get the expr2->rank
5806 right here, so that the correct class container is obtained. */
5807 ref = selector->ref;
5808 while (ref && ref->next)
5809 ref = ref->next;
5810
5811 if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as
5812 && ref && ref->type == REF_ARRAY)
5813 {
5814 /* Ensure that the array reference type is set. We cannot use
5815 gfc_resolve_expr at this point, so the usable parts of
5816 resolve.c(resolve_array_ref) are employed to do it. */
5817 if (ref->u.ar.type == AR_UNKNOWN)
5818 {
5819 ref->u.ar.type = AR_ELEMENT;
5820 for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
5821 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
5822 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR
5823 || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
5824 && ref->u.ar.start[i] && ref->u.ar.start[i]->rank))
5825 {
5826 ref->u.ar.type = AR_SECTION;
5827 break;
5828 }
5829 }
5830
5831 if (ref->u.ar.type == AR_FULL)
5832 selector->rank = CLASS_DATA (selector)->as->rank;
5833 else if (ref->u.ar.type == AR_SECTION)
5834 selector->rank = ref->u.ar.dimen;
5835 else
5836 selector->rank = 0;
5837 }
5838
5839 if (selector->rank)
5840 {
5841 assoc_sym->attr.dimension = 1;
5842 assoc_sym->as = gfc_get_array_spec ();
5843 assoc_sym->as->rank = selector->rank;
5844 assoc_sym->as->type = AS_DEFERRED;
5845 }
5846 else
5847 assoc_sym->as = NULL;
5848
5849 if (selector->ts.type == BT_CLASS)
5850 {
5851 /* The correct class container has to be available. */
5852 assoc_sym->ts.type = BT_CLASS;
5853 assoc_sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
5854 assoc_sym->attr.pointer = 1;
5855 gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
5856 }
5857 }
5858
5859
5860 /* Push the current selector onto the SELECT TYPE stack. */
5861
5862 static void
5863 select_type_push (gfc_symbol *sel)
5864 {
5865 gfc_select_type_stack *top = gfc_get_select_type_stack ();
5866 top->selector = sel;
5867 top->tmp = NULL;
5868 top->prev = select_type_stack;
5869
5870 select_type_stack = top;
5871 }
5872
5873
5874 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
5875
5876 static gfc_symtree *
5877 select_intrinsic_set_tmp (gfc_typespec *ts)
5878 {
5879 char name[GFC_MAX_SYMBOL_LEN];
5880 gfc_symtree *tmp;
5881 int charlen = 0;
5882
5883 if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
5884 return NULL;
5885
5886 if (select_type_stack->selector->ts.type == BT_CLASS
5887 && !select_type_stack->selector->attr.class_ok)
5888 return NULL;
5889
5890 if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
5891 && ts->u.cl->length->expr_type == EXPR_CONSTANT)
5892 charlen = mpz_get_si (ts->u.cl->length->value.integer);
5893
5894 if (ts->type != BT_CHARACTER)
5895 sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
5896 ts->kind);
5897 else
5898 sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (ts->type),
5899 charlen, ts->kind);
5900
5901 gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
5902 gfc_add_type (tmp->n.sym, ts, NULL);
5903
5904 /* Copy across the array spec to the selector. */
5905 if (select_type_stack->selector->ts.type == BT_CLASS
5906 && (CLASS_DATA (select_type_stack->selector)->attr.dimension
5907 || CLASS_DATA (select_type_stack->selector)->attr.codimension))
5908 {
5909 tmp->n.sym->attr.pointer = 1;
5910 tmp->n.sym->attr.dimension
5911 = CLASS_DATA (select_type_stack->selector)->attr.dimension;
5912 tmp->n.sym->attr.codimension
5913 = CLASS_DATA (select_type_stack->selector)->attr.codimension;
5914 tmp->n.sym->as
5915 = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
5916 }
5917
5918 gfc_set_sym_referenced (tmp->n.sym);
5919 gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
5920 tmp->n.sym->attr.select_type_temporary = 1;
5921
5922 return tmp;
5923 }
5924
5925
5926 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
5927
5928 static void
5929 select_type_set_tmp (gfc_typespec *ts)
5930 {
5931 char name[GFC_MAX_SYMBOL_LEN];
5932 gfc_symtree *tmp = NULL;
5933
5934 if (!ts)
5935 {
5936 select_type_stack->tmp = NULL;
5937 return;
5938 }
5939
5940 tmp = select_intrinsic_set_tmp (ts);
5941
5942 if (tmp == NULL)
5943 {
5944 if (!ts->u.derived)
5945 return;
5946
5947 if (ts->type == BT_CLASS)
5948 sprintf (name, "__tmp_class_%s", ts->u.derived->name);
5949 else
5950 sprintf (name, "__tmp_type_%s", ts->u.derived->name);
5951 gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
5952 gfc_add_type (tmp->n.sym, ts, NULL);
5953
5954 if (select_type_stack->selector->ts.type == BT_CLASS
5955 && select_type_stack->selector->attr.class_ok)
5956 {
5957 tmp->n.sym->attr.pointer
5958 = CLASS_DATA (select_type_stack->selector)->attr.class_pointer;
5959
5960 /* Copy across the array spec to the selector. */
5961 if (CLASS_DATA (select_type_stack->selector)->attr.dimension
5962 || CLASS_DATA (select_type_stack->selector)->attr.codimension)
5963 {
5964 tmp->n.sym->attr.dimension
5965 = CLASS_DATA (select_type_stack->selector)->attr.dimension;
5966 tmp->n.sym->attr.codimension
5967 = CLASS_DATA (select_type_stack->selector)->attr.codimension;
5968 tmp->n.sym->as
5969 = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
5970 }
5971 }
5972
5973 gfc_set_sym_referenced (tmp->n.sym);
5974 gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
5975 tmp->n.sym->attr.select_type_temporary = 1;
5976
5977 if (ts->type == BT_CLASS)
5978 gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
5979 &tmp->n.sym->as);
5980 }
5981
5982 /* Add an association for it, so the rest of the parser knows it is
5983 an associate-name. The target will be set during resolution. */
5984 tmp->n.sym->assoc = gfc_get_association_list ();
5985 tmp->n.sym->assoc->dangling = 1;
5986 tmp->n.sym->assoc->st = tmp;
5987
5988 select_type_stack->tmp = tmp;
5989 }
5990
5991
5992 /* Match a SELECT TYPE statement. */
5993
5994 match
5995 gfc_match_select_type (void)
5996 {
5997 gfc_expr *expr1, *expr2 = NULL;
5998 match m;
5999 char name[GFC_MAX_SYMBOL_LEN];
6000 bool class_array;
6001 gfc_symbol *sym;
6002 gfc_namespace *ns = gfc_current_ns;
6003
6004 m = gfc_match_label ();
6005 if (m == MATCH_ERROR)
6006 return m;
6007
6008 m = gfc_match (" select type ( ");
6009 if (m != MATCH_YES)
6010 return m;
6011
6012 gfc_current_ns = gfc_build_block_ns (ns);
6013 m = gfc_match (" %n => %e", name, &expr2);
6014 if (m == MATCH_YES)
6015 {
6016 expr1 = gfc_get_expr ();
6017 expr1->expr_type = EXPR_VARIABLE;
6018 expr1->where = expr2->where;
6019 if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
6020 {
6021 m = MATCH_ERROR;
6022 goto cleanup;
6023 }
6024
6025 sym = expr1->symtree->n.sym;
6026 if (expr2->ts.type == BT_UNKNOWN)
6027 sym->attr.untyped = 1;
6028 else
6029 copy_ts_from_selector_to_associate (expr1, expr2);
6030
6031 sym->attr.flavor = FL_VARIABLE;
6032 sym->attr.referenced = 1;
6033 sym->attr.class_ok = 1;
6034 }
6035 else
6036 {
6037 m = gfc_match (" %e ", &expr1);
6038 if (m != MATCH_YES)
6039 {
6040 std::swap (ns, gfc_current_ns);
6041 gfc_free_namespace (ns);
6042 return m;
6043 }
6044 }
6045
6046 m = gfc_match (" )%t");
6047 if (m != MATCH_YES)
6048 {
6049 gfc_error ("parse error in SELECT TYPE statement at %C");
6050 goto cleanup;
6051 }
6052
6053 /* This ghastly expression seems to be needed to distinguish a CLASS
6054 array, which can have a reference, from other expressions that
6055 have references, such as derived type components, and are not
6056 allowed by the standard.
6057 TODO: see if it is sufficient to exclude component and substring
6058 references. */
6059 class_array = (expr1->expr_type == EXPR_VARIABLE
6060 && expr1->ts.type == BT_CLASS
6061 && CLASS_DATA (expr1)
6062 && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0)
6063 && (CLASS_DATA (expr1)->attr.dimension
6064 || CLASS_DATA (expr1)->attr.codimension)
6065 && expr1->ref
6066 && expr1->ref->type == REF_ARRAY
6067 && expr1->ref->next == NULL);
6068
6069 /* Check for F03:C811. */
6070 if (!expr2 && (expr1->expr_type != EXPR_VARIABLE
6071 || (!class_array && expr1->ref != NULL)))
6072 {
6073 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
6074 "use associate-name=>");
6075 m = MATCH_ERROR;
6076 goto cleanup;
6077 }
6078
6079 new_st.op = EXEC_SELECT_TYPE;
6080 new_st.expr1 = expr1;
6081 new_st.expr2 = expr2;
6082 new_st.ext.block.ns = gfc_current_ns;
6083
6084 select_type_push (expr1->symtree->n.sym);
6085 gfc_current_ns = ns;
6086
6087 return MATCH_YES;
6088
6089 cleanup:
6090 gfc_free_expr (expr1);
6091 gfc_free_expr (expr2);
6092 gfc_undo_symbols ();
6093 std::swap (ns, gfc_current_ns);
6094 gfc_free_namespace (ns);
6095 return m;
6096 }
6097
6098
6099 /* Match a CASE statement. */
6100
6101 match
6102 gfc_match_case (void)
6103 {
6104 gfc_case *c, *head, *tail;
6105 match m;
6106
6107 head = tail = NULL;
6108
6109 if (gfc_current_state () != COMP_SELECT)
6110 {
6111 gfc_error ("Unexpected CASE statement at %C");
6112 return MATCH_ERROR;
6113 }
6114
6115 if (gfc_match ("% default") == MATCH_YES)
6116 {
6117 m = match_case_eos ();
6118 if (m == MATCH_NO)
6119 goto syntax;
6120 if (m == MATCH_ERROR)
6121 goto cleanup;
6122
6123 new_st.op = EXEC_SELECT;
6124 c = gfc_get_case ();
6125 c->where = gfc_current_locus;
6126 new_st.ext.block.case_list = c;
6127 return MATCH_YES;
6128 }
6129
6130 if (gfc_match_char ('(') != MATCH_YES)
6131 goto syntax;
6132
6133 for (;;)
6134 {
6135 if (match_case_selector (&c) == MATCH_ERROR)
6136 goto cleanup;
6137
6138 if (head == NULL)
6139 head = c;
6140 else
6141 tail->next = c;
6142
6143 tail = c;
6144
6145 if (gfc_match_char (')') == MATCH_YES)
6146 break;
6147 if (gfc_match_char (',') != MATCH_YES)
6148 goto syntax;
6149 }
6150
6151 m = match_case_eos ();
6152 if (m == MATCH_NO)
6153 goto syntax;
6154 if (m == MATCH_ERROR)
6155 goto cleanup;
6156
6157 new_st.op = EXEC_SELECT;
6158 new_st.ext.block.case_list = head;
6159
6160 return MATCH_YES;
6161
6162 syntax:
6163 gfc_error ("Syntax error in CASE specification at %C");
6164
6165 cleanup:
6166 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
6167 return MATCH_ERROR;
6168 }
6169
6170
6171 /* Match a TYPE IS statement. */
6172
6173 match
6174 gfc_match_type_is (void)
6175 {
6176 gfc_case *c = NULL;
6177 match m;
6178
6179 if (gfc_current_state () != COMP_SELECT_TYPE)
6180 {
6181 gfc_error ("Unexpected TYPE IS statement at %C");
6182 return MATCH_ERROR;
6183 }
6184
6185 if (gfc_match_char ('(') != MATCH_YES)
6186 goto syntax;
6187
6188 c = gfc_get_case ();
6189 c->where = gfc_current_locus;
6190
6191 m = gfc_match_type_spec (&c->ts);
6192 if (m == MATCH_NO)
6193 goto syntax;
6194 if (m == MATCH_ERROR)
6195 goto cleanup;
6196
6197 if (gfc_match_char (')') != MATCH_YES)
6198 goto syntax;
6199
6200 m = match_case_eos ();
6201 if (m == MATCH_NO)
6202 goto syntax;
6203 if (m == MATCH_ERROR)
6204 goto cleanup;
6205
6206 new_st.op = EXEC_SELECT_TYPE;
6207 new_st.ext.block.case_list = c;
6208
6209 if (c->ts.type == BT_DERIVED && c->ts.u.derived
6210 && (c->ts.u.derived->attr.sequence
6211 || c->ts.u.derived->attr.is_bind_c))
6212 {
6213 gfc_error ("The type-spec shall not specify a sequence derived "
6214 "type or a type with the BIND attribute in SELECT "
6215 "TYPE at %C [F2003:C815]");
6216 return MATCH_ERROR;
6217 }
6218
6219 if (c->ts.type == BT_DERIVED
6220 && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
6221 && gfc_spec_list_type (type_param_spec_list, c->ts.u.derived)
6222 != SPEC_ASSUMED)
6223 {
6224 gfc_error ("All the LEN type parameters in the TYPE IS statement "
6225 "at %C must be ASSUMED");
6226 return MATCH_ERROR;
6227 }
6228
6229 /* Create temporary variable. */
6230 select_type_set_tmp (&c->ts);
6231
6232 return MATCH_YES;
6233
6234 syntax:
6235 gfc_error ("Syntax error in TYPE IS specification at %C");
6236
6237 cleanup:
6238 if (c != NULL)
6239 gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
6240 return MATCH_ERROR;
6241 }
6242
6243
6244 /* Match a CLASS IS or CLASS DEFAULT statement. */
6245
6246 match
6247 gfc_match_class_is (void)
6248 {
6249 gfc_case *c = NULL;
6250 match m;
6251
6252 if (gfc_current_state () != COMP_SELECT_TYPE)
6253 return MATCH_NO;
6254
6255 if (gfc_match ("% default") == MATCH_YES)
6256 {
6257 m = match_case_eos ();
6258 if (m == MATCH_NO)
6259 goto syntax;
6260 if (m == MATCH_ERROR)
6261 goto cleanup;
6262
6263 new_st.op = EXEC_SELECT_TYPE;
6264 c = gfc_get_case ();
6265 c->where = gfc_current_locus;
6266 c->ts.type = BT_UNKNOWN;
6267 new_st.ext.block.case_list = c;
6268 select_type_set_tmp (NULL);
6269 return MATCH_YES;
6270 }
6271
6272 m = gfc_match ("% is");
6273 if (m == MATCH_NO)
6274 goto syntax;
6275 if (m == MATCH_ERROR)
6276 goto cleanup;
6277
6278 if (gfc_match_char ('(') != MATCH_YES)
6279 goto syntax;
6280
6281 c = gfc_get_case ();
6282 c->where = gfc_current_locus;
6283
6284 m = match_derived_type_spec (&c->ts);
6285 if (m == MATCH_NO)
6286 goto syntax;
6287 if (m == MATCH_ERROR)
6288 goto cleanup;
6289
6290 if (c->ts.type == BT_DERIVED)
6291 c->ts.type = BT_CLASS;
6292
6293 if (gfc_match_char (')') != MATCH_YES)
6294 goto syntax;
6295
6296 m = match_case_eos ();
6297 if (m == MATCH_NO)
6298 goto syntax;
6299 if (m == MATCH_ERROR)
6300 goto cleanup;
6301
6302 new_st.op = EXEC_SELECT_TYPE;
6303 new_st.ext.block.case_list = c;
6304
6305 /* Create temporary variable. */
6306 select_type_set_tmp (&c->ts);
6307
6308 return MATCH_YES;
6309
6310 syntax:
6311 gfc_error ("Syntax error in CLASS IS specification at %C");
6312
6313 cleanup:
6314 if (c != NULL)
6315 gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
6316 return MATCH_ERROR;
6317 }
6318
6319
6320 /********************* WHERE subroutines ********************/
6321
6322 /* Match the rest of a simple WHERE statement that follows an IF statement.
6323 */
6324
6325 static match
6326 match_simple_where (void)
6327 {
6328 gfc_expr *expr;
6329 gfc_code *c;
6330 match m;
6331
6332 m = gfc_match (" ( %e )", &expr);
6333 if (m != MATCH_YES)
6334 return m;
6335
6336 m = gfc_match_assignment ();
6337 if (m == MATCH_NO)
6338 goto syntax;
6339 if (m == MATCH_ERROR)
6340 goto cleanup;
6341
6342 if (gfc_match_eos () != MATCH_YES)
6343 goto syntax;
6344
6345 c = gfc_get_code (EXEC_WHERE);
6346 c->expr1 = expr;
6347
6348 c->next = XCNEW (gfc_code);
6349 *c->next = new_st;
6350 c->next->loc = gfc_current_locus;
6351 gfc_clear_new_st ();
6352
6353 new_st.op = EXEC_WHERE;
6354 new_st.block = c;
6355
6356 return MATCH_YES;
6357
6358 syntax:
6359 gfc_syntax_error (ST_WHERE);
6360
6361 cleanup:
6362 gfc_free_expr (expr);
6363 return MATCH_ERROR;
6364 }
6365
6366
6367 /* Match a WHERE statement. */
6368
6369 match
6370 gfc_match_where (gfc_statement *st)
6371 {
6372 gfc_expr *expr;
6373 match m0, m;
6374 gfc_code *c;
6375
6376 m0 = gfc_match_label ();
6377 if (m0 == MATCH_ERROR)
6378 return m0;
6379
6380 m = gfc_match (" where ( %e )", &expr);
6381 if (m != MATCH_YES)
6382 return m;
6383
6384 if (gfc_match_eos () == MATCH_YES)
6385 {
6386 *st = ST_WHERE_BLOCK;
6387 new_st.op = EXEC_WHERE;
6388 new_st.expr1 = expr;
6389 return MATCH_YES;
6390 }
6391
6392 m = gfc_match_assignment ();
6393 if (m == MATCH_NO)
6394 gfc_syntax_error (ST_WHERE);
6395
6396 if (m != MATCH_YES)
6397 {
6398 gfc_free_expr (expr);
6399 return MATCH_ERROR;
6400 }
6401
6402 /* We've got a simple WHERE statement. */
6403 *st = ST_WHERE;
6404 c = gfc_get_code (EXEC_WHERE);
6405 c->expr1 = expr;
6406
6407 /* Put in the assignment. It will not be processed by add_statement, so we
6408 need to copy the location here. */
6409
6410 c->next = XCNEW (gfc_code);
6411 *c->next = new_st;
6412 c->next->loc = gfc_current_locus;
6413 gfc_clear_new_st ();
6414
6415 new_st.op = EXEC_WHERE;
6416 new_st.block = c;
6417
6418 return MATCH_YES;
6419 }
6420
6421
6422 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
6423 new_st if successful. */
6424
6425 match
6426 gfc_match_elsewhere (void)
6427 {
6428 char name[GFC_MAX_SYMBOL_LEN + 1];
6429 gfc_expr *expr;
6430 match m;
6431
6432 if (gfc_current_state () != COMP_WHERE)
6433 {
6434 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
6435 return MATCH_ERROR;
6436 }
6437
6438 expr = NULL;
6439
6440 if (gfc_match_char ('(') == MATCH_YES)
6441 {
6442 m = gfc_match_expr (&expr);
6443 if (m == MATCH_NO)
6444 goto syntax;
6445 if (m == MATCH_ERROR)
6446 return MATCH_ERROR;
6447
6448 if (gfc_match_char (')') != MATCH_YES)
6449 goto syntax;
6450 }
6451
6452 if (gfc_match_eos () != MATCH_YES)
6453 {
6454 /* Only makes sense if we have a where-construct-name. */
6455 if (!gfc_current_block ())
6456 {
6457 m = MATCH_ERROR;
6458 goto cleanup;
6459 }
6460 /* Better be a name at this point. */
6461 m = gfc_match_name (name);
6462 if (m == MATCH_NO)
6463 goto syntax;
6464 if (m == MATCH_ERROR)
6465 goto cleanup;
6466
6467 if (gfc_match_eos () != MATCH_YES)
6468 goto syntax;
6469
6470 if (strcmp (name, gfc_current_block ()->name) != 0)
6471 {
6472 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
6473 name, gfc_current_block ()->name);
6474 goto cleanup;
6475 }
6476 }
6477
6478 new_st.op = EXEC_WHERE;
6479 new_st.expr1 = expr;
6480 return MATCH_YES;
6481
6482 syntax:
6483 gfc_syntax_error (ST_ELSEWHERE);
6484
6485 cleanup:
6486 gfc_free_expr (expr);
6487 return MATCH_ERROR;
6488 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org