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