projects / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
re PR fortran/39626 (Correctly implement details of Fortran 2008 BLOCK construct)
[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, false))
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.expr1 = 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 || gfc_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.expr1 = 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 feature: Arithmetic IF "
1387 "statement at %C") == FAILURE)
1388 return MATCH_ERROR;
1389
1390 new_st.op = EXEC_ARITHMETIC_IF;
1391 new_st.expr1 = expr;
1392 new_st.label1 = 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 feature: Arithmetic IF "
1468 "statement at %C") == FAILURE)
1469 return MATCH_ERROR;
1470
1471 new_st.op = EXEC_ARITHMETIC_IF;
1472 new_st.expr1 = expr;
1473 new_st.label1 = 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.expr1 = 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->expr1 = 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.expr1 = 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 BLOCK statement. */
1709
1710 match
1711 gfc_match_block (void)
1712 {
1713 match m;
1714
1715 if (gfc_match_label () == MATCH_ERROR)
1716 return MATCH_ERROR;
1717
1718 if (gfc_match (" block") != MATCH_YES)
1719 return MATCH_NO;
1720
1721 /* For this to be a correct BLOCK statement, the line must end now. */
1722 m = gfc_match_eos ();
1723 if (m == MATCH_ERROR)
1724 return MATCH_ERROR;
1725 if (m == MATCH_NO)
1726 return MATCH_NO;
1727
1728 return MATCH_YES;
1729 }
1730
1731
1732 /* Match a DO statement. */
1733
1734 match
1735 gfc_match_do (void)
1736 {
1737 gfc_iterator iter, *ip;
1738 locus old_loc;
1739 gfc_st_label *label;
1740 match m;
1741
1742 old_loc = gfc_current_locus;
1743
1744 label = NULL;
1745 iter.var = iter.start = iter.end = iter.step = NULL;
1746
1747 m = gfc_match_label ();
1748 if (m == MATCH_ERROR)
1749 return m;
1750
1751 if (gfc_match (" do") != MATCH_YES)
1752 return MATCH_NO;
1753
1754 m = gfc_match_st_label (&label);
1755 if (m == MATCH_ERROR)
1756 goto cleanup;
1757
1758 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
1759
1760 if (gfc_match_eos () == MATCH_YES)
1761 {
1762 iter.end = gfc_logical_expr (1, NULL);
1763 new_st.op = EXEC_DO_WHILE;
1764 goto done;
1765 }
1766
1767 /* Match an optional comma, if no comma is found, a space is obligatory. */
1768 if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
1769 return MATCH_NO;
1770
1771 /* Check for balanced parens. */
1772
1773 if (gfc_match_parens () == MATCH_ERROR)
1774 return MATCH_ERROR;
1775
1776 /* See if we have a DO WHILE. */
1777 if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1778 {
1779 new_st.op = EXEC_DO_WHILE;
1780 goto done;
1781 }
1782
1783 /* The abortive DO WHILE may have done something to the symbol
1784 table, so we start over. */
1785 gfc_undo_symbols ();
1786 gfc_current_locus = old_loc;
1787
1788 gfc_match_label (); /* This won't error. */
1789 gfc_match (" do "); /* This will work. */
1790
1791 gfc_match_st_label (&label); /* Can't error out. */
1792 gfc_match_char (','); /* Optional comma. */
1793
1794 m = gfc_match_iterator (&iter, 0);
1795 if (m == MATCH_NO)
1796 return MATCH_NO;
1797 if (m == MATCH_ERROR)
1798 goto cleanup;
1799
1800 iter.var->symtree->n.sym->attr.implied_index = 0;
1801 gfc_check_do_variable (iter.var->symtree);
1802
1803 if (gfc_match_eos () != MATCH_YES)
1804 {
1805 gfc_syntax_error (ST_DO);
1806 goto cleanup;
1807 }
1808
1809 new_st.op = EXEC_DO;
1810
1811 done:
1812 if (label != NULL
1813 && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1814 goto cleanup;
1815
1816 new_st.label1 = label;
1817
1818 if (new_st.op == EXEC_DO_WHILE)
1819 new_st.expr1 = iter.end;
1820 else
1821 {
1822 new_st.ext.iterator = ip = gfc_get_iterator ();
1823 *ip = iter;
1824 }
1825
1826 return MATCH_YES;
1827
1828 cleanup:
1829 gfc_free_iterator (&iter, 0);
1830
1831 return MATCH_ERROR;
1832 }
1833
1834
1835 /* Match an EXIT or CYCLE statement. */
1836
1837 static match
1838 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1839 {
1840 gfc_state_data *p, *o;
1841 gfc_symbol *sym;
1842 match m;
1843
1844 if (gfc_match_eos () == MATCH_YES)
1845 sym = NULL;
1846 else
1847 {
1848 m = gfc_match ("% %s%t", &sym);
1849 if (m == MATCH_ERROR)
1850 return MATCH_ERROR;
1851 if (m == MATCH_NO)
1852 {
1853 gfc_syntax_error (st);
1854 return MATCH_ERROR;
1855 }
1856
1857 if (sym->attr.flavor != FL_LABEL)
1858 {
1859 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1860 sym->name, gfc_ascii_statement (st));
1861 return MATCH_ERROR;
1862 }
1863 }
1864
1865 /* Find the loop mentioned specified by the label (or lack of a label). */
1866 for (o = NULL, p = gfc_state_stack; p; p = p->previous)
1867 if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1868 break;
1869 else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
1870 o = p;
1871
1872 if (p == NULL)
1873 {
1874 if (sym == NULL)
1875 gfc_error ("%s statement at %C is not within a loop",
1876 gfc_ascii_statement (st));
1877 else
1878 gfc_error ("%s statement at %C is not within loop '%s'",
1879 gfc_ascii_statement (st), sym->name);
1880
1881 return MATCH_ERROR;
1882 }
1883
1884 if (o != NULL)
1885 {
1886 gfc_error ("%s statement at %C leaving OpenMP structured block",
1887 gfc_ascii_statement (st));
1888 return MATCH_ERROR;
1889 }
1890 else if (st == ST_EXIT
1891 && p->previous != NULL
1892 && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
1893 && (p->previous->head->op == EXEC_OMP_DO
1894 || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
1895 {
1896 gcc_assert (p->previous->head->next != NULL);
1897 gcc_assert (p->previous->head->next->op == EXEC_DO
1898 || p->previous->head->next->op == EXEC_DO_WHILE);
1899 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1900 return MATCH_ERROR;
1901 }
1902
1903 /* Save the first statement in the loop - needed by the backend. */
1904 new_st.ext.whichloop = p->head;
1905
1906 new_st.op = op;
1907
1908 return MATCH_YES;
1909 }
1910
1911
1912 /* Match the EXIT statement. */
1913
1914 match
1915 gfc_match_exit (void)
1916 {
1917 return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1918 }
1919
1920
1921 /* Match the CYCLE statement. */
1922
1923 match
1924 gfc_match_cycle (void)
1925 {
1926 return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1927 }
1928
1929
1930 /* Match a number or character constant after a STOP or PAUSE statement. */
1931
1932 static match
1933 gfc_match_stopcode (gfc_statement st)
1934 {
1935 int stop_code;
1936 gfc_expr *e;
1937 match m;
1938 int cnt;
1939
1940 stop_code = -1;
1941 e = NULL;
1942
1943 if (gfc_match_eos () != MATCH_YES)
1944 {
1945 m = gfc_match_small_literal_int (&stop_code, &cnt);
1946 if (m == MATCH_ERROR)
1947 goto cleanup;
1948
1949 if (m == MATCH_YES && cnt > 5)
1950 {
1951 gfc_error ("Too many digits in STOP code at %C");
1952 goto cleanup;
1953 }
1954
1955 if (m == MATCH_NO)
1956 {
1957 /* Try a character constant. */
1958 m = gfc_match_expr (&e);
1959 if (m == MATCH_ERROR)
1960 goto cleanup;
1961 if (m == MATCH_NO)
1962 goto syntax;
1963 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1964 goto syntax;
1965 }
1966
1967 if (gfc_match_eos () != MATCH_YES)
1968 goto syntax;
1969 }
1970
1971 if (gfc_pure (NULL))
1972 {
1973 gfc_error ("%s statement not allowed in PURE procedure at %C",
1974 gfc_ascii_statement (st));
1975 goto cleanup;
1976 }
1977
1978 new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1979 new_st.expr1 = e;
1980 new_st.ext.stop_code = stop_code;
1981
1982 return MATCH_YES;
1983
1984 syntax:
1985 gfc_syntax_error (st);
1986
1987 cleanup:
1988
1989 gfc_free_expr (e);
1990 return MATCH_ERROR;
1991 }
1992
1993
1994 /* Match the (deprecated) PAUSE statement. */
1995
1996 match
1997 gfc_match_pause (void)
1998 {
1999 match m;
2000
2001 m = gfc_match_stopcode (ST_PAUSE);
2002 if (m == MATCH_YES)
2003 {
2004 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
2005 " at %C")
2006 == FAILURE)
2007 m = MATCH_ERROR;
2008 }
2009 return m;
2010 }
2011
2012
2013 /* Match the STOP statement. */
2014
2015 match
2016 gfc_match_stop (void)
2017 {
2018 return gfc_match_stopcode (ST_STOP);
2019 }
2020
2021
2022 /* Match a CONTINUE statement. */
2023
2024 match
2025 gfc_match_continue (void)
2026 {
2027 if (gfc_match_eos () != MATCH_YES)
2028 {
2029 gfc_syntax_error (ST_CONTINUE);
2030 return MATCH_ERROR;
2031 }
2032
2033 new_st.op = EXEC_CONTINUE;
2034 return MATCH_YES;
2035 }
2036
2037
2038 /* Match the (deprecated) ASSIGN statement. */
2039
2040 match
2041 gfc_match_assign (void)
2042 {
2043 gfc_expr *expr;
2044 gfc_st_label *label;
2045
2046 if (gfc_match (" %l", &label) == MATCH_YES)
2047 {
2048 if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
2049 return MATCH_ERROR;
2050 if (gfc_match (" to %v%t", &expr) == MATCH_YES)
2051 {
2052 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
2053 "statement at %C")
2054 == FAILURE)
2055 return MATCH_ERROR;
2056
2057 expr->symtree->n.sym->attr.assign = 1;
2058
2059 new_st.op = EXEC_LABEL_ASSIGN;
2060 new_st.label1 = label;
2061 new_st.expr1 = expr;
2062 return MATCH_YES;
2063 }
2064 }
2065 return MATCH_NO;
2066 }
2067
2068
2069 /* Match the GO TO statement. As a computed GOTO statement is
2070 matched, it is transformed into an equivalent SELECT block. No
2071 tree is necessary, and the resulting jumps-to-jumps are
2072 specifically optimized away by the back end. */
2073
2074 match
2075 gfc_match_goto (void)
2076 {
2077 gfc_code *head, *tail;
2078 gfc_expr *expr;
2079 gfc_case *cp;
2080 gfc_st_label *label;
2081 int i;
2082 match m;
2083
2084 if (gfc_match (" %l%t", &label) == MATCH_YES)
2085 {
2086 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2087 return MATCH_ERROR;
2088
2089 new_st.op = EXEC_GOTO;
2090 new_st.label1 = label;
2091 return MATCH_YES;
2092 }
2093
2094 /* The assigned GO TO statement. */
2095
2096 if (gfc_match_variable (&expr, 0) == MATCH_YES)
2097 {
2098 if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
2099 "statement at %C")
2100 == FAILURE)
2101 return MATCH_ERROR;
2102
2103 new_st.op = EXEC_GOTO;
2104 new_st.expr1 = expr;
2105
2106 if (gfc_match_eos () == MATCH_YES)
2107 return MATCH_YES;
2108
2109 /* Match label list. */
2110 gfc_match_char (',');
2111 if (gfc_match_char ('(') != MATCH_YES)
2112 {
2113 gfc_syntax_error (ST_GOTO);
2114 return MATCH_ERROR;
2115 }
2116 head = tail = NULL;
2117
2118 do
2119 {
2120 m = gfc_match_st_label (&label);
2121 if (m != MATCH_YES)
2122 goto syntax;
2123
2124 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2125 goto cleanup;
2126
2127 if (head == NULL)
2128 head = tail = gfc_get_code ();
2129 else
2130 {
2131 tail->block = gfc_get_code ();
2132 tail = tail->block;
2133 }
2134
2135 tail->label1 = label;
2136 tail->op = EXEC_GOTO;
2137 }
2138 while (gfc_match_char (',') == MATCH_YES);
2139
2140 if (gfc_match (")%t") != MATCH_YES)
2141 goto syntax;
2142
2143 if (head == NULL)
2144 {
2145 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2146 goto syntax;
2147 }
2148 new_st.block = head;
2149
2150 return MATCH_YES;
2151 }
2152
2153 /* Last chance is a computed GO TO statement. */
2154 if (gfc_match_char ('(') != MATCH_YES)
2155 {
2156 gfc_syntax_error (ST_GOTO);
2157 return MATCH_ERROR;
2158 }
2159
2160 head = tail = NULL;
2161 i = 1;
2162
2163 do
2164 {
2165 m = gfc_match_st_label (&label);
2166 if (m != MATCH_YES)
2167 goto syntax;
2168
2169 if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2170 goto cleanup;
2171
2172 if (head == NULL)
2173 head = tail = gfc_get_code ();
2174 else
2175 {
2176 tail->block = gfc_get_code ();
2177 tail = tail->block;
2178 }
2179
2180 cp = gfc_get_case ();
2181 cp->low = cp->high = gfc_int_expr (i++);
2182
2183 tail->op = EXEC_SELECT;
2184 tail->ext.case_list = cp;
2185
2186 tail->next = gfc_get_code ();
2187 tail->next->op = EXEC_GOTO;
2188 tail->next->label1 = label;
2189 }
2190 while (gfc_match_char (',') == MATCH_YES);
2191
2192 if (gfc_match_char (')') != MATCH_YES)
2193 goto syntax;
2194
2195 if (head == NULL)
2196 {
2197 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2198 goto syntax;
2199 }
2200
2201 /* Get the rest of the statement. */
2202 gfc_match_char (',');
2203
2204 if (gfc_match (" %e%t", &expr) != MATCH_YES)
2205 goto syntax;
2206
2207 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Computed GOTO "
2208 "at %C") == FAILURE)
2209 return MATCH_ERROR;
2210
2211 /* At this point, a computed GOTO has been fully matched and an
2212 equivalent SELECT statement constructed. */
2213
2214 new_st.op = EXEC_SELECT;
2215 new_st.expr1 = NULL;
2216
2217 /* Hack: For a "real" SELECT, the expression is in expr. We put
2218 it in expr2 so we can distinguish then and produce the correct
2219 diagnostics. */
2220 new_st.expr2 = expr;
2221 new_st.block = head;
2222 return MATCH_YES;
2223
2224 syntax:
2225 gfc_syntax_error (ST_GOTO);
2226 cleanup:
2227 gfc_free_statements (head);
2228 return MATCH_ERROR;
2229 }
2230
2231
2232 /* Frees a list of gfc_alloc structures. */
2233
2234 void
2235 gfc_free_alloc_list (gfc_alloc *p)
2236 {
2237 gfc_alloc *q;
2238
2239 for (; p; p = q)
2240 {
2241 q = p->next;
2242 gfc_free_expr (p->expr);
2243 gfc_free (p);
2244 }
2245 }
2246
2247
2248 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2249 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2250 It only includes the intrinsic types from the Fortran 2003 standard
2251 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2252 the implicit_flag is not needed, so it was removed. Derived types are
2253 identified by their name alone. */
2254
2255 static match
2256 match_type_spec (gfc_typespec *ts)
2257 {
2258 match m;
2259 gfc_symbol *derived;
2260 locus old_locus;
2261
2262 gfc_clear_ts (ts);
2263 old_locus = gfc_current_locus;
2264
2265 if (gfc_match ("integer") == MATCH_YES)
2266 {
2267 ts->type = BT_INTEGER;
2268 ts->kind = gfc_default_integer_kind;
2269 goto kind_selector;
2270 }
2271
2272 if (gfc_match ("real") == MATCH_YES)
2273 {
2274 ts->type = BT_REAL;
2275 ts->kind = gfc_default_real_kind;
2276 goto kind_selector;
2277 }
2278
2279 if (gfc_match ("double precision") == MATCH_YES)
2280 {
2281 ts->type = BT_REAL;
2282 ts->kind = gfc_default_double_kind;
2283 return MATCH_YES;
2284 }
2285
2286 if (gfc_match ("complex") == MATCH_YES)
2287 {
2288 ts->type = BT_COMPLEX;
2289 ts->kind = gfc_default_complex_kind;
2290 goto kind_selector;
2291 }
2292
2293 if (gfc_match ("character") == MATCH_YES)
2294 {
2295 ts->type = BT_CHARACTER;
2296 goto char_selector;
2297 }
2298
2299 if (gfc_match ("logical") == MATCH_YES)
2300 {
2301 ts->type = BT_LOGICAL;
2302 ts->kind = gfc_default_logical_kind;
2303 goto kind_selector;
2304 }
2305
2306 if (gfc_match_symbol (&derived, 1) == MATCH_YES)
2307 {
2308 if (derived->attr.flavor == FL_DERIVED)
2309 {
2310 old_locus = gfc_current_locus;
2311 if (gfc_match (" :: ") != MATCH_YES)
2312 return MATCH_ERROR;
2313 gfc_current_locus = old_locus;
2314 ts->type = BT_DERIVED;
2315 ts->u.derived = derived;
2316 /* Enfore F03:C401. */
2317 if (derived->attr.abstract)
2318 {
2319 gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
2320 derived->name, &old_locus);
2321 return MATCH_ERROR;
2322 }
2323 return MATCH_YES;
2324 }
2325 else
2326 {
2327 if (gfc_match (" :: ") == MATCH_YES)
2328 {
2329 /* Enforce F03:C476. */
2330 gfc_error ("'%s' at %L is not an accessible derived type",
2331 derived->name, &old_locus);
2332 return MATCH_ERROR;
2333 }
2334 else
2335 {
2336 gfc_current_locus = old_locus;
2337 return MATCH_NO;
2338 }
2339 }
2340 }
2341
2342 /* If a type is not matched, simply return MATCH_NO. */
2343 return MATCH_NO;
2344
2345 kind_selector:
2346
2347 gfc_gobble_whitespace ();
2348 if (gfc_peek_ascii_char () == '*')
2349 {
2350 gfc_error ("Invalid type-spec at %C");
2351 return MATCH_ERROR;
2352 }
2353
2354 m = gfc_match_kind_spec (ts, false);
2355
2356 if (m == MATCH_NO)
2357 m = MATCH_YES; /* No kind specifier found. */
2358
2359 return m;
2360
2361 char_selector:
2362
2363 m = gfc_match_char_spec (ts);
2364
2365 if (m == MATCH_NO)
2366 m = MATCH_YES; /* No kind specifier found. */
2367
2368 return m;
2369 }
2370
2371
2372 /* Used in gfc_match_allocate to check that a allocation-object and
2373 a source-expr are conformable. This does not catch all possible
2374 cases; in particular a runtime checking is needed. */
2375
2376 static gfc_try
2377 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
2378 {
2379 /* First compare rank. */
2380 if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
2381 {
2382 gfc_error ("Source-expr at %L must be scalar or have the "
2383 "same rank as the allocate-object at %L",
2384 &e1->where, &e2->where);
2385 return FAILURE;
2386 }
2387
2388 if (e1->shape)
2389 {
2390 int i;
2391 mpz_t s;
2392
2393 mpz_init (s);
2394
2395 for (i = 0; i < e1->rank; i++)
2396 {
2397 if (e2->ref->u.ar.end[i])
2398 {
2399 mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
2400 mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
2401 mpz_add_ui (s, s, 1);
2402 }
2403 else
2404 {
2405 mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
2406 }
2407
2408 if (mpz_cmp (e1->shape[i], s) != 0)
2409 {
2410 gfc_error ("Source-expr at %L and allocate-object at %L must "
2411 "have the same shape", &e1->where, &e2->where);
2412 mpz_clear (s);
2413 return FAILURE;
2414 }
2415 }
2416
2417 mpz_clear (s);
2418 }
2419
2420 return SUCCESS;
2421 }
2422
2423
2424 /* Match an ALLOCATE statement. */
2425
2426 match
2427 gfc_match_allocate (void)
2428 {
2429 gfc_alloc *head, *tail;
2430 gfc_expr *stat, *errmsg, *tmp, *source;
2431 gfc_typespec ts;
2432 match m;
2433 locus old_locus;
2434 bool saw_stat, saw_errmsg, saw_source, b1, b2, b3;
2435
2436 head = tail = NULL;
2437 stat = errmsg = source = tmp = NULL;
2438 saw_stat = saw_errmsg = saw_source = false;
2439
2440 if (gfc_match_char ('(') != MATCH_YES)
2441 goto syntax;
2442
2443 /* Match an optional type-spec. */
2444 old_locus = gfc_current_locus;
2445 m = match_type_spec (&ts);
2446 if (m == MATCH_ERROR)
2447 goto cleanup;
2448 else if (m == MATCH_NO)
2449 ts.type = BT_UNKNOWN;
2450 else
2451 {
2452 if (gfc_match (" :: ") == MATCH_YES)
2453 {
2454 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
2455 "ALLOCATE at %L", &old_locus) == FAILURE)
2456 goto cleanup;
2457 }
2458 else
2459 {
2460 ts.type = BT_UNKNOWN;
2461 gfc_current_locus = old_locus;
2462 }
2463 }
2464
2465 for (;;)
2466 {
2467 if (head == NULL)
2468 head = tail = gfc_get_alloc ();
2469 else
2470 {
2471 tail->next = gfc_get_alloc ();
2472 tail = tail->next;
2473 }
2474
2475 m = gfc_match_variable (&tail->expr, 0);
2476 if (m == MATCH_NO)
2477 goto syntax;
2478 if (m == MATCH_ERROR)
2479 goto cleanup;
2480
2481 if (gfc_check_do_variable (tail->expr->symtree))
2482 goto cleanup;
2483
2484 if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
2485 {
2486 gfc_error ("Bad allocate-object at %C for a PURE procedure");
2487 goto cleanup;
2488 }
2489
2490 /* The ALLOCATE statement had an optional typespec. Check the
2491 constraints. */
2492 if (ts.type != BT_UNKNOWN)
2493 {
2494 /* Enforce F03:C624. */
2495 if (!gfc_type_compatible (&tail->expr->ts, &ts))
2496 {
2497 gfc_error ("Type of entity at %L is type incompatible with "
2498 "typespec", &tail->expr->where);
2499 goto cleanup;
2500 }
2501
2502 /* Enforce F03:C627. */
2503 if (ts.kind != tail->expr->ts.kind)
2504 {
2505 gfc_error ("Kind type parameter for entity at %L differs from "
2506 "the kind type parameter of the typespec",
2507 &tail->expr->where);
2508 goto cleanup;
2509 }
2510 }
2511
2512 if (tail->expr->ts.type == BT_DERIVED)
2513 tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
2514
2515 /* FIXME: disable the checking on derived types and arrays. */
2516 b1 = !(tail->expr->ref
2517 && (tail->expr->ref->type == REF_COMPONENT
2518 || tail->expr->ref->type == REF_ARRAY));
2519 b2 = tail->expr->symtree->n.sym
2520 && !(tail->expr->symtree->n.sym->attr.allocatable
2521 || tail->expr->symtree->n.sym->attr.pointer
2522 || tail->expr->symtree->n.sym->attr.proc_pointer);
2523 b3 = tail->expr->symtree->n.sym
2524 && tail->expr->symtree->n.sym->ns
2525 && tail->expr->symtree->n.sym->ns->proc_name
2526 && (tail->expr->symtree->n.sym->ns->proc_name->attr.allocatable
2527 || tail->expr->symtree->n.sym->ns->proc_name->attr.pointer
2528 || tail->expr->symtree->n.sym->ns->proc_name->attr.proc_pointer);
2529 if (b1 && b2 && !b3)
2530 {
2531 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2532 "or an allocatable variable");
2533 goto cleanup;
2534 }
2535
2536 if (gfc_match_char (',') != MATCH_YES)
2537 break;
2538
2539 alloc_opt_list:
2540
2541 m = gfc_match (" stat = %v", &tmp);
2542 if (m == MATCH_ERROR)
2543 goto cleanup;
2544 if (m == MATCH_YES)
2545 {
2546 /* Enforce C630. */
2547 if (saw_stat)
2548 {
2549 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2550 goto cleanup;
2551 }
2552
2553 stat = tmp;
2554 saw_stat = true;
2555
2556 if (gfc_check_do_variable (stat->symtree))
2557 goto cleanup;
2558
2559 if (gfc_match_char (',') == MATCH_YES)
2560 goto alloc_opt_list;
2561 }
2562
2563 m = gfc_match (" errmsg = %v", &tmp);
2564 if (m == MATCH_ERROR)
2565 goto cleanup;
2566 if (m == MATCH_YES)
2567 {
2568 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L",
2569 &tmp->where) == FAILURE)
2570 goto cleanup;
2571
2572 /* Enforce C630. */
2573 if (saw_errmsg)
2574 {
2575 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2576 goto cleanup;
2577 }
2578
2579 errmsg = tmp;
2580 saw_errmsg = true;
2581
2582 if (gfc_match_char (',') == MATCH_YES)
2583 goto alloc_opt_list;
2584 }
2585
2586 m = gfc_match (" source = %e", &tmp);
2587 if (m == MATCH_ERROR)
2588 goto cleanup;
2589 if (m == MATCH_YES)
2590 {
2591 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L",
2592 &tmp->where) == FAILURE)
2593 goto cleanup;
2594
2595 /* Enforce C630. */
2596 if (saw_source)
2597 {
2598 gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
2599 goto cleanup;
2600 }
2601
2602 /* The next 3 conditionals check C631. */
2603 if (ts.type != BT_UNKNOWN)
2604 {
2605 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
2606 &tmp->where, &old_locus);
2607 goto cleanup;
2608 }
2609
2610 if (head->next)
2611 {
2612 gfc_error ("SOURCE tag at %L requires only a single entity in "
2613 "the allocation-list", &tmp->where);
2614 goto cleanup;
2615 }
2616
2617 gfc_resolve_expr (tmp);
2618
2619 if (head->expr->ts.type != tmp->ts.type)
2620 {
2621 gfc_error ("Type of entity at %L is type incompatible with "
2622 "source-expr at %L", &head->expr->where, &tmp->where);
2623 goto cleanup;
2624 }
2625
2626 /* Check C633. */
2627 if (tmp->ts.kind != head->expr->ts.kind)
2628 {
2629 gfc_error ("The allocate-object at %L and the source-expr at %L "
2630 "shall have the same kind type parameter",
2631 &head->expr->where, &tmp->where);
2632 goto cleanup;
2633 }
2634
2635 /* Check C632 and restriction following Note 6.18. */
2636 if (tmp->rank > 0 && conformable_arrays (tmp, head->expr) == FAILURE)
2637 goto cleanup;
2638
2639 source = tmp;
2640 saw_source = true;
2641
2642 if (gfc_match_char (',') == MATCH_YES)
2643 goto alloc_opt_list;
2644 }
2645
2646 gfc_gobble_whitespace ();
2647
2648 if (gfc_peek_char () == ')')
2649 break;
2650 }
2651
2652
2653 if (gfc_match (" )%t") != MATCH_YES)
2654 goto syntax;
2655
2656 new_st.op = EXEC_ALLOCATE;
2657 new_st.expr1 = stat;
2658 new_st.expr2 = errmsg;
2659 new_st.expr3 = source;
2660 new_st.ext.alloc_list = head;
2661
2662 return MATCH_YES;
2663
2664 syntax:
2665 gfc_syntax_error (ST_ALLOCATE);
2666
2667 cleanup:
2668 gfc_free_expr (errmsg);
2669 gfc_free_expr (source);
2670 gfc_free_expr (stat);
2671 gfc_free_expr (tmp);
2672 gfc_free_alloc_list (head);
2673 return MATCH_ERROR;
2674 }
2675
2676
2677 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
2678 a set of pointer assignments to intrinsic NULL(). */
2679
2680 match
2681 gfc_match_nullify (void)
2682 {
2683 gfc_code *tail;
2684 gfc_expr *e, *p;
2685 match m;
2686
2687 tail = NULL;
2688
2689 if (gfc_match_char ('(') != MATCH_YES)
2690 goto syntax;
2691
2692 for (;;)
2693 {
2694 m = gfc_match_variable (&p, 0);
2695 if (m == MATCH_ERROR)
2696 goto cleanup;
2697 if (m == MATCH_NO)
2698 goto syntax;
2699
2700 if (gfc_check_do_variable (p->symtree))
2701 goto cleanup;
2702
2703 if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
2704 {
2705 gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
2706 goto cleanup;
2707 }
2708
2709 /* build ' => NULL() '. */
2710 e = gfc_get_expr ();
2711 e->where = gfc_current_locus;
2712 e->expr_type = EXPR_NULL;
2713 e->ts.type = BT_UNKNOWN;
2714
2715 /* Chain to list. */
2716 if (tail == NULL)
2717 tail = &new_st;
2718 else
2719 {
2720 tail->next = gfc_get_code ();
2721 tail = tail->next;
2722 }
2723
2724 tail->op = EXEC_POINTER_ASSIGN;
2725 tail->expr1 = p;
2726 tail->expr2 = e;
2727
2728 if (gfc_match (" )%t") == MATCH_YES)
2729 break;
2730 if (gfc_match_char (',') != MATCH_YES)
2731 goto syntax;
2732 }
2733
2734 return MATCH_YES;
2735
2736 syntax:
2737 gfc_syntax_error (ST_NULLIFY);
2738
2739 cleanup:
2740 gfc_free_statements (new_st.next);
2741 new_st.next = NULL;
2742 gfc_free_expr (new_st.expr1);
2743 new_st.expr1 = NULL;
2744 gfc_free_expr (new_st.expr2);
2745 new_st.expr2 = NULL;
2746 return MATCH_ERROR;
2747 }
2748
2749
2750 /* Match a DEALLOCATE statement. */
2751
2752 match
2753 gfc_match_deallocate (void)
2754 {
2755 gfc_alloc *head, *tail;
2756 gfc_expr *stat, *errmsg, *tmp;
2757 match m;
2758 bool saw_stat, saw_errmsg;
2759
2760 head = tail = NULL;
2761 stat = errmsg = tmp = NULL;
2762 saw_stat = saw_errmsg = false;
2763
2764 if (gfc_match_char ('(') != MATCH_YES)
2765 goto syntax;
2766
2767 for (;;)
2768 {
2769 if (head == NULL)
2770 head = tail = gfc_get_alloc ();
2771 else
2772 {
2773 tail->next = gfc_get_alloc ();
2774 tail = tail->next;
2775 }
2776
2777 m = gfc_match_variable (&tail->expr, 0);
2778 if (m == MATCH_ERROR)
2779 goto cleanup;
2780 if (m == MATCH_NO)
2781 goto syntax;
2782
2783 if (gfc_check_do_variable (tail->expr->symtree))
2784 goto cleanup;
2785
2786 if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
2787 {
2788 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
2789 goto cleanup;
2790 }
2791
2792 /* FIXME: disable the checking on derived types. */
2793 if (!(tail->expr->ref
2794 && (tail->expr->ref->type == REF_COMPONENT
2795 || tail->expr->ref->type == REF_ARRAY))
2796 && tail->expr->symtree->n.sym
2797 && !(tail->expr->symtree->n.sym->attr.allocatable
2798 || tail->expr->symtree->n.sym->attr.pointer
2799 || tail->expr->symtree->n.sym->attr.proc_pointer))
2800 {
2801 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2802 "or an allocatable variable");
2803 goto cleanup;
2804 }
2805
2806 if (gfc_match_char (',') != MATCH_YES)
2807 break;
2808
2809 dealloc_opt_list:
2810
2811 m = gfc_match (" stat = %v", &tmp);
2812 if (m == MATCH_ERROR)
2813 goto cleanup;
2814 if (m == MATCH_YES)
2815 {
2816 if (saw_stat)
2817 {
2818 gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2819 gfc_free_expr (tmp);
2820 goto cleanup;
2821 }
2822
2823 stat = tmp;
2824 saw_stat = true;
2825
2826 if (gfc_check_do_variable (stat->symtree))
2827 goto cleanup;
2828
2829 if (gfc_match_char (',') == MATCH_YES)
2830 goto dealloc_opt_list;
2831 }
2832
2833 m = gfc_match (" errmsg = %v", &tmp);
2834 if (m == MATCH_ERROR)
2835 goto cleanup;
2836 if (m == MATCH_YES)
2837 {
2838 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
2839 &tmp->where) == FAILURE)
2840 goto cleanup;
2841
2842 if (saw_errmsg)
2843 {
2844 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2845 gfc_free_expr (tmp);
2846 goto cleanup;
2847 }
2848
2849 errmsg = tmp;
2850 saw_errmsg = true;
2851
2852 if (gfc_match_char (',') == MATCH_YES)
2853 goto dealloc_opt_list;
2854 }
2855
2856 gfc_gobble_whitespace ();
2857
2858 if (gfc_peek_char () == ')')
2859 break;
2860 }
2861
2862 if (gfc_match (" )%t") != MATCH_YES)
2863 goto syntax;
2864
2865 new_st.op = EXEC_DEALLOCATE;
2866 new_st.expr1 = stat;
2867 new_st.expr2 = errmsg;
2868 new_st.ext.alloc_list = head;
2869
2870 return MATCH_YES;
2871
2872 syntax:
2873 gfc_syntax_error (ST_DEALLOCATE);
2874
2875 cleanup:
2876 gfc_free_expr (errmsg);
2877 gfc_free_expr (stat);
2878 gfc_free_alloc_list (head);
2879 return MATCH_ERROR;
2880 }
2881
2882
2883 /* Match a RETURN statement. */
2884
2885 match
2886 gfc_match_return (void)
2887 {
2888 gfc_expr *e;
2889 match m;
2890 gfc_compile_state s;
2891
2892 e = NULL;
2893 if (gfc_match_eos () == MATCH_YES)
2894 goto done;
2895
2896 if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
2897 {
2898 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2899 "a SUBROUTINE");
2900 goto cleanup;
2901 }
2902
2903 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Alternate RETURN "
2904 "at %C") == FAILURE)
2905 return MATCH_ERROR;
2906
2907 if (gfc_current_form == FORM_FREE)
2908 {
2909 /* The following are valid, so we can't require a blank after the
2910 RETURN keyword:
2911 return+1
2912 return(1) */
2913 char c = gfc_peek_ascii_char ();
2914 if (ISALPHA (c) || ISDIGIT (c))
2915 return MATCH_NO;
2916 }
2917
2918 m = gfc_match (" %e%t", &e);
2919 if (m == MATCH_YES)
2920 goto done;
2921 if (m == MATCH_ERROR)
2922 goto cleanup;
2923
2924 gfc_syntax_error (ST_RETURN);
2925
2926 cleanup:
2927 gfc_free_expr (e);
2928 return MATCH_ERROR;
2929
2930 done:
2931 gfc_enclosing_unit (&s);
2932 if (s == COMP_PROGRAM
2933 && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
2934 "main program at %C") == FAILURE)
2935 return MATCH_ERROR;
2936
2937 new_st.op = EXEC_RETURN;
2938 new_st.expr1 = e;
2939
2940 return MATCH_YES;
2941 }
2942
2943
2944 /* Match the call of a type-bound procedure, if CALL%var has already been
2945 matched and var found to be a derived-type variable. */
2946
2947 static match
2948 match_typebound_call (gfc_symtree* varst)
2949 {
2950 gfc_symbol* var;
2951 gfc_expr* base;
2952 match m;
2953
2954 var = varst->n.sym;
2955
2956 base = gfc_get_expr ();
2957 base->expr_type = EXPR_VARIABLE;
2958 base->symtree = varst;
2959 base->where = gfc_current_locus;
2960 gfc_set_sym_referenced (varst->n.sym);
2961
2962 m = gfc_match_varspec (base, 0, true, true);
2963 if (m == MATCH_NO)
2964 gfc_error ("Expected component reference at %C");
2965 if (m != MATCH_YES)
2966 return MATCH_ERROR;
2967
2968 if (gfc_match_eos () != MATCH_YES)
2969 {
2970 gfc_error ("Junk after CALL at %C");
2971 return MATCH_ERROR;
2972 }
2973
2974 if (base->expr_type == EXPR_COMPCALL)
2975 new_st.op = EXEC_COMPCALL;
2976 else if (base->expr_type == EXPR_PPC)
2977 new_st.op = EXEC_CALL_PPC;
2978 else
2979 {
2980 gfc_error ("Expected type-bound procedure or procedure pointer component "
2981 "at %C");
2982 return MATCH_ERROR;
2983 }
2984 new_st.expr1 = base;
2985
2986 return MATCH_YES;
2987 }
2988
2989
2990 /* Match a CALL statement. The tricky part here are possible
2991 alternate return specifiers. We handle these by having all
2992 "subroutines" actually return an integer via a register that gives
2993 the return number. If the call specifies alternate returns, we
2994 generate code for a SELECT statement whose case clauses contain
2995 GOTOs to the various labels. */
2996
2997 match
2998 gfc_match_call (void)
2999 {
3000 char name[GFC_MAX_SYMBOL_LEN + 1];
3001 gfc_actual_arglist *a, *arglist;
3002 gfc_case *new_case;
3003 gfc_symbol *sym;
3004 gfc_symtree *st;
3005 gfc_code *c;
3006 match m;
3007 int i;
3008
3009 arglist = NULL;
3010
3011 m = gfc_match ("% %n", name);
3012 if (m == MATCH_NO)
3013 goto syntax;
3014 if (m != MATCH_YES)
3015 return m;
3016
3017 if (gfc_get_ha_sym_tree (name, &st))
3018 return MATCH_ERROR;
3019
3020 sym = st->n.sym;
3021
3022 /* If this is a variable of derived-type, it probably starts a type-bound
3023 procedure call. */
3024 if (sym->attr.flavor != FL_PROCEDURE && sym->ts.type == BT_DERIVED)
3025 return match_typebound_call (st);
3026
3027 /* If it does not seem to be callable (include functions so that the
3028 right association is made. They are thrown out in resolution.)
3029 ... */
3030 if (!sym->attr.generic
3031 && !sym->attr.subroutine
3032 && !sym->attr.function)
3033 {
3034 if (!(sym->attr.external && !sym->attr.referenced))
3035 {
3036 /* ...create a symbol in this scope... */
3037 if (sym->ns != gfc_current_ns
3038 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
3039 return MATCH_ERROR;
3040
3041 if (sym != st->n.sym)
3042 sym = st->n.sym;
3043 }
3044
3045 /* ...and then to try to make the symbol into a subroutine. */
3046 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
3047 return MATCH_ERROR;
3048 }
3049
3050 gfc_set_sym_referenced (sym);
3051
3052 if (gfc_match_eos () != MATCH_YES)
3053 {
3054 m = gfc_match_actual_arglist (1, &arglist);
3055 if (m == MATCH_NO)
3056 goto syntax;
3057 if (m == MATCH_ERROR)
3058 goto cleanup;
3059
3060 if (gfc_match_eos () != MATCH_YES)
3061 goto syntax;
3062 }
3063
3064 /* If any alternate return labels were found, construct a SELECT
3065 statement that will jump to the right place. */
3066
3067 i = 0;
3068 for (a = arglist; a; a = a->next)
3069 if (a->expr == NULL)
3070 i = 1;
3071
3072 if (i)
3073 {
3074 gfc_symtree *select_st;
3075 gfc_symbol *select_sym;
3076 char name[GFC_MAX_SYMBOL_LEN + 1];
3077
3078 new_st.next = c = gfc_get_code ();
3079 c->op = EXEC_SELECT;
3080 sprintf (name, "_result_%s", sym->name);
3081 gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
3082
3083 select_sym = select_st->n.sym;
3084 select_sym->ts.type = BT_INTEGER;
3085 select_sym->ts.kind = gfc_default_integer_kind;
3086 gfc_set_sym_referenced (select_sym);
3087 c->expr1 = gfc_get_expr ();
3088 c->expr1->expr_type = EXPR_VARIABLE;
3089 c->expr1->symtree = select_st;
3090 c->expr1->ts = select_sym->ts;
3091 c->expr1->where = gfc_current_locus;
3092
3093 i = 0;
3094 for (a = arglist; a; a = a->next)
3095 {
3096 if (a->expr != NULL)
3097 continue;
3098
3099 if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
3100 continue;
3101
3102 i++;
3103
3104 c->block = gfc_get_code ();
3105 c = c->block;
3106 c->op = EXEC_SELECT;
3107
3108 new_case = gfc_get_case ();
3109 new_case->high = new_case->low = gfc_int_expr (i);
3110 c->ext.case_list = new_case;
3111
3112 c->next = gfc_get_code ();
3113 c->next->op = EXEC_GOTO;
3114 c->next->label1 = a->label;
3115 }
3116 }
3117
3118 new_st.op = EXEC_CALL;
3119 new_st.symtree = st;
3120 new_st.ext.actual = arglist;
3121
3122 return MATCH_YES;
3123
3124 syntax:
3125 gfc_syntax_error (ST_CALL);
3126
3127 cleanup:
3128 gfc_free_actual_arglist (arglist);
3129 return MATCH_ERROR;
3130 }
3131
3132
3133 /* Given a name, return a pointer to the common head structure,
3134 creating it if it does not exist. If FROM_MODULE is nonzero, we
3135 mangle the name so that it doesn't interfere with commons defined
3136 in the using namespace.
3137 TODO: Add to global symbol tree. */
3138
3139 gfc_common_head *
3140 gfc_get_common (const char *name, int from_module)
3141 {
3142 gfc_symtree *st;
3143 static int serial = 0;
3144 char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
3145
3146 if (from_module)
3147 {
3148 /* A use associated common block is only needed to correctly layout
3149 the variables it contains. */
3150 snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
3151 st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
3152 }
3153 else
3154 {
3155 st = gfc_find_symtree (gfc_current_ns->common_root, name);
3156
3157 if (st == NULL)
3158 st = gfc_new_symtree (&gfc_current_ns->common_root, name);
3159 }
3160
3161 if (st->n.common == NULL)
3162 {
3163 st->n.common = gfc_get_common_head ();
3164 st->n.common->where = gfc_current_locus;
3165 strcpy (st->n.common->name, name);
3166 }
3167
3168 return st->n.common;
3169 }
3170
3171
3172 /* Match a common block name. */
3173
3174 match match_common_name (char *name)
3175 {
3176 match m;
3177
3178 if (gfc_match_char ('/') == MATCH_NO)
3179 {
3180 name[0] = '\0';
3181 return MATCH_YES;
3182 }
3183
3184 if (gfc_match_char ('/') == MATCH_YES)
3185 {
3186 name[0] = '\0';
3187 return MATCH_YES;
3188 }
3189
3190 m = gfc_match_name (name);
3191
3192 if (m == MATCH_ERROR)
3193 return MATCH_ERROR;
3194 if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
3195 return MATCH_YES;
3196
3197 gfc_error ("Syntax error in common block name at %C");
3198 return MATCH_ERROR;
3199 }
3200
3201
3202 /* Match a COMMON statement. */
3203
3204 match
3205 gfc_match_common (void)
3206 {
3207 gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
3208 char name[GFC_MAX_SYMBOL_LEN + 1];
3209 gfc_common_head *t;
3210 gfc_array_spec *as;
3211 gfc_equiv *e1, *e2;
3212 match m;
3213 gfc_gsymbol *gsym;
3214
3215 old_blank_common = gfc_current_ns->blank_common.head;
3216 if (old_blank_common)
3217 {
3218 while (old_blank_common->common_next)
3219 old_blank_common = old_blank_common->common_next;
3220 }
3221
3222 as = NULL;
3223
3224 for (;;)
3225 {
3226 m = match_common_name (name);
3227 if (m == MATCH_ERROR)
3228 goto cleanup;
3229
3230 gsym = gfc_get_gsymbol (name);
3231 if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
3232 {
3233 gfc_error ("Symbol '%s' at %C is already an external symbol that "
3234 "is not COMMON", name);
3235 goto cleanup;
3236 }
3237
3238 if (gsym->type == GSYM_UNKNOWN)
3239 {
3240 gsym->type = GSYM_COMMON;
3241 gsym->where = gfc_current_locus;
3242 gsym->defined = 1;
3243 }
3244
3245 gsym->used = 1;
3246
3247 if (name[0] == '\0')
3248 {
3249 t = &gfc_current_ns->blank_common;
3250 if (t->head == NULL)
3251 t->where = gfc_current_locus;
3252 }
3253 else
3254 {
3255 t = gfc_get_common (name, 0);
3256 }
3257 head = &t->head;
3258
3259 if (*head == NULL)
3260 tail = NULL;
3261 else
3262 {
3263 tail = *head;
3264 while (tail->common_next)
3265 tail = tail->common_next;
3266 }
3267
3268 /* Grab the list of symbols. */
3269 for (;;)
3270 {
3271 m = gfc_match_symbol (&sym, 0);
3272 if (m == MATCH_ERROR)
3273 goto cleanup;
3274 if (m == MATCH_NO)
3275 goto syntax;
3276
3277 /* Store a ref to the common block for error checking. */
3278 sym->common_block = t;
3279
3280 /* See if we know the current common block is bind(c), and if
3281 so, then see if we can check if the symbol is (which it'll
3282 need to be). This can happen if the bind(c) attr stmt was
3283 applied to the common block, and the variable(s) already
3284 defined, before declaring the common block. */
3285 if (t->is_bind_c == 1)
3286 {
3287 if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
3288 {
3289 /* If we find an error, just print it and continue,
3290 cause it's just semantic, and we can see if there
3291 are more errors. */
3292 gfc_error_now ("Variable '%s' at %L in common block '%s' "
3293 "at %C must be declared with a C "
3294 "interoperable kind since common block "
3295 "'%s' is bind(c)",
3296 sym->name, &(sym->declared_at), t->name,
3297 t->name);
3298 }
3299
3300 if (sym->attr.is_bind_c == 1)
3301 gfc_error_now ("Variable '%s' in common block "
3302 "'%s' at %C can not be bind(c) since "
3303 "it is not global", sym->name, t->name);
3304 }
3305
3306 if (sym->attr.in_common)
3307 {
3308 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
3309 sym->name);
3310 goto cleanup;
3311 }
3312
3313 if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
3314 || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
3315 {
3316 if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
3317 "can only be COMMON in "
3318 "BLOCK DATA", sym->name)
3319 == FAILURE)
3320 goto cleanup;
3321 }
3322
3323 if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
3324 goto cleanup;
3325
3326 if (tail != NULL)
3327 tail->common_next = sym;
3328 else
3329 *head = sym;
3330
3331 tail = sym;
3332
3333 /* Deal with an optional array specification after the
3334 symbol name. */
3335 m = gfc_match_array_spec (&as);
3336 if (m == MATCH_ERROR)
3337 goto cleanup;
3338
3339 if (m == MATCH_YES)
3340 {
3341 if (as->type != AS_EXPLICIT)
3342 {
3343 gfc_error ("Array specification for symbol '%s' in COMMON "
3344 "at %C must be explicit", sym->name);
3345 goto cleanup;
3346 }
3347
3348 if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
3349 goto cleanup;
3350
3351 if (sym->attr.pointer)
3352 {
3353 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
3354 "POINTER array", sym->name);
3355 goto cleanup;
3356 }
3357
3358 sym->as = as;
3359 as = NULL;
3360
3361 }
3362
3363 sym->common_head = t;
3364
3365 /* Check to see if the symbol is already in an equivalence group.
3366 If it is, set the other members as being in common. */
3367 if (sym->attr.in_equivalence)
3368 {
3369 for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
3370 {
3371 for (e2 = e1; e2; e2 = e2->eq)
3372 if (e2->expr->symtree->n.sym == sym)
3373 goto equiv_found;
3374
3375 continue;
3376
3377 equiv_found:
3378
3379 for (e2 = e1; e2; e2 = e2->eq)
3380 {
3381 other = e2->expr->symtree->n.sym;
3382 if (other->common_head
3383 && other->common_head != sym->common_head)
3384 {
3385 gfc_error ("Symbol '%s', in COMMON block '%s' at "
3386 "%C is being indirectly equivalenced to "
3387 "another COMMON block '%s'",
3388 sym->name, sym->common_head->name,
3389 other->common_head->name);
3390 goto cleanup;
3391 }
3392 other->attr.in_common = 1;
3393 other->common_head = t;
3394 }
3395 }
3396 }
3397
3398
3399 gfc_gobble_whitespace ();
3400 if (gfc_match_eos () == MATCH_YES)
3401 goto done;
3402 if (gfc_peek_ascii_char () == '/')
3403 break;
3404 if (gfc_match_char (',') != MATCH_YES)
3405 goto syntax;
3406 gfc_gobble_whitespace ();
3407 if (gfc_peek_ascii_char () == '/')
3408 break;
3409 }
3410 }
3411
3412 done:
3413 return MATCH_YES;
3414
3415 syntax:
3416 gfc_syntax_error (ST_COMMON);
3417
3418 cleanup:
3419 if (old_blank_common)
3420 old_blank_common->common_next = NULL;
3421 else
3422 gfc_current_ns->blank_common.head = NULL;
3423 gfc_free_array_spec (as);
3424 return MATCH_ERROR;
3425 }
3426
3427
3428 /* Match a BLOCK DATA program unit. */
3429
3430 match
3431 gfc_match_block_data (void)
3432 {
3433 char name[GFC_MAX_SYMBOL_LEN + 1];
3434 gfc_symbol *sym;
3435 match m;
3436
3437 if (gfc_match_eos () == MATCH_YES)
3438 {
3439 gfc_new_block = NULL;
3440 return MATCH_YES;
3441 }
3442
3443 m = gfc_match ("% %n%t", name);
3444 if (m != MATCH_YES)
3445 return MATCH_ERROR;
3446
3447 if (gfc_get_symbol (name, NULL, &sym))
3448 return MATCH_ERROR;
3449
3450 if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
3451 return MATCH_ERROR;
3452
3453 gfc_new_block = sym;
3454
3455 return MATCH_YES;
3456 }
3457
3458
3459 /* Free a namelist structure. */
3460
3461 void
3462 gfc_free_namelist (gfc_namelist *name)
3463 {
3464 gfc_namelist *n;
3465
3466 for (; name; name = n)
3467 {
3468 n = name->next;
3469 gfc_free (name);
3470 }
3471 }
3472
3473
3474 /* Match a NAMELIST statement. */
3475
3476 match
3477 gfc_match_namelist (void)
3478 {
3479 gfc_symbol *group_name, *sym;
3480 gfc_namelist *nl;
3481 match m, m2;
3482
3483 m = gfc_match (" / %s /", &group_name);
3484 if (m == MATCH_NO)
3485 goto syntax;
3486 if (m == MATCH_ERROR)
3487 goto error;
3488
3489 for (;;)
3490 {
3491 if (group_name->ts.type != BT_UNKNOWN)
3492 {
3493 gfc_error ("Namelist group name '%s' at %C already has a basic "
3494 "type of %s", group_name->name,
3495 gfc_typename (&group_name->ts));
3496 return MATCH_ERROR;
3497 }
3498
3499 if (group_name->attr.flavor == FL_NAMELIST
3500 && group_name->attr.use_assoc
3501 && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
3502 "at %C already is USE associated and can"
3503 "not be respecified.", group_name->name)
3504 == FAILURE)
3505 return MATCH_ERROR;
3506
3507 if (group_name->attr.flavor != FL_NAMELIST
3508 && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
3509 group_name->name, NULL) == FAILURE)
3510 return MATCH_ERROR;
3511
3512 for (;;)
3513 {
3514 m = gfc_match_symbol (&sym, 1);
3515 if (m == MATCH_NO)
3516 goto syntax;
3517 if (m == MATCH_ERROR)
3518 goto error;
3519
3520 if (sym->attr.in_namelist == 0
3521 && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
3522 goto error;
3523
3524 /* Use gfc_error_check here, rather than goto error, so that
3525 these are the only errors for the next two lines. */
3526 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
3527 {
3528 gfc_error ("Assumed size array '%s' in namelist '%s' at "
3529 "%C is not allowed", sym->name, group_name->name);
3530 gfc_error_check ();
3531 }
3532
3533 if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl->length == NULL)
3534 {
3535 gfc_error ("Assumed character length '%s' in namelist '%s' at "
3536 "%C is not allowed", sym->name, group_name->name);
3537 gfc_error_check ();
3538 }
3539
3540 nl = gfc_get_namelist ();
3541 nl->sym = sym;
3542 sym->refs++;
3543
3544 if (group_name->namelist == NULL)
3545 group_name->namelist = group_name->namelist_tail = nl;
3546 else
3547 {
3548 group_name->namelist_tail->next = nl;
3549 group_name->namelist_tail = nl;
3550 }
3551
3552 if (gfc_match_eos () == MATCH_YES)
3553 goto done;
3554
3555 m = gfc_match_char (',');
3556
3557 if (gfc_match_char ('/') == MATCH_YES)
3558 {
3559 m2 = gfc_match (" %s /", &group_name);
3560 if (m2 == MATCH_YES)
3561 break;
3562 if (m2 == MATCH_ERROR)
3563 goto error;
3564 goto syntax;
3565 }
3566
3567 if (m != MATCH_YES)
3568 goto syntax;
3569 }
3570 }
3571
3572 done:
3573 return MATCH_YES;
3574
3575 syntax:
3576 gfc_syntax_error (ST_NAMELIST);
3577
3578 error:
3579 return MATCH_ERROR;
3580 }
3581
3582
3583 /* Match a MODULE statement. */
3584
3585 match
3586 gfc_match_module (void)
3587 {
3588 match m;
3589
3590 m = gfc_match (" %s%t", &gfc_new_block);
3591 if (m != MATCH_YES)
3592 return m;
3593
3594 if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
3595 gfc_new_block->name, NULL) == FAILURE)
3596 return MATCH_ERROR;
3597
3598 return MATCH_YES;
3599 }
3600
3601
3602 /* Free equivalence sets and lists. Recursively is the easiest way to
3603 do this. */
3604
3605 void
3606 gfc_free_equiv (gfc_equiv *eq)
3607 {
3608 if (eq == NULL)
3609 return;
3610
3611 gfc_free_equiv (eq->eq);
3612 gfc_free_equiv (eq->next);
3613 gfc_free_expr (eq->expr);
3614 gfc_free (eq);
3615 }
3616
3617
3618 /* Match an EQUIVALENCE statement. */
3619
3620 match
3621 gfc_match_equivalence (void)
3622 {
3623 gfc_equiv *eq, *set, *tail;
3624 gfc_ref *ref;
3625 gfc_symbol *sym;
3626 match m;
3627 gfc_common_head *common_head = NULL;
3628 bool common_flag;
3629 int cnt;
3630
3631 tail = NULL;
3632
3633 for (;;)
3634 {
3635 eq = gfc_get_equiv ();
3636 if (tail == NULL)
3637 tail = eq;
3638
3639 eq->next = gfc_current_ns->equiv;
3640 gfc_current_ns->equiv = eq;
3641
3642 if (gfc_match_char ('(') != MATCH_YES)
3643 goto syntax;
3644
3645 set = eq;
3646 common_flag = FALSE;
3647 cnt = 0;
3648
3649 for (;;)
3650 {
3651 m = gfc_match_equiv_variable (&set->expr);
3652 if (m == MATCH_ERROR)
3653 goto cleanup;
3654 if (m == MATCH_NO)
3655 goto syntax;
3656
3657 /* count the number of objects. */
3658 cnt++;
3659
3660 if (gfc_match_char ('%') == MATCH_YES)
3661 {
3662 gfc_error ("Derived type component %C is not a "
3663 "permitted EQUIVALENCE member");
3664 goto cleanup;
3665 }
3666
3667 for (ref = set->expr->ref; ref; ref = ref->next)
3668 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3669 {
3670 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
3671 "be an array section");
3672 goto cleanup;
3673 }
3674
3675 sym = set->expr->symtree->n.sym;
3676
3677 if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
3678 goto cleanup;
3679
3680 if (sym->attr.in_common)
3681 {
3682 common_flag = TRUE;
3683 common_head = sym->common_head;
3684 }
3685
3686 if (gfc_match_char (')') == MATCH_YES)
3687 break;
3688
3689 if (gfc_match_char (',') != MATCH_YES)
3690 goto syntax;
3691
3692 set->eq = gfc_get_equiv ();
3693 set = set->eq;
3694 }
3695
3696 if (cnt < 2)
3697 {
3698 gfc_error ("EQUIVALENCE at %C requires two or more objects");
3699 goto cleanup;
3700 }
3701
3702 /* If one of the members of an equivalence is in common, then
3703 mark them all as being in common. Before doing this, check
3704 that members of the equivalence group are not in different
3705 common blocks. */
3706 if (common_flag)
3707 for (set = eq; set; set = set->eq)
3708 {
3709 sym = set->expr->symtree->n.sym;
3710 if (sym->common_head && sym->common_head != common_head)
3711 {
3712 gfc_error ("Attempt to indirectly overlap COMMON "
3713 "blocks %s and %s by EQUIVALENCE at %C",
3714 sym->common_head->name, common_head->name);
3715 goto cleanup;
3716 }
3717 sym->attr.in_common = 1;
3718 sym->common_head = common_head;
3719 }
3720
3721 if (gfc_match_eos () == MATCH_YES)
3722 break;
3723 if (gfc_match_char (',') != MATCH_YES)
3724 goto syntax;
3725 }
3726
3727 return MATCH_YES;
3728
3729 syntax:
3730 gfc_syntax_error (ST_EQUIVALENCE);
3731
3732 cleanup:
3733 eq = tail->next;
3734 tail->next = NULL;
3735
3736 gfc_free_equiv (gfc_current_ns->equiv);
3737 gfc_current_ns->equiv = eq;
3738
3739 return MATCH_ERROR;
3740 }
3741
3742
3743 /* Check that a statement function is not recursive. This is done by looking
3744 for the statement function symbol(sym) by looking recursively through its
3745 expression(e). If a reference to sym is found, true is returned.
3746 12.5.4 requires that any variable of function that is implicitly typed
3747 shall have that type confirmed by any subsequent type declaration. The
3748 implicit typing is conveniently done here. */
3749 static bool
3750 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
3751
3752 static bool
3753 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
3754 {
3755
3756 if (e == NULL)
3757 return false;
3758
3759 switch (e->expr_type)
3760 {
3761 case EXPR_FUNCTION:
3762 if (e->symtree == NULL)
3763 return false;
3764
3765 /* Check the name before testing for nested recursion! */
3766 if (sym->name == e->symtree->n.sym->name)
3767 return true;
3768
3769 /* Catch recursion via other statement functions. */
3770 if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
3771 && e->symtree->n.sym->value
3772 && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
3773 return true;
3774
3775 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3776 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3777
3778 break;
3779
3780 case EXPR_VARIABLE:
3781 if (e->symtree && sym->name == e->symtree->n.sym->name)
3782 return true;
3783
3784 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3785 gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3786 break;
3787
3788 default:
3789 break;
3790 }
3791
3792 return false;
3793 }
3794
3795
3796 static bool
3797 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
3798 {
3799 return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
3800 }
3801
3802
3803 /* Match a statement function declaration. It is so easy to match
3804 non-statement function statements with a MATCH_ERROR as opposed to
3805 MATCH_NO that we suppress error message in most cases. */
3806
3807 match
3808 gfc_match_st_function (void)
3809 {
3810 gfc_error_buf old_error;
3811 gfc_symbol *sym;
3812 gfc_expr *expr;
3813 match m;
3814
3815 m = gfc_match_symbol (&sym, 0);
3816 if (m != MATCH_YES)
3817 return m;
3818
3819 gfc_push_error (&old_error);
3820
3821 if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
3822 sym->name, NULL) == FAILURE)
3823 goto undo_error;
3824
3825 if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
3826 goto undo_error;
3827
3828 m = gfc_match (" = %e%t", &expr);
3829 if (m == MATCH_NO)
3830 goto undo_error;
3831
3832 gfc_free_error (&old_error);
3833 if (m == MATCH_ERROR)
3834 return m;
3835
3836 if (recursive_stmt_fcn (expr, sym))
3837 {
3838 gfc_error ("Statement function at %L is recursive", &expr->where);
3839 return MATCH_ERROR;
3840 }
3841
3842 sym->value = expr;
3843
3844 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
3845 "Statement function at %C") == FAILURE)
3846 return MATCH_ERROR;
3847
3848 return MATCH_YES;
3849
3850 undo_error:
3851 gfc_pop_error (&old_error);
3852 return MATCH_NO;
3853 }
3854
3855
3856 /***************** SELECT CASE subroutines ******************/
3857
3858 /* Free a single case structure. */
3859
3860 static void
3861 free_case (gfc_case *p)
3862 {
3863 if (p->low == p->high)
3864 p->high = NULL;
3865 gfc_free_expr (p->low);
3866 gfc_free_expr (p->high);
3867 gfc_free (p);
3868 }
3869
3870
3871 /* Free a list of case structures. */
3872
3873 void
3874 gfc_free_case_list (gfc_case *p)
3875 {
3876 gfc_case *q;
3877
3878 for (; p; p = q)
3879 {
3880 q = p->next;
3881 free_case (p);
3882 }
3883 }
3884
3885
3886 /* Match a single case selector. */
3887
3888 static match
3889 match_case_selector (gfc_case **cp)
3890 {
3891 gfc_case *c;
3892 match m;
3893
3894 c = gfc_get_case ();
3895 c->where = gfc_current_locus;
3896
3897 if (gfc_match_char (':') == MATCH_YES)
3898 {
3899 m = gfc_match_init_expr (&c->high);
3900 if (m == MATCH_NO)
3901 goto need_expr;
3902 if (m == MATCH_ERROR)
3903 goto cleanup;
3904 }
3905 else
3906 {
3907 m = gfc_match_init_expr (&c->low);
3908 if (m == MATCH_ERROR)
3909 goto cleanup;
3910 if (m == MATCH_NO)
3911 goto need_expr;
3912
3913 /* If we're not looking at a ':' now, make a range out of a single
3914 target. Else get the upper bound for the case range. */
3915 if (gfc_match_char (':') != MATCH_YES)
3916 c->high = c->low;
3917 else
3918 {
3919 m = gfc_match_init_expr (&c->high);
3920 if (m == MATCH_ERROR)
3921 goto cleanup;
3922 /* MATCH_NO is fine. It's OK if nothing is there! */
3923 }
3924 }
3925
3926 *cp = c;
3927 return MATCH_YES;
3928
3929 need_expr:
3930 gfc_error ("Expected initialization expression in CASE at %C");
3931
3932 cleanup:
3933 free_case (c);
3934 return MATCH_ERROR;
3935 }
3936
3937
3938 /* Match the end of a case statement. */
3939
3940 static match
3941 match_case_eos (void)
3942 {
3943 char name[GFC_MAX_SYMBOL_LEN + 1];
3944 match m;
3945
3946 if (gfc_match_eos () == MATCH_YES)
3947 return MATCH_YES;
3948
3949 /* If the case construct doesn't have a case-construct-name, we
3950 should have matched the EOS. */
3951 if (!gfc_current_block ())
3952 {
3953 gfc_error ("Expected the name of the SELECT CASE construct at %C");
3954 return MATCH_ERROR;
3955 }
3956
3957 gfc_gobble_whitespace ();
3958
3959 m = gfc_match_name (name);
3960 if (m != MATCH_YES)
3961 return m;
3962
3963 if (strcmp (name, gfc_current_block ()->name) != 0)
3964 {
3965 gfc_error ("Expected case name of '%s' at %C",
3966 gfc_current_block ()->name);
3967 return MATCH_ERROR;
3968 }
3969
3970 return gfc_match_eos ();
3971 }
3972
3973
3974 /* Match a SELECT statement. */
3975
3976 match
3977 gfc_match_select (void)
3978 {
3979 gfc_expr *expr;
3980 match m;
3981
3982 m = gfc_match_label ();
3983 if (m == MATCH_ERROR)
3984 return m;
3985
3986 m = gfc_match (" select case ( %e )%t", &expr);
3987 if (m != MATCH_YES)
3988 return m;
3989
3990 new_st.op = EXEC_SELECT;
3991 new_st.expr1 = expr;
3992
3993 return MATCH_YES;
3994 }
3995
3996
3997 /* Match a CASE statement. */
3998
3999 match
4000 gfc_match_case (void)
4001 {
4002 gfc_case *c, *head, *tail;
4003 match m;
4004
4005 head = tail = NULL;
4006
4007 if (gfc_current_state () != COMP_SELECT)
4008 {
4009 gfc_error ("Unexpected CASE statement at %C");
4010 return MATCH_ERROR;
4011 }
4012
4013 if (gfc_match ("% default") == MATCH_YES)
4014 {
4015 m = match_case_eos ();
4016 if (m == MATCH_NO)
4017 goto syntax;
4018 if (m == MATCH_ERROR)
4019 goto cleanup;
4020
4021 new_st.op = EXEC_SELECT;
4022 c = gfc_get_case ();
4023 c->where = gfc_current_locus;
4024 new_st.ext.case_list = c;
4025 return MATCH_YES;
4026 }
4027
4028 if (gfc_match_char ('(') != MATCH_YES)
4029 goto syntax;
4030
4031 for (;;)
4032 {
4033 if (match_case_selector (&c) == MATCH_ERROR)
4034 goto cleanup;
4035
4036 if (head == NULL)
4037 head = c;
4038 else
4039 tail->next = c;
4040
4041 tail = c;
4042
4043 if (gfc_match_char (')') == MATCH_YES)
4044 break;
4045 if (gfc_match_char (',') != MATCH_YES)
4046 goto syntax;
4047 }
4048
4049 m = match_case_eos ();
4050 if (m == MATCH_NO)
4051 goto syntax;
4052 if (m == MATCH_ERROR)
4053 goto cleanup;
4054
4055 new_st.op = EXEC_SELECT;
4056 new_st.ext.case_list = head;
4057
4058 return MATCH_YES;
4059
4060 syntax:
4061 gfc_error ("Syntax error in CASE-specification at %C");
4062
4063 cleanup:
4064 gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
4065 return MATCH_ERROR;
4066 }
4067
4068 /********************* WHERE subroutines ********************/
4069
4070 /* Match the rest of a simple WHERE statement that follows an IF statement.
4071 */
4072
4073 static match
4074 match_simple_where (void)
4075 {
4076 gfc_expr *expr;
4077 gfc_code *c;
4078 match m;
4079
4080 m = gfc_match (" ( %e )", &expr);
4081 if (m != MATCH_YES)
4082 return m;
4083
4084 m = gfc_match_assignment ();
4085 if (m == MATCH_NO)
4086 goto syntax;
4087 if (m == MATCH_ERROR)
4088 goto cleanup;
4089
4090 if (gfc_match_eos () != MATCH_YES)
4091 goto syntax;
4092
4093 c = gfc_get_code ();
4094
4095 c->op = EXEC_WHERE;
4096 c->expr1 = expr;
4097 c->next = gfc_get_code ();
4098
4099 *c->next = new_st;
4100 gfc_clear_new_st ();
4101
4102 new_st.op = EXEC_WHERE;
4103 new_st.block = c;
4104
4105 return MATCH_YES;
4106
4107 syntax:
4108 gfc_syntax_error (ST_WHERE);
4109
4110 cleanup:
4111 gfc_free_expr (expr);
4112 return MATCH_ERROR;
4113 }
4114
4115
4116 /* Match a WHERE statement. */
4117
4118 match
4119 gfc_match_where (gfc_statement *st)
4120 {
4121 gfc_expr *expr;
4122 match m0, m;
4123 gfc_code *c;
4124
4125 m0 = gfc_match_label ();
4126 if (m0 == MATCH_ERROR)
4127 return m0;
4128
4129 m = gfc_match (" where ( %e )", &expr);
4130 if (m != MATCH_YES)
4131 return m;
4132
4133 if (gfc_match_eos () == MATCH_YES)
4134 {
4135 *st = ST_WHERE_BLOCK;
4136 new_st.op = EXEC_WHERE;
4137 new_st.expr1 = expr;
4138 return MATCH_YES;
4139 }
4140
4141 m = gfc_match_assignment ();
4142 if (m == MATCH_NO)
4143 gfc_syntax_error (ST_WHERE);
4144
4145 if (m != MATCH_YES)
4146 {
4147 gfc_free_expr (expr);
4148 return MATCH_ERROR;
4149 }
4150
4151 /* We've got a simple WHERE statement. */
4152 *st = ST_WHERE;
4153 c = gfc_get_code ();
4154
4155 c->op = EXEC_WHERE;
4156 c->expr1 = expr;
4157 c->next = gfc_get_code ();
4158
4159 *c->next = new_st;
4160 gfc_clear_new_st ();
4161
4162 new_st.op = EXEC_WHERE;
4163 new_st.block = c;
4164
4165 return MATCH_YES;
4166 }
4167
4168
4169 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
4170 new_st if successful. */
4171
4172 match
4173 gfc_match_elsewhere (void)
4174 {
4175 char name[GFC_MAX_SYMBOL_LEN + 1];
4176 gfc_expr *expr;
4177 match m;
4178
4179 if (gfc_current_state () != COMP_WHERE)
4180 {
4181 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
4182 return MATCH_ERROR;
4183 }
4184
4185 expr = NULL;
4186
4187 if (gfc_match_char ('(') == MATCH_YES)
4188 {
4189 m = gfc_match_expr (&expr);
4190 if (m == MATCH_NO)
4191 goto syntax;
4192 if (m == MATCH_ERROR)
4193 return MATCH_ERROR;
4194
4195 if (gfc_match_char (')') != MATCH_YES)
4196 goto syntax;
4197 }
4198
4199 if (gfc_match_eos () != MATCH_YES)
4200 {
4201 /* Only makes sense if we have a where-construct-name. */
4202 if (!gfc_current_block ())
4203 {
4204 m = MATCH_ERROR;
4205 goto cleanup;
4206 }
4207 /* Better be a name at this point. */
4208 m = gfc_match_name (name);
4209 if (m == MATCH_NO)
4210 goto syntax;
4211 if (m == MATCH_ERROR)
4212 goto cleanup;
4213
4214 if (gfc_match_eos () != MATCH_YES)
4215 goto syntax;
4216
4217 if (strcmp (name, gfc_current_block ()->name) != 0)
4218 {
4219 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
4220 name, gfc_current_block ()->name);
4221 goto cleanup;
4222 }
4223 }
4224
4225 new_st.op = EXEC_WHERE;
4226 new_st.expr1 = expr;
4227 return MATCH_YES;
4228
4229 syntax:
4230 gfc_syntax_error (ST_ELSEWHERE);
4231
4232 cleanup:
4233 gfc_free_expr (expr);
4234 return MATCH_ERROR;
4235 }
4236
4237
4238 /******************** FORALL subroutines ********************/
4239
4240 /* Free a list of FORALL iterators. */
4241
4242 void
4243 gfc_free_forall_iterator (gfc_forall_iterator *iter)
4244 {
4245 gfc_forall_iterator *next;
4246
4247 while (iter)
4248 {
4249 next = iter->next;
4250 gfc_free_expr (iter->var);
4251 gfc_free_expr (iter->start);
4252 gfc_free_expr (iter->end);
4253 gfc_free_expr (iter->stride);
4254 gfc_free (iter);
4255 iter = next;
4256 }
4257 }
4258
4259
4260 /* Match an iterator as part of a FORALL statement. The format is:
4261
4262 <var> = <start>:<end>[:<stride>]
4263
4264 On MATCH_NO, the caller tests for the possibility that there is a
4265 scalar mask expression. */
4266
4267 static match
4268 match_forall_iterator (gfc_forall_iterator **result)
4269 {
4270 gfc_forall_iterator *iter;
4271 locus where;
4272 match m;
4273
4274 where = gfc_current_locus;
4275 iter = XCNEW (gfc_forall_iterator);
4276
4277 m = gfc_match_expr (&iter->var);
4278 if (m != MATCH_YES)
4279 goto cleanup;
4280
4281 if (gfc_match_char ('=') != MATCH_YES
4282 || iter->var->expr_type != EXPR_VARIABLE)
4283 {
4284 m = MATCH_NO;
4285 goto cleanup;
4286 }
4287
4288 m = gfc_match_expr (&iter->start);
4289 if (m != MATCH_YES)
4290 goto cleanup;
4291
4292 if (gfc_match_char (':') != MATCH_YES)
4293 goto syntax;
4294
4295 m = gfc_match_expr (&iter->end);
4296 if (m == MATCH_NO)
4297 goto syntax;
4298 if (m == MATCH_ERROR)
4299 goto cleanup;
4300
4301 if (gfc_match_char (':') == MATCH_NO)
4302 iter->stride = gfc_int_expr (1);
4303 else
4304 {
4305 m = gfc_match_expr (&iter->stride);
4306 if (m == MATCH_NO)
4307 goto syntax;
4308 if (m == MATCH_ERROR)
4309 goto cleanup;
4310 }
4311
4312 /* Mark the iteration variable's symbol as used as a FORALL index. */
4313 iter->var->symtree->n.sym->forall_index = true;
4314
4315 *result = iter;
4316 return MATCH_YES;
4317
4318 syntax:
4319 gfc_error ("Syntax error in FORALL iterator at %C");
4320 m = MATCH_ERROR;
4321
4322 cleanup:
4323
4324 gfc_current_locus = where;
4325 gfc_free_forall_iterator (iter);
4326 return m;
4327 }
4328
4329
4330 /* Match the header of a FORALL statement. */
4331
4332 static match
4333 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
4334 {
4335 gfc_forall_iterator *head, *tail, *new_iter;
4336 gfc_expr *msk;
4337 match m;
4338
4339 gfc_gobble_whitespace ();
4340
4341 head = tail = NULL;
4342 msk = NULL;
4343
4344 if (gfc_match_char ('(') != MATCH_YES)
4345 return MATCH_NO;
4346
4347 m = match_forall_iterator (&new_iter);
4348 if (m == MATCH_ERROR)
4349 goto cleanup;
4350 if (m == MATCH_NO)
4351 goto syntax;
4352
4353 head = tail = new_iter;
4354
4355 for (;;)
4356 {
4357 if (gfc_match_char (',') != MATCH_YES)
4358 break;
4359
4360 m = match_forall_iterator (&new_iter);
4361 if (m == MATCH_ERROR)
4362 goto cleanup;
4363
4364 if (m == MATCH_YES)
4365 {
4366 tail->next = new_iter;
4367 tail = new_iter;
4368 continue;
4369 }
4370
4371 /* Have to have a mask expression. */
4372
4373 m = gfc_match_expr (&msk);
4374 if (m == MATCH_NO)
4375 goto syntax;
4376 if (m == MATCH_ERROR)
4377 goto cleanup;
4378
4379 break;
4380 }
4381
4382 if (gfc_match_char (')') == MATCH_NO)
4383 goto syntax;
4384
4385 *phead = head;
4386 *mask = msk;
4387 return MATCH_YES;
4388
4389 syntax:
4390 gfc_syntax_error (ST_FORALL);
4391
4392 cleanup:
4393 gfc_free_expr (msk);
4394 gfc_free_forall_iterator (head);
4395
4396 return MATCH_ERROR;
4397 }
4398
4399 /* Match the rest of a simple FORALL statement that follows an
4400 IF statement. */
4401
4402 static match
4403 match_simple_forall (void)
4404 {
4405 gfc_forall_iterator *head;
4406 gfc_expr *mask;
4407 gfc_code *c;
4408 match m;
4409
4410 mask = NULL;
4411 head = NULL;
4412 c = NULL;
4413
4414 m = match_forall_header (&head, &mask);
4415
4416 if (m == MATCH_NO)
4417 goto syntax;
4418 if (m != MATCH_YES)
4419 goto cleanup;
4420
4421 m = gfc_match_assignment ();
4422
4423 if (m == MATCH_ERROR)
4424 goto cleanup;
4425 if (m == MATCH_NO)
4426 {
4427 m = gfc_match_pointer_assignment ();
4428 if (m == MATCH_ERROR)
4429 goto cleanup;
4430 if (m == MATCH_NO)
4431 goto syntax;
4432 }
4433
4434 c = gfc_get_code ();
4435 *c = new_st;
4436 c->loc = gfc_current_locus;
4437
4438 if (gfc_match_eos () != MATCH_YES)
4439 goto syntax;
4440
4441 gfc_clear_new_st ();
4442 new_st.op = EXEC_FORALL;
4443 new_st.expr1 = mask;
4444 new_st.ext.forall_iterator = head;
4445 new_st.block = gfc_get_code ();
4446
4447 new_st.block->op = EXEC_FORALL;
4448 new_st.block->next = c;
4449
4450 return MATCH_YES;
4451
4452 syntax:
4453 gfc_syntax_error (ST_FORALL);
4454
4455 cleanup:
4456 gfc_free_forall_iterator (head);
4457 gfc_free_expr (mask);
4458
4459 return MATCH_ERROR;
4460 }
4461
4462
4463 /* Match a FORALL statement. */
4464
4465 match
4466 gfc_match_forall (gfc_statement *st)
4467 {
4468 gfc_forall_iterator *head;
4469 gfc_expr *mask;
4470 gfc_code *c;
4471 match m0, m;
4472
4473 head = NULL;
4474 mask = NULL;
4475 c = NULL;
4476
4477 m0 = gfc_match_label ();
4478 if (m0 == MATCH_ERROR)
4479 return MATCH_ERROR;
4480
4481 m = gfc_match (" forall");
4482 if (m != MATCH_YES)
4483 return m;
4484
4485 m = match_forall_header (&head, &mask);
4486 if (m == MATCH_ERROR)
4487 goto cleanup;
4488 if (m == MATCH_NO)
4489 goto syntax;
4490
4491 if (gfc_match_eos () == MATCH_YES)
4492 {
4493 *st = ST_FORALL_BLOCK;
4494 new_st.op = EXEC_FORALL;
4495 new_st.expr1 = mask;
4496 new_st.ext.forall_iterator = head;
4497 return MATCH_YES;
4498 }
4499
4500 m = gfc_match_assignment ();
4501 if (m == MATCH_ERROR)
4502 goto cleanup;
4503 if (m == MATCH_NO)
4504 {
4505 m = gfc_match_pointer_assignment ();
4506 if (m == MATCH_ERROR)
4507 goto cleanup;
4508 if (m == MATCH_NO)
4509 goto syntax;
4510 }
4511
4512 c = gfc_get_code ();
4513 *c = new_st;
4514 c->loc = gfc_current_locus;
4515
4516 gfc_clear_new_st ();
4517 new_st.op = EXEC_FORALL;
4518 new_st.expr1 = mask;
4519 new_st.ext.forall_iterator = head;
4520 new_st.block = gfc_get_code ();
4521 new_st.block->op = EXEC_FORALL;
4522 new_st.block->next = c;
4523
4524 *st = ST_FORALL;
4525 return MATCH_YES;
4526
4527 syntax:
4528 gfc_syntax_error (ST_FORALL);
4529
4530 cleanup:
4531 gfc_free_forall_iterator (head);
4532 gfc_free_expr (mask);
4533 gfc_free_statements (c);
4534 return MATCH_NO;
4535 }