1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000-2013 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
29 #include "stringpool.h"
31 int gfc_matching_ptr_assignment
= 0;
32 int gfc_matching_procptr_assignment
= 0;
33 bool gfc_matching_prefix
= false;
35 /* Stack of SELECT TYPE statements. */
36 gfc_select_type_stack
*select_type_stack
= NULL
;
38 /* For debugging and diagnostic purposes. Return the textual representation
39 of the intrinsic operator OP. */
41 gfc_op2string (gfc_intrinsic_op op
)
49 case INTRINSIC_UMINUS
:
55 case INTRINSIC_CONCAT
:
59 case INTRINSIC_DIVIDE
:
98 case INTRINSIC_ASSIGN
:
101 case INTRINSIC_PARENTHESES
:
108 gfc_internal_error ("gfc_op2string(): Bad code");
113 /******************** Generic matching subroutines ************************/
115 /* This function scans the current statement counting the opened and closed
116 parenthesis to make sure they are balanced. */
119 gfc_match_parens (void)
121 locus old_loc
, where
;
123 gfc_instring instring
;
126 old_loc
= gfc_current_locus
;
128 instring
= NONSTRING
;
133 c
= gfc_next_char_literal (instring
);
136 if (quote
== ' ' && ((c
== '\'') || (c
== '"')))
139 instring
= INSTRING_WARN
;
142 if (quote
!= ' ' && c
== quote
)
145 instring
= NONSTRING
;
149 if (c
== '(' && quote
== ' ')
152 where
= gfc_current_locus
;
154 if (c
== ')' && quote
== ' ')
157 where
= gfc_current_locus
;
161 gfc_current_locus
= old_loc
;
165 gfc_error ("Missing ')' in statement at or before %L", &where
);
170 gfc_error ("Missing '(' in statement at or before %L", &where
);
178 /* See if the next character is a special character that has
179 escaped by a \ via the -fbackslash option. */
182 gfc_match_special_char (gfc_char_t
*res
)
190 switch ((c
= gfc_next_char_literal (INSTRING_WARN
)))
223 /* Hexadecimal form of wide characters. */
224 len
= (c
== 'x' ? 2 : (c
== 'u' ? 4 : 8));
226 for (i
= 0; i
< len
; i
++)
228 char buf
[2] = { '\0', '\0' };
230 c
= gfc_next_char_literal (INSTRING_WARN
);
231 if (!gfc_wide_fits_in_byte (c
)
232 || !gfc_check_digit ((unsigned char) c
, 16))
235 buf
[0] = (unsigned char) c
;
237 n
+= strtol (buf
, NULL
, 16);
243 /* Unknown backslash codes are simply not expanded. */
252 /* In free form, match at least one space. Always matches in fixed
256 gfc_match_space (void)
261 if (gfc_current_form
== FORM_FIXED
)
264 old_loc
= gfc_current_locus
;
266 c
= gfc_next_ascii_char ();
267 if (!gfc_is_whitespace (c
))
269 gfc_current_locus
= old_loc
;
273 gfc_gobble_whitespace ();
279 /* Match an end of statement. End of statement is optional
280 whitespace, followed by a ';' or '\n' or comment '!'. If a
281 semicolon is found, we continue to eat whitespace and semicolons. */
294 old_loc
= gfc_current_locus
;
295 gfc_gobble_whitespace ();
297 c
= gfc_next_ascii_char ();
303 c
= gfc_next_ascii_char ();
320 gfc_current_locus
= old_loc
;
321 return (flag
) ? MATCH_YES
: MATCH_NO
;
325 /* Match a literal integer on the input, setting the value on
326 MATCH_YES. Literal ints occur in kind-parameters as well as
327 old-style character length specifications. If cnt is non-NULL it
328 will be set to the number of digits. */
331 gfc_match_small_literal_int (int *value
, int *cnt
)
337 old_loc
= gfc_current_locus
;
340 gfc_gobble_whitespace ();
341 c
= gfc_next_ascii_char ();
347 gfc_current_locus
= old_loc
;
356 old_loc
= gfc_current_locus
;
357 c
= gfc_next_ascii_char ();
362 i
= 10 * i
+ c
- '0';
367 gfc_error ("Integer too large at %C");
372 gfc_current_locus
= old_loc
;
381 /* Match a small, constant integer expression, like in a kind
382 statement. On MATCH_YES, 'value' is set. */
385 gfc_match_small_int (int *value
)
392 m
= gfc_match_expr (&expr
);
396 p
= gfc_extract_int (expr
, &i
);
397 gfc_free_expr (expr
);
410 /* This function is the same as the gfc_match_small_int, except that
411 we're keeping the pointer to the expr. This function could just be
412 removed and the previously mentioned one modified, though all calls
413 to it would have to be modified then (and there were a number of
414 them). Return MATCH_ERROR if fail to extract the int; otherwise,
415 return the result of gfc_match_expr(). The expr (if any) that was
416 matched is returned in the parameter expr. */
419 gfc_match_small_int_expr (int *value
, gfc_expr
**expr
)
425 m
= gfc_match_expr (expr
);
429 p
= gfc_extract_int (*expr
, &i
);
442 /* Matches a statement label. Uses gfc_match_small_literal_int() to
443 do most of the work. */
446 gfc_match_st_label (gfc_st_label
**label
)
452 old_loc
= gfc_current_locus
;
454 m
= gfc_match_small_literal_int (&i
, &cnt
);
460 gfc_error ("Too many digits in statement label at %C");
466 gfc_error ("Statement label at %C is zero");
470 *label
= gfc_get_st_label (i
);
475 gfc_current_locus
= old_loc
;
480 /* Match and validate a label associated with a named IF, DO or SELECT
481 statement. If the symbol does not have the label attribute, we add
482 it. We also make sure the symbol does not refer to another
483 (active) block. A matched label is pointed to by gfc_new_block. */
486 gfc_match_label (void)
488 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
491 gfc_new_block
= NULL
;
493 m
= gfc_match (" %n :", name
);
497 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
499 gfc_error ("Label name '%s' at %C is ambiguous", name
);
503 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
505 gfc_error ("Duplicate construct label '%s' at %C", name
);
509 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
510 gfc_new_block
->name
, NULL
))
517 /* See if the current input looks like a name of some sort. Modifies
518 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
519 Note that options.c restricts max_identifier_length to not more
520 than GFC_MAX_SYMBOL_LEN. */
523 gfc_match_name (char *buffer
)
529 old_loc
= gfc_current_locus
;
530 gfc_gobble_whitespace ();
532 c
= gfc_next_ascii_char ();
533 if (!(ISALPHA (c
) || (c
== '_' && gfc_option
.flag_allow_leading_underscore
)))
535 if (gfc_error_flag_test () == 0 && c
!= '(')
536 gfc_error ("Invalid character in name at %C");
537 gfc_current_locus
= old_loc
;
547 if (i
> gfc_option
.max_identifier_length
)
549 gfc_error ("Name at %C is too long");
553 old_loc
= gfc_current_locus
;
554 c
= gfc_next_ascii_char ();
556 while (ISALNUM (c
) || c
== '_' || (gfc_option
.flag_dollar_ok
&& c
== '$'));
558 if (c
== '$' && !gfc_option
.flag_dollar_ok
)
560 gfc_fatal_error ("Invalid character '$' at %L. Use -fdollar-ok to allow "
561 "it as an extension", &old_loc
);
566 gfc_current_locus
= old_loc
;
572 /* Match a valid name for C, which is almost the same as for Fortran,
573 except that you can start with an underscore, etc.. It could have
574 been done by modifying the gfc_match_name, but this way other
575 things C allows can be done, such as no limits on the length.
576 Also, by rewriting it, we use the gfc_next_char_C() to prevent the
577 input characters from being automatically lower cased, since C is
578 case sensitive. The parameter, buffer, is used to return the name
579 that is matched. Return MATCH_ERROR if the name is not a valid C
580 name, MATCH_NO if what we're seeing isn't a name, and MATCH_YES if
581 we successfully match a C name. */
584 gfc_match_name_C (const char **buffer
)
592 old_loc
= gfc_current_locus
;
593 gfc_gobble_whitespace ();
595 /* Get the next char (first possible char of name) and see if
596 it's valid for C (either a letter or an underscore). */
597 c
= gfc_next_char_literal (INSTRING_WARN
);
599 /* If the user put nothing expect spaces between the quotes, it is valid
600 and simply means there is no name= specifier and the name is the Fortran
601 symbol name, all lowercase. */
602 if (c
== '"' || c
== '\'')
604 gfc_current_locus
= old_loc
;
608 if (!ISALPHA (c
) && c
!= '_')
610 gfc_error ("Invalid C name in NAME= specifier at %C");
614 buf
= XNEWVEC (char, cursz
);
615 /* Continue to read valid variable name characters. */
618 gcc_assert (gfc_wide_fits_in_byte (c
));
620 buf
[i
++] = (unsigned char) c
;
625 buf
= XRESIZEVEC (char, buf
, cursz
);
628 old_loc
= gfc_current_locus
;
630 /* Get next char; param means we're in a string. */
631 c
= gfc_next_char_literal (INSTRING_WARN
);
632 } while (ISALNUM (c
) || c
== '_');
634 /* The binding label will be needed later anyway, so just insert it
635 into the symbol table. */
637 *buffer
= IDENTIFIER_POINTER (get_identifier (buf
));
639 gfc_current_locus
= old_loc
;
641 /* See if we stopped because of whitespace. */
644 gfc_gobble_whitespace ();
645 c
= gfc_peek_ascii_char ();
646 if (c
!= '"' && c
!= '\'')
648 gfc_error ("Embedded space in NAME= specifier at %C");
653 /* If we stopped because we had an invalid character for a C name, report
654 that to the user by returning MATCH_NO. */
655 if (c
!= '"' && c
!= '\'')
657 gfc_error ("Invalid C name in NAME= specifier at %C");
665 /* Match a symbol on the input. Modifies the pointer to the symbol
666 pointer if successful. */
669 gfc_match_sym_tree (gfc_symtree
**matched_symbol
, int host_assoc
)
671 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
674 m
= gfc_match_name (buffer
);
679 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
680 ? MATCH_ERROR
: MATCH_YES
;
682 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
, false))
690 gfc_match_symbol (gfc_symbol
**matched_symbol
, int host_assoc
)
695 m
= gfc_match_sym_tree (&st
, host_assoc
);
700 *matched_symbol
= st
->n
.sym
;
702 *matched_symbol
= NULL
;
705 *matched_symbol
= NULL
;
710 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
711 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
715 gfc_match_intrinsic_op (gfc_intrinsic_op
*result
)
717 locus orig_loc
= gfc_current_locus
;
720 gfc_gobble_whitespace ();
721 ch
= gfc_next_ascii_char ();
726 *result
= INTRINSIC_PLUS
;
731 *result
= INTRINSIC_MINUS
;
735 if (gfc_next_ascii_char () == '=')
738 *result
= INTRINSIC_EQ
;
744 if (gfc_peek_ascii_char () == '=')
747 gfc_next_ascii_char ();
748 *result
= INTRINSIC_LE
;
752 *result
= INTRINSIC_LT
;
756 if (gfc_peek_ascii_char () == '=')
759 gfc_next_ascii_char ();
760 *result
= INTRINSIC_GE
;
764 *result
= INTRINSIC_GT
;
768 if (gfc_peek_ascii_char () == '*')
771 gfc_next_ascii_char ();
772 *result
= INTRINSIC_POWER
;
776 *result
= INTRINSIC_TIMES
;
780 ch
= gfc_peek_ascii_char ();
784 gfc_next_ascii_char ();
785 *result
= INTRINSIC_NE
;
791 gfc_next_ascii_char ();
792 *result
= INTRINSIC_CONCAT
;
796 *result
= INTRINSIC_DIVIDE
;
800 ch
= gfc_next_ascii_char ();
804 if (gfc_next_ascii_char () == 'n'
805 && gfc_next_ascii_char () == 'd'
806 && gfc_next_ascii_char () == '.')
808 /* Matched ".and.". */
809 *result
= INTRINSIC_AND
;
815 if (gfc_next_ascii_char () == 'q')
817 ch
= gfc_next_ascii_char ();
820 /* Matched ".eq.". */
821 *result
= INTRINSIC_EQ_OS
;
826 if (gfc_next_ascii_char () == '.')
828 /* Matched ".eqv.". */
829 *result
= INTRINSIC_EQV
;
837 ch
= gfc_next_ascii_char ();
840 if (gfc_next_ascii_char () == '.')
842 /* Matched ".ge.". */
843 *result
= INTRINSIC_GE_OS
;
849 if (gfc_next_ascii_char () == '.')
851 /* Matched ".gt.". */
852 *result
= INTRINSIC_GT_OS
;
859 ch
= gfc_next_ascii_char ();
862 if (gfc_next_ascii_char () == '.')
864 /* Matched ".le.". */
865 *result
= INTRINSIC_LE_OS
;
871 if (gfc_next_ascii_char () == '.')
873 /* Matched ".lt.". */
874 *result
= INTRINSIC_LT_OS
;
881 ch
= gfc_next_ascii_char ();
884 ch
= gfc_next_ascii_char ();
887 /* Matched ".ne.". */
888 *result
= INTRINSIC_NE_OS
;
893 if (gfc_next_ascii_char () == 'v'
894 && gfc_next_ascii_char () == '.')
896 /* Matched ".neqv.". */
897 *result
= INTRINSIC_NEQV
;
904 if (gfc_next_ascii_char () == 't'
905 && gfc_next_ascii_char () == '.')
907 /* Matched ".not.". */
908 *result
= INTRINSIC_NOT
;
915 if (gfc_next_ascii_char () == 'r'
916 && gfc_next_ascii_char () == '.')
918 /* Matched ".or.". */
919 *result
= INTRINSIC_OR
;
933 gfc_current_locus
= orig_loc
;
938 /* Match a loop control phrase:
940 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
942 If the final integer expression is not present, a constant unity
943 expression is returned. We don't return MATCH_ERROR until after
944 the equals sign is seen. */
947 gfc_match_iterator (gfc_iterator
*iter
, int init_flag
)
949 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
950 gfc_expr
*var
, *e1
, *e2
, *e3
;
956 /* Match the start of an iterator without affecting the symbol table. */
958 start
= gfc_current_locus
;
959 m
= gfc_match (" %n =", name
);
960 gfc_current_locus
= start
;
965 m
= gfc_match_variable (&var
, 0);
969 /* F2008, C617 & C565. */
970 if (var
->symtree
->n
.sym
->attr
.codimension
)
972 gfc_error ("Loop variable at %C cannot be a coarray");
976 if (var
->ref
!= NULL
)
978 gfc_error ("Loop variable at %C cannot be a sub-component");
982 gfc_match_char ('=');
984 var
->symtree
->n
.sym
->attr
.implied_index
= 1;
986 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
989 if (m
== MATCH_ERROR
)
992 if (gfc_match_char (',') != MATCH_YES
)
995 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
998 if (m
== MATCH_ERROR
)
1001 if (gfc_match_char (',') != MATCH_YES
)
1003 e3
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1007 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
1008 if (m
== MATCH_ERROR
)
1012 gfc_error ("Expected a step value in iterator at %C");
1024 gfc_error ("Syntax error in iterator at %C");
1035 /* Tries to match the next non-whitespace character on the input.
1036 This subroutine does not return MATCH_ERROR. */
1039 gfc_match_char (char c
)
1043 where
= gfc_current_locus
;
1044 gfc_gobble_whitespace ();
1046 if (gfc_next_ascii_char () == c
)
1049 gfc_current_locus
= where
;
1054 /* General purpose matching subroutine. The target string is a
1055 scanf-like format string in which spaces correspond to arbitrary
1056 whitespace (including no whitespace), characters correspond to
1057 themselves. The %-codes are:
1059 %% Literal percent sign
1060 %e Expression, pointer to a pointer is set
1061 %s Symbol, pointer to the symbol is set
1062 %n Name, character buffer is set to name
1063 %t Matches end of statement.
1064 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1065 %l Matches a statement label
1066 %v Matches a variable expression (an lvalue)
1067 % Matches a required space (in free form) and optional spaces. */
1070 gfc_match (const char *target
, ...)
1072 gfc_st_label
**label
;
1081 old_loc
= gfc_current_locus
;
1082 va_start (argp
, target
);
1092 gfc_gobble_whitespace ();
1103 vp
= va_arg (argp
, void **);
1104 n
= gfc_match_expr ((gfc_expr
**) vp
);
1115 vp
= va_arg (argp
, void **);
1116 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
1127 vp
= va_arg (argp
, void **);
1128 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
1139 np
= va_arg (argp
, char *);
1140 n
= gfc_match_name (np
);
1151 label
= va_arg (argp
, gfc_st_label
**);
1152 n
= gfc_match_st_label (label
);
1163 ip
= va_arg (argp
, int *);
1164 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
1175 if (gfc_match_eos () != MATCH_YES
)
1183 if (gfc_match_space () == MATCH_YES
)
1189 break; /* Fall through to character matcher. */
1192 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
1197 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1198 expect an upper case character here! */
1199 gcc_assert (TOLOWER (c
) == c
);
1201 if (c
== gfc_next_ascii_char ())
1211 /* Clean up after a failed match. */
1212 gfc_current_locus
= old_loc
;
1213 va_start (argp
, target
);
1216 for (; matches
> 0; matches
--)
1218 while (*p
++ != '%');
1226 /* Matches that don't have to be undone */
1231 (void) va_arg (argp
, void **);
1236 vp
= va_arg (argp
, void **);
1237 gfc_free_expr ((struct gfc_expr
*)*vp
);
1250 /*********************** Statement level matching **********************/
1252 /* Matches the start of a program unit, which is the program keyword
1253 followed by an obligatory symbol. */
1256 gfc_match_program (void)
1261 m
= gfc_match ("% %s%t", &sym
);
1265 gfc_error ("Invalid form of PROGRAM statement at %C");
1269 if (m
== MATCH_ERROR
)
1272 if (!gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
))
1275 gfc_new_block
= sym
;
1281 /* Match a simple assignment statement. */
1284 gfc_match_assignment (void)
1286 gfc_expr
*lvalue
, *rvalue
;
1290 old_loc
= gfc_current_locus
;
1293 m
= gfc_match (" %v =", &lvalue
);
1296 gfc_current_locus
= old_loc
;
1297 gfc_free_expr (lvalue
);
1302 m
= gfc_match (" %e%t", &rvalue
);
1305 gfc_current_locus
= old_loc
;
1306 gfc_free_expr (lvalue
);
1307 gfc_free_expr (rvalue
);
1311 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1313 new_st
.op
= EXEC_ASSIGN
;
1314 new_st
.expr1
= lvalue
;
1315 new_st
.expr2
= rvalue
;
1317 gfc_check_do_variable (lvalue
->symtree
);
1323 /* Match a pointer assignment statement. */
1326 gfc_match_pointer_assignment (void)
1328 gfc_expr
*lvalue
, *rvalue
;
1332 old_loc
= gfc_current_locus
;
1334 lvalue
= rvalue
= NULL
;
1335 gfc_matching_ptr_assignment
= 0;
1336 gfc_matching_procptr_assignment
= 0;
1338 m
= gfc_match (" %v =>", &lvalue
);
1345 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1346 || gfc_is_proc_ptr_comp (lvalue
))
1347 gfc_matching_procptr_assignment
= 1;
1349 gfc_matching_ptr_assignment
= 1;
1351 m
= gfc_match (" %e%t", &rvalue
);
1352 gfc_matching_ptr_assignment
= 0;
1353 gfc_matching_procptr_assignment
= 0;
1357 new_st
.op
= EXEC_POINTER_ASSIGN
;
1358 new_st
.expr1
= lvalue
;
1359 new_st
.expr2
= rvalue
;
1364 gfc_current_locus
= old_loc
;
1365 gfc_free_expr (lvalue
);
1366 gfc_free_expr (rvalue
);
1371 /* We try to match an easy arithmetic IF statement. This only happens
1372 when just after having encountered a simple IF statement. This code
1373 is really duplicate with parts of the gfc_match_if code, but this is
1377 match_arithmetic_if (void)
1379 gfc_st_label
*l1
, *l2
, *l3
;
1383 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1387 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1388 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1389 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1391 gfc_free_expr (expr
);
1395 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Arithmetic IF statement at %C"))
1398 new_st
.op
= EXEC_ARITHMETIC_IF
;
1399 new_st
.expr1
= expr
;
1408 /* The IF statement is a bit of a pain. First of all, there are three
1409 forms of it, the simple IF, the IF that starts a block and the
1412 There is a problem with the simple IF and that is the fact that we
1413 only have a single level of undo information on symbols. What this
1414 means is for a simple IF, we must re-match the whole IF statement
1415 multiple times in order to guarantee that the symbol table ends up
1416 in the proper state. */
1418 static match
match_simple_forall (void);
1419 static match
match_simple_where (void);
1422 gfc_match_if (gfc_statement
*if_type
)
1425 gfc_st_label
*l1
, *l2
, *l3
;
1426 locus old_loc
, old_loc2
;
1430 n
= gfc_match_label ();
1431 if (n
== MATCH_ERROR
)
1434 old_loc
= gfc_current_locus
;
1436 m
= gfc_match (" if ( %e", &expr
);
1440 old_loc2
= gfc_current_locus
;
1441 gfc_current_locus
= old_loc
;
1443 if (gfc_match_parens () == MATCH_ERROR
)
1446 gfc_current_locus
= old_loc2
;
1448 if (gfc_match_char (')') != MATCH_YES
)
1450 gfc_error ("Syntax error in IF-expression at %C");
1451 gfc_free_expr (expr
);
1455 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1461 gfc_error ("Block label not appropriate for arithmetic IF "
1463 gfc_free_expr (expr
);
1467 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1468 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1469 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1471 gfc_free_expr (expr
);
1475 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Arithmetic IF statement at %C"))
1478 new_st
.op
= EXEC_ARITHMETIC_IF
;
1479 new_st
.expr1
= expr
;
1484 *if_type
= ST_ARITHMETIC_IF
;
1488 if (gfc_match (" then%t") == MATCH_YES
)
1490 new_st
.op
= EXEC_IF
;
1491 new_st
.expr1
= expr
;
1492 *if_type
= ST_IF_BLOCK
;
1498 gfc_error ("Block label is not appropriate for IF statement at %C");
1499 gfc_free_expr (expr
);
1503 /* At this point the only thing left is a simple IF statement. At
1504 this point, n has to be MATCH_NO, so we don't have to worry about
1505 re-matching a block label. From what we've got so far, try
1506 matching an assignment. */
1508 *if_type
= ST_SIMPLE_IF
;
1510 m
= gfc_match_assignment ();
1514 gfc_free_expr (expr
);
1515 gfc_undo_symbols ();
1516 gfc_current_locus
= old_loc
;
1518 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1519 assignment was found. For MATCH_NO, continue to call the various
1521 if (m
== MATCH_ERROR
)
1524 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1526 m
= gfc_match_pointer_assignment ();
1530 gfc_free_expr (expr
);
1531 gfc_undo_symbols ();
1532 gfc_current_locus
= old_loc
;
1534 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1536 /* Look at the next keyword to see which matcher to call. Matching
1537 the keyword doesn't affect the symbol table, so we don't have to
1538 restore between tries. */
1540 #define match(string, subr, statement) \
1541 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1545 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1546 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1547 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1548 match ("call", gfc_match_call
, ST_CALL
)
1549 match ("close", gfc_match_close
, ST_CLOSE
)
1550 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1551 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1552 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1553 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1554 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
)
1555 match ("exit", gfc_match_exit
, ST_EXIT
)
1556 match ("flush", gfc_match_flush
, ST_FLUSH
)
1557 match ("forall", match_simple_forall
, ST_FORALL
)
1558 match ("go to", gfc_match_goto
, ST_GOTO
)
1559 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1560 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1561 match ("lock", gfc_match_lock
, ST_LOCK
)
1562 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1563 match ("open", gfc_match_open
, ST_OPEN
)
1564 match ("pause", gfc_match_pause
, ST_NONE
)
1565 match ("print", gfc_match_print
, ST_WRITE
)
1566 match ("read", gfc_match_read
, ST_READ
)
1567 match ("return", gfc_match_return
, ST_RETURN
)
1568 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1569 match ("stop", gfc_match_stop
, ST_STOP
)
1570 match ("wait", gfc_match_wait
, ST_WAIT
)
1571 match ("sync all", gfc_match_sync_all
, ST_SYNC_CALL
);
1572 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
1573 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
1574 match ("unlock", gfc_match_unlock
, ST_UNLOCK
)
1575 match ("where", match_simple_where
, ST_WHERE
)
1576 match ("write", gfc_match_write
, ST_WRITE
)
1578 /* The gfc_match_assignment() above may have returned a MATCH_NO
1579 where the assignment was to a named constant. Check that
1580 special case here. */
1581 m
= gfc_match_assignment ();
1584 gfc_error ("Cannot assign to a named constant at %C");
1585 gfc_free_expr (expr
);
1586 gfc_undo_symbols ();
1587 gfc_current_locus
= old_loc
;
1591 /* All else has failed, so give up. See if any of the matchers has
1592 stored an error message of some sort. */
1593 if (gfc_error_check () == 0)
1594 gfc_error ("Unclassifiable statement in IF-clause at %C");
1596 gfc_free_expr (expr
);
1601 gfc_error ("Syntax error in IF-clause at %C");
1604 gfc_free_expr (expr
);
1608 /* At this point, we've matched the single IF and the action clause
1609 is in new_st. Rearrange things so that the IF statement appears
1612 p
= gfc_get_code (EXEC_IF
);
1613 p
->next
= XCNEW (gfc_code
);
1615 p
->next
->loc
= gfc_current_locus
;
1619 gfc_clear_new_st ();
1621 new_st
.op
= EXEC_IF
;
1630 /* Match an ELSE statement. */
1633 gfc_match_else (void)
1635 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1637 if (gfc_match_eos () == MATCH_YES
)
1640 if (gfc_match_name (name
) != MATCH_YES
1641 || gfc_current_block () == NULL
1642 || gfc_match_eos () != MATCH_YES
)
1644 gfc_error ("Unexpected junk after ELSE statement at %C");
1648 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1650 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1651 name
, gfc_current_block ()->name
);
1659 /* Match an ELSE IF statement. */
1662 gfc_match_elseif (void)
1664 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1668 m
= gfc_match (" ( %e ) then", &expr
);
1672 if (gfc_match_eos () == MATCH_YES
)
1675 if (gfc_match_name (name
) != MATCH_YES
1676 || gfc_current_block () == NULL
1677 || gfc_match_eos () != MATCH_YES
)
1679 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1683 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1685 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1686 name
, gfc_current_block ()->name
);
1691 new_st
.op
= EXEC_IF
;
1692 new_st
.expr1
= expr
;
1696 gfc_free_expr (expr
);
1701 /* Free a gfc_iterator structure. */
1704 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1710 gfc_free_expr (iter
->var
);
1711 gfc_free_expr (iter
->start
);
1712 gfc_free_expr (iter
->end
);
1713 gfc_free_expr (iter
->step
);
1720 /* Match a CRITICAL statement. */
1722 gfc_match_critical (void)
1724 gfc_st_label
*label
= NULL
;
1726 if (gfc_match_label () == MATCH_ERROR
)
1729 if (gfc_match (" critical") != MATCH_YES
)
1732 if (gfc_match_st_label (&label
) == MATCH_ERROR
)
1735 if (gfc_match_eos () != MATCH_YES
)
1737 gfc_syntax_error (ST_CRITICAL
);
1741 if (gfc_pure (NULL
))
1743 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1747 if (gfc_find_state (COMP_DO_CONCURRENT
))
1749 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1754 if (gfc_implicit_pure (NULL
))
1755 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1757 if (!gfc_notify_std (GFC_STD_F2008
, "CRITICAL statement at %C"))
1760 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
1762 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
1766 if (gfc_find_state (COMP_CRITICAL
))
1768 gfc_error ("Nested CRITICAL block at %C");
1772 new_st
.op
= EXEC_CRITICAL
;
1775 && !gfc_reference_st_label (label
, ST_LABEL_TARGET
))
1782 /* Match a BLOCK statement. */
1785 gfc_match_block (void)
1789 if (gfc_match_label () == MATCH_ERROR
)
1792 if (gfc_match (" block") != MATCH_YES
)
1795 /* For this to be a correct BLOCK statement, the line must end now. */
1796 m
= gfc_match_eos ();
1797 if (m
== MATCH_ERROR
)
1806 /* Match an ASSOCIATE statement. */
1809 gfc_match_associate (void)
1811 if (gfc_match_label () == MATCH_ERROR
)
1814 if (gfc_match (" associate") != MATCH_YES
)
1817 /* Match the association list. */
1818 if (gfc_match_char ('(') != MATCH_YES
)
1820 gfc_error ("Expected association list at %C");
1823 new_st
.ext
.block
.assoc
= NULL
;
1826 gfc_association_list
* newAssoc
= gfc_get_association_list ();
1827 gfc_association_list
* a
;
1829 /* Match the next association. */
1830 if (gfc_match (" %n => %e", newAssoc
->name
, &newAssoc
->target
)
1833 gfc_error ("Expected association at %C");
1834 goto assocListError
;
1836 newAssoc
->where
= gfc_current_locus
;
1838 /* Check that the current name is not yet in the list. */
1839 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
1840 if (!strcmp (a
->name
, newAssoc
->name
))
1842 gfc_error ("Duplicate name '%s' in association at %C",
1844 goto assocListError
;
1847 /* The target expression must not be coindexed. */
1848 if (gfc_is_coindexed (newAssoc
->target
))
1850 gfc_error ("Association target at %C must not be coindexed");
1851 goto assocListError
;
1854 /* The `variable' field is left blank for now; because the target is not
1855 yet resolved, we can't use gfc_has_vector_subscript to determine it
1856 for now. This is set during resolution. */
1858 /* Put it into the list. */
1859 newAssoc
->next
= new_st
.ext
.block
.assoc
;
1860 new_st
.ext
.block
.assoc
= newAssoc
;
1862 /* Try next one or end if closing parenthesis is found. */
1863 gfc_gobble_whitespace ();
1864 if (gfc_peek_char () == ')')
1866 if (gfc_match_char (',') != MATCH_YES
)
1868 gfc_error ("Expected ')' or ',' at %C");
1878 if (gfc_match_char (')') != MATCH_YES
)
1880 /* This should never happen as we peek above. */
1884 if (gfc_match_eos () != MATCH_YES
)
1886 gfc_error ("Junk after ASSOCIATE statement at %C");
1893 gfc_free_association_list (new_st
.ext
.block
.assoc
);
1898 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1899 an accessible derived type. */
1902 match_derived_type_spec (gfc_typespec
*ts
)
1904 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1906 gfc_symbol
*derived
;
1908 old_locus
= gfc_current_locus
;
1910 if (gfc_match ("%n", name
) != MATCH_YES
)
1912 gfc_current_locus
= old_locus
;
1916 gfc_find_symbol (name
, NULL
, 1, &derived
);
1918 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
&& derived
->attr
.generic
)
1919 derived
= gfc_find_dt_in_generic (derived
);
1921 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
1923 ts
->type
= BT_DERIVED
;
1924 ts
->u
.derived
= derived
;
1928 gfc_current_locus
= old_locus
;
1933 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
1934 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
1935 It only includes the intrinsic types from the Fortran 2003 standard
1936 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
1937 the implicit_flag is not needed, so it was removed. Derived types are
1938 identified by their name alone. */
1941 gfc_match_type_spec (gfc_typespec
*ts
)
1947 gfc_gobble_whitespace ();
1948 old_locus
= gfc_current_locus
;
1950 if (match_derived_type_spec (ts
) == MATCH_YES
)
1952 /* Enforce F03:C401. */
1953 if (ts
->u
.derived
->attr
.abstract
)
1955 gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
1956 ts
->u
.derived
->name
, &old_locus
);
1962 if (gfc_match ("integer") == MATCH_YES
)
1964 ts
->type
= BT_INTEGER
;
1965 ts
->kind
= gfc_default_integer_kind
;
1969 if (gfc_match ("real") == MATCH_YES
)
1972 ts
->kind
= gfc_default_real_kind
;
1976 if (gfc_match ("double precision") == MATCH_YES
)
1979 ts
->kind
= gfc_default_double_kind
;
1983 if (gfc_match ("complex") == MATCH_YES
)
1985 ts
->type
= BT_COMPLEX
;
1986 ts
->kind
= gfc_default_complex_kind
;
1990 if (gfc_match ("character") == MATCH_YES
)
1992 ts
->type
= BT_CHARACTER
;
1994 m
= gfc_match_char_spec (ts
);
2002 if (gfc_match ("logical") == MATCH_YES
)
2004 ts
->type
= BT_LOGICAL
;
2005 ts
->kind
= gfc_default_logical_kind
;
2009 /* If a type is not matched, simply return MATCH_NO. */
2010 gfc_current_locus
= old_locus
;
2015 gfc_gobble_whitespace ();
2016 if (gfc_peek_ascii_char () == '*')
2018 gfc_error ("Invalid type-spec at %C");
2022 m
= gfc_match_kind_spec (ts
, false);
2025 m
= MATCH_YES
; /* No kind specifier found. */
2031 /******************** FORALL subroutines ********************/
2033 /* Free a list of FORALL iterators. */
2036 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
2038 gfc_forall_iterator
*next
;
2043 gfc_free_expr (iter
->var
);
2044 gfc_free_expr (iter
->start
);
2045 gfc_free_expr (iter
->end
);
2046 gfc_free_expr (iter
->stride
);
2053 /* Match an iterator as part of a FORALL statement. The format is:
2055 <var> = <start>:<end>[:<stride>]
2057 On MATCH_NO, the caller tests for the possibility that there is a
2058 scalar mask expression. */
2061 match_forall_iterator (gfc_forall_iterator
**result
)
2063 gfc_forall_iterator
*iter
;
2067 where
= gfc_current_locus
;
2068 iter
= XCNEW (gfc_forall_iterator
);
2070 m
= gfc_match_expr (&iter
->var
);
2074 if (gfc_match_char ('=') != MATCH_YES
2075 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
2081 m
= gfc_match_expr (&iter
->start
);
2085 if (gfc_match_char (':') != MATCH_YES
)
2088 m
= gfc_match_expr (&iter
->end
);
2091 if (m
== MATCH_ERROR
)
2094 if (gfc_match_char (':') == MATCH_NO
)
2095 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2098 m
= gfc_match_expr (&iter
->stride
);
2101 if (m
== MATCH_ERROR
)
2105 /* Mark the iteration variable's symbol as used as a FORALL index. */
2106 iter
->var
->symtree
->n
.sym
->forall_index
= true;
2112 gfc_error ("Syntax error in FORALL iterator at %C");
2117 gfc_current_locus
= where
;
2118 gfc_free_forall_iterator (iter
);
2123 /* Match the header of a FORALL statement. */
2126 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
2128 gfc_forall_iterator
*head
, *tail
, *new_iter
;
2132 gfc_gobble_whitespace ();
2137 if (gfc_match_char ('(') != MATCH_YES
)
2140 m
= match_forall_iterator (&new_iter
);
2141 if (m
== MATCH_ERROR
)
2146 head
= tail
= new_iter
;
2150 if (gfc_match_char (',') != MATCH_YES
)
2153 m
= match_forall_iterator (&new_iter
);
2154 if (m
== MATCH_ERROR
)
2159 tail
->next
= new_iter
;
2164 /* Have to have a mask expression. */
2166 m
= gfc_match_expr (&msk
);
2169 if (m
== MATCH_ERROR
)
2175 if (gfc_match_char (')') == MATCH_NO
)
2183 gfc_syntax_error (ST_FORALL
);
2186 gfc_free_expr (msk
);
2187 gfc_free_forall_iterator (head
);
2192 /* Match the rest of a simple FORALL statement that follows an
2196 match_simple_forall (void)
2198 gfc_forall_iterator
*head
;
2207 m
= match_forall_header (&head
, &mask
);
2214 m
= gfc_match_assignment ();
2216 if (m
== MATCH_ERROR
)
2220 m
= gfc_match_pointer_assignment ();
2221 if (m
== MATCH_ERROR
)
2227 c
= XCNEW (gfc_code
);
2229 c
->loc
= gfc_current_locus
;
2231 if (gfc_match_eos () != MATCH_YES
)
2234 gfc_clear_new_st ();
2235 new_st
.op
= EXEC_FORALL
;
2236 new_st
.expr1
= mask
;
2237 new_st
.ext
.forall_iterator
= head
;
2238 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2239 new_st
.block
->next
= c
;
2244 gfc_syntax_error (ST_FORALL
);
2247 gfc_free_forall_iterator (head
);
2248 gfc_free_expr (mask
);
2254 /* Match a FORALL statement. */
2257 gfc_match_forall (gfc_statement
*st
)
2259 gfc_forall_iterator
*head
;
2268 m0
= gfc_match_label ();
2269 if (m0
== MATCH_ERROR
)
2272 m
= gfc_match (" forall");
2276 m
= match_forall_header (&head
, &mask
);
2277 if (m
== MATCH_ERROR
)
2282 if (gfc_match_eos () == MATCH_YES
)
2284 *st
= ST_FORALL_BLOCK
;
2285 new_st
.op
= EXEC_FORALL
;
2286 new_st
.expr1
= mask
;
2287 new_st
.ext
.forall_iterator
= head
;
2291 m
= gfc_match_assignment ();
2292 if (m
== MATCH_ERROR
)
2296 m
= gfc_match_pointer_assignment ();
2297 if (m
== MATCH_ERROR
)
2303 c
= XCNEW (gfc_code
);
2305 c
->loc
= gfc_current_locus
;
2307 gfc_clear_new_st ();
2308 new_st
.op
= EXEC_FORALL
;
2309 new_st
.expr1
= mask
;
2310 new_st
.ext
.forall_iterator
= head
;
2311 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2312 new_st
.block
->next
= c
;
2318 gfc_syntax_error (ST_FORALL
);
2321 gfc_free_forall_iterator (head
);
2322 gfc_free_expr (mask
);
2323 gfc_free_statements (c
);
2328 /* Match a DO statement. */
2333 gfc_iterator iter
, *ip
;
2335 gfc_st_label
*label
;
2338 old_loc
= gfc_current_locus
;
2341 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
2343 m
= gfc_match_label ();
2344 if (m
== MATCH_ERROR
)
2347 if (gfc_match (" do") != MATCH_YES
)
2350 m
= gfc_match_st_label (&label
);
2351 if (m
== MATCH_ERROR
)
2354 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2356 if (gfc_match_eos () == MATCH_YES
)
2358 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
2359 new_st
.op
= EXEC_DO_WHILE
;
2363 /* Match an optional comma, if no comma is found, a space is obligatory. */
2364 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
2367 /* Check for balanced parens. */
2369 if (gfc_match_parens () == MATCH_ERROR
)
2372 if (gfc_match (" concurrent") == MATCH_YES
)
2374 gfc_forall_iterator
*head
;
2377 if (!gfc_notify_std (GFC_STD_F2008
, "DO CONCURRENT construct at %C"))
2383 m
= match_forall_header (&head
, &mask
);
2387 if (m
== MATCH_ERROR
)
2388 goto concurr_cleanup
;
2390 if (gfc_match_eos () != MATCH_YES
)
2391 goto concurr_cleanup
;
2394 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2395 goto concurr_cleanup
;
2397 new_st
.label1
= label
;
2398 new_st
.op
= EXEC_DO_CONCURRENT
;
2399 new_st
.expr1
= mask
;
2400 new_st
.ext
.forall_iterator
= head
;
2405 gfc_syntax_error (ST_DO
);
2406 gfc_free_expr (mask
);
2407 gfc_free_forall_iterator (head
);
2411 /* See if we have a DO WHILE. */
2412 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
2414 new_st
.op
= EXEC_DO_WHILE
;
2418 /* The abortive DO WHILE may have done something to the symbol
2419 table, so we start over. */
2420 gfc_undo_symbols ();
2421 gfc_current_locus
= old_loc
;
2423 gfc_match_label (); /* This won't error. */
2424 gfc_match (" do "); /* This will work. */
2426 gfc_match_st_label (&label
); /* Can't error out. */
2427 gfc_match_char (','); /* Optional comma. */
2429 m
= gfc_match_iterator (&iter
, 0);
2432 if (m
== MATCH_ERROR
)
2435 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
2436 gfc_check_do_variable (iter
.var
->symtree
);
2438 if (gfc_match_eos () != MATCH_YES
)
2440 gfc_syntax_error (ST_DO
);
2444 new_st
.op
= EXEC_DO
;
2448 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2451 new_st
.label1
= label
;
2453 if (new_st
.op
== EXEC_DO_WHILE
)
2454 new_st
.expr1
= iter
.end
;
2457 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
2464 gfc_free_iterator (&iter
, 0);
2470 /* Match an EXIT or CYCLE statement. */
2473 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2475 gfc_state_data
*p
, *o
;
2480 if (gfc_match_eos () == MATCH_YES
)
2484 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2487 m
= gfc_match ("% %n%t", name
);
2488 if (m
== MATCH_ERROR
)
2492 gfc_syntax_error (st
);
2496 /* Find the corresponding symbol. If there's a BLOCK statement
2497 between here and the label, it is not in gfc_current_ns but a parent
2499 stree
= gfc_find_symtree_in_proc (name
, gfc_current_ns
);
2502 gfc_error ("Name '%s' in %s statement at %C is unknown",
2503 name
, gfc_ascii_statement (st
));
2508 if (sym
->attr
.flavor
!= FL_LABEL
)
2510 gfc_error ("Name '%s' in %s statement at %C is not a construct name",
2511 name
, gfc_ascii_statement (st
));
2516 /* Find the loop specified by the label (or lack of a label). */
2517 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2518 if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2520 else if (p
->state
== COMP_CRITICAL
)
2522 gfc_error("%s statement at %C leaves CRITICAL construct",
2523 gfc_ascii_statement (st
));
2526 else if (p
->state
== COMP_DO_CONCURRENT
2527 && (op
== EXEC_EXIT
|| (sym
&& sym
!= p
->sym
)))
2529 /* F2008, C821 & C845. */
2530 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2531 gfc_ascii_statement (st
));
2534 else if ((sym
&& sym
== p
->sym
)
2535 || (!sym
&& (p
->state
== COMP_DO
2536 || p
->state
== COMP_DO_CONCURRENT
)))
2542 gfc_error ("%s statement at %C is not within a construct",
2543 gfc_ascii_statement (st
));
2545 gfc_error ("%s statement at %C is not within construct '%s'",
2546 gfc_ascii_statement (st
), sym
->name
);
2551 /* Special checks for EXIT from non-loop constructs. */
2555 case COMP_DO_CONCURRENT
:
2559 /* This is already handled above. */
2562 case COMP_ASSOCIATE
:
2566 case COMP_SELECT_TYPE
:
2568 if (op
== EXEC_CYCLE
)
2570 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2571 " construct '%s'", sym
->name
);
2574 gcc_assert (op
== EXEC_EXIT
);
2575 if (!gfc_notify_std (GFC_STD_F2008
, "EXIT statement with no"
2576 " do-construct-name at %C"))
2581 gfc_error ("%s statement at %C is not applicable to construct '%s'",
2582 gfc_ascii_statement (st
), sym
->name
);
2588 gfc_error ("%s statement at %C leaving OpenMP structured block",
2589 gfc_ascii_statement (st
));
2593 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2597 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
2598 && (o
->head
->op
== EXEC_OMP_DO
2599 || o
->head
->op
== EXEC_OMP_PARALLEL_DO
))
2602 gcc_assert (o
->head
->next
!= NULL
2603 && (o
->head
->next
->op
== EXEC_DO
2604 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2605 && o
->previous
!= NULL
2606 && o
->previous
->tail
->op
== o
->head
->op
);
2607 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2608 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2609 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2610 if (st
== ST_EXIT
&& cnt
<= collapse
)
2612 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2615 if (st
== ST_CYCLE
&& cnt
< collapse
)
2617 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2623 /* Save the first statement in the construct - needed by the backend. */
2624 new_st
.ext
.which_construct
= p
->construct
;
2632 /* Match the EXIT statement. */
2635 gfc_match_exit (void)
2637 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2641 /* Match the CYCLE statement. */
2644 gfc_match_cycle (void)
2646 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2650 /* Match a number or character constant after an (ALL) STOP or PAUSE statement. */
2653 gfc_match_stopcode (gfc_statement st
)
2660 if (gfc_match_eos () != MATCH_YES
)
2662 m
= gfc_match_init_expr (&e
);
2663 if (m
== MATCH_ERROR
)
2668 if (gfc_match_eos () != MATCH_YES
)
2672 if (gfc_pure (NULL
))
2674 gfc_error ("%s statement not allowed in PURE procedure at %C",
2675 gfc_ascii_statement (st
));
2679 if (gfc_implicit_pure (NULL
))
2680 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
2682 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
))
2684 gfc_error ("Image control statement STOP at %C in CRITICAL block");
2687 if (st
== ST_STOP
&& gfc_find_state (COMP_DO_CONCURRENT
))
2689 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
2695 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
2697 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2704 gfc_error ("STOP code at %L must be scalar",
2709 if (e
->ts
.type
== BT_CHARACTER
2710 && e
->ts
.kind
!= gfc_default_character_kind
)
2712 gfc_error ("STOP code at %L must be default character KIND=%d",
2713 &e
->where
, (int) gfc_default_character_kind
);
2717 if (e
->ts
.type
== BT_INTEGER
2718 && e
->ts
.kind
!= gfc_default_integer_kind
)
2720 gfc_error ("STOP code at %L must be default integer KIND=%d",
2721 &e
->where
, (int) gfc_default_integer_kind
);
2729 new_st
.op
= EXEC_STOP
;
2732 new_st
.op
= EXEC_ERROR_STOP
;
2735 new_st
.op
= EXEC_PAUSE
;
2742 new_st
.ext
.stop_code
= -1;
2747 gfc_syntax_error (st
);
2756 /* Match the (deprecated) PAUSE statement. */
2759 gfc_match_pause (void)
2763 m
= gfc_match_stopcode (ST_PAUSE
);
2766 if (!gfc_notify_std (GFC_STD_F95_DEL
, "PAUSE statement at %C"))
2773 /* Match the STOP statement. */
2776 gfc_match_stop (void)
2778 return gfc_match_stopcode (ST_STOP
);
2782 /* Match the ERROR STOP statement. */
2785 gfc_match_error_stop (void)
2787 if (!gfc_notify_std (GFC_STD_F2008
, "ERROR STOP statement at %C"))
2790 return gfc_match_stopcode (ST_ERROR_STOP
);
2794 /* Match LOCK/UNLOCK statement. Syntax:
2795 LOCK ( lock-variable [ , lock-stat-list ] )
2796 UNLOCK ( lock-variable [ , sync-stat-list ] )
2797 where lock-stat is ACQUIRED_LOCK or sync-stat
2798 and sync-stat is STAT= or ERRMSG=. */
2801 lock_unlock_statement (gfc_statement st
)
2804 gfc_expr
*tmp
, *lockvar
, *acq_lock
, *stat
, *errmsg
;
2805 bool saw_acq_lock
, saw_stat
, saw_errmsg
;
2807 tmp
= lockvar
= acq_lock
= stat
= errmsg
= NULL
;
2808 saw_acq_lock
= saw_stat
= saw_errmsg
= false;
2810 if (gfc_pure (NULL
))
2812 gfc_error ("Image control statement %s at %C in PURE procedure",
2813 st
== ST_LOCK
? "LOCK" : "UNLOCK");
2817 if (gfc_implicit_pure (NULL
))
2818 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
2820 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
2822 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2826 if (gfc_find_state (COMP_CRITICAL
))
2828 gfc_error ("Image control statement %s at %C in CRITICAL block",
2829 st
== ST_LOCK
? "LOCK" : "UNLOCK");
2833 if (gfc_find_state (COMP_DO_CONCURRENT
))
2835 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
2836 st
== ST_LOCK
? "LOCK" : "UNLOCK");
2840 if (gfc_match_char ('(') != MATCH_YES
)
2843 if (gfc_match ("%e", &lockvar
) != MATCH_YES
)
2845 m
= gfc_match_char (',');
2846 if (m
== MATCH_ERROR
)
2850 m
= gfc_match_char (')');
2858 m
= gfc_match (" stat = %v", &tmp
);
2859 if (m
== MATCH_ERROR
)
2865 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
2871 m
= gfc_match_char (',');
2879 m
= gfc_match (" errmsg = %v", &tmp
);
2880 if (m
== MATCH_ERROR
)
2886 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
2892 m
= gfc_match_char (',');
2900 m
= gfc_match (" acquired_lock = %v", &tmp
);
2901 if (m
== MATCH_ERROR
|| st
== ST_UNLOCK
)
2907 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
2912 saw_acq_lock
= true;
2914 m
= gfc_match_char (',');
2925 if (m
== MATCH_ERROR
)
2928 if (gfc_match (" )%t") != MATCH_YES
)
2935 new_st
.op
= EXEC_LOCK
;
2938 new_st
.op
= EXEC_UNLOCK
;
2944 new_st
.expr1
= lockvar
;
2945 new_st
.expr2
= stat
;
2946 new_st
.expr3
= errmsg
;
2947 new_st
.expr4
= acq_lock
;
2952 gfc_syntax_error (st
);
2955 if (acq_lock
!= tmp
)
2956 gfc_free_expr (acq_lock
);
2958 gfc_free_expr (errmsg
);
2960 gfc_free_expr (stat
);
2962 gfc_free_expr (tmp
);
2963 gfc_free_expr (lockvar
);
2970 gfc_match_lock (void)
2972 if (!gfc_notify_std (GFC_STD_F2008
, "LOCK statement at %C"))
2975 return lock_unlock_statement (ST_LOCK
);
2980 gfc_match_unlock (void)
2982 if (!gfc_notify_std (GFC_STD_F2008
, "UNLOCK statement at %C"))
2985 return lock_unlock_statement (ST_UNLOCK
);
2989 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
2990 SYNC ALL [(sync-stat-list)]
2991 SYNC MEMORY [(sync-stat-list)]
2992 SYNC IMAGES (image-set [, sync-stat-list] )
2993 with sync-stat is int-expr or *. */
2996 sync_statement (gfc_statement st
)
2999 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
3000 bool saw_stat
, saw_errmsg
;
3002 tmp
= imageset
= stat
= errmsg
= NULL
;
3003 saw_stat
= saw_errmsg
= false;
3005 if (gfc_pure (NULL
))
3007 gfc_error ("Image control statement SYNC at %C in PURE procedure");
3011 if (gfc_implicit_pure (NULL
))
3012 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3014 if (!gfc_notify_std (GFC_STD_F2008
, "SYNC statement at %C"))
3017 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
3019 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
3023 if (gfc_find_state (COMP_CRITICAL
))
3025 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3029 if (gfc_find_state (COMP_DO_CONCURRENT
))
3031 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3035 if (gfc_match_eos () == MATCH_YES
)
3037 if (st
== ST_SYNC_IMAGES
)
3042 if (gfc_match_char ('(') != MATCH_YES
)
3045 if (st
== ST_SYNC_IMAGES
)
3047 /* Denote '*' as imageset == NULL. */
3048 m
= gfc_match_char ('*');
3049 if (m
== MATCH_ERROR
)
3053 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
3056 m
= gfc_match_char (',');
3057 if (m
== MATCH_ERROR
)
3061 m
= gfc_match_char (')');
3070 m
= gfc_match (" stat = %v", &tmp
);
3071 if (m
== MATCH_ERROR
)
3077 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3083 if (gfc_match_char (',') == MATCH_YES
)
3090 m
= gfc_match (" errmsg = %v", &tmp
);
3091 if (m
== MATCH_ERROR
)
3097 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3103 if (gfc_match_char (',') == MATCH_YES
)
3113 if (gfc_match (" )%t") != MATCH_YES
)
3120 new_st
.op
= EXEC_SYNC_ALL
;
3122 case ST_SYNC_IMAGES
:
3123 new_st
.op
= EXEC_SYNC_IMAGES
;
3125 case ST_SYNC_MEMORY
:
3126 new_st
.op
= EXEC_SYNC_MEMORY
;
3132 new_st
.expr1
= imageset
;
3133 new_st
.expr2
= stat
;
3134 new_st
.expr3
= errmsg
;
3139 gfc_syntax_error (st
);
3143 gfc_free_expr (stat
);
3145 gfc_free_expr (errmsg
);
3147 gfc_free_expr (tmp
);
3148 gfc_free_expr (imageset
);
3154 /* Match SYNC ALL statement. */
3157 gfc_match_sync_all (void)
3159 return sync_statement (ST_SYNC_ALL
);
3163 /* Match SYNC IMAGES statement. */
3166 gfc_match_sync_images (void)
3168 return sync_statement (ST_SYNC_IMAGES
);
3172 /* Match SYNC MEMORY statement. */
3175 gfc_match_sync_memory (void)
3177 return sync_statement (ST_SYNC_MEMORY
);
3181 /* Match a CONTINUE statement. */
3184 gfc_match_continue (void)
3186 if (gfc_match_eos () != MATCH_YES
)
3188 gfc_syntax_error (ST_CONTINUE
);
3192 new_st
.op
= EXEC_CONTINUE
;
3197 /* Match the (deprecated) ASSIGN statement. */
3200 gfc_match_assign (void)
3203 gfc_st_label
*label
;
3205 if (gfc_match (" %l", &label
) == MATCH_YES
)
3207 if (!gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
))
3209 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
3211 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGN statement at %C"))
3214 expr
->symtree
->n
.sym
->attr
.assign
= 1;
3216 new_st
.op
= EXEC_LABEL_ASSIGN
;
3217 new_st
.label1
= label
;
3218 new_st
.expr1
= expr
;
3226 /* Match the GO TO statement. As a computed GOTO statement is
3227 matched, it is transformed into an equivalent SELECT block. No
3228 tree is necessary, and the resulting jumps-to-jumps are
3229 specifically optimized away by the back end. */
3232 gfc_match_goto (void)
3234 gfc_code
*head
, *tail
;
3237 gfc_st_label
*label
;
3241 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
3243 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3246 new_st
.op
= EXEC_GOTO
;
3247 new_st
.label1
= label
;
3251 /* The assigned GO TO statement. */
3253 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
3255 if (!gfc_notify_std (GFC_STD_F95_DEL
, "Assigned GOTO statement at %C"))
3258 new_st
.op
= EXEC_GOTO
;
3259 new_st
.expr1
= expr
;
3261 if (gfc_match_eos () == MATCH_YES
)
3264 /* Match label list. */
3265 gfc_match_char (',');
3266 if (gfc_match_char ('(') != MATCH_YES
)
3268 gfc_syntax_error (ST_GOTO
);
3275 m
= gfc_match_st_label (&label
);
3279 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3283 head
= tail
= gfc_get_code (EXEC_GOTO
);
3286 tail
->block
= gfc_get_code (EXEC_GOTO
);
3290 tail
->label1
= label
;
3292 while (gfc_match_char (',') == MATCH_YES
);
3294 if (gfc_match (")%t") != MATCH_YES
)
3299 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3302 new_st
.block
= head
;
3307 /* Last chance is a computed GO TO statement. */
3308 if (gfc_match_char ('(') != MATCH_YES
)
3310 gfc_syntax_error (ST_GOTO
);
3319 m
= gfc_match_st_label (&label
);
3323 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3327 head
= tail
= gfc_get_code (EXEC_SELECT
);
3330 tail
->block
= gfc_get_code (EXEC_SELECT
);
3334 cp
= gfc_get_case ();
3335 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
3338 tail
->ext
.block
.case_list
= cp
;
3340 tail
->next
= gfc_get_code (EXEC_GOTO
);
3341 tail
->next
->label1
= label
;
3343 while (gfc_match_char (',') == MATCH_YES
);
3345 if (gfc_match_char (')') != MATCH_YES
)
3350 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3354 /* Get the rest of the statement. */
3355 gfc_match_char (',');
3357 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
3360 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Computed GOTO at %C"))
3363 /* At this point, a computed GOTO has been fully matched and an
3364 equivalent SELECT statement constructed. */
3366 new_st
.op
= EXEC_SELECT
;
3367 new_st
.expr1
= NULL
;
3369 /* Hack: For a "real" SELECT, the expression is in expr. We put
3370 it in expr2 so we can distinguish then and produce the correct
3372 new_st
.expr2
= expr
;
3373 new_st
.block
= head
;
3377 gfc_syntax_error (ST_GOTO
);
3379 gfc_free_statements (head
);
3384 /* Frees a list of gfc_alloc structures. */
3387 gfc_free_alloc_list (gfc_alloc
*p
)
3394 gfc_free_expr (p
->expr
);
3400 /* Match an ALLOCATE statement. */
3403 gfc_match_allocate (void)
3405 gfc_alloc
*head
, *tail
;
3406 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
3410 locus old_locus
, deferred_locus
;
3411 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, saw_deferred
, b1
, b2
, b3
;
3412 bool saw_unlimited
= false;
3415 stat
= errmsg
= source
= mold
= tmp
= NULL
;
3416 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= saw_deferred
= false;
3418 if (gfc_match_char ('(') != MATCH_YES
)
3421 /* Match an optional type-spec. */
3422 old_locus
= gfc_current_locus
;
3423 m
= gfc_match_type_spec (&ts
);
3424 if (m
== MATCH_ERROR
)
3426 else if (m
== MATCH_NO
)
3428 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
3430 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
3432 gfc_error ("Error in type-spec at %L", &old_locus
);
3436 ts
.type
= BT_UNKNOWN
;
3440 if (gfc_match (" :: ") == MATCH_YES
)
3442 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
3448 gfc_error ("Type-spec at %L cannot contain a deferred "
3449 "type parameter", &old_locus
);
3453 if (ts
.type
== BT_CHARACTER
)
3454 ts
.u
.cl
->length_from_typespec
= true;
3458 ts
.type
= BT_UNKNOWN
;
3459 gfc_current_locus
= old_locus
;
3466 head
= tail
= gfc_get_alloc ();
3469 tail
->next
= gfc_get_alloc ();
3473 m
= gfc_match_variable (&tail
->expr
, 0);
3476 if (m
== MATCH_ERROR
)
3479 if (gfc_check_do_variable (tail
->expr
->symtree
))
3482 if (gfc_pure (NULL
) && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
3484 gfc_error ("Bad allocate-object at %C for a PURE procedure");
3488 if (gfc_implicit_pure (NULL
)
3489 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
3490 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3492 if (tail
->expr
->ts
.deferred
)
3494 saw_deferred
= true;
3495 deferred_locus
= tail
->expr
->where
;
3498 if (gfc_find_state (COMP_DO_CONCURRENT
)
3499 || gfc_find_state (COMP_CRITICAL
))
3502 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
3503 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
3504 if (ref
->type
== REF_COMPONENT
)
3505 coarray
= ref
->u
.c
.component
->attr
.codimension
;
3507 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
3509 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
3512 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
3514 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
3519 /* Check for F08:C628. */
3520 sym
= tail
->expr
->symtree
->n
.sym
;
3521 b1
= !(tail
->expr
->ref
3522 && (tail
->expr
->ref
->type
== REF_COMPONENT
3523 || tail
->expr
->ref
->type
== REF_ARRAY
));
3524 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
3525 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
3526 || CLASS_DATA (sym
)->attr
.class_pointer
);
3528 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
3529 || sym
->attr
.proc_pointer
);
3530 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
3531 && (sym
->ns
->proc_name
->attr
.allocatable
3532 || sym
->ns
->proc_name
->attr
.pointer
3533 || sym
->ns
->proc_name
->attr
.proc_pointer
);
3534 if (b1
&& b2
&& !b3
)
3536 gfc_error ("Allocate-object at %L is neither a data pointer "
3537 "nor an allocatable variable", &tail
->expr
->where
);
3541 /* The ALLOCATE statement had an optional typespec. Check the
3543 if (ts
.type
!= BT_UNKNOWN
)
3545 /* Enforce F03:C624. */
3546 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
3548 gfc_error ("Type of entity at %L is type incompatible with "
3549 "typespec", &tail
->expr
->where
);
3553 /* Enforce F03:C627. */
3554 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
3556 gfc_error ("Kind type parameter for entity at %L differs from "
3557 "the kind type parameter of the typespec",
3558 &tail
->expr
->where
);
3563 if (tail
->expr
->ts
.type
== BT_DERIVED
)
3564 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
3566 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
3568 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
3570 gfc_error ("Shape specification for allocatable scalar at %C");
3574 if (gfc_match_char (',') != MATCH_YES
)
3579 m
= gfc_match (" stat = %v", &tmp
);
3580 if (m
== MATCH_ERROR
)
3587 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3595 if (gfc_check_do_variable (stat
->symtree
))
3598 if (gfc_match_char (',') == MATCH_YES
)
3599 goto alloc_opt_list
;
3602 m
= gfc_match (" errmsg = %v", &tmp
);
3603 if (m
== MATCH_ERROR
)
3607 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
3613 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3621 if (gfc_match_char (',') == MATCH_YES
)
3622 goto alloc_opt_list
;
3625 m
= gfc_match (" source = %e", &tmp
);
3626 if (m
== MATCH_ERROR
)
3630 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
3636 gfc_error ("Redundant SOURCE tag found at %L ", &tmp
->where
);
3640 /* The next 2 conditionals check C631. */
3641 if (ts
.type
!= BT_UNKNOWN
)
3643 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
3644 &tmp
->where
, &old_locus
);
3649 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
3650 " with more than a single allocate object",
3658 if (gfc_match_char (',') == MATCH_YES
)
3659 goto alloc_opt_list
;
3662 m
= gfc_match (" mold = %e", &tmp
);
3663 if (m
== MATCH_ERROR
)
3667 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
3670 /* Check F08:C636. */
3673 gfc_error ("Redundant MOLD tag found at %L ", &tmp
->where
);
3677 /* Check F08:C637. */
3678 if (ts
.type
!= BT_UNKNOWN
)
3680 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
3681 &tmp
->where
, &old_locus
);
3690 if (gfc_match_char (',') == MATCH_YES
)
3691 goto alloc_opt_list
;
3694 gfc_gobble_whitespace ();
3696 if (gfc_peek_char () == ')')
3700 if (gfc_match (" )%t") != MATCH_YES
)
3703 /* Check F08:C637. */
3706 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
3707 &mold
->where
, &source
->where
);
3711 /* Check F03:C623, */
3712 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
3714 gfc_error ("Allocate-object at %L with a deferred type parameter "
3715 "requires either a type-spec or SOURCE tag or a MOLD tag",
3720 /* Check F03:C625, */
3721 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
3723 for (tail
= head
; tail
; tail
= tail
->next
)
3725 if (UNLIMITED_POLY (tail
->expr
))
3726 gfc_error ("Unlimited polymorphic allocate-object at %L "
3727 "requires either a type-spec or SOURCE tag "
3728 "or a MOLD tag", &tail
->expr
->where
);
3733 new_st
.op
= EXEC_ALLOCATE
;
3734 new_st
.expr1
= stat
;
3735 new_st
.expr2
= errmsg
;
3737 new_st
.expr3
= source
;
3739 new_st
.expr3
= mold
;
3740 new_st
.ext
.alloc
.list
= head
;
3741 new_st
.ext
.alloc
.ts
= ts
;
3746 gfc_syntax_error (ST_ALLOCATE
);
3749 gfc_free_expr (errmsg
);
3750 gfc_free_expr (source
);
3751 gfc_free_expr (stat
);
3752 gfc_free_expr (mold
);
3753 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
3754 gfc_free_alloc_list (head
);
3759 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
3760 a set of pointer assignments to intrinsic NULL(). */
3763 gfc_match_nullify (void)
3771 if (gfc_match_char ('(') != MATCH_YES
)
3776 m
= gfc_match_variable (&p
, 0);
3777 if (m
== MATCH_ERROR
)
3782 if (gfc_check_do_variable (p
->symtree
))
3786 if (gfc_is_coindexed (p
))
3788 gfc_error ("Pointer object at %C shall not be coindexed");
3792 /* build ' => NULL() '. */
3793 e
= gfc_get_null_expr (&gfc_current_locus
);
3795 /* Chain to list. */
3799 tail
->op
= EXEC_POINTER_ASSIGN
;
3803 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
3810 if (gfc_match (" )%t") == MATCH_YES
)
3812 if (gfc_match_char (',') != MATCH_YES
)
3819 gfc_syntax_error (ST_NULLIFY
);
3822 gfc_free_statements (new_st
.next
);
3824 gfc_free_expr (new_st
.expr1
);
3825 new_st
.expr1
= NULL
;
3826 gfc_free_expr (new_st
.expr2
);
3827 new_st
.expr2
= NULL
;
3832 /* Match a DEALLOCATE statement. */
3835 gfc_match_deallocate (void)
3837 gfc_alloc
*head
, *tail
;
3838 gfc_expr
*stat
, *errmsg
, *tmp
;
3841 bool saw_stat
, saw_errmsg
, b1
, b2
;
3844 stat
= errmsg
= tmp
= NULL
;
3845 saw_stat
= saw_errmsg
= false;
3847 if (gfc_match_char ('(') != MATCH_YES
)
3853 head
= tail
= gfc_get_alloc ();
3856 tail
->next
= gfc_get_alloc ();
3860 m
= gfc_match_variable (&tail
->expr
, 0);
3861 if (m
== MATCH_ERROR
)
3866 if (gfc_check_do_variable (tail
->expr
->symtree
))
3869 sym
= tail
->expr
->symtree
->n
.sym
;
3871 if (gfc_pure (NULL
) && gfc_impure_variable (sym
))
3873 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3877 if (gfc_implicit_pure (NULL
) && gfc_impure_variable (sym
))
3878 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3880 if (gfc_is_coarray (tail
->expr
)
3881 && gfc_find_state (COMP_DO_CONCURRENT
))
3883 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
3887 if (gfc_is_coarray (tail
->expr
)
3888 && gfc_find_state (COMP_CRITICAL
))
3890 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
3894 /* FIXME: disable the checking on derived types. */
3895 b1
= !(tail
->expr
->ref
3896 && (tail
->expr
->ref
->type
== REF_COMPONENT
3897 || tail
->expr
->ref
->type
== REF_ARRAY
));
3898 if (sym
&& sym
->ts
.type
== BT_CLASS
)
3899 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
3900 || CLASS_DATA (sym
)->attr
.class_pointer
);
3902 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
3903 || sym
->attr
.proc_pointer
);
3906 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3907 "nor an allocatable variable");
3911 if (gfc_match_char (',') != MATCH_YES
)
3916 m
= gfc_match (" stat = %v", &tmp
);
3917 if (m
== MATCH_ERROR
)
3923 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3924 gfc_free_expr (tmp
);
3931 if (gfc_check_do_variable (stat
->symtree
))
3934 if (gfc_match_char (',') == MATCH_YES
)
3935 goto dealloc_opt_list
;
3938 m
= gfc_match (" errmsg = %v", &tmp
);
3939 if (m
== MATCH_ERROR
)
3943 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
3948 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3949 gfc_free_expr (tmp
);
3956 if (gfc_match_char (',') == MATCH_YES
)
3957 goto dealloc_opt_list
;
3960 gfc_gobble_whitespace ();
3962 if (gfc_peek_char () == ')')
3966 if (gfc_match (" )%t") != MATCH_YES
)
3969 new_st
.op
= EXEC_DEALLOCATE
;
3970 new_st
.expr1
= stat
;
3971 new_st
.expr2
= errmsg
;
3972 new_st
.ext
.alloc
.list
= head
;
3977 gfc_syntax_error (ST_DEALLOCATE
);
3980 gfc_free_expr (errmsg
);
3981 gfc_free_expr (stat
);
3982 gfc_free_alloc_list (head
);
3987 /* Match a RETURN statement. */
3990 gfc_match_return (void)
3994 gfc_compile_state s
;
3998 if (gfc_find_state (COMP_CRITICAL
))
4000 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4004 if (gfc_find_state (COMP_DO_CONCURRENT
))
4006 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4010 if (gfc_match_eos () == MATCH_YES
)
4013 if (!gfc_find_state (COMP_SUBROUTINE
))
4015 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4020 if (gfc_current_form
== FORM_FREE
)
4022 /* The following are valid, so we can't require a blank after the
4026 char c
= gfc_peek_ascii_char ();
4027 if (ISALPHA (c
) || ISDIGIT (c
))
4031 m
= gfc_match (" %e%t", &e
);
4034 if (m
== MATCH_ERROR
)
4037 gfc_syntax_error (ST_RETURN
);
4044 gfc_enclosing_unit (&s
);
4045 if (s
== COMP_PROGRAM
4046 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
4047 "main program at %C"))
4050 new_st
.op
= EXEC_RETURN
;
4057 /* Match the call of a type-bound procedure, if CALL%var has already been
4058 matched and var found to be a derived-type variable. */
4061 match_typebound_call (gfc_symtree
* varst
)
4066 base
= gfc_get_expr ();
4067 base
->expr_type
= EXPR_VARIABLE
;
4068 base
->symtree
= varst
;
4069 base
->where
= gfc_current_locus
;
4070 gfc_set_sym_referenced (varst
->n
.sym
);
4072 m
= gfc_match_varspec (base
, 0, true, true);
4074 gfc_error ("Expected component reference at %C");
4077 gfc_free_expr (base
);
4081 if (gfc_match_eos () != MATCH_YES
)
4083 gfc_error ("Junk after CALL at %C");
4084 gfc_free_expr (base
);
4088 if (base
->expr_type
== EXPR_COMPCALL
)
4089 new_st
.op
= EXEC_COMPCALL
;
4090 else if (base
->expr_type
== EXPR_PPC
)
4091 new_st
.op
= EXEC_CALL_PPC
;
4094 gfc_error ("Expected type-bound procedure or procedure pointer component "
4096 gfc_free_expr (base
);
4099 new_st
.expr1
= base
;
4105 /* Match a CALL statement. The tricky part here are possible
4106 alternate return specifiers. We handle these by having all
4107 "subroutines" actually return an integer via a register that gives
4108 the return number. If the call specifies alternate returns, we
4109 generate code for a SELECT statement whose case clauses contain
4110 GOTOs to the various labels. */
4113 gfc_match_call (void)
4115 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4116 gfc_actual_arglist
*a
, *arglist
;
4126 m
= gfc_match ("% %n", name
);
4132 if (gfc_get_ha_sym_tree (name
, &st
))
4137 /* If this is a variable of derived-type, it probably starts a type-bound
4139 if ((sym
->attr
.flavor
!= FL_PROCEDURE
4140 || gfc_is_function_return_value (sym
, gfc_current_ns
))
4141 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
4142 return match_typebound_call (st
);
4144 /* If it does not seem to be callable (include functions so that the
4145 right association is made. They are thrown out in resolution.)
4147 if (!sym
->attr
.generic
4148 && !sym
->attr
.subroutine
4149 && !sym
->attr
.function
)
4151 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
4153 /* ...create a symbol in this scope... */
4154 if (sym
->ns
!= gfc_current_ns
4155 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
4158 if (sym
!= st
->n
.sym
)
4162 /* ...and then to try to make the symbol into a subroutine. */
4163 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
4167 gfc_set_sym_referenced (sym
);
4169 if (gfc_match_eos () != MATCH_YES
)
4171 m
= gfc_match_actual_arglist (1, &arglist
);
4174 if (m
== MATCH_ERROR
)
4177 if (gfc_match_eos () != MATCH_YES
)
4181 /* If any alternate return labels were found, construct a SELECT
4182 statement that will jump to the right place. */
4185 for (a
= arglist
; a
; a
= a
->next
)
4186 if (a
->expr
== NULL
)
4194 gfc_symtree
*select_st
;
4195 gfc_symbol
*select_sym
;
4196 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4198 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
4199 sprintf (name
, "_result_%s", sym
->name
);
4200 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
4202 select_sym
= select_st
->n
.sym
;
4203 select_sym
->ts
.type
= BT_INTEGER
;
4204 select_sym
->ts
.kind
= gfc_default_integer_kind
;
4205 gfc_set_sym_referenced (select_sym
);
4206 c
->expr1
= gfc_get_expr ();
4207 c
->expr1
->expr_type
= EXPR_VARIABLE
;
4208 c
->expr1
->symtree
= select_st
;
4209 c
->expr1
->ts
= select_sym
->ts
;
4210 c
->expr1
->where
= gfc_current_locus
;
4213 for (a
= arglist
; a
; a
= a
->next
)
4215 if (a
->expr
!= NULL
)
4218 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
4223 c
->block
= gfc_get_code (EXEC_SELECT
);
4226 new_case
= gfc_get_case ();
4227 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
4228 new_case
->low
= new_case
->high
;
4229 c
->ext
.block
.case_list
= new_case
;
4231 c
->next
= gfc_get_code (EXEC_GOTO
);
4232 c
->next
->label1
= a
->label
;
4236 new_st
.op
= EXEC_CALL
;
4237 new_st
.symtree
= st
;
4238 new_st
.ext
.actual
= arglist
;
4243 gfc_syntax_error (ST_CALL
);
4246 gfc_free_actual_arglist (arglist
);
4251 /* Given a name, return a pointer to the common head structure,
4252 creating it if it does not exist. If FROM_MODULE is nonzero, we
4253 mangle the name so that it doesn't interfere with commons defined
4254 in the using namespace.
4255 TODO: Add to global symbol tree. */
4258 gfc_get_common (const char *name
, int from_module
)
4261 static int serial
= 0;
4262 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
4266 /* A use associated common block is only needed to correctly layout
4267 the variables it contains. */
4268 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
4269 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
4273 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
4276 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
4279 if (st
->n
.common
== NULL
)
4281 st
->n
.common
= gfc_get_common_head ();
4282 st
->n
.common
->where
= gfc_current_locus
;
4283 strcpy (st
->n
.common
->name
, name
);
4286 return st
->n
.common
;
4290 /* Match a common block name. */
4292 match
match_common_name (char *name
)
4296 if (gfc_match_char ('/') == MATCH_NO
)
4302 if (gfc_match_char ('/') == MATCH_YES
)
4308 m
= gfc_match_name (name
);
4310 if (m
== MATCH_ERROR
)
4312 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
4315 gfc_error ("Syntax error in common block name at %C");
4320 /* Match a COMMON statement. */
4323 gfc_match_common (void)
4325 gfc_symbol
*sym
, **head
, *tail
, *other
, *old_blank_common
;
4326 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4332 old_blank_common
= gfc_current_ns
->blank_common
.head
;
4333 if (old_blank_common
)
4335 while (old_blank_common
->common_next
)
4336 old_blank_common
= old_blank_common
->common_next
;
4343 m
= match_common_name (name
);
4344 if (m
== MATCH_ERROR
)
4347 if (name
[0] == '\0')
4349 t
= &gfc_current_ns
->blank_common
;
4350 if (t
->head
== NULL
)
4351 t
->where
= gfc_current_locus
;
4355 t
= gfc_get_common (name
, 0);
4364 while (tail
->common_next
)
4365 tail
= tail
->common_next
;
4368 /* Grab the list of symbols. */
4371 m
= gfc_match_symbol (&sym
, 0);
4372 if (m
== MATCH_ERROR
)
4377 /* Store a ref to the common block for error checking. */
4378 sym
->common_block
= t
;
4379 sym
->common_block
->refs
++;
4381 /* See if we know the current common block is bind(c), and if
4382 so, then see if we can check if the symbol is (which it'll
4383 need to be). This can happen if the bind(c) attr stmt was
4384 applied to the common block, and the variable(s) already
4385 defined, before declaring the common block. */
4386 if (t
->is_bind_c
== 1)
4388 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
4390 /* If we find an error, just print it and continue,
4391 cause it's just semantic, and we can see if there
4393 gfc_error_now ("Variable '%s' at %L in common block '%s' "
4394 "at %C must be declared with a C "
4395 "interoperable kind since common block "
4397 sym
->name
, &(sym
->declared_at
), t
->name
,
4401 if (sym
->attr
.is_bind_c
== 1)
4402 gfc_error_now ("Variable '%s' in common block "
4403 "'%s' at %C can not be bind(c) since "
4404 "it is not global", sym
->name
, t
->name
);
4407 if (sym
->attr
.in_common
)
4409 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
4414 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
4415 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
4417 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol '%s' at "
4418 "%C can only be COMMON in BLOCK DATA",
4423 if (!gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
))
4427 tail
->common_next
= sym
;
4433 /* Deal with an optional array specification after the
4435 m
= gfc_match_array_spec (&as
, true, true);
4436 if (m
== MATCH_ERROR
)
4441 if (as
->type
!= AS_EXPLICIT
)
4443 gfc_error ("Array specification for symbol '%s' in COMMON "
4444 "at %C must be explicit", sym
->name
);
4448 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
4451 if (sym
->attr
.pointer
)
4453 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
4454 "POINTER array", sym
->name
);
4463 sym
->common_head
= t
;
4465 /* Check to see if the symbol is already in an equivalence group.
4466 If it is, set the other members as being in common. */
4467 if (sym
->attr
.in_equivalence
)
4469 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
4471 for (e2
= e1
; e2
; e2
= e2
->eq
)
4472 if (e2
->expr
->symtree
->n
.sym
== sym
)
4479 for (e2
= e1
; e2
; e2
= e2
->eq
)
4481 other
= e2
->expr
->symtree
->n
.sym
;
4482 if (other
->common_head
4483 && other
->common_head
!= sym
->common_head
)
4485 gfc_error ("Symbol '%s', in COMMON block '%s' at "
4486 "%C is being indirectly equivalenced to "
4487 "another COMMON block '%s'",
4488 sym
->name
, sym
->common_head
->name
,
4489 other
->common_head
->name
);
4492 other
->attr
.in_common
= 1;
4493 other
->common_head
= t
;
4499 gfc_gobble_whitespace ();
4500 if (gfc_match_eos () == MATCH_YES
)
4502 if (gfc_peek_ascii_char () == '/')
4504 if (gfc_match_char (',') != MATCH_YES
)
4506 gfc_gobble_whitespace ();
4507 if (gfc_peek_ascii_char () == '/')
4516 gfc_syntax_error (ST_COMMON
);
4519 gfc_free_array_spec (as
);
4524 /* Match a BLOCK DATA program unit. */
4527 gfc_match_block_data (void)
4529 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4533 if (gfc_match_eos () == MATCH_YES
)
4535 gfc_new_block
= NULL
;
4539 m
= gfc_match ("% %n%t", name
);
4543 if (gfc_get_symbol (name
, NULL
, &sym
))
4546 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
4549 gfc_new_block
= sym
;
4555 /* Free a namelist structure. */
4558 gfc_free_namelist (gfc_namelist
*name
)
4562 for (; name
; name
= n
)
4570 /* Match a NAMELIST statement. */
4573 gfc_match_namelist (void)
4575 gfc_symbol
*group_name
, *sym
;
4579 m
= gfc_match (" / %s /", &group_name
);
4582 if (m
== MATCH_ERROR
)
4587 if (group_name
->ts
.type
!= BT_UNKNOWN
)
4589 gfc_error ("Namelist group name '%s' at %C already has a basic "
4590 "type of %s", group_name
->name
,
4591 gfc_typename (&group_name
->ts
));
4595 if (group_name
->attr
.flavor
== FL_NAMELIST
4596 && group_name
->attr
.use_assoc
4597 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name '%s' "
4598 "at %C already is USE associated and can"
4599 "not be respecified.", group_name
->name
))
4602 if (group_name
->attr
.flavor
!= FL_NAMELIST
4603 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
4604 group_name
->name
, NULL
))
4609 m
= gfc_match_symbol (&sym
, 1);
4612 if (m
== MATCH_ERROR
)
4615 if (sym
->attr
.in_namelist
== 0
4616 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
4619 /* Use gfc_error_check here, rather than goto error, so that
4620 these are the only errors for the next two lines. */
4621 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
4623 gfc_error ("Assumed size array '%s' in namelist '%s' at "
4624 "%C is not allowed", sym
->name
, group_name
->name
);
4628 nl
= gfc_get_namelist ();
4632 if (group_name
->namelist
== NULL
)
4633 group_name
->namelist
= group_name
->namelist_tail
= nl
;
4636 group_name
->namelist_tail
->next
= nl
;
4637 group_name
->namelist_tail
= nl
;
4640 if (gfc_match_eos () == MATCH_YES
)
4643 m
= gfc_match_char (',');
4645 if (gfc_match_char ('/') == MATCH_YES
)
4647 m2
= gfc_match (" %s /", &group_name
);
4648 if (m2
== MATCH_YES
)
4650 if (m2
== MATCH_ERROR
)
4664 gfc_syntax_error (ST_NAMELIST
);
4671 /* Match a MODULE statement. */
4674 gfc_match_module (void)
4678 m
= gfc_match (" %s%t", &gfc_new_block
);
4682 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
4683 gfc_new_block
->name
, NULL
))
4690 /* Free equivalence sets and lists. Recursively is the easiest way to
4694 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
4699 gfc_free_equiv (eq
->eq
);
4700 gfc_free_equiv_until (eq
->next
, stop
);
4701 gfc_free_expr (eq
->expr
);
4707 gfc_free_equiv (gfc_equiv
*eq
)
4709 gfc_free_equiv_until (eq
, NULL
);
4713 /* Match an EQUIVALENCE statement. */
4716 gfc_match_equivalence (void)
4718 gfc_equiv
*eq
, *set
, *tail
;
4722 gfc_common_head
*common_head
= NULL
;
4730 eq
= gfc_get_equiv ();
4734 eq
->next
= gfc_current_ns
->equiv
;
4735 gfc_current_ns
->equiv
= eq
;
4737 if (gfc_match_char ('(') != MATCH_YES
)
4741 common_flag
= FALSE
;
4746 m
= gfc_match_equiv_variable (&set
->expr
);
4747 if (m
== MATCH_ERROR
)
4752 /* count the number of objects. */
4755 if (gfc_match_char ('%') == MATCH_YES
)
4757 gfc_error ("Derived type component %C is not a "
4758 "permitted EQUIVALENCE member");
4762 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
4763 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
4765 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
4766 "be an array section");
4770 sym
= set
->expr
->symtree
->n
.sym
;
4772 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
4775 if (sym
->attr
.in_common
)
4778 common_head
= sym
->common_head
;
4781 if (gfc_match_char (')') == MATCH_YES
)
4784 if (gfc_match_char (',') != MATCH_YES
)
4787 set
->eq
= gfc_get_equiv ();
4793 gfc_error ("EQUIVALENCE at %C requires two or more objects");
4797 /* If one of the members of an equivalence is in common, then
4798 mark them all as being in common. Before doing this, check
4799 that members of the equivalence group are not in different
4802 for (set
= eq
; set
; set
= set
->eq
)
4804 sym
= set
->expr
->symtree
->n
.sym
;
4805 if (sym
->common_head
&& sym
->common_head
!= common_head
)
4807 gfc_error ("Attempt to indirectly overlap COMMON "
4808 "blocks %s and %s by EQUIVALENCE at %C",
4809 sym
->common_head
->name
, common_head
->name
);
4812 sym
->attr
.in_common
= 1;
4813 sym
->common_head
= common_head
;
4816 if (gfc_match_eos () == MATCH_YES
)
4818 if (gfc_match_char (',') != MATCH_YES
)
4820 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
4828 gfc_syntax_error (ST_EQUIVALENCE
);
4834 gfc_free_equiv (gfc_current_ns
->equiv
);
4835 gfc_current_ns
->equiv
= eq
;
4841 /* Check that a statement function is not recursive. This is done by looking
4842 for the statement function symbol(sym) by looking recursively through its
4843 expression(e). If a reference to sym is found, true is returned.
4844 12.5.4 requires that any variable of function that is implicitly typed
4845 shall have that type confirmed by any subsequent type declaration. The
4846 implicit typing is conveniently done here. */
4848 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
4851 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
4857 switch (e
->expr_type
)
4860 if (e
->symtree
== NULL
)
4863 /* Check the name before testing for nested recursion! */
4864 if (sym
->name
== e
->symtree
->n
.sym
->name
)
4867 /* Catch recursion via other statement functions. */
4868 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
4869 && e
->symtree
->n
.sym
->value
4870 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
4873 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
4874 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
4879 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
4882 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
4883 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
4895 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
4897 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
4901 /* Match a statement function declaration. It is so easy to match
4902 non-statement function statements with a MATCH_ERROR as opposed to
4903 MATCH_NO that we suppress error message in most cases. */
4906 gfc_match_st_function (void)
4908 gfc_error_buf old_error
;
4913 m
= gfc_match_symbol (&sym
, 0);
4917 gfc_push_error (&old_error
);
4919 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
4922 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
4925 m
= gfc_match (" = %e%t", &expr
);
4929 gfc_free_error (&old_error
);
4930 if (m
== MATCH_ERROR
)
4933 if (recursive_stmt_fcn (expr
, sym
))
4935 gfc_error ("Statement function at %L is recursive", &expr
->where
);
4941 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
4947 gfc_pop_error (&old_error
);
4952 /***************** SELECT CASE subroutines ******************/
4954 /* Free a single case structure. */
4957 free_case (gfc_case
*p
)
4959 if (p
->low
== p
->high
)
4961 gfc_free_expr (p
->low
);
4962 gfc_free_expr (p
->high
);
4967 /* Free a list of case structures. */
4970 gfc_free_case_list (gfc_case
*p
)
4982 /* Match a single case selector. */
4985 match_case_selector (gfc_case
**cp
)
4990 c
= gfc_get_case ();
4991 c
->where
= gfc_current_locus
;
4993 if (gfc_match_char (':') == MATCH_YES
)
4995 m
= gfc_match_init_expr (&c
->high
);
4998 if (m
== MATCH_ERROR
)
5003 m
= gfc_match_init_expr (&c
->low
);
5004 if (m
== MATCH_ERROR
)
5009 /* If we're not looking at a ':' now, make a range out of a single
5010 target. Else get the upper bound for the case range. */
5011 if (gfc_match_char (':') != MATCH_YES
)
5015 m
= gfc_match_init_expr (&c
->high
);
5016 if (m
== MATCH_ERROR
)
5018 /* MATCH_NO is fine. It's OK if nothing is there! */
5026 gfc_error ("Expected initialization expression in CASE at %C");
5034 /* Match the end of a case statement. */
5037 match_case_eos (void)
5039 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5042 if (gfc_match_eos () == MATCH_YES
)
5045 /* If the case construct doesn't have a case-construct-name, we
5046 should have matched the EOS. */
5047 if (!gfc_current_block ())
5050 gfc_gobble_whitespace ();
5052 m
= gfc_match_name (name
);
5056 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5058 gfc_error ("Expected block name '%s' of SELECT construct at %C",
5059 gfc_current_block ()->name
);
5063 return gfc_match_eos ();
5067 /* Match a SELECT statement. */
5070 gfc_match_select (void)
5075 m
= gfc_match_label ();
5076 if (m
== MATCH_ERROR
)
5079 m
= gfc_match (" select case ( %e )%t", &expr
);
5083 new_st
.op
= EXEC_SELECT
;
5084 new_st
.expr1
= expr
;
5090 /* Transfer the selector typespec to the associate name. */
5093 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
)
5096 gfc_symbol
*assoc_sym
;
5098 assoc_sym
= associate
->symtree
->n
.sym
;
5100 /* At this stage the expression rank and arrayspec dimensions have
5101 not been completely sorted out. We must get the expr2->rank
5102 right here, so that the correct class container is obtained. */
5103 ref
= selector
->ref
;
5104 while (ref
&& ref
->next
)
5107 if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
5108 && ref
&& ref
->type
== REF_ARRAY
)
5110 /* Ensure that the array reference type is set. We cannot use
5111 gfc_resolve_expr at this point, so the usable parts of
5112 resolve.c(resolve_array_ref) are employed to do it. */
5113 if (ref
->u
.ar
.type
== AR_UNKNOWN
)
5115 ref
->u
.ar
.type
= AR_ELEMENT
;
5116 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
5117 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5118 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
5119 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
5120 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
5122 ref
->u
.ar
.type
= AR_SECTION
;
5127 if (ref
->u
.ar
.type
== AR_FULL
)
5128 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
5129 else if (ref
->u
.ar
.type
== AR_SECTION
)
5130 selector
->rank
= ref
->u
.ar
.dimen
;
5137 assoc_sym
->attr
.dimension
= 1;
5138 assoc_sym
->as
= gfc_get_array_spec ();
5139 assoc_sym
->as
->rank
= selector
->rank
;
5140 assoc_sym
->as
->type
= AS_DEFERRED
;
5143 assoc_sym
->as
= NULL
;
5145 if (selector
->ts
.type
== BT_CLASS
)
5147 /* The correct class container has to be available. */
5148 assoc_sym
->ts
.type
= BT_CLASS
;
5149 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
5150 assoc_sym
->attr
.pointer
= 1;
5151 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
,
5152 &assoc_sym
->as
, false);
5157 /* Push the current selector onto the SELECT TYPE stack. */
5160 select_type_push (gfc_symbol
*sel
)
5162 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
5163 top
->selector
= sel
;
5165 top
->prev
= select_type_stack
;
5167 select_type_stack
= top
;
5171 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
5173 static gfc_symtree
*
5174 select_intrinsic_set_tmp (gfc_typespec
*ts
)
5176 char name
[GFC_MAX_SYMBOL_LEN
];
5180 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
5183 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5184 && !select_type_stack
->selector
->attr
.class_ok
)
5187 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
5188 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5189 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
5191 if (ts
->type
!= BT_CHARACTER
)
5192 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
5195 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (ts
->type
),
5198 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5199 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5201 /* Copy across the array spec to the selector. */
5202 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5203 && (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5204 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
))
5206 tmp
->n
.sym
->attr
.pointer
= 1;
5207 tmp
->n
.sym
->attr
.dimension
5208 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5209 tmp
->n
.sym
->attr
.codimension
5210 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5212 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5215 gfc_set_sym_referenced (tmp
->n
.sym
);
5216 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5217 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5223 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
5226 select_type_set_tmp (gfc_typespec
*ts
)
5228 char name
[GFC_MAX_SYMBOL_LEN
];
5229 gfc_symtree
*tmp
= NULL
;
5233 select_type_stack
->tmp
= NULL
;
5237 tmp
= select_intrinsic_set_tmp (ts
);
5244 if (ts
->type
== BT_CLASS
)
5245 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
5247 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
5248 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5249 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5251 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5252 && select_type_stack
->selector
->attr
.class_ok
)
5254 tmp
->n
.sym
->attr
.pointer
5255 = CLASS_DATA (select_type_stack
->selector
)->attr
.class_pointer
;
5257 /* Copy across the array spec to the selector. */
5258 if (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5259 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
)
5261 tmp
->n
.sym
->attr
.dimension
5262 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5263 tmp
->n
.sym
->attr
.codimension
5264 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5266 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5270 gfc_set_sym_referenced (tmp
->n
.sym
);
5271 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5272 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5274 if (ts
->type
== BT_CLASS
)
5275 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
5276 &tmp
->n
.sym
->as
, false);
5279 /* Add an association for it, so the rest of the parser knows it is
5280 an associate-name. The target will be set during resolution. */
5281 tmp
->n
.sym
->assoc
= gfc_get_association_list ();
5282 tmp
->n
.sym
->assoc
->dangling
= 1;
5283 tmp
->n
.sym
->assoc
->st
= tmp
;
5285 select_type_stack
->tmp
= tmp
;
5289 /* Match a SELECT TYPE statement. */
5292 gfc_match_select_type (void)
5294 gfc_expr
*expr1
, *expr2
= NULL
;
5296 char name
[GFC_MAX_SYMBOL_LEN
];
5300 m
= gfc_match_label ();
5301 if (m
== MATCH_ERROR
)
5304 m
= gfc_match (" select type ( ");
5308 m
= gfc_match (" %n => %e", name
, &expr2
);
5311 expr1
= gfc_get_expr();
5312 expr1
->expr_type
= EXPR_VARIABLE
;
5313 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
5319 sym
= expr1
->symtree
->n
.sym
;
5320 if (expr2
->ts
.type
== BT_UNKNOWN
)
5321 sym
->attr
.untyped
= 1;
5323 copy_ts_from_selector_to_associate (expr1
, expr2
);
5325 sym
->attr
.flavor
= FL_VARIABLE
;
5326 sym
->attr
.referenced
= 1;
5327 sym
->attr
.class_ok
= 1;
5331 m
= gfc_match (" %e ", &expr1
);
5336 m
= gfc_match (" )%t");
5339 gfc_error ("parse error in SELECT TYPE statement at %C");
5343 /* This ghastly expression seems to be needed to distinguish a CLASS
5344 array, which can have a reference, from other expressions that
5345 have references, such as derived type components, and are not
5346 allowed by the standard.
5347 TODO: see if it is sufficient to exclude component and substring
5349 class_array
= expr1
->expr_type
== EXPR_VARIABLE
5350 && expr1
->ts
.type
== BT_CLASS
5351 && CLASS_DATA (expr1
)
5352 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
5353 && (CLASS_DATA (expr1
)->attr
.dimension
5354 || CLASS_DATA (expr1
)->attr
.codimension
)
5356 && expr1
->ref
->type
== REF_ARRAY
5357 && expr1
->ref
->next
== NULL
;
5359 /* Check for F03:C811. */
5360 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
5361 || (!class_array
&& expr1
->ref
!= NULL
)))
5363 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
5364 "use associate-name=>");
5369 new_st
.op
= EXEC_SELECT_TYPE
;
5370 new_st
.expr1
= expr1
;
5371 new_st
.expr2
= expr2
;
5372 new_st
.ext
.block
.ns
= gfc_current_ns
;
5374 select_type_push (expr1
->symtree
->n
.sym
);
5379 gfc_free_expr (expr1
);
5380 gfc_free_expr (expr2
);
5385 /* Match a CASE statement. */
5388 gfc_match_case (void)
5390 gfc_case
*c
, *head
, *tail
;
5395 if (gfc_current_state () != COMP_SELECT
)
5397 gfc_error ("Unexpected CASE statement at %C");
5401 if (gfc_match ("% default") == MATCH_YES
)
5403 m
= match_case_eos ();
5406 if (m
== MATCH_ERROR
)
5409 new_st
.op
= EXEC_SELECT
;
5410 c
= gfc_get_case ();
5411 c
->where
= gfc_current_locus
;
5412 new_st
.ext
.block
.case_list
= c
;
5416 if (gfc_match_char ('(') != MATCH_YES
)
5421 if (match_case_selector (&c
) == MATCH_ERROR
)
5431 if (gfc_match_char (')') == MATCH_YES
)
5433 if (gfc_match_char (',') != MATCH_YES
)
5437 m
= match_case_eos ();
5440 if (m
== MATCH_ERROR
)
5443 new_st
.op
= EXEC_SELECT
;
5444 new_st
.ext
.block
.case_list
= head
;
5449 gfc_error ("Syntax error in CASE specification at %C");
5452 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
5457 /* Match a TYPE IS statement. */
5460 gfc_match_type_is (void)
5465 if (gfc_current_state () != COMP_SELECT_TYPE
)
5467 gfc_error ("Unexpected TYPE IS statement at %C");
5471 if (gfc_match_char ('(') != MATCH_YES
)
5474 c
= gfc_get_case ();
5475 c
->where
= gfc_current_locus
;
5477 if (gfc_match_type_spec (&c
->ts
) == MATCH_ERROR
)
5480 if (gfc_match_char (')') != MATCH_YES
)
5483 m
= match_case_eos ();
5486 if (m
== MATCH_ERROR
)
5489 new_st
.op
= EXEC_SELECT_TYPE
;
5490 new_st
.ext
.block
.case_list
= c
;
5492 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
5493 && (c
->ts
.u
.derived
->attr
.sequence
5494 || c
->ts
.u
.derived
->attr
.is_bind_c
))
5496 gfc_error ("The type-spec shall not specify a sequence derived "
5497 "type or a type with the BIND attribute in SELECT "
5498 "TYPE at %C [F2003:C815]");
5502 /* Create temporary variable. */
5503 select_type_set_tmp (&c
->ts
);
5508 gfc_error ("Syntax error in TYPE IS specification at %C");
5512 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
5517 /* Match a CLASS IS or CLASS DEFAULT statement. */
5520 gfc_match_class_is (void)
5525 if (gfc_current_state () != COMP_SELECT_TYPE
)
5528 if (gfc_match ("% default") == MATCH_YES
)
5530 m
= match_case_eos ();
5533 if (m
== MATCH_ERROR
)
5536 new_st
.op
= EXEC_SELECT_TYPE
;
5537 c
= gfc_get_case ();
5538 c
->where
= gfc_current_locus
;
5539 c
->ts
.type
= BT_UNKNOWN
;
5540 new_st
.ext
.block
.case_list
= c
;
5541 select_type_set_tmp (NULL
);
5545 m
= gfc_match ("% is");
5548 if (m
== MATCH_ERROR
)
5551 if (gfc_match_char ('(') != MATCH_YES
)
5554 c
= gfc_get_case ();
5555 c
->where
= gfc_current_locus
;
5557 if (match_derived_type_spec (&c
->ts
) == MATCH_ERROR
)
5560 if (c
->ts
.type
== BT_DERIVED
)
5561 c
->ts
.type
= BT_CLASS
;
5563 if (gfc_match_char (')') != MATCH_YES
)
5566 m
= match_case_eos ();
5569 if (m
== MATCH_ERROR
)
5572 new_st
.op
= EXEC_SELECT_TYPE
;
5573 new_st
.ext
.block
.case_list
= c
;
5575 /* Create temporary variable. */
5576 select_type_set_tmp (&c
->ts
);
5581 gfc_error ("Syntax error in CLASS IS specification at %C");
5585 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
5590 /********************* WHERE subroutines ********************/
5592 /* Match the rest of a simple WHERE statement that follows an IF statement.
5596 match_simple_where (void)
5602 m
= gfc_match (" ( %e )", &expr
);
5606 m
= gfc_match_assignment ();
5609 if (m
== MATCH_ERROR
)
5612 if (gfc_match_eos () != MATCH_YES
)
5615 c
= gfc_get_code (EXEC_WHERE
);
5618 c
->next
= XCNEW (gfc_code
);
5620 gfc_clear_new_st ();
5622 new_st
.op
= EXEC_WHERE
;
5628 gfc_syntax_error (ST_WHERE
);
5631 gfc_free_expr (expr
);
5636 /* Match a WHERE statement. */
5639 gfc_match_where (gfc_statement
*st
)
5645 m0
= gfc_match_label ();
5646 if (m0
== MATCH_ERROR
)
5649 m
= gfc_match (" where ( %e )", &expr
);
5653 if (gfc_match_eos () == MATCH_YES
)
5655 *st
= ST_WHERE_BLOCK
;
5656 new_st
.op
= EXEC_WHERE
;
5657 new_st
.expr1
= expr
;
5661 m
= gfc_match_assignment ();
5663 gfc_syntax_error (ST_WHERE
);
5667 gfc_free_expr (expr
);
5671 /* We've got a simple WHERE statement. */
5673 c
= gfc_get_code (EXEC_WHERE
);
5676 c
->next
= XCNEW (gfc_code
);
5678 gfc_clear_new_st ();
5680 new_st
.op
= EXEC_WHERE
;
5687 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
5688 new_st if successful. */
5691 gfc_match_elsewhere (void)
5693 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5697 if (gfc_current_state () != COMP_WHERE
)
5699 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
5705 if (gfc_match_char ('(') == MATCH_YES
)
5707 m
= gfc_match_expr (&expr
);
5710 if (m
== MATCH_ERROR
)
5713 if (gfc_match_char (')') != MATCH_YES
)
5717 if (gfc_match_eos () != MATCH_YES
)
5719 /* Only makes sense if we have a where-construct-name. */
5720 if (!gfc_current_block ())
5725 /* Better be a name at this point. */
5726 m
= gfc_match_name (name
);
5729 if (m
== MATCH_ERROR
)
5732 if (gfc_match_eos () != MATCH_YES
)
5735 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5737 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
5738 name
, gfc_current_block ()->name
);
5743 new_st
.op
= EXEC_WHERE
;
5744 new_st
.expr1
= expr
;
5748 gfc_syntax_error (ST_ELSEWHERE
);
5751 gfc_free_expr (expr
);