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