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