projects / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
re PR fortran/39630 ([F03] Procedure Pointer Components)
[gcc.git] / gcc / fortran / match.c
1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
21
22 #include "config.h"
23 #include "system.h"
24 #include "flags.h"
25 #include "gfortran.h"
26 #include "match.h"
27 #include "parse.h"
28
29 int gfc_matching_procptr_assignment = 0;
30 bool gfc_matching_prefix = false;
31
32 /* For debugging and diagnostic purposes. Return the textual representation
33 of the intrinsic operator OP. */
34 const char *
35 gfc_op2string (gfc_intrinsic_op op)
36 {
37 switch (op)
38 {
39 case INTRINSIC_UPLUS:
40 case INTRINSIC_PLUS:
41 return "+";
42
43 case INTRINSIC_UMINUS:
44 case INTRINSIC_MINUS:
45 return "-";
46
47 case INTRINSIC_POWER:
48 return "**";
49 case INTRINSIC_CONCAT:
50 return "//";
51 case INTRINSIC_TIMES:
52 return "*";
53 case INTRINSIC_DIVIDE:
54 return "/";
55
56 case INTRINSIC_AND:
57 return ".and.";
58 case INTRINSIC_OR:
59 return ".or.";
60 case INTRINSIC_EQV:
61 return ".eqv.";
62 case INTRINSIC_NEQV:
63 return ".neqv.";
64
65 case INTRINSIC_EQ_OS:
66 return ".eq.";
67 case INTRINSIC_EQ:
68 return "==";
69 case INTRINSIC_NE_OS:
70 return ".ne.";
71 case INTRINSIC_NE:
72 return "/=";
73 case INTRINSIC_GE_OS:
74 return ".ge.";
75 case INTRINSIC_GE:
76 return ">=";
77 case INTRINSIC_LE_OS:
78 return ".le.";
79 case INTRINSIC_LE:
80 return "<=";
81 case INTRINSIC_LT_OS:
82 return ".lt.";
83 case INTRINSIC_LT:
84 return "<";
85 case INTRINSIC_GT_OS:
86 return ".gt.";
87 case INTRINSIC_GT:
88 return ">";
89 case INTRINSIC_NOT:
90 return ".not.";
91
92 case INTRINSIC_ASSIGN:
93 return "=";
94
95 case INTRINSIC_PARENTHESES:
96 return "parens";
97
98 default:
99 break;
100 }
101
102 gfc_internal_error ("gfc_op2string(): Bad code");
103 /* Not reached. */
104 }
105
106
107 /******************** Generic matching subroutines ************************/
108
109 /* This function scans the current statement counting the opened and closed
110 parenthesis to make sure they are balanced. */
111
112 match
113 gfc_match_parens (void)
114 {
115 locus old_loc, where;
116 int count, instring;
117 gfc_char_t c, quote;
118
119 old_loc = gfc_current_locus;
120 count = 0;
121 instring = 0;
122 quote = ' ';
123
124 for (;;)
125 {
126 c = gfc_next_char_literal (instring);
127 if (c == '\n')
128 break;
129 if (quote == ' ' && ((c == '\'') || (c == '"')))
130 {
131 quote = c;
132 instring = 1;
133 continue;
134 }
135 if (quote != ' ' && c == quote)
136 {
137 quote = ' ';
138 instring = 0;
139 continue;
140 }
141
142 if (c == '(' && quote == ' ')
143 {
144 count++;
145 where = gfc_current_locus;
146 }
147 if (c == ')' && quote == ' ')
148 {
149 count--;
150 where = gfc_current_locus;
151 }
152 }
153
154 gfc_current_locus = old_loc;
155
156 if (count > 0)
157 {
158 gfc_error ("Missing ')' in statement at or before %L", &where);
159 return MATCH_ERROR;
160 }
161 if (count < 0)
162 {
163 gfc_error ("Missing '(' in statement at or before %L", &where);
164 return MATCH_ERROR;
165 }
166
167 return MATCH_YES;
168 }
169
170
171 /* See if the next character is a special character that has
172 escaped by a \ via the -fbackslash option. */
173
174 match
175 gfc_match_special_char (gfc_char_t *res)
176 {
177 int len, i;
178 gfc_char_t c, n;
179 match m;
180
181 m = MATCH_YES;
182
183 switch ((c = gfc_next_char_literal (1)))
184 {
185 case 'a':
186 *res = '\a';
187 break;
188 case 'b':
189 *res = '\b';
190 break;
191 case 't':
192 *res = '\t';
193 break;
194 case 'f':
195 *res = '\f';
196 break;
197 case 'n':
198 *res = '\n';
199 break;
200 case 'r':
201 *res = '\r';
202 break;
203 case 'v':
204 *res = '\v';
205 break;
206 case '\\':
207 *res = '\\';
208 break;
209 case '0':
210 *res = '\0';
211 break;
212
213 case 'x':
214 case 'u':
215 case 'U':
216 /* Hexadecimal form of wide characters. */
217 len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8));
218 n = 0;
219 for (i = 0; i < len; i++)
220 {
221 char buf[2] = { '\0', '\0' };
222
223 c = gfc_next_char_literal (1);
224 if (!gfc_wide_fits_in_byte (c)
225 || !gfc_check_digit ((unsigned char) c, 16))
226 return MATCH_NO;
227
228 buf[0] = (unsigned char) c;
229 n = n << 4;
230 n += strtol (buf, NULL, 16);
231 }
232 *res = n;
233 break;
234
235 default:
236 /* Unknown backslash codes are simply not expanded. */
237 m = MATCH_NO;
238 break;
239 }
240
241 return m;
242 }
243
244
245 /* In free form, match at least one space. Always matches in fixed
246 form. */
247
248 match
249 gfc_match_space (void)
250 {
251 locus old_loc;
252 char c;
253
254 if (gfc_current_form == FORM_FIXED)
255 return MATCH_YES;
256
257 old_loc = gfc_current_locus;
258
259 c = gfc_next_ascii_char ();
260 if (!gfc_is_whitespace (c))
261 {
262 gfc_current_locus = old_loc;
263 return MATCH_NO;
264 }
265
266 gfc_gobble_whitespace ();
267
268 return MATCH_YES;
269 }
270
271
272 /* Match an end of statement. End of statement is optional
273 whitespace, followed by a ';' or '\n' or comment '!'. If a
274 semicolon is found, we continue to eat whitespace and semicolons. */
275
276 match
277 gfc_match_eos (void)
278 {
279 locus old_loc;
280 int flag;
281 char c;
282
283 flag = 0;
284
285 for (;;)
286 {
287 old_loc = gfc_current_locus;
288 gfc_gobble_whitespace ();
289
290 c = gfc_next_ascii_char ();
291 switch (c)
292 {
293 case '!':
294 do
295 {
296 c = gfc_next_ascii_char ();
297 }
298 while (c != '\n');
299
300 /* Fall through. */
301
302 case '\n':
303 return MATCH_YES;
304
305 case ';':
306 flag = 1;
307 continue;
308 }
309
310 break;
311 }
312
313 gfc_current_locus = old_loc;
314 return (flag) ? MATCH_YES : MATCH_NO;
315 }
316
317
318 /* Match a literal integer on the input, setting the value on
319 MATCH_YES. Literal ints occur in kind-parameters as well as
320 old-style character length specifications. If cnt is non-NULL it
321 will be set to the number of digits. */
322
323 match
324 gfc_match_small_literal_int (int *value, int *cnt)
325 {
326 locus old_loc;
327 char c;
328 int i, j;
329
330 old_loc = gfc_current_locus;
331
332 *value = -1;
333 gfc_gobble_whitespace ();
334 c = gfc_next_ascii_char ();
335 if (cnt)
336 *cnt = 0;
337
338 if (!ISDIGIT (c))
339 {
340 gfc_current_locus = old_loc;
341 return MATCH_NO;
342 }
343
344 i = c - '0';
345 j = 1;
346
347 for (;;)
348 {
349 old_loc = gfc_current_locus;
350 c = gfc_next_ascii_char ();
351
352 if (!ISDIGIT (c))
353 break;
354
355 i = 10 * i + c - '0';
356 j++;
357
358 if (i > 99999999)
359 {
360 gfc_error ("Integer too large at %C");
361 return MATCH_ERROR;
362 }
363 }
364
365 gfc_current_locus = old_loc;
366
367 *value = i;
368 if (cnt)
369 *cnt = j;
370 return MATCH_YES;
371 }
372
373
374 /* Match a small, constant integer expression, like in a kind
375 statement. On MATCH_YES, 'value' is set. */
376
377 match
378 gfc_match_small_int (int *value)
379 {
380 gfc_expr *expr;
381 const char *p;
382 match m;
383 int i;
384
385 m = gfc_match_expr (&expr);
386 if (m != MATCH_YES)
387 return m;
388
389 p = gfc_extract_int (expr, &i);
390 gfc_free_expr (expr);
391
392 if (p != NULL)
393 {
394 gfc_error (p);
395 m = MATCH_ERROR;
396 }
397
398 *value = i;
399 return m;
400 }
401
402
403 /* This function is the same as the gfc_match_small_int, except that
404 we're keeping the pointer to the expr. This function could just be
405 removed and the previously mentioned one modified, though all calls
406 to it would have to be modified then (and there were a number of
407 them). Return MATCH_ERROR if fail to extract the int; otherwise,
408 return the result of gfc_match_expr(). The expr (if any) that was
409 matched is returned in the parameter expr. */
410
411 match
412 gfc_match_small_int_expr (int *value, gfc_expr **expr)
413 {
414 const char *p;
415 match m;
416 int i;
417
418 m = gfc_match_expr (expr);
419 if (m != MATCH_YES)
420 return m;
421
422 p = gfc_extract_int (*expr, &i);
423
424 if (p != NULL)
425 {
426 gfc_error (p);
427 m = MATCH_ERROR;
428 }
429
430 *value = i;
431 return m;
432 }
433
434
435 /* Matches a statement label. Uses gfc_match_small_literal_int() to
436 do most of the work. */
437
438 match
439 gfc_match_st_label (gfc_st_label **label)
440 {
441 locus old_loc;
442 match m;
443 int i, cnt;
444
445 old_loc = gfc_current_locus;
446
447 m = gfc_match_small_literal_int (&i, &cnt);
448 if (m != MATCH_YES)
449 return m;
450
451 if (cnt > 5)
452 {
453 gfc_error ("Too many digits in statement label at %C");
454 goto cleanup;
455 }
456
457 if (i == 0)
458 {
459 gfc_error ("Statement label at %C is zero");
460 goto cleanup;
461 }
462
463 *label = gfc_get_st_label (i);
464 return MATCH_YES;
465
466 cleanup:
467
468 gfc_current_locus = old_loc;
469 return MATCH_ERROR;
470 }
471
472
473 /* Match and validate a label associated with a named IF, DO or SELECT
474 statement. If the symbol does not have the label attribute, we add
475 it. We also make sure the symbol does not refer to another
476 (active) block. A matched label is pointed to by gfc_new_block. */
477
478 match
479 gfc_match_label (void)
480 {
481 char name[GFC_MAX_SYMBOL_LEN + 1];
482 match m;
483
484 gfc_new_block = NULL;
485
486 m = gfc_match (" %n :", name);
487 if (m != MATCH_YES)
488 return m;
489
490 if (gfc_get_symbol (name, NULL, &gfc_new_block))
491 {
492 gfc_error ("Label name '%s' at %C is ambiguous", name);
493 return MATCH_ERROR;
494 }
495
496 if (gfc_new_block->attr.flavor == FL_LABEL)
497 {
498 gfc_error ("Duplicate construct label '%s' at %C", name);
499 return MATCH_ERROR;
500 }
501
502 if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
503 gfc_new_block->name, NULL) == FAILURE)
504 return MATCH_ERROR;
505
506 return MATCH_YES;
507 }
508
509
510 /* See if the current input looks like a name of some sort. Modifies
511 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
512 Note that options.c restricts max_identifier_length to not more
513 than GFC_MAX_SYMBOL_LEN. */
514
515 match
516 gfc_match_name (char *buffer)
517 {
518 locus old_loc;
519 int i;
520 char c;
521
522 old_loc = gfc_current_locus;
523 gfc_gobble_whitespace ();
524
525 c = gfc_next_ascii_char ();
526 if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore)))
527 {
528 if (gfc_error_flag_test() == 0 && c != '(')
529 gfc_error ("Invalid character in name at %C");
530 gfc_current_locus = old_loc;
531 return MATCH_NO;
532 }
533
534 i = 0;
535
536 do
537 {
538 buffer[i++] = c;
539
540 if (i > gfc_option.max_identifier_length)
541 {
542 gfc_error ("Name at %C is too long");
543 return MATCH_ERROR;
544 }
545
546 old_loc = gfc_current_locus;
547 c = gfc_next_ascii_char ();
548 }
549 while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));
550
551 if (c == '$' && !gfc_option.flag_dollar_ok)
552 {
553 gfc_error ("Invalid character '$' at %C. Use -fdollar-ok to allow it "
554 "as an extension");
555 return MATCH_ERROR;
556 }
557
558 buffer[i] = '\0';
559 gfc_current_locus = old_loc;
560
561 return MATCH_YES;
562 }
563
564
565 /* Match a valid name for C, which is almost the same as for Fortran,
566 except that you can start with an underscore, etc.. It could have
567 been done by modifying the gfc_match_name, but this way other
568 things C allows can be added, such as no limits on the length.
569 Right now, the length is limited to the same thing as Fortran..
570 Also, by rewriting it, we use the gfc_next_char_C() to prevent the
571 input characters from being automatically lower cased, since C is
572 case sensitive. The parameter, buffer, is used to return the name
573 that is matched. Return MATCH_ERROR if the name is too long
574 (though this is a self-imposed limit), MATCH_NO if what we're
575 seeing isn't a name, and MATCH_YES if we successfully match a C
576 name. */
577
578 match
579 gfc_match_name_C (char *buffer)
580 {
581 locus old_loc;
582 int i = 0;
583 gfc_char_t c;
584
585 old_loc = gfc_current_locus;
586 gfc_gobble_whitespace ();
587
588 /* Get the next char (first possible char of name) and see if
589 it's valid for C (either a letter or an underscore). */
590 c = gfc_next_char_literal (1);
591
592 /* If the user put nothing expect spaces between the quotes, it is valid
593 and simply means there is no name= specifier and the name is the fortran
594 symbol name, all lowercase. */
595 if (c == '"' || c == '\'')
596 {
597 buffer[0] = '\0';
598 gfc_current_locus = old_loc;
599 return MATCH_YES;
600 }
601
602 if (!ISALPHA (c) && c != '_')
603 {
604 gfc_error ("Invalid C name in NAME= specifier at %C");
605 return MATCH_ERROR;
606 }
607
608 /* Continue to read valid variable name characters. */
609 do
610 {
611 gcc_assert (gfc_wide_fits_in_byte (c));
612
613 buffer[i++] = (unsigned char) c;
614
615 /* C does not define a maximum length of variable names, to my
616 knowledge, but the compiler typically places a limit on them.
617 For now, i'll use the same as the fortran limit for simplicity,
618 but this may need to be changed to a dynamic buffer that can
619 be realloc'ed here if necessary, or more likely, a larger
620 upper-bound set. */
621 if (i > gfc_option.max_identifier_length)
622 {
623 gfc_error ("Name at %C is too long");
624 return MATCH_ERROR;
625 }
626
627 old_loc = gfc_current_locus;
628
629 /* Get next char; param means we're in a string. */
630 c = gfc_next_char_literal (1);
631 } while (ISALNUM (c) || c == '_');
632
633 buffer[i] = '\0';
634 gfc_current_locus = old_loc;
635
636 /* See if we stopped because of whitespace. */
637 if (c == ' ')
638 {
639 gfc_gobble_whitespace ();
640 c = gfc_peek_ascii_char ();
641 if (c != '"' && c != '\'')
642 {
643 gfc_error ("Embedded space in NAME= specifier at %C");
644 return MATCH_ERROR;
645 }
646 }
647
648 /* If we stopped because we had an invalid character for a C name, report
649 that to the user by returning MATCH_NO. */
650 if (c != '"' && c != '\'')
651 {
652 gfc_error ("Invalid C name in NAME= specifier at %C");
653 return MATCH_ERROR;
654 }
655
656 return MATCH_YES;
657 }
658
659
660 /* Match a symbol on the input. Modifies the pointer to the symbol
661 pointer if successful. */
662
663 match
664 gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
665 {
666 char buffer[GFC_MAX_SYMBOL_LEN + 1];
667 match m;
668
669 m = gfc_match_name (buffer);
670 if (m != MATCH_YES)
671 return m;
672
673 if (host_assoc)
674 return (gfc_get_ha_sym_tree (buffer, matched_symbol))
675 ? MATCH_ERROR : MATCH_YES;
676
677 if (gfc_get_sym_tree (buffer, NULL, matched_symbol))
678 return MATCH_ERROR;
679
680 return MATCH_YES;
681 }
682
683
684 match
685 gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
686 {
687 gfc_symtree *st;
688 match m;
689
690 m = gfc_match_sym_tree (&st, host_assoc);
691
692 if (m == MATCH_YES)
693 {
694 if (st)
695 *matched_symbol = st->n.sym;
696 else
697 *matched_symbol = NULL;
698 }
699 else
700 *matched_symbol = NULL;
701 return m;
702 }
703
704
705 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
706 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
707 in matchexp.c. */
708
709 match
710 gfc_match_intrinsic_op (gfc_intrinsic_op *result)
711 {
712 locus orig_loc = gfc_current_locus;
713 char ch;
714
715 gfc_gobble_whitespace ();
716 ch = gfc_next_ascii_char ();
717 switch (ch)
718 {
719 case '+':
720 /* Matched "+". */
721 *result = INTRINSIC_PLUS;
722 return MATCH_YES;
723
724 case '-':
725 /* Matched "-". */
726 *result = INTRINSIC_MINUS;
727 return MATCH_YES;
728
729 case '=':
730 if (gfc_next_ascii_char () == '=')
731 {
732 /* Matched "==". */
733 *result = INTRINSIC_EQ;
734 return MATCH_YES;
735 }
736 break;
737
738 case '<':
739 if (gfc_peek_ascii_char () == '=')
740 {
741 /* Matched "<=". */
742 gfc_next_ascii_char ();
743 *result = INTRINSIC_LE;
744 return MATCH_YES;
745 }
746 /* Matched "<". */
747 *result = INTRINSIC_LT;
748 return MATCH_YES;
749
750 case '>':
751 if (gfc_peek_ascii_char () == '=')
752 {
753 /* Matched ">=". */
754 gfc_next_ascii_char ();
755 *result = INTRINSIC_GE;
756 return MATCH_YES;
757 }
758 /* Matched ">". */
759 *result = INTRINSIC_GT;
760 return MATCH_YES;
761
762 case '*':
763 if (gfc_peek_ascii_char () == '*')
764 {
765 /* Matched "**". */
766 gfc_next_ascii_char ();
767 *result = INTRINSIC_POWER;
768 return MATCH_YES;
769 }
770 /* Matched "*". */
771 *result = INTRINSIC_TIMES;
772 return MATCH_YES;
773
774 case '/':
775 ch = gfc_peek_ascii_char ();
776 if (ch == '=')
777 {
778 /* Matched "/=". */
779 gfc_next_ascii_char ();
780 *result = INTRINSIC_NE;
781 return MATCH_YES;
782 }
783 else if (ch == '/')
784 {
785 /* Matched "//". */
786 gfc_next_ascii_char ();
787 *result = INTRINSIC_CONCAT;
788 return MATCH_YES;
789 }
790 /* Matched "/". */
791 *result = INTRINSIC_DIVIDE;
792 return MATCH_YES;
793
794 case '.':
795 ch = gfc_next_ascii_char ();
796 switch (ch)
797 {
798 case 'a':
799 if (gfc_next_ascii_char () == 'n'
800 && gfc_next_ascii_char () == 'd'
801 && gfc_next_ascii_char () == '.')
802 {
803 /* Matched ".and.". */
804 *result = INTRINSIC_AND;
805 return MATCH_YES;
806 }
807 break;
808
809 case 'e':
810 if (gfc_next_ascii_char () == 'q')
811 {
812 ch = gfc_next_ascii_char ();
813 if (ch == '.')
814 {
815 /* Matched ".eq.". */
816 *result = INTRINSIC_EQ_OS;
817 return MATCH_YES;
818 }
819 else if (ch == 'v')
820 {
821 if (gfc_next_ascii_char () == '.')
822 {
823 /* Matched ".eqv.". */
824 *result = INTRINSIC_EQV;
825 return MATCH_YES;
826 }
827 }
828 }
829 break;
830
831 case 'g':
832 ch = gfc_next_ascii_char ();
833 if (ch == 'e')
834 {
835 if (gfc_next_ascii_char () == '.')
836 {
837 /* Matched ".ge.". */
838 *result = INTRINSIC_GE_OS;
839 return MATCH_YES;
840 }
841 }
842 else if (ch == 't')
843 {
844 if (gfc_next_ascii_char () == '.')
845 {
846 /* Matched ".gt.". */
847 *result = INTRINSIC_GT_OS;
848 return MATCH_YES;
849 }
850 }
851 break;
852
853 case 'l':
854 ch = gfc_next_ascii_char ();
855 if (ch == 'e')
856 {
857 if (gfc_next_ascii_char () == '.')
858 {
859 /* Matched ".le.". */
860 *result = INTRINSIC_LE_OS;
861 return MATCH_YES;
862 }
863 }
864 else if (ch == 't')
865 {
866 if (gfc_next_ascii_char () == '.')
867 {
868 /* Matched ".lt.". */
869 *result = INTRINSIC_LT_OS;
870 return MATCH_YES;
871 }
872 }
873 break;
874
875 case 'n':
876 ch = gfc_next_ascii_char ();
877 if (ch == 'e')
878 {
879 ch = gfc_next_ascii_char ();
880 if (ch == '.')
881 {
882 /* Matched ".ne.". */
883 *result = INTRINSIC_NE_OS;
884 return MATCH_YES;
885 }
886 else if (ch == 'q')
887 {
888 if (gfc_next_ascii_char () == 'v'
889 && gfc_next_ascii_char () == '.')
890 {
891 /* Matched ".neqv.". */
892 *result = INTRINSIC_NEQV;
893 return MATCH_YES;
894 }
895 }
896 }
897 else if (ch == 'o')
898 {
899 if (gfc_next_ascii_char () == 't'
900 && gfc_next_ascii_char () == '.')
901 {
902 /* Matched ".not.". */
903 *result = INTRINSIC_NOT;
904 return MATCH_YES;
905 }
906 }
907 break;
908
909 case 'o':
910 if (gfc_next_ascii_char () == 'r'
911 && gfc_next_ascii_char () == '.')
912 {
913 /* Matched ".or.". */
914 *result = INTRINSIC_OR;
915 return MATCH_YES;
916 }
917 break;
918
919 default:
920 break;
921 }
922 break;
923
924 default:
925 break;
926 }
927
928 gfc_current_locus = orig_loc;
929 return MATCH_NO;
930 }
931
932
933 /* Match a loop control phrase:
934
935 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
936
937 If the final integer expression is not present, a constant unity
938 expression is returned. We don't return MATCH_ERROR until after
939 the equals sign is seen. */
940
941 match
942 gfc_match_iterator (gfc_iterator *iter, int init_flag)
943 {
944 char name[GFC_MAX_SYMBOL_LEN + 1];
945 gfc_expr *var, *e1, *e2, *e3;
946 locus start;
947 match m;
948
949 /* Match the start of an iterator without affecting the symbol table. */
950
951 start = gfc_current_locus;
952 m = gfc_match (" %n =", name);
953 gfc_current_locus = start;
954
955 if (m != MATCH_YES)
956 return MATCH_NO;
957
958 m = gfc_match_variable (&var, 0);
959 if (m != MATCH_YES)
960 return MATCH_NO;
961
962 gfc_match_char ('=');
963
964 e1 = e2 = e3 = NULL;
965
966 if (var->ref != NULL)
967 {
968 gfc_error ("Loop variable at %C cannot be a sub-component");
969 goto cleanup;
970 }
971
972 if (var->symtree->n.sym->attr.intent == INTENT_IN)
973 {
974 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
975 var->symtree->n.sym->name);
976 goto cleanup;
977 }
978
979 var->symtree->n.sym->attr.implied_index = 1;
980
981 m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
982 if (m == MATCH_NO)
983 goto syntax;
984 if (m == MATCH_ERROR)
985 goto cleanup;
986
987 if (gfc_match_char (',') != MATCH_YES)
988 goto syntax;
989
990 m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
991 if (m == MATCH_NO)
992 goto syntax;
993 if (m == MATCH_ERROR)
994 goto cleanup;
995
996 if (gfc_match_char (',') != MATCH_YES)
997 {
998 e3 = gfc_int_expr (1);
999 goto done;
1000 }
1001
1002 m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
1003 if (m == MATCH_ERROR)
1004 goto cleanup;
1005 if (m == MATCH_NO)
1006 {
1007 gfc_error ("Expected a step value in iterator at %C");
1008 goto cleanup;
1009 }
1010
1011 done:
1012 iter->var = var;
1013 iter->start = e1;
1014 iter->end = e2;
1015 iter->step = e3;
1016 return MATCH_YES;
1017
1018 syntax:
1019 gfc_error ("Syntax error in iterator at %C");
1020
1021 cleanup:
1022 gfc_free_expr (e1);
1023 gfc_free_expr (e2);
1024 gfc_free_expr (e3);
1025
1026 return MATCH_ERROR;
1027 }
1028
1029
1030 /* Tries to match the next non-whitespace character on the input.
1031 This subroutine does not return MATCH_ERROR. */
1032
1033 match
1034 gfc_match_char (char c)
1035 {
1036 locus where;
1037
1038 where = gfc_current_locus;
1039 gfc_gobble_whitespace ();
1040
1041 if (gfc_next_ascii_char () == c)
1042 return MATCH_YES;
1043
1044 gfc_current_locus = where;
1045 return MATCH_NO;
1046 }
1047
1048
1049 /* General purpose matching subroutine. The target string is a
1050 scanf-like format string in which spaces correspond to arbitrary
1051 whitespace (including no whitespace), characters correspond to
1052 themselves. The %-codes are:
1053
1054 %% Literal percent sign
1055 %e Expression, pointer to a pointer is set
1056 %s Symbol, pointer to the symbol is set
1057 %n Name, character buffer is set to name
1058 %t Matches end of statement.
1059 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1060 %l Matches a statement label
1061 %v Matches a variable expression (an lvalue)
1062 % Matches a required space (in free form) and optional spaces. */
1063
1064 match
1065 gfc_match (const char *target, ...)
1066 {
1067 gfc_st_label **label;
1068 int matches, *ip;
1069 locus old_loc;
1070 va_list argp;
1071 char c, *np;
1072 match m, n;
1073 void **vp;
1074 const char *p;
1075
1076 old_loc = gfc_current_locus;
1077 va_start (argp, target);
1078 m = MATCH_NO;
1079 matches = 0;
1080 p = target;
1081
1082 loop:
1083 c = *p++;
1084 switch (c)
1085 {
1086 case ' ':
1087 gfc_gobble_whitespace ();
1088 goto loop;
1089 case '\0':
1090 m = MATCH_YES;
1091 break;
1092
1093 case '%':
1094 c = *p++;
1095 switch (c)
1096 {
1097 case 'e':
1098 vp = va_arg (argp, void **);
1099 n = gfc_match_expr ((gfc_expr **) vp);
1100 if (n != MATCH_YES)
1101 {
1102 m = n;
1103 goto not_yes;
1104 }
1105
1106 matches++;
1107 goto loop;
1108
1109 case 'v':
1110 vp = va_arg (argp, void **);
1111 n = gfc_match_variable ((gfc_expr **) vp, 0);
1112 if (n != MATCH_YES)
1113 {
1114 m = n;
1115 goto not_yes;
1116 }
1117
1118 matches++;
1119 goto loop;
1120
1121 case 's':
1122 vp = va_arg (argp, void **);
1123 n = gfc_match_symbol ((gfc_symbol **) vp, 0);
1124 if (n != MATCH_YES)
1125 {
1126 m = n;
1127 goto not_yes;
1128 }
1129
1130 matches++;
1131 goto loop;
1132
1133 case 'n':
1134 np = va_arg (argp, char *);
1135 n = gfc_match_name (np);
1136 if (n != MATCH_YES)
1137 {
1138 m = n;
1139 goto not_yes;
1140 }
1141
1142 matches++;
1143 goto loop;
1144
1145 case 'l':
1146 label = va_arg (argp, gfc_st_label **);
1147 n = gfc_match_st_label (label);
1148 if (n != MATCH_YES)
1149 {
1150 m = n;
1151 goto not_yes;
1152 }
1153
1154 matches++;
1155 goto loop;
1156
1157 case 'o':
1158 ip = va_arg (argp, int *);
1159 n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
1160 if (n != MATCH_YES)
1161 {
1162 m = n;
1163 goto not_yes;
1164 }
1165
1166 matches++;
1167 goto loop;
1168
1169 case 't':
1170 if (gfc_match_eos () != MATCH_YES)
1171 {
1172 m = MATCH_NO;
1173 goto not_yes;
1174 }
1175 goto loop;
1176
1177 case ' ':
1178 if (gfc_match_space () == MATCH_YES)
1179 goto loop;
1180 m = MATCH_NO;
1181 goto not_yes;
1182
1183 case '%':
1184 break; /* Fall through to character matcher. */
1185
1186 default:
1187 gfc_internal_error ("gfc_match(): Bad match code %c", c);
1188 }
1189
1190 default:
1191
1192 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1193 expect an upper case character here! */
1194 gcc_assert (TOLOWER (c) == c);
1195
1196 if (c == gfc_next_ascii_char ())
1197 goto loop;
1198 break;
1199 }
1200
1201 not_yes:
1202 va_end (argp);
1203
1204 if (m != MATCH_YES)
1205 {
1206 /* Clean up after a failed match. */
1207 gfc_current_locus = old_loc;
1208 va_start (argp, target);
1209
1210 p = target;
1211 for (; matches > 0; matches--)
1212 {
1213 while (*p++ != '%');
1214
1215 switch (*p++)
1216 {
1217 case '%':
1218 matches++;
1219 break; /* Skip. */
1220
1221 /* Matches that don't have to be undone */
1222 case 'o':
1223 case 'l':
1224 case 'n':
1225 case 's':
1226 (void) va_arg (argp, void **);
1227 break;
1228
1229 case 'e':
1230 case 'v':
1231 vp = va_arg (argp, void **);
1232 gfc_free_expr ((struct gfc_expr *)*vp);
1233 *vp = NULL;
1234 break;
1235 }
1236 }
1237
1238 va_end (argp);
1239 }
1240
1241 return m;
1242 }
1243
1244
1245 /*********************** Statement level matching **********************/
1246
1247 /* Matches the start of a program unit, which is the program keyword
1248 followed by an obligatory symbol. */
1249
1250 match
1251 gfc_match_program (void)
1252 {
1253 gfc_symbol *sym;
1254 match m;
1255
1256 m = gfc_match ("% %s%t", &sym);
1257
1258 if (m == MATCH_NO)
1259 {
1260 gfc_error ("Invalid form of PROGRAM statement at %C");
1261 m = MATCH_ERROR;
1262 }
1263
1264 if (m == MATCH_ERROR)
1265 return m;
1266
1267 if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
1268 return MATCH_ERROR;
1269
1270 gfc_new_block = sym;
1271
1272 return MATCH_YES;
1273 }
1274
1275
1276 /* Match a simple assignment statement. */
1277
1278 match
1279 gfc_match_assignment (void)
1280 {
1281 gfc_expr *lvalue, *rvalue;
1282 locus old_loc;
1283 match m;
1284
1285 old_loc = gfc_current_locus;
1286
1287 lvalue = NULL;
1288 m = gfc_match (" %v =", &lvalue);
1289 if (m != MATCH_YES)
1290 {
1291 gfc_current_locus = old_loc;
1292 gfc_free_expr (lvalue);
1293 return MATCH_NO;
1294 }
1295
1296 rvalue = NULL;
1297 m = gfc_match (" %e%t", &rvalue);
1298 if (m != MATCH_YES)
1299 {
1300 gfc_current_locus = old_loc;
1301 gfc_free_expr (lvalue);
1302 gfc_free_expr (rvalue);
1303 return m;
1304 }
1305
1306 gfc_set_sym_referenced (lvalue->symtree->n.sym);
1307
1308 new_st.op = EXEC_ASSIGN;
1309 new_st.expr = lvalue;
1310 new_st.expr2 = rvalue;
1311
1312 gfc_check_do_variable (lvalue->symtree);
1313
1314 return MATCH_YES;
1315 }
1316
1317
1318 /* Match a pointer assignment statement. */
1319
1320 match
1321 gfc_match_pointer_assignment (void)
1322 {
1323 gfc_expr *lvalue, *rvalue;
1324 locus old_loc;
1325 match m;
1326
1327 old_loc = gfc_current_locus;
1328
1329 lvalue = rvalue = NULL;
1330 gfc_matching_procptr_assignment = 0;
1331
1332 m = gfc_match (" %v =>", &lvalue);
1333 if (m != MATCH_YES)
1334 {
1335 m = MATCH_NO;
1336 goto cleanup;
1337 }
1338
1339 if (lvalue->symtree->n.sym->attr.proc_pointer
1340 || is_proc_ptr_comp (lvalue, NULL))
1341 gfc_matching_procptr_assignment = 1;
1342
1343 m = gfc_match (" %e%t", &rvalue);
1344 gfc_matching_procptr_assignment = 0;
1345 if (m != MATCH_YES)
1346 goto cleanup;
1347
1348 new_st.op = EXEC_POINTER_ASSIGN;
1349 new_st.expr = lvalue;
1350 new_st.expr2 = rvalue;
1351
1352 return MATCH_YES;
1353
1354 cleanup:
1355 gfc_current_locus = old_loc;
1356 gfc_free_expr (lvalue);
1357 gfc_free_expr (rvalue);
1358 return m;
1359 }
1360
1361
1362 /* We try to match an easy arithmetic IF statement. This only happens
1363 when just after having encountered a simple IF statement. This code
1364 is really duplicate with parts of the gfc_match_if code, but this is
1365 *much* easier. */
1366
1367 static match
1368 match_arithmetic_if (void)
1369 {
1370 gfc_st_label *l1, *l2, *l3;
1371 gfc_expr *expr;
1372 match m;
1373
1374 m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
1375 if (m != MATCH_YES)
1376 return m;
1377
1378 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1379 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1380 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1381 {
1382 gfc_free_expr (expr);
1383 return MATCH_ERROR;
1384 }
1385
1386 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF statement "
1387 "at %C") == FAILURE)
1388 return MATCH_ERROR;
1389
1390 new_st.op = EXEC_ARITHMETIC_IF;
1391 new_st.expr = expr;
1392 new_st.label = l1;
1393 new_st.label2 = l2;
1394 new_st.label3 = l3;
1395
1396 return MATCH_YES;
1397 }
1398
1399
1400 /* The IF statement is a bit of a pain. First of all, there are three
1401 forms of it, the simple IF, the IF that starts a block and the
1402 arithmetic IF.
1403
1404 There is a problem with the simple IF and that is the fact that we
1405 only have a single level of undo information on symbols. What this
1406 means is for a simple IF, we must re-match the whole IF statement
1407 multiple times in order to guarantee that the symbol table ends up
1408 in the proper state. */
1409
1410 static match match_simple_forall (void);
1411 static match match_simple_where (void);
1412
1413 match
1414 gfc_match_if (gfc_statement *if_type)
1415 {
1416 gfc_expr *expr;
1417 gfc_st_label *l1, *l2, *l3;
1418 locus old_loc, old_loc2;
1419 gfc_code *p;
1420 match m, n;
1421
1422 n = gfc_match_label ();
1423 if (n == MATCH_ERROR)
1424 return n;
1425
1426 old_loc = gfc_current_locus;
1427
1428 m = gfc_match (" if ( %e", &expr);
1429 if (m != MATCH_YES)
1430 return m;
1431
1432 old_loc2 = gfc_current_locus;
1433 gfc_current_locus = old_loc;
1434
1435 if (gfc_match_parens () == MATCH_ERROR)
1436 return MATCH_ERROR;
1437
1438 gfc_current_locus = old_loc2;
1439
1440 if (gfc_match_char (')') != MATCH_YES)
1441 {
1442 gfc_error ("Syntax error in IF-expression at %C");
1443 gfc_free_expr (expr);
1444 return MATCH_ERROR;
1445 }
1446
1447 m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
1448
1449 if (m == MATCH_YES)
1450 {
1451 if (n == MATCH_YES)
1452 {
1453 gfc_error ("Block label not appropriate for arithmetic IF "
1454 "statement at %C");
1455 gfc_free_expr (expr);
1456 return MATCH_ERROR;
1457 }
1458
1459 if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1460 || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1461 || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1462 {
1463 gfc_free_expr (expr);
1464 return MATCH_ERROR;
1465 }
1466
1467 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF "
1468 "statement at %C") == FAILURE)
1469 return MATCH_ERROR;
1470
1471 new_st.op = EXEC_ARITHMETIC_IF;
1472 new_st.expr = expr;
1473 new_st.label = l1;
1474 new_st.label2 = l2;
1475 new_st.label3 = l3;
1476
1477 *if_type = ST_ARITHMETIC_IF;
1478 return MATCH_YES;
1479 }
1480
1481 if (gfc_match (" then%t") == MATCH_YES)
1482 {
1483 new_st.op = EXEC_IF;
1484 new_st.expr = expr;
1485 *if_type = ST_IF_BLOCK;
1486 return MATCH_YES;
1487 }
1488
1489 if (n == MATCH_YES)
1490 {
1491 gfc_error ("Block label is not appropriate for IF statement at %C");
1492 gfc_free_expr (expr);
1493 return MATCH_ERROR;
1494 }
1495
1496 /* At this point the only thing left is a simple IF statement. At
1497 this point, n has to be MATCH_NO, so we don't have to worry about
1498 re-matching a block label. From what we've got so far, try
1499 matching an assignment. */
1500
1501 *if_type = ST_SIMPLE_IF;
1502
1503 m = gfc_match_assignment ();
1504 if (m == MATCH_YES)
1505 goto got_match;
1506
1507 gfc_free_expr (expr);
1508 gfc_undo_symbols ();
1509 gfc_current_locus = old_loc;
1510
1511 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1512 assignment was found. For MATCH_NO, continue to call the various
1513 matchers. */
1514 if (m == MATCH_ERROR)
1515 return MATCH_ERROR;
1516
1517 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
1518
1519 m = gfc_match_pointer_assignment ();
1520 if (m == MATCH_YES)
1521 goto got_match;
1522
1523 gfc_free_expr (expr);
1524 gfc_undo_symbols ();
1525 gfc_current_locus = old_loc;
1526
1527 gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
1528
1529 /* Look at the next keyword to see which matcher to call. Matching
1530 the keyword doesn't affect the symbol table, so we don't have to
1531 restore between tries. */
1532
1533 #define match(string, subr, statement) \
1534 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1535
1536 gfc_clear_error ();
1537
1538 match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1539 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1540 match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1541 match ("call", gfc_match_call, ST_CALL)
1542 match ("close", gfc_match_close, ST_CLOSE)
1543 match ("continue", gfc_match_continue, ST_CONTINUE)
1544 match ("cycle", gfc_match_cycle, ST_CYCLE)
1545 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1546 match ("end file", gfc_match_endfile, ST_END_FILE)
1547 match ("exit", gfc_match_exit, ST_EXIT)
1548 match ("flush", gfc_match_flush, ST_FLUSH)
1549 match ("forall", match_simple_forall, ST_FORALL)
1550 match ("go to", gfc_match_goto, ST_GOTO)
1551 match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1552 match ("inquire", gfc_match_inquire, ST_INQUIRE)
1553 match ("nullify", gfc_match_nullify, ST_NULLIFY)
1554 match ("open", gfc_match_open, ST_OPEN)
1555 match ("pause", gfc_match_pause, ST_NONE)
1556 match ("print", gfc_match_print, ST_WRITE)
1557 match ("read", gfc_match_read, ST_READ)
1558 match ("return", gfc_match_return, ST_RETURN)
1559 match ("rewind", gfc_match_rewind, ST_REWIND)
1560 match ("stop", gfc_match_stop, ST_STOP)
1561 match ("wait", gfc_match_wait, ST_WAIT)
1562 match ("where", match_simple_where, ST_WHERE)
1563 match ("write", gfc_match_write, ST_WRITE)
1564
1565 /* The gfc_match_assignment() above may have returned a MATCH_NO
1566 where the assignment was to a named constant. Check that
1567 special case here. */
1568 m = gfc_match_assignment ();
1569 if (m == MATCH_NO)
1570 {
1571 gfc_error ("Cannot assign to a named constant at %C");
1572 gfc_free_expr (expr);
1573 gfc_undo_symbols ();
1574 gfc_current_locus = old_loc;
1575 return MATCH_ERROR;
1576 }
1577
1578 /* All else has failed, so give up. See if any of the matchers has
1579 stored an error message of some sort. */
1580 if (gfc_error_check () == 0)
1581 gfc_error ("Unclassifiable statement in IF-clause at %C");
1582
1583 gfc_free_expr (expr);
1584 return MATCH_ERROR;
1585
1586 got_match:
1587 if (m == MATCH_NO)
1588 gfc_error ("Syntax error in IF-clause at %C");
1589 if (m != MATCH_YES)
1590 {
1591 gfc_free_expr (expr);
1592 return MATCH_ERROR;
1593 }
1594
1595 /* At this point, we've matched the single IF and the action clause
1596 is in new_st. Rearrange things so that the IF statement appears
1597 in new_st. */
1598
1599 p = gfc_get_code ();
1600 p->next = gfc_get_code ();
1601 *p->next = new_st;
1602 p->next->loc = gfc_current_locus;
1603
1604 p->expr = expr;
1605 p->op = EXEC_IF;
1606
1607 gfc_clear_new_st ();
1608
1609 new_st.op = EXEC_IF;
1610 new_st.block = p;
1611
1612 return MATCH_YES;
1613 }
1614
1615 #undef match
1616
1617
1618 /* Match an ELSE statement. */
1619
1620 match
1621 gfc_match_else (void)
1622 {
1623 char name[GFC_MAX_SYMBOL_LEN + 1];
1624
1625 if (gfc_match_eos () == MATCH_YES)
1626 return MATCH_YES;
1627
1628 if (gfc_match_name (name) != MATCH_YES
1629 || gfc_current_block () == NULL
1630 || gfc_match_eos () != MATCH_YES)
1631 {
1632 gfc_error ("Unexpected junk after ELSE statement at %C");
1633 return MATCH_ERROR;
1634 }
1635
1636 if (strcmp (name, gfc_current_block ()->name) != 0)
1637 {
1638 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1639 name, gfc_current_block ()->name);
1640 return MATCH_ERROR;
1641 }
1642
1643 return MATCH_YES;
1644 }
1645
1646
1647 /* Match an ELSE IF statement. */
1648
1649 match
1650 gfc_match_elseif (void)
1651 {
1652 char name[GFC_MAX_SYMBOL_LEN + 1];
1653 gfc_expr *expr;
1654 match m;
1655
1656 m = gfc_match (" ( %e ) then", &expr);
1657 if (m != MATCH_YES)
1658 return m;
1659
1660 if (gfc_match_eos () == MATCH_YES)
1661 goto done;
1662
1663 if (gfc_match_name (name) != MATCH_YES
1664 || gfc_current_block () == NULL
1665 || gfc_match_eos () != MATCH_YES)
1666 {
1667 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1668 goto cleanup;
1669 }
1670
1671 if (strcmp (name, gfc_current_block ()->name) != 0)
1672 {
1673 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1674 name, gfc_current_block ()->name);
1675 goto cleanup;
1676 }
1677
1678 done:
1679 new_st.op = EXEC_IF;
1680 new_st.expr = expr;
1681 return MATCH_YES;
1682
1683 cleanup:
1684 gfc_free_expr (expr);
1685 return MATCH_ERROR;
1686 }
1687
1688
1689 /* Free a gfc_iterator structure. */
1690
1691 void
1692 gfc_free_iterator (gfc_iterator *iter, int flag)
1693 {
1694
1695 if (iter == NULL)
1696 return;
1697
1698 gfc_free_expr (iter->var);
1699 gfc_free_expr (iter->start);
1700 gfc_free_expr (iter->end);
1701 gfc_free_expr (iter->step);
1702
1703 if (flag)
1704 gfc_free (iter);
1705 }
1706
1707
1708 /* Match a DO statement. */
1709
1710 match
1711 gfc_match_do (void)
1712 {
1713 gfc_iterator iter, *ip;
1714 locus old_loc;
1715 gfc_st_label *label;
1716 match m;
1717
1718 old_loc = gfc_current_locus;
1719
1720 label = NULL;
1721 iter.var = iter.start = iter.end = iter.step = NULL;
1722
1723 m = gfc_match_label ();
1724 if (m == MATCH_ERROR)
1725 return m;
1726
1727 if (gfc_match (" do") != MATCH_YES)
1728 return MATCH_NO;
1729
1730 m = gfc_match_st_label (&label);
1731 if (m == MATCH_ERROR)
1732 goto cleanup;
1733
1734 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
1735
1736 if (gfc_match_eos () == MATCH_YES)
1737 {
1738 iter.end = gfc_logical_expr (1, NULL);
1739 new_st.op = EXEC_DO_WHILE;
1740 goto done;
1741 }
1742
1743 /* Match an optional comma, if no comma is found, a space is obligatory. */
1744 if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
1745 return MATCH_NO;
1746
1747 /* Check for balanced parens. */
1748
1749 if (gfc_match_parens () == MATCH_ERROR)
1750 return MATCH_ERROR;
1751
1752 /* See if we have a DO WHILE. */
1753 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1754 {
1755 new_st.op = EXEC_DO_WHILE;
1756 goto done;
1757 }
1758
1759 /* The abortive DO WHILE may have done something to the symbol
1760 table, so we start over. */
1761 gfc_undo_symbols ();
1762 gfc_current_locus = old_loc;
1763
1764 gfc_match_label (); /* This won't error. */
1765 gfc_match (" do "); /* This will work. */
1766
1767 gfc_match_st_label (&label); /* Can't error out. */
1768 gfc_match_char (','); /* Optional comma. */
1769
1770 m = gfc_match_iterator (&iter, 0);
1771 if (m == MATCH_NO)
1772 return MATCH_NO;
1773 if (m == MATCH_ERROR)
1774 goto cleanup;
1775
1776 iter.var->symtree->n.sym->attr.implied_index = 0;
1777 gfc_check_do_variable (iter.var->symtree);
1778
1779 if (gfc_match_eos () != MATCH_YES)
1780 {
1781 gfc_syntax_error (ST_DO);
1782 goto cleanup;
1783 }
1784
1785 new_st.op = EXEC_DO;
1786
1787 done:
1788 if (label != NULL
1789 && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1790 goto cleanup;
1791
1792 new_st.label = label;
1793
1794 if (new_st.op == EXEC_DO_WHILE)
1795 new_st.expr = iter.end;
1796 else
1797 {
1798 new_st.ext.iterator = ip = gfc_get_iterator ();
1799 *ip = iter;
1800 }
1801
1802 return MATCH_YES;
1803
1804 cleanup:
1805 gfc_free_iterator (&iter, 0);
1806
1807 return MATCH_ERROR;
1808 }
1809
1810
1811 /* Match an EXIT or CYCLE statement. */
1812
1813 static match
1814 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1815 {
1816 gfc_state_data *p, *o;
1817 gfc_symbol *sym;
1818 match m;
1819
1820 if (gfc_match_eos () == MATCH_YES)
1821 sym = NULL;
1822 else
1823 {
1824 m = gfc_match ("% %s%t", &sym);
1825 if (m == MATCH_ERROR)
1826 return MATCH_ERROR;
1827 if (m == MATCH_NO)
1828 {
1829 gfc_syntax_error (st);
1830 return MATCH_ERROR;
1831 }
1832
1833 if (sym->attr.flavor != FL_LABEL)
1834 {
1835 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1836 sym->name, gfc_ascii_statement (st));
1837 return MATCH_ERROR;
1838 }
1839 }
1840
1841 /* Find the loop mentioned specified by the label (or lack of a label). */
1842 for (o = NULL, p = gfc_state_stack; p; p = p->previous)
1843 if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1844 break;
1845 else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
1846 o = p;
1847
1848 if (p == NULL)
1849 {
1850 if (sym == NULL)
1851 gfc_error ("%s statement at %C is not within a loop",
1852 gfc_ascii_statement (st));
1853 else
1854 gfc_error ("%s statement at %C is not within loop '%s'",
1855 gfc_ascii_statement (st), sym->name);
1856
1857 return MATCH_ERROR;
1858 }
1859
1860 if (o != NULL)
1861 {
1862 gfc_error ("%s statement at %C leaving OpenMP structured block",
1863 gfc_ascii_statement (st));
1864 return MATCH_ERROR;
1865 }
1866 else if (st == ST_EXIT
1867 && p->previous != NULL
1868 && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
1869 && (p->previous->head->op == EXEC_OMP_DO
1870 || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
1871 {
1872 gcc_assert (p->previous->head->next != NULL);
1873 gcc_assert (p->previous->head->next->op == EXEC_DO
1874 || p->previous->head->next->op == EXEC_DO_WHILE);
1875 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1876 return MATCH_ERROR;
1877 }
1878
1879 /* Save the first statement in the loop - needed by the backend. */
1880 new_st.ext.whichloop = p->head;
1881
1882 new_st.op = op;
1883
1884 return MATCH_YES;
1885 }
1886
1887
1888 /* Match the EXIT statement. */
1889
1890 match
1891 gfc_match_exit (void)
1892 {
1893 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1894 }
1895
1896
1897 /* Match the CYCLE statement. */
1898
1899 match
1900 gfc_match_cycle (void)
1901 {
1902 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1903 }
1904
1905
1906 /* Match a number or character constant after a STOP or PAUSE statement. */
1907
1908 static match
1909 gfc_match_stopcode (gfc_statement st)
1910 {
1911 int stop_code;
1912 gfc_expr *e;
1913 match m;
1914 int cnt;
1915
1916 stop_code = -1;
1917 e = NULL;
1918
1919 if (gfc_match_eos () != MATCH_YES)
1920 {
1921 m = gfc_match_small_literal_int (&stop_code, &cnt);
1922 if (m == MATCH_ERROR)
1923 goto cleanup;
1924
1925 if (m == MATCH_YES && cnt > 5)
1926 {
1927 gfc_error ("Too many digits in STOP code at %C");
1928 goto cleanup;
1929 }
1930
1931 if (m == MATCH_NO)
1932 {
1933 /* Try a character constant. */
1934 m = gfc_match_expr (&e);
1935 if (m == MATCH_ERROR)
1936 goto cleanup;
1937 if (m == MATCH_NO)
1938 goto syntax;
1939 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1940 goto syntax;
1941 }
1942
1943 if (gfc_match_eos () != MATCH_YES)
1944 goto syntax;
1945 }
1946
1947 if (gfc_pure (NULL))
1948 {
1949 gfc_error ("%s statement not allowed in PURE procedure at %C",
1950 gfc_ascii_statement (st));
1951 goto cleanup;
1952 }
1953
1954 new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1955 new_st.expr = e;
1956 new_st.ext.stop_code = stop_code;
1957
1958 return MATCH_YES;
1959
1960 syntax:
1961 gfc_syntax_error (st);
1962
1963 cleanup:
1964
1965 gfc_free_expr (e);
1966 return MATCH_ERROR;
1967 }
1968
1969
1970 /* Match the (deprecated) PAUSE statement. */
1971
1972 match
1973 gfc_match_pause (void)
1974 {
1975 match m;
1976
1977 m = gfc_match_stopcode (ST_PAUSE);
1978 if (m == MATCH_YES)
1979 {
1980 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
1981 " at %C")
1982 == FAILURE)
1983 m = MATCH_ERROR;
1984 }
1985 return m;
1986 }
1987
1988
1989 /* Match the STOP statement. */
1990
1991 match
1992 gfc_match_stop (void)
1993 {
1994 return gfc_match_stopcode (ST_STOP);
1995 }
1996
1997
1998 /* Match a CONTINUE statement. */
1999
2000 match
2001 gfc_match_continue (void)
2002 {
2003 if (gfc_match_eos () != MATCH_YES)
2004 {
2005 gfc_syntax_error (ST_CONTINUE);
2006 return MATCH_ERROR;
2007 }
2008
2009 new_st.op = EXEC_CONTINUE;
2010 return MATCH_YES;
2011 }
2012
2013
2014 /* Match the (deprecated) ASSIGN statement. */
2015
2016 match
2017 gfc_match_assign (void)
2018 {
2019 gfc_expr *expr;
2020 gfc_st_label *label;
2021
2022 if (gfc_match (" %l", &label) == MATCH_YES)
2023 {
2024 if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
2025 return MATCH_ERROR;
2026 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
2027 {
2028 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
2029 "statement at %C")
2030 == FAILURE)
2031 return MATCH_ERROR;
2032
2033 expr->symtree->n.sym->attr.assign = 1;
2034
2035 new_st.op = EXEC_LABEL_ASSIGN;
2036 new_st.label = label;
2037 new_st.expr = expr;
2038 return MATCH_YES;
2039 }
2040 }
2041 return MATCH_NO;
2042 }
2043
2044
2045 /* Match the GO TO statement. As a computed GOTO statement is
2046 matched, it is transformed into an equivalent SELECT block. No
2047 tree is necessary, and the resulting jumps-to-jumps are
2048 specifically optimized away by the back end. */
2049
2050 match
2051 gfc_match_goto (void)
2052 {
2053 gfc_code *head, *tail;
2054 gfc_expr *expr;
2055 gfc_case *cp;
2056 gfc_st_label *label;
2057 int i;
2058 match m;
2059
2060 if (gfc_match (" %l%t", &label) == MATCH_YES)
2061 {
2062 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2063 return MATCH_ERROR;
2064
2065 new_st.op = EXEC_GOTO;
2066 new_st.label = label;
2067 return MATCH_YES;
2068 }
2069
2070 /* The assigned GO TO statement. */
2071
2072 if (gfc_match_variable (&expr, 0) == MATCH_YES)
2073 {
2074 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
2075 "statement at %C")
2076 == FAILURE)
2077 return MATCH_ERROR;
2078
2079 new_st.op = EXEC_GOTO;
2080 new_st.expr = expr;
2081
2082 if (gfc_match_eos () == MATCH_YES)
2083 return MATCH_YES;
2084
2085 /* Match label list. */
2086 gfc_match_char (',');
2087 if (gfc_match_char ('(') != MATCH_YES)
2088 {
2089 gfc_syntax_error (ST_GOTO);
2090 return MATCH_ERROR;
2091 }
2092 head = tail = NULL;
2093
2094 do
2095 {
2096 m = gfc_match_st_label (&label);
2097 if (m != MATCH_YES)
2098 goto syntax;
2099
2100 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2101 goto cleanup;
2102
2103 if (head == NULL)
2104 head = tail = gfc_get_code ();
2105 else
2106 {
2107 tail->block = gfc_get_code ();
2108 tail = tail->block;
2109 }
2110
2111 tail->label = label;
2112 tail->op = EXEC_GOTO;
2113 }
2114 while (gfc_match_char (',') == MATCH_YES);
2115
2116 if (gfc_match (")%t") != MATCH_YES)
2117 goto syntax;
2118
2119 if (head == NULL)
2120 {
2121 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2122 goto syntax;
2123 }
2124 new_st.block = head;
2125
2126 return MATCH_YES;
2127 }
2128
2129 /* Last chance is a computed GO TO statement. */
2130 if (gfc_match_char ('(') != MATCH_YES)
2131 {
2132 gfc_syntax_error (ST_GOTO);
2133 return MATCH_ERROR;
2134 }
2135
2136 head = tail = NULL;
2137 i = 1;
2138
2139 do
2140 {
2141 m = gfc_match_st_label (&label);
2142 if (m != MATCH_YES)
2143 goto syntax;
2144
2145 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2146 goto cleanup;
2147
2148 if (head == NULL)
2149 head = tail = gfc_get_code ();
2150 else
2151 {
2152 tail->block = gfc_get_code ();
2153 tail = tail->block;
2154 }
2155
2156 cp = gfc_get_case ();
2157 cp->low = cp->high = gfc_int_expr (i++);
2158
2159 tail->op = EXEC_SELECT;
2160 tail->ext.case_list = cp;
2161
2162 tail->next = gfc_get_code ();
2163 tail->next->op = EXEC_GOTO;
2164 tail->next->label = label;
2165 }
2166 while (gfc_match_char (',') == MATCH_YES);
2167
2168 if (gfc_match_char (')') != MATCH_YES)
2169 goto syntax;
2170
2171 if (head == NULL)
2172 {
2173 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2174 goto syntax;
2175 }
2176
2177 /* Get the rest of the statement. */
2178 gfc_match_char (',');
2179
2180 if (gfc_match (" %e%t", &expr) != MATCH_YES)
2181 goto syntax;
2182
2183 /* At this point, a computed GOTO has been fully matched and an
2184 equivalent SELECT statement constructed. */
2185
2186 new_st.op = EXEC_SELECT;
2187 new_st.expr = NULL;
2188
2189 /* Hack: For a "real" SELECT, the expression is in expr. We put
2190 it in expr2 so we can distinguish then and produce the correct
2191 diagnostics. */
2192 new_st.expr2 = expr;
2193 new_st.block = head;
2194 return MATCH_YES;
2195
2196 syntax:
2197 gfc_syntax_error (ST_GOTO);
2198 cleanup:
2199 gfc_free_statements (head);
2200 return MATCH_ERROR;
2201 }
2202
2203
2204 /* Frees a list of gfc_alloc structures. */
2205
2206 void
2207 gfc_free_alloc_list (gfc_alloc *p)
2208 {
2209 gfc_alloc *q;
2210
2211 for (; p; p = q)
2212 {
2213 q = p->next;
2214 gfc_free_expr (p->expr);
2215 gfc_free (p);
2216 }
2217 }
2218
2219
2220 /* Match an ALLOCATE statement. */
2221
2222 match
2223 gfc_match_allocate (void)
2224 {
2225 gfc_alloc *head, *tail;
2226 gfc_expr *stat, *errmsg, *tmp;
2227 match m;
2228 bool saw_stat, saw_errmsg;
2229
2230 head = tail = NULL;
2231 stat = errmsg = tmp = NULL;
2232 saw_stat = saw_errmsg = false;
2233
2234 if (gfc_match_char ('(') != MATCH_YES)
2235 goto syntax;
2236
2237 for (;;)
2238 {
2239 if (head == NULL)
2240 head = tail = gfc_get_alloc ();
2241 else
2242 {
2243 tail->next = gfc_get_alloc ();
2244 tail = tail->next;
2245 }
2246
2247 m = gfc_match_variable (&tail->expr, 0);
2248 if (m == MATCH_NO)
2249 goto syntax;
2250 if (m == MATCH_ERROR)
2251 goto cleanup;
2252
2253 if (gfc_check_do_variable (tail->expr->symtree))
2254 goto cleanup;
2255
2256 if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
2257 {
2258 gfc_error ("Bad allocate-object at %C for a PURE procedure");
2259 goto cleanup;
2260 }
2261
2262 if (tail->expr->ts.type == BT_DERIVED)
2263 tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
2264
2265 /* FIXME: disable the checking on derived types and arrays. */
2266 if (!(tail->expr->ref
2267 && (tail->expr->ref->type == REF_COMPONENT
2268 || tail->expr->ref->type == REF_ARRAY))
2269 && tail->expr->symtree->n.sym
2270 && !(tail->expr->symtree->n.sym->attr.allocatable
2271 || tail->expr->symtree->n.sym->attr.pointer
2272 || tail->expr->symtree->n.sym->attr.proc_pointer))
2273 {
2274 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2275 "or an allocatable variable");
2276 goto cleanup;
2277 }
2278
2279 if (gfc_match_char (',') != MATCH_YES)
2280 break;
2281
2282 alloc_opt_list:
2283
2284 m = gfc_match (" stat = %v", &tmp);
2285 if (m == MATCH_ERROR)
2286 goto cleanup;
2287 if (m == MATCH_YES)
2288 {
2289 if (saw_stat)
2290 {
2291 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2292 gfc_free_expr (tmp);
2293 goto cleanup;
2294 }
2295
2296 stat = tmp;
2297 saw_stat = true;
2298
2299 if (gfc_check_do_variable (stat->symtree))
2300 goto cleanup;
2301
2302 if (gfc_match_char (',') == MATCH_YES)
2303 goto alloc_opt_list;
2304 }
2305
2306 m = gfc_match (" errmsg = %v", &tmp);
2307 if (m == MATCH_ERROR)
2308 goto cleanup;
2309 if (m == MATCH_YES)
2310 {
2311 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
2312 &tmp->where) == FAILURE)
2313 goto cleanup;
2314
2315 if (saw_errmsg)
2316 {
2317 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2318 gfc_free_expr (tmp);
2319 goto cleanup;
2320 }
2321
2322 errmsg = tmp;
2323 saw_errmsg = true;
2324
2325 if (gfc_match_char (',') == MATCH_YES)
2326 goto alloc_opt_list;
2327 }
2328
2329 gfc_gobble_whitespace ();
2330
2331 if (gfc_peek_char () == ')')
2332 break;
2333 }
2334
2335
2336 if (gfc_match (" )%t") != MATCH_YES)
2337 goto syntax;
2338
2339 new_st.op = EXEC_ALLOCATE;
2340 new_st.expr = stat;
2341 new_st.expr2 = errmsg;
2342 new_st.ext.alloc_list = head;
2343
2344 return MATCH_YES;
2345
2346 syntax:
2347 gfc_syntax_error (ST_ALLOCATE);
2348
2349 cleanup:
2350 gfc_free_expr (errmsg);
2351 gfc_free_expr (stat);
2352 gfc_free_alloc_list (head);
2353 return MATCH_ERROR;
2354 }
2355
2356
2357 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
2358 a set of pointer assignments to intrinsic NULL(). */
2359
2360 match
2361 gfc_match_nullify (void)
2362 {
2363 gfc_code *tail;
2364 gfc_expr *e, *p;
2365 match m;
2366
2367 tail = NULL;
2368
2369 if (gfc_match_char ('(') != MATCH_YES)
2370 goto syntax;
2371
2372 for (;;)
2373 {
2374 m = gfc_match_variable (&p, 0);
2375 if (m == MATCH_ERROR)
2376 goto cleanup;
2377 if (m == MATCH_NO)
2378 goto syntax;
2379
2380 if (gfc_check_do_variable (p->symtree))
2381 goto cleanup;
2382
2383 if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
2384 {
2385 gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
2386 goto cleanup;
2387 }
2388
2389 /* build ' => NULL() '. */
2390 e = gfc_get_expr ();
2391 e->where = gfc_current_locus;
2392 e->expr_type = EXPR_NULL;
2393 e->ts.type = BT_UNKNOWN;
2394
2395 /* Chain to list. */
2396 if (tail == NULL)
2397 tail = &new_st;
2398 else
2399 {
2400 tail->next = gfc_get_code ();
2401 tail = tail->next;
2402 }
2403
2404 tail->op = EXEC_POINTER_ASSIGN;
2405 tail->expr = p;
2406 tail->expr2 = e;
2407
2408 if (gfc_match (" )%t") == MATCH_YES)
2409 break;
2410 if (gfc_match_char (',') != MATCH_YES)
2411 goto syntax;
2412 }
2413
2414 return MATCH_YES;
2415
2416 syntax:
2417 gfc_syntax_error (ST_NULLIFY);
2418
2419 cleanup:
2420 gfc_free_statements (new_st.next);
2421 return MATCH_ERROR;
2422 }
2423
2424
2425 /* Match a DEALLOCATE statement. */
2426
2427 match
2428 gfc_match_deallocate (void)
2429 {
2430 gfc_alloc *head, *tail;
2431 gfc_expr *stat, *errmsg, *tmp;
2432 match m;
2433 bool saw_stat, saw_errmsg;
2434
2435 head = tail = NULL;
2436 stat = errmsg = tmp = NULL;
2437 saw_stat = saw_errmsg = false;
2438
2439 if (gfc_match_char ('(') != MATCH_YES)
2440 goto syntax;
2441
2442 for (;;)
2443 {
2444 if (head == NULL)
2445 head = tail = gfc_get_alloc ();
2446 else
2447 {
2448 tail->next = gfc_get_alloc ();
2449 tail = tail->next;
2450 }
2451
2452 m = gfc_match_variable (&tail->expr, 0);
2453 if (m == MATCH_ERROR)
2454 goto cleanup;
2455 if (m == MATCH_NO)
2456 goto syntax;
2457
2458 if (gfc_check_do_variable (tail->expr->symtree))
2459 goto cleanup;
2460
2461 if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
2462 {
2463 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
2464 goto cleanup;
2465 }
2466
2467 /* FIXME: disable the checking on derived types. */
2468 if (!(tail->expr->ref
2469 && (tail->expr->ref->type == REF_COMPONENT
2470 || tail->expr->ref->type == REF_ARRAY))
2471 && tail->expr->symtree->n.sym
2472 && !(tail->expr->symtree->n.sym->attr.allocatable
2473 || tail->expr->symtree->n.sym->attr.pointer
2474 || tail->expr->symtree->n.sym->attr.proc_pointer))
2475 {
2476 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2477 "or an allocatable variable");
2478 goto cleanup;
2479 }
2480
2481 if (gfc_match_char (',') != MATCH_YES)
2482 break;
2483
2484 dealloc_opt_list:
2485
2486 m = gfc_match (" stat = %v", &tmp);
2487 if (m == MATCH_ERROR)
2488 goto cleanup;
2489 if (m == MATCH_YES)
2490 {
2491 if (saw_stat)
2492 {
2493 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2494 gfc_free_expr (tmp);
2495 goto cleanup;
2496 }
2497
2498 stat = tmp;
2499 saw_stat = true;
2500
2501 if (gfc_check_do_variable (stat->symtree))
2502 goto cleanup;
2503
2504 if (gfc_match_char (',') == MATCH_YES)
2505 goto dealloc_opt_list;
2506 }
2507
2508 m = gfc_match (" errmsg = %v", &tmp);
2509 if (m == MATCH_ERROR)
2510 goto cleanup;
2511 if (m == MATCH_YES)
2512 {
2513 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
2514 &tmp->where) == FAILURE)
2515 goto cleanup;
2516
2517 if (saw_errmsg)
2518 {
2519 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2520 gfc_free_expr (tmp);
2521 goto cleanup;
2522 }
2523
2524 errmsg = tmp;
2525 saw_errmsg = true;
2526
2527 if (gfc_match_char (',') == MATCH_YES)
2528 goto dealloc_opt_list;
2529 }
2530
2531 gfc_gobble_whitespace ();
2532
2533 if (gfc_peek_char () == ')')
2534 break;
2535 }
2536
2537 if (gfc_match (" )%t") != MATCH_YES)
2538 goto syntax;
2539
2540 new_st.op = EXEC_DEALLOCATE;
2541 new_st.expr = stat;
2542 new_st.expr2 = errmsg;
2543 new_st.ext.alloc_list = head;
2544
2545 return MATCH_YES;
2546
2547 syntax:
2548 gfc_syntax_error (ST_DEALLOCATE);
2549
2550 cleanup:
2551 gfc_free_expr (errmsg);
2552 gfc_free_expr (stat);
2553 gfc_free_alloc_list (head);
2554 return MATCH_ERROR;
2555 }
2556
2557
2558 /* Match a RETURN statement. */
2559
2560 match
2561 gfc_match_return (void)
2562 {
2563 gfc_expr *e;
2564 match m;
2565 gfc_compile_state s;
2566
2567 e = NULL;
2568 if (gfc_match_eos () == MATCH_YES)
2569 goto done;
2570
2571 if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
2572 {
2573 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2574 "a SUBROUTINE");
2575 goto cleanup;
2576 }
2577
2578 if (gfc_current_form == FORM_FREE)
2579 {
2580 /* The following are valid, so we can't require a blank after the
2581 RETURN keyword:
2582 return+1
2583 return(1) */
2584 char c = gfc_peek_ascii_char ();
2585 if (ISALPHA (c) || ISDIGIT (c))
2586 return MATCH_NO;
2587 }
2588
2589 m = gfc_match (" %e%t", &e);
2590 if (m == MATCH_YES)
2591 goto done;
2592 if (m == MATCH_ERROR)
2593 goto cleanup;
2594
2595 gfc_syntax_error (ST_RETURN);
2596
2597 cleanup:
2598 gfc_free_expr (e);
2599 return MATCH_ERROR;
2600
2601 done:
2602 gfc_enclosing_unit (&s);
2603 if (s == COMP_PROGRAM
2604 && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
2605 "main program at %C") == FAILURE)
2606 return MATCH_ERROR;
2607
2608 new_st.op = EXEC_RETURN;
2609 new_st.expr = e;
2610
2611 return MATCH_YES;
2612 }
2613
2614
2615 /* Match the call of a type-bound procedure, if CALL%var has already been
2616 matched and var found to be a derived-type variable. */
2617
2618 static match
2619 match_typebound_call (gfc_symtree* varst)
2620 {
2621 gfc_symbol* var;
2622 gfc_expr* base;
2623 match m;
2624
2625 var = varst->n.sym;
2626
2627 base = gfc_get_expr ();
2628 base->expr_type = EXPR_VARIABLE;
2629 base->symtree = varst;
2630 base->where = gfc_current_locus;
2631 gfc_set_sym_referenced (varst->n.sym);
2632
2633 m = gfc_match_varspec (base, 0, true, true);
2634 if (m == MATCH_NO)
2635 gfc_error ("Expected component reference at %C");
2636 if (m != MATCH_YES)
2637 return MATCH_ERROR;
2638
2639 if (gfc_match_eos () != MATCH_YES)
2640 {
2641 gfc_error ("Junk after CALL at %C");
2642 return MATCH_ERROR;
2643 }
2644
2645 if (base->expr_type == EXPR_COMPCALL)
2646 new_st.op = EXEC_COMPCALL;
2647 else if (base->expr_type == EXPR_PPC)
2648 new_st.op = EXEC_CALL_PPC;
2649 else
2650 {
2651 gfc_error ("Expected type-bound procedure or procedure pointer component "
2652 "at %C");
2653 return MATCH_ERROR;
2654 }
2655 new_st.expr = base;
2656
2657 return MATCH_YES;
2658 }
2659
2660
2661 /* Match a CALL statement. The tricky part here are possible
2662 alternate return specifiers. We handle these by having all
2663 "subroutines" actually return an integer via a register that gives
2664 the return number. If the call specifies alternate returns, we
2665 generate code for a SELECT statement whose case clauses contain
2666 GOTOs to the various labels. */
2667
2668 match
2669 gfc_match_call (void)
2670 {
2671 char name[GFC_MAX_SYMBOL_LEN + 1];
2672 gfc_actual_arglist *a, *arglist;
2673 gfc_case *new_case;
2674 gfc_symbol *sym;
2675 gfc_symtree *st;
2676 gfc_code *c;
2677 match m;
2678 int i;
2679
2680 arglist = NULL;
2681
2682 m = gfc_match ("% %n", name);
2683 if (m == MATCH_NO)
2684 goto syntax;
2685 if (m != MATCH_YES)
2686 return m;
2687
2688 if (gfc_get_ha_sym_tree (name, &st))
2689 return MATCH_ERROR;
2690
2691 sym = st->n.sym;
2692
2693 /* If this is a variable of derived-type, it probably starts a type-bound
2694 procedure call. */
2695 if (sym->attr.flavor != FL_PROCEDURE && sym->ts.type == BT_DERIVED)
2696 return match_typebound_call (st);
2697
2698 /* If it does not seem to be callable (include functions so that the
2699 right association is made. They are thrown out in resolution.)
2700 ... */
2701 if (!sym->attr.generic
2702 && !sym->attr.subroutine
2703 && !sym->attr.function)
2704 {
2705 if (!(sym->attr.external && !sym->attr.referenced))
2706 {
2707 /* ...create a symbol in this scope... */
2708 if (sym->ns != gfc_current_ns
2709 && gfc_get_sym_tree (name, NULL, &st) == 1)
2710 return MATCH_ERROR;
2711
2712 if (sym != st->n.sym)
2713 sym = st->n.sym;
2714 }
2715
2716 /* ...and then to try to make the symbol into a subroutine. */
2717 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2718 return MATCH_ERROR;
2719 }
2720
2721 gfc_set_sym_referenced (sym);
2722
2723 if (gfc_match_eos () != MATCH_YES)
2724 {
2725 m = gfc_match_actual_arglist (1, &arglist);
2726 if (m == MATCH_NO)
2727 goto syntax;
2728 if (m == MATCH_ERROR)
2729 goto cleanup;
2730
2731 if (gfc_match_eos () != MATCH_YES)
2732 goto syntax;
2733 }
2734
2735 /* If any alternate return labels were found, construct a SELECT
2736 statement that will jump to the right place. */
2737
2738 i = 0;
2739 for (a = arglist; a; a = a->next)
2740 if (a->expr == NULL)
2741 i = 1;
2742
2743 if (i)
2744 {
2745 gfc_symtree *select_st;
2746 gfc_symbol *select_sym;
2747 char name[GFC_MAX_SYMBOL_LEN + 1];
2748
2749 new_st.next = c = gfc_get_code ();
2750 c->op = EXEC_SELECT;
2751 sprintf (name, "_result_%s", sym->name);
2752 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
2753
2754 select_sym = select_st->n.sym;
2755 select_sym->ts.type = BT_INTEGER;
2756 select_sym->ts.kind = gfc_default_integer_kind;
2757 gfc_set_sym_referenced (select_sym);
2758 c->expr = gfc_get_expr ();
2759 c->expr->expr_type = EXPR_VARIABLE;
2760 c->expr->symtree = select_st;
2761 c->expr->ts = select_sym->ts;
2762 c->expr->where = gfc_current_locus;
2763
2764 i = 0;
2765 for (a = arglist; a; a = a->next)
2766 {
2767 if (a->expr != NULL)
2768 continue;
2769
2770 if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2771 continue;
2772
2773 i++;
2774
2775 c->block = gfc_get_code ();
2776 c = c->block;
2777 c->op = EXEC_SELECT;
2778
2779 new_case = gfc_get_case ();
2780 new_case->high = new_case->low = gfc_int_expr (i);
2781 c->ext.case_list = new_case;
2782
2783 c->next = gfc_get_code ();
2784 c->next->op = EXEC_GOTO;
2785 c->next->label = a->label;
2786 }
2787 }
2788
2789 new_st.op = EXEC_CALL;
2790 new_st.symtree = st;
2791 new_st.ext.actual = arglist;
2792
2793 return MATCH_YES;
2794
2795 syntax:
2796 gfc_syntax_error (ST_CALL);
2797
2798 cleanup:
2799 gfc_free_actual_arglist (arglist);
2800 return MATCH_ERROR;
2801 }
2802
2803
2804 /* Given a name, return a pointer to the common head structure,
2805 creating it if it does not exist. If FROM_MODULE is nonzero, we
2806 mangle the name so that it doesn't interfere with commons defined
2807 in the using namespace.
2808 TODO: Add to global symbol tree. */
2809
2810 gfc_common_head *
2811 gfc_get_common (const char *name, int from_module)
2812 {
2813 gfc_symtree *st;
2814 static int serial = 0;
2815 char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
2816
2817 if (from_module)
2818 {
2819 /* A use associated common block is only needed to correctly layout
2820 the variables it contains. */
2821 snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2822 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2823 }
2824 else
2825 {
2826 st = gfc_find_symtree (gfc_current_ns->common_root, name);
2827
2828 if (st == NULL)
2829 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2830 }
2831
2832 if (st->n.common == NULL)
2833 {
2834 st->n.common = gfc_get_common_head ();
2835 st->n.common->where = gfc_current_locus;
2836 strcpy (st->n.common->name, name);
2837 }
2838
2839 return st->n.common;
2840 }
2841
2842
2843 /* Match a common block name. */
2844
2845 match match_common_name (char *name)
2846 {
2847 match m;
2848
2849 if (gfc_match_char ('/') == MATCH_NO)
2850 {
2851 name[0] = '\0';
2852 return MATCH_YES;
2853 }
2854
2855 if (gfc_match_char ('/') == MATCH_YES)
2856 {
2857 name[0] = '\0';
2858 return MATCH_YES;
2859 }
2860
2861 m = gfc_match_name (name);
2862
2863 if (m == MATCH_ERROR)
2864 return MATCH_ERROR;
2865 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2866 return MATCH_YES;
2867
2868 gfc_error ("Syntax error in common block name at %C");
2869 return MATCH_ERROR;
2870 }
2871
2872
2873 /* Match a COMMON statement. */
2874
2875 match
2876 gfc_match_common (void)
2877 {
2878 gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
2879 char name[GFC_MAX_SYMBOL_LEN + 1];
2880 gfc_common_head *t;
2881 gfc_array_spec *as;
2882 gfc_equiv *e1, *e2;
2883 match m;
2884 gfc_gsymbol *gsym;
2885
2886 old_blank_common = gfc_current_ns->blank_common.head;
2887 if (old_blank_common)
2888 {
2889 while (old_blank_common->common_next)
2890 old_blank_common = old_blank_common->common_next;
2891 }
2892
2893 as = NULL;
2894
2895 for (;;)
2896 {
2897 m = match_common_name (name);
2898 if (m == MATCH_ERROR)
2899 goto cleanup;
2900
2901 gsym = gfc_get_gsymbol (name);
2902 if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
2903 {
2904 gfc_error ("Symbol '%s' at %C is already an external symbol that "
2905 "is not COMMON", name);
2906 goto cleanup;
2907 }
2908
2909 if (gsym->type == GSYM_UNKNOWN)
2910 {
2911 gsym->type = GSYM_COMMON;
2912 gsym->where = gfc_current_locus;
2913 gsym->defined = 1;
2914 }
2915
2916 gsym->used = 1;
2917
2918 if (name[0] == '\0')
2919 {
2920 t = &gfc_current_ns->blank_common;
2921 if (t->head == NULL)
2922 t->where = gfc_current_locus;
2923 }
2924 else
2925 {
2926 t = gfc_get_common (name, 0);
2927 }
2928 head = &t->head;
2929
2930 if (*head == NULL)
2931 tail = NULL;
2932 else
2933 {
2934 tail = *head;
2935 while (tail->common_next)
2936 tail = tail->common_next;
2937 }
2938
2939 /* Grab the list of symbols. */
2940 for (;;)
2941 {
2942 m = gfc_match_symbol (&sym, 0);
2943 if (m == MATCH_ERROR)
2944 goto cleanup;
2945 if (m == MATCH_NO)
2946 goto syntax;
2947
2948 /* Store a ref to the common block for error checking. */
2949 sym->common_block = t;
2950
2951 /* See if we know the current common block is bind(c), and if
2952 so, then see if we can check if the symbol is (which it'll
2953 need to be). This can happen if the bind(c) attr stmt was
2954 applied to the common block, and the variable(s) already
2955 defined, before declaring the common block. */
2956 if (t->is_bind_c == 1)
2957 {
2958 if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
2959 {
2960 /* If we find an error, just print it and continue,
2961 cause it's just semantic, and we can see if there
2962 are more errors. */
2963 gfc_error_now ("Variable '%s' at %L in common block '%s' "
2964 "at %C must be declared with a C "
2965 "interoperable kind since common block "
2966 "'%s' is bind(c)",
2967 sym->name, &(sym->declared_at), t->name,
2968 t->name);
2969 }
2970
2971 if (sym->attr.is_bind_c == 1)
2972 gfc_error_now ("Variable '%s' in common block "
2973 "'%s' at %C can not be bind(c) since "
2974 "it is not global", sym->name, t->name);
2975 }
2976
2977 if (sym->attr.in_common)
2978 {
2979 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2980 sym->name);
2981 goto cleanup;
2982 }
2983
2984 if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
2985 || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
2986 {
2987 if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
2988 "can only be COMMON in "
2989 "BLOCK DATA", sym->name)
2990 == FAILURE)
2991 goto cleanup;
2992 }
2993
2994 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2995 goto cleanup;
2996
2997 if (tail != NULL)
2998 tail->common_next = sym;
2999 else
3000 *head = sym;
3001
3002 tail = sym;
3003
3004 /* Deal with an optional array specification after the
3005 symbol name. */
3006 m = gfc_match_array_spec (&as);
3007 if (m == MATCH_ERROR)
3008 goto cleanup;
3009
3010 if (m == MATCH_YES)
3011 {
3012 if (as->type != AS_EXPLICIT)
3013 {
3014 gfc_error ("Array specification for symbol '%s' in COMMON "
3015 "at %C must be explicit", sym->name);
3016 goto cleanup;
3017 }
3018
3019 if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
3020 goto cleanup;
3021
3022 if (sym->attr.pointer)
3023 {
3024 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
3025 "POINTER array", sym->name);
3026 goto cleanup;
3027 }
3028
3029 sym->as = as;
3030 as = NULL;
3031
3032 }
3033
3034 sym->common_head = t;
3035
3036 /* Check to see if the symbol is already in an equivalence group.
3037 If it is, set the other members as being in common. */
3038 if (sym->attr.in_equivalence)
3039 {
3040 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
3041 {
3042 for (e2 = e1; e2; e2 = e2->eq)
3043 if (e2->expr->symtree->n.sym == sym)
3044 goto equiv_found;
3045
3046 continue;
3047
3048 equiv_found:
3049
3050 for (e2 = e1; e2; e2 = e2->eq)
3051 {
3052 other = e2->expr->symtree->n.sym;
3053 if (other->common_head
3054 && other->common_head != sym->common_head)
3055 {
3056 gfc_error ("Symbol '%s', in COMMON block '%s' at "
3057 "%C is being indirectly equivalenced to "
3058 "another COMMON block '%s'",
3059 sym->name, sym->common_head->name,
3060 other->common_head->name);
3061 goto cleanup;
3062 }
3063 other->attr.in_common = 1;
3064 other->common_head = t;
3065 }
3066 }
3067 }
3068
3069
3070 gfc_gobble_whitespace ();
3071 if (gfc_match_eos () == MATCH_YES)
3072 goto done;
3073 if (gfc_peek_ascii_char () == '/')
3074 break;
3075 if (gfc_match_char (',') != MATCH_YES)
3076 goto syntax;
3077 gfc_gobble_whitespace ();
3078 if (gfc_peek_ascii_char () == '/')
3079 break;
3080 }
3081 }
3082
3083 done:
3084 return MATCH_YES;
3085
3086 syntax:
3087 gfc_syntax_error (ST_COMMON);
3088
3089 cleanup:
3090 if (old_blank_common)
3091 old_blank_common->common_next = NULL;
3092 else
3093 gfc_current_ns->blank_common.head = NULL;
3094 gfc_free_array_spec (as);
3095 return MATCH_ERROR;
3096 }
3097
3098
3099 /* Match a BLOCK DATA program unit. */
3100
3101 match
3102 gfc_match_block_data (void)
3103 {
3104 char name[GFC_MAX_SYMBOL_LEN + 1];
3105 gfc_symbol *sym;
3106 match m;
3107
3108 if (gfc_match_eos () == MATCH_YES)
3109 {
3110 gfc_new_block = NULL;
3111 return MATCH_YES;
3112 }
3113
3114 m = gfc_match ("% %n%t", name);
3115 if (m != MATCH_YES)
3116 return MATCH_ERROR;
3117
3118 if (gfc_get_symbol (name, NULL, &sym))
3119 return MATCH_ERROR;
3120
3121 if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
3122 return MATCH_ERROR;
3123
3124 gfc_new_block = sym;
3125
3126 return MATCH_YES;
3127 }
3128
3129
3130 /* Free a namelist structure. */
3131
3132 void
3133 gfc_free_namelist (gfc_namelist *name)
3134 {
3135 gfc_namelist *n;
3136
3137 for (; name; name = n)
3138 {
3139 n = name->next;
3140 gfc_free (name);
3141 }
3142 }
3143
3144
3145 /* Match a NAMELIST statement. */
3146
3147 match
3148 gfc_match_namelist (void)
3149 {
3150 gfc_symbol *group_name, *sym;
3151 gfc_namelist *nl;
3152 match m, m2;
3153
3154 m = gfc_match (" / %s /", &group_name);
3155 if (m == MATCH_NO)
3156 goto syntax;
3157 if (m == MATCH_ERROR)
3158 goto error;
3159
3160 for (;;)
3161 {
3162 if (group_name->ts.type != BT_UNKNOWN)
3163 {
3164 gfc_error ("Namelist group name '%s' at %C already has a basic "
3165 "type of %s", group_name->name,
3166 gfc_typename (&group_name->ts));
3167 return MATCH_ERROR;
3168 }
3169
3170 if (group_name->attr.flavor == FL_NAMELIST
3171 && group_name->attr.use_assoc
3172 && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
3173 "at %C already is USE associated and can"
3174 "not be respecified.", group_name->name)
3175 == FAILURE)
3176 return MATCH_ERROR;
3177
3178 if (group_name->attr.flavor != FL_NAMELIST
3179 && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
3180 group_name->name, NULL) == FAILURE)
3181 return MATCH_ERROR;
3182
3183 for (;;)
3184 {
3185 m = gfc_match_symbol (&sym, 1);
3186 if (m == MATCH_NO)
3187 goto syntax;
3188 if (m == MATCH_ERROR)
3189 goto error;
3190
3191 if (sym->attr.in_namelist == 0
3192 && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
3193 goto error;
3194
3195 /* Use gfc_error_check here, rather than goto error, so that
3196 these are the only errors for the next two lines. */
3197 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
3198 {
3199 gfc_error ("Assumed size array '%s' in namelist '%s' at "
3200 "%C is not allowed", sym->name, group_name->name);
3201 gfc_error_check ();
3202 }
3203
3204 if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL)
3205 {
3206 gfc_error ("Assumed character length '%s' in namelist '%s' at "
3207 "%C is not allowed", sym->name, group_name->name);
3208 gfc_error_check ();
3209 }
3210
3211 nl = gfc_get_namelist ();
3212 nl->sym = sym;
3213 sym->refs++;
3214
3215 if (group_name->namelist == NULL)
3216 group_name->namelist = group_name->namelist_tail = nl;
3217 else
3218 {
3219 group_name->namelist_tail->next = nl;
3220 group_name->namelist_tail = nl;
3221 }
3222
3223 if (gfc_match_eos () == MATCH_YES)
3224 goto done;
3225
3226 m = gfc_match_char (',');
3227
3228 if (gfc_match_char ('/') == MATCH_YES)
3229 {
3230 m2 = gfc_match (" %s /", &group_name);
3231 if (m2 == MATCH_YES)
3232 break;
3233 if (m2 == MATCH_ERROR)
3234 goto error;
3235 goto syntax;
3236 }
3237
3238 if (m != MATCH_YES)
3239 goto syntax;
3240 }
3241 }
3242
3243 done:
3244 return MATCH_YES;
3245
3246 syntax:
3247 gfc_syntax_error (ST_NAMELIST);
3248
3249 error:
3250 return MATCH_ERROR;
3251 }
3252
3253
3254 /* Match a MODULE statement. */
3255
3256 match
3257 gfc_match_module (void)
3258 {
3259 match m;
3260
3261 m = gfc_match (" %s%t", &gfc_new_block);
3262 if (m != MATCH_YES)
3263 return m;
3264
3265 if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
3266 gfc_new_block->name, NULL) == FAILURE)
3267 return MATCH_ERROR;
3268
3269 return MATCH_YES;
3270 }
3271
3272
3273 /* Free equivalence sets and lists. Recursively is the easiest way to
3274 do this. */
3275
3276 void
3277 gfc_free_equiv (gfc_equiv *eq)
3278 {
3279 if (eq == NULL)
3280 return;
3281
3282 gfc_free_equiv (eq->eq);
3283 gfc_free_equiv (eq->next);
3284 gfc_free_expr (eq->expr);
3285 gfc_free (eq);
3286 }
3287
3288
3289 /* Match an EQUIVALENCE statement. */
3290
3291 match
3292 gfc_match_equivalence (void)
3293 {
3294 gfc_equiv *eq, *set, *tail;
3295 gfc_ref *ref;
3296 gfc_symbol *sym;
3297 match m;
3298 gfc_common_head *common_head = NULL;
3299 bool common_flag;
3300 int cnt;
3301
3302 tail = NULL;
3303
3304 for (;;)
3305 {
3306 eq = gfc_get_equiv ();
3307 if (tail == NULL)
3308 tail = eq;
3309
3310 eq->next = gfc_current_ns->equiv;
3311 gfc_current_ns->equiv = eq;
3312
3313 if (gfc_match_char ('(') != MATCH_YES)
3314 goto syntax;
3315
3316 set = eq;
3317 common_flag = FALSE;
3318 cnt = 0;
3319
3320 for (;;)
3321 {
3322 m = gfc_match_equiv_variable (&set->expr);
3323 if (m == MATCH_ERROR)
3324 goto cleanup;
3325 if (m == MATCH_NO)
3326 goto syntax;
3327
3328 /* count the number of objects. */
3329 cnt++;
3330
3331 if (gfc_match_char ('%') == MATCH_YES)
3332 {
3333 gfc_error ("Derived type component %C is not a "
3334 "permitted EQUIVALENCE member");
3335 goto cleanup;
3336 }
3337
3338 for (ref = set->expr->ref; ref; ref = ref->next)
3339 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3340 {
3341 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
3342 "be an array section");
3343 goto cleanup;
3344 }
3345
3346 sym = set->expr->symtree->n.sym;
3347
3348 if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
3349 goto cleanup;
3350
3351 if (sym->attr.in_common)
3352 {
3353 common_flag = TRUE;
3354 common_head = sym->common_head;
3355 }
3356
3357 if (gfc_match_char (')') == MATCH_YES)
3358 break;
3359
3360 if (gfc_match_char (',') != MATCH_YES)
3361 goto syntax;
3362
3363 set->eq = gfc_get_equiv ();
3364 set = set->eq;
3365 }
3366
3367 if (cnt < 2)
3368 {
3369 gfc_error ("EQUIVALENCE at %C requires two or more objects");
3370 goto cleanup;
3371 }
3372
3373 /* If one of the members of an equivalence is in common, then
3374 mark them all as being in common. Before doing this, check
3375 that members of the equivalence group are not in different
3376 common blocks. */
3377 if (common_flag)
3378 for (set = eq; set; set = set->eq)
3379 {
3380 sym = set->expr->symtree->n.sym;
3381 if (sym->common_head && sym->common_head != common_head)
3382 {
3383 gfc_error ("Attempt to indirectly overlap COMMON "
3384 "blocks %s and %s by EQUIVALENCE at %C",
3385 sym->common_head->name, common_head->name);
3386 goto cleanup;
3387 }
3388 sym->attr.in_common = 1;
3389 sym->common_head = common_head;
3390 }
3391
3392 if (gfc_match_eos () == MATCH_YES)
3393 break;
3394 if (gfc_match_char (',') != MATCH_YES)
3395 goto syntax;
3396 }
3397
3398 return MATCH_YES;
3399
3400 syntax:
3401 gfc_syntax_error (ST_EQUIVALENCE);
3402
3403 cleanup:
3404 eq = tail->next;
3405 tail->next = NULL;
3406
3407 gfc_free_equiv (gfc_current_ns->equiv);
3408 gfc_current_ns->equiv = eq;
3409
3410 return MATCH_ERROR;
3411 }
3412
3413
3414 /* Check that a statement function is not recursive. This is done by looking
3415 for the statement function symbol(sym) by looking recursively through its
3416 expression(e). If a reference to sym is found, true is returned.
3417 12.5.4 requires that any variable of function that is implicitly typed
3418 shall have that type confirmed by any subsequent type declaration. The
3419 implicit typing is conveniently done here. */
3420 static bool
3421 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
3422
3423 static bool
3424 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
3425 {
3426
3427 if (e == NULL)
3428 return false;
3429
3430 switch (e->expr_type)
3431 {
3432 case EXPR_FUNCTION:
3433 if (e->symtree == NULL)
3434 return false;
3435
3436 /* Check the name before testing for nested recursion! */
3437 if (sym->name == e->symtree->n.sym->name)
3438 return true;
3439
3440 /* Catch recursion via other statement functions. */
3441 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
3442 && e->symtree->n.sym->value
3443 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
3444 return true;
3445
3446 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3447 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3448
3449 break;
3450
3451 case EXPR_VARIABLE:
3452 if (e->symtree && sym->name == e->symtree->n.sym->name)
3453 return true;
3454
3455 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3456 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3457 break;
3458
3459 default:
3460 break;
3461 }
3462
3463 return false;
3464 }
3465
3466
3467 static bool
3468 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
3469 {
3470 return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
3471 }
3472
3473
3474 /* Match a statement function declaration. It is so easy to match
3475 non-statement function statements with a MATCH_ERROR as opposed to
3476 MATCH_NO that we suppress error message in most cases. */
3477
3478 match
3479 gfc_match_st_function (void)
3480 {
3481 gfc_error_buf old_error;
3482 gfc_symbol *sym;
3483 gfc_expr *expr;
3484 match m;
3485
3486 m = gfc_match_symbol (&sym, 0);
3487 if (m != MATCH_YES)
3488 return m;
3489
3490 gfc_push_error (&old_error);
3491
3492 if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
3493 sym->name, NULL) == FAILURE)
3494 goto undo_error;
3495
3496 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
3497 goto undo_error;
3498
3499 m = gfc_match (" = %e%t", &expr);
3500 if (m == MATCH_NO)
3501 goto undo_error;
3502
3503 gfc_free_error (&old_error);
3504 if (m == MATCH_ERROR)
3505 return m;
3506
3507 if (recursive_stmt_fcn (expr, sym))
3508 {
3509 gfc_error ("Statement function at %L is recursive", &expr->where);
3510 return MATCH_ERROR;
3511 }
3512
3513 sym->value = expr;
3514
3515 return MATCH_YES;
3516
3517 undo_error:
3518 gfc_pop_error (&old_error);
3519 return MATCH_NO;
3520 }
3521
3522
3523 /***************** SELECT CASE subroutines ******************/
3524
3525 /* Free a single case structure. */
3526
3527 static void
3528 free_case (gfc_case *p)
3529 {
3530 if (p->low == p->high)
3531 p->high = NULL;
3532 gfc_free_expr (p->low);
3533 gfc_free_expr (p->high);
3534 gfc_free (p);
3535 }
3536
3537
3538 /* Free a list of case structures. */
3539
3540 void
3541 gfc_free_case_list (gfc_case *p)
3542 {
3543 gfc_case *q;
3544
3545 for (; p; p = q)
3546 {
3547 q = p->next;
3548 free_case (p);
3549 }
3550 }
3551
3552
3553 /* Match a single case selector. */
3554
3555 static match
3556 match_case_selector (gfc_case **cp)
3557 {
3558 gfc_case *c;
3559 match m;
3560
3561 c = gfc_get_case ();
3562 c->where = gfc_current_locus;
3563
3564 if (gfc_match_char (':') == MATCH_YES)
3565 {
3566 m = gfc_match_init_expr (&c->high);
3567 if (m == MATCH_NO)
3568 goto need_expr;
3569 if (m == MATCH_ERROR)
3570 goto cleanup;
3571 }
3572 else
3573 {
3574 m = gfc_match_init_expr (&c->low);
3575 if (m == MATCH_ERROR)
3576 goto cleanup;
3577 if (m == MATCH_NO)
3578 goto need_expr;
3579
3580 /* If we're not looking at a ':' now, make a range out of a single
3581 target. Else get the upper bound for the case range. */
3582 if (gfc_match_char (':') != MATCH_YES)
3583 c->high = c->low;
3584 else
3585 {
3586 m = gfc_match_init_expr (&c->high);
3587 if (m == MATCH_ERROR)
3588 goto cleanup;
3589 /* MATCH_NO is fine. It's OK if nothing is there! */
3590 }
3591 }
3592
3593 *cp = c;
3594 return MATCH_YES;
3595
3596 need_expr:
3597 gfc_error ("Expected initialization expression in CASE at %C");
3598
3599 cleanup:
3600 free_case (c);
3601 return MATCH_ERROR;
3602 }
3603
3604
3605 /* Match the end of a case statement. */
3606
3607 static match
3608 match_case_eos (void)
3609 {
3610 char name[GFC_MAX_SYMBOL_LEN + 1];
3611 match m;
3612
3613 if (gfc_match_eos () == MATCH_YES)
3614 return MATCH_YES;
3615
3616 /* If the case construct doesn't have a case-construct-name, we
3617 should have matched the EOS. */
3618 if (!gfc_current_block ())
3619 {
3620 gfc_error ("Expected the name of the SELECT CASE construct at %C");
3621 return MATCH_ERROR;
3622 }
3623
3624 gfc_gobble_whitespace ();
3625
3626 m = gfc_match_name (name);
3627 if (m != MATCH_YES)
3628 return m;
3629
3630 if (strcmp (name, gfc_current_block ()->name) != 0)
3631 {
3632 gfc_error ("Expected case name of '%s' at %C",
3633 gfc_current_block ()->name);
3634 return MATCH_ERROR;
3635 }
3636
3637 return gfc_match_eos ();
3638 }
3639
3640
3641 /* Match a SELECT statement. */
3642
3643 match
3644 gfc_match_select (void)
3645 {
3646 gfc_expr *expr;
3647 match m;
3648
3649 m = gfc_match_label ();
3650 if (m == MATCH_ERROR)
3651 return m;
3652
3653 m = gfc_match (" select case ( %e )%t", &expr);
3654 if (m != MATCH_YES)
3655 return m;
3656
3657 new_st.op = EXEC_SELECT;
3658 new_st.expr = expr;
3659
3660 return MATCH_YES;
3661 }
3662
3663
3664 /* Match a CASE statement. */
3665
3666 match
3667 gfc_match_case (void)
3668 {
3669 gfc_case *c, *head, *tail;
3670 match m;
3671
3672 head = tail = NULL;
3673
3674 if (gfc_current_state () != COMP_SELECT)
3675 {
3676 gfc_error ("Unexpected CASE statement at %C");
3677 return MATCH_ERROR;
3678 }
3679
3680 if (gfc_match ("% default") == MATCH_YES)
3681 {
3682 m = match_case_eos ();
3683 if (m == MATCH_NO)
3684 goto syntax;
3685 if (m == MATCH_ERROR)
3686 goto cleanup;
3687
3688 new_st.op = EXEC_SELECT;
3689 c = gfc_get_case ();
3690 c->where = gfc_current_locus;
3691 new_st.ext.case_list = c;
3692 return MATCH_YES;
3693 }
3694
3695 if (gfc_match_char ('(') != MATCH_YES)
3696 goto syntax;
3697
3698 for (;;)
3699 {
3700 if (match_case_selector (&c) == MATCH_ERROR)
3701 goto cleanup;
3702
3703 if (head == NULL)
3704 head = c;
3705 else
3706 tail->next = c;
3707
3708 tail = c;
3709
3710 if (gfc_match_char (')') == MATCH_YES)
3711 break;
3712 if (gfc_match_char (',') != MATCH_YES)
3713 goto syntax;
3714 }
3715
3716 m = match_case_eos ();
3717 if (m == MATCH_NO)
3718 goto syntax;
3719 if (m == MATCH_ERROR)
3720 goto cleanup;
3721
3722 new_st.op = EXEC_SELECT;
3723 new_st.ext.case_list = head;
3724
3725 return MATCH_YES;
3726
3727 syntax:
3728 gfc_error ("Syntax error in CASE-specification at %C");
3729
3730 cleanup:
3731 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
3732 return MATCH_ERROR;
3733 }
3734
3735 /********************* WHERE subroutines ********************/
3736
3737 /* Match the rest of a simple WHERE statement that follows an IF statement.
3738 */
3739
3740 static match
3741 match_simple_where (void)
3742 {
3743 gfc_expr *expr;
3744 gfc_code *c;
3745 match m;
3746
3747 m = gfc_match (" ( %e )", &expr);
3748 if (m != MATCH_YES)
3749 return m;
3750
3751 m = gfc_match_assignment ();
3752 if (m == MATCH_NO)
3753 goto syntax;
3754 if (m == MATCH_ERROR)
3755 goto cleanup;
3756
3757 if (gfc_match_eos () != MATCH_YES)
3758 goto syntax;
3759
3760 c = gfc_get_code ();
3761
3762 c->op = EXEC_WHERE;
3763 c->expr = expr;
3764 c->next = gfc_get_code ();
3765
3766 *c->next = new_st;
3767 gfc_clear_new_st ();
3768
3769 new_st.op = EXEC_WHERE;
3770 new_st.block = c;
3771
3772 return MATCH_YES;
3773
3774 syntax:
3775 gfc_syntax_error (ST_WHERE);
3776
3777 cleanup:
3778 gfc_free_expr (expr);
3779 return MATCH_ERROR;
3780 }
3781
3782
3783 /* Match a WHERE statement. */
3784
3785 match
3786 gfc_match_where (gfc_statement *st)
3787 {
3788 gfc_expr *expr;
3789 match m0, m;
3790 gfc_code *c;
3791
3792 m0 = gfc_match_label ();
3793 if (m0 == MATCH_ERROR)
3794 return m0;
3795
3796 m = gfc_match (" where ( %e )", &expr);
3797 if (m != MATCH_YES)
3798 return m;
3799
3800 if (gfc_match_eos () == MATCH_YES)
3801 {
3802 *st = ST_WHERE_BLOCK;
3803 new_st.op = EXEC_WHERE;
3804 new_st.expr = expr;
3805 return MATCH_YES;
3806 }
3807
3808 m = gfc_match_assignment ();
3809 if (m == MATCH_NO)
3810 gfc_syntax_error (ST_WHERE);
3811
3812 if (m != MATCH_YES)
3813 {
3814 gfc_free_expr (expr);
3815 return MATCH_ERROR;
3816 }
3817
3818 /* We've got a simple WHERE statement. */
3819 *st = ST_WHERE;
3820 c = gfc_get_code ();
3821
3822 c->op = EXEC_WHERE;
3823 c->expr = expr;
3824 c->next = gfc_get_code ();
3825
3826 *c->next = new_st;
3827 gfc_clear_new_st ();
3828
3829 new_st.op = EXEC_WHERE;
3830 new_st.block = c;
3831
3832 return MATCH_YES;
3833 }
3834
3835
3836 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3837 new_st if successful. */
3838
3839 match
3840 gfc_match_elsewhere (void)
3841 {
3842 char name[GFC_MAX_SYMBOL_LEN + 1];
3843 gfc_expr *expr;
3844 match m;
3845
3846 if (gfc_current_state () != COMP_WHERE)
3847 {
3848 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3849 return MATCH_ERROR;
3850 }
3851
3852 expr = NULL;
3853
3854 if (gfc_match_char ('(') == MATCH_YES)
3855 {
3856 m = gfc_match_expr (&expr);
3857 if (m == MATCH_NO)
3858 goto syntax;
3859 if (m == MATCH_ERROR)
3860 return MATCH_ERROR;
3861
3862 if (gfc_match_char (')') != MATCH_YES)
3863 goto syntax;
3864 }
3865
3866 if (gfc_match_eos () != MATCH_YES)
3867 {
3868 /* Only makes sense if we have a where-construct-name. */
3869 if (!gfc_current_block ())
3870 {
3871 m = MATCH_ERROR;
3872 goto cleanup;
3873 }
3874 /* Better be a name at this point. */
3875 m = gfc_match_name (name);
3876 if (m == MATCH_NO)
3877 goto syntax;
3878 if (m == MATCH_ERROR)
3879 goto cleanup;
3880
3881 if (gfc_match_eos () != MATCH_YES)
3882 goto syntax;
3883
3884 if (strcmp (name, gfc_current_block ()->name) != 0)
3885 {
3886 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3887 name, gfc_current_block ()->name);
3888 goto cleanup;
3889 }
3890 }
3891
3892 new_st.op = EXEC_WHERE;
3893 new_st.expr = expr;
3894 return MATCH_YES;
3895
3896 syntax:
3897 gfc_syntax_error (ST_ELSEWHERE);
3898
3899 cleanup:
3900 gfc_free_expr (expr);
3901 return MATCH_ERROR;
3902 }
3903
3904
3905 /******************** FORALL subroutines ********************/
3906
3907 /* Free a list of FORALL iterators. */
3908
3909 void
3910 gfc_free_forall_iterator (gfc_forall_iterator *iter)
3911 {
3912 gfc_forall_iterator *next;
3913
3914 while (iter)
3915 {
3916 next = iter->next;
3917 gfc_free_expr (iter->var);
3918 gfc_free_expr (iter->start);
3919 gfc_free_expr (iter->end);
3920 gfc_free_expr (iter->stride);
3921 gfc_free (iter);
3922 iter = next;
3923 }
3924 }
3925
3926
3927 /* Match an iterator as part of a FORALL statement. The format is:
3928
3929 <var> = <start>:<end>[:<stride>]
3930
3931 On MATCH_NO, the caller tests for the possibility that there is a
3932 scalar mask expression. */
3933
3934 static match
3935 match_forall_iterator (gfc_forall_iterator **result)
3936 {
3937 gfc_forall_iterator *iter;
3938 locus where;
3939 match m;
3940
3941 where = gfc_current_locus;
3942 iter = XCNEW (gfc_forall_iterator);
3943
3944 m = gfc_match_expr (&iter->var);
3945 if (m != MATCH_YES)
3946 goto cleanup;
3947
3948 if (gfc_match_char ('=') != MATCH_YES
3949 || iter->var->expr_type != EXPR_VARIABLE)
3950 {
3951 m = MATCH_NO;
3952 goto cleanup;
3953 }
3954
3955 m = gfc_match_expr (&iter->start);
3956 if (m != MATCH_YES)
3957 goto cleanup;
3958
3959 if (gfc_match_char (':') != MATCH_YES)
3960 goto syntax;
3961
3962 m = gfc_match_expr (&iter->end);
3963 if (m == MATCH_NO)
3964 goto syntax;
3965 if (m == MATCH_ERROR)
3966 goto cleanup;
3967
3968 if (gfc_match_char (':') == MATCH_NO)
3969 iter->stride = gfc_int_expr (1);
3970 else
3971 {
3972 m = gfc_match_expr (&iter->stride);
3973 if (m == MATCH_NO)
3974 goto syntax;
3975 if (m == MATCH_ERROR)
3976 goto cleanup;
3977 }
3978
3979 /* Mark the iteration variable's symbol as used as a FORALL index. */
3980 iter->var->symtree->n.sym->forall_index = true;
3981
3982 *result = iter;
3983 return MATCH_YES;
3984
3985 syntax:
3986 gfc_error ("Syntax error in FORALL iterator at %C");
3987 m = MATCH_ERROR;
3988
3989 cleanup:
3990
3991 gfc_current_locus = where;
3992 gfc_free_forall_iterator (iter);
3993 return m;
3994 }
3995
3996
3997 /* Match the header of a FORALL statement. */
3998
3999 static match
4000 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
4001 {
4002 gfc_forall_iterator *head, *tail, *new_iter;
4003 gfc_expr *msk;
4004 match m;
4005
4006 gfc_gobble_whitespace ();
4007
4008 head = tail = NULL;
4009 msk = NULL;
4010
4011 if (gfc_match_char ('(') != MATCH_YES)
4012 return MATCH_NO;
4013
4014 m = match_forall_iterator (&new_iter);
4015 if (m == MATCH_ERROR)
4016 goto cleanup;
4017 if (m == MATCH_NO)
4018 goto syntax;
4019
4020 head = tail = new_iter;
4021
4022 for (;;)
4023 {
4024 if (gfc_match_char (',') != MATCH_YES)
4025 break;
4026
4027 m = match_forall_iterator (&new_iter);
4028 if (m == MATCH_ERROR)
4029 goto cleanup;
4030
4031 if (m == MATCH_YES)
4032 {
4033 tail->next = new_iter;
4034 tail = new_iter;
4035 continue;
4036 }
4037
4038 /* Have to have a mask expression. */
4039
4040 m = gfc_match_expr (&msk);
4041 if (m == MATCH_NO)
4042 goto syntax;
4043 if (m == MATCH_ERROR)
4044 goto cleanup;
4045
4046 break;
4047 }
4048
4049 if (gfc_match_char (')') == MATCH_NO)
4050 goto syntax;
4051
4052 *phead = head;
4053 *mask = msk;
4054 return MATCH_YES;
4055
4056 syntax:
4057 gfc_syntax_error (ST_FORALL);
4058
4059 cleanup:
4060 gfc_free_expr (msk);
4061 gfc_free_forall_iterator (head);
4062
4063 return MATCH_ERROR;
4064 }
4065
4066 /* Match the rest of a simple FORALL statement that follows an
4067 IF statement. */
4068
4069 static match
4070 match_simple_forall (void)
4071 {
4072 gfc_forall_iterator *head;
4073 gfc_expr *mask;
4074 gfc_code *c;
4075 match m;
4076
4077 mask = NULL;
4078 head = NULL;
4079 c = NULL;
4080
4081 m = match_forall_header (&head, &mask);
4082
4083 if (m == MATCH_NO)
4084 goto syntax;
4085 if (m != MATCH_YES)
4086 goto cleanup;
4087
4088 m = gfc_match_assignment ();
4089
4090 if (m == MATCH_ERROR)
4091 goto cleanup;
4092 if (m == MATCH_NO)
4093 {
4094 m = gfc_match_pointer_assignment ();
4095 if (m == MATCH_ERROR)
4096 goto cleanup;
4097 if (m == MATCH_NO)
4098 goto syntax;
4099 }
4100
4101 c = gfc_get_code ();
4102 *c = new_st;
4103 c->loc = gfc_current_locus;
4104
4105 if (gfc_match_eos () != MATCH_YES)
4106 goto syntax;
4107
4108 gfc_clear_new_st ();
4109 new_st.op = EXEC_FORALL;
4110 new_st.expr = mask;
4111 new_st.ext.forall_iterator = head;
4112 new_st.block = gfc_get_code ();
4113
4114 new_st.block->op = EXEC_FORALL;
4115 new_st.block->next = c;
4116
4117 return MATCH_YES;
4118
4119 syntax:
4120 gfc_syntax_error (ST_FORALL);
4121
4122 cleanup:
4123 gfc_free_forall_iterator (head);
4124 gfc_free_expr (mask);
4125
4126 return MATCH_ERROR;
4127 }
4128
4129
4130 /* Match a FORALL statement. */
4131
4132 match
4133 gfc_match_forall (gfc_statement *st)
4134 {
4135 gfc_forall_iterator *head;
4136 gfc_expr *mask;
4137 gfc_code *c;
4138 match m0, m;
4139
4140 head = NULL;
4141 mask = NULL;
4142 c = NULL;
4143
4144 m0 = gfc_match_label ();
4145 if (m0 == MATCH_ERROR)
4146 return MATCH_ERROR;
4147
4148 m = gfc_match (" forall");
4149 if (m != MATCH_YES)
4150 return m;
4151
4152 m = match_forall_header (&head, &mask);
4153 if (m == MATCH_ERROR)
4154 goto cleanup;
4155 if (m == MATCH_NO)
4156 goto syntax;
4157
4158 if (gfc_match_eos () == MATCH_YES)
4159 {
4160 *st = ST_FORALL_BLOCK;
4161 new_st.op = EXEC_FORALL;
4162 new_st.expr = mask;
4163 new_st.ext.forall_iterator = head;
4164 return MATCH_YES;
4165 }
4166
4167 m = gfc_match_assignment ();
4168 if (m == MATCH_ERROR)
4169 goto cleanup;
4170 if (m == MATCH_NO)
4171 {
4172 m = gfc_match_pointer_assignment ();
4173 if (m == MATCH_ERROR)
4174 goto cleanup;
4175 if (m == MATCH_NO)
4176 goto syntax;
4177 }
4178
4179 c = gfc_get_code ();
4180 *c = new_st;
4181 c->loc = gfc_current_locus;
4182
4183 gfc_clear_new_st ();
4184 new_st.op = EXEC_FORALL;
4185 new_st.expr = mask;
4186 new_st.ext.forall_iterator = head;
4187 new_st.block = gfc_get_code ();
4188 new_st.block->op = EXEC_FORALL;
4189 new_st.block->next = c;
4190
4191 *st = ST_FORALL;
4192 return MATCH_YES;
4193
4194 syntax:
4195 gfc_syntax_error (ST_FORALL);
4196
4197 cleanup:
4198 gfc_free_forall_iterator (head);
4199 gfc_free_expr (mask);
4200 gfc_free_statements (c);
4201 return MATCH_NO;
4202 }