1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000-2018 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 int gfc_matching_ptr_assignment
= 0;
30 int gfc_matching_procptr_assignment
= 0;
31 bool gfc_matching_prefix
= false;
33 /* Stack of SELECT TYPE statements. */
34 gfc_select_type_stack
*select_type_stack
= NULL
;
36 /* List of type parameter expressions. */
37 gfc_actual_arglist
*type_param_spec_list
;
39 /* For debugging and diagnostic purposes. Return the textual representation
40 of the intrinsic operator OP. */
42 gfc_op2string (gfc_intrinsic_op op
)
50 case INTRINSIC_UMINUS
:
56 case INTRINSIC_CONCAT
:
60 case INTRINSIC_DIVIDE
:
99 case INTRINSIC_ASSIGN
:
102 case INTRINSIC_PARENTHESES
:
109 case INTRINSIC_FORMATTED
:
111 case INTRINSIC_UNFORMATTED
:
112 return "unformatted";
118 gfc_internal_error ("gfc_op2string(): Bad code");
123 /******************** Generic matching subroutines ************************/
125 /* Matches a member separator. With standard FORTRAN this is '%', but with
126 DEC structures we must carefully match dot ('.').
127 Because operators are spelled ".op.", a dotted string such as "x.y.z..."
128 can be either a component reference chain or a combination of binary
130 There is no real way to win because the string may be grammatically
131 ambiguous. The following rules help avoid ambiguities - they match
132 some behavior of other (older) compilers. If the rules here are changed
133 the test cases should be updated. If the user has problems with these rules
134 they probably deserve the consequences. Consider "x.y.z":
135 (1) If any user defined operator ".y." exists, this is always y(x,z)
136 (even if ".y." is the wrong type and/or x has a member y).
137 (2) Otherwise if x has a member y, and y is itself a derived type,
138 this is (x->y)->z, even if an intrinsic operator exists which
140 (3) If x has no member y or (x->y) is not a derived type but ".y."
141 is an intrinsic operator (such as ".eq."), this is y(x,z).
142 (4) Lastly if there is no operator ".y." and x has no member "y", it is an
144 It is worth noting that the logic here does not support mixed use of member
145 accessors within a single string. That is, even if x has component y and y
146 has component z, the following are all syntax errors:
147 "x%y.z" "x.y%z" "(x.y).z" "(x%y)%z"
151 gfc_match_member_sep(gfc_symbol
*sym
)
153 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
154 locus dot_loc
, start_loc
;
155 gfc_intrinsic_op iop
;
158 gfc_component
*c
= NULL
;
160 /* What a relief: '%' is an unambiguous member separator. */
161 if (gfc_match_char ('%') == MATCH_YES
)
164 /* Beware ye who enter here. */
165 if (!flag_dec_structure
|| !sym
)
170 /* We may be given either a derived type variable or the derived type
171 declaration itself (which actually contains the components);
172 we need the latter to search for components. */
173 if (gfc_fl_struct (sym
->attr
.flavor
))
175 else if (gfc_bt_struct (sym
->ts
.type
))
176 tsym
= sym
->ts
.u
.derived
;
178 iop
= INTRINSIC_NONE
;
182 /* If we have to reject come back here later. */
183 start_loc
= gfc_current_locus
;
185 /* Look for a component access next. */
186 if (gfc_match_char ('.') != MATCH_YES
)
189 /* If we accept, come back here. */
190 dot_loc
= gfc_current_locus
;
192 /* Try to match a symbol name following the dot. */
193 if (gfc_match_name (name
) != MATCH_YES
)
195 gfc_error ("Expected structure component or operator name "
200 /* If no dot follows we have "x.y" which should be a component access. */
201 if (gfc_match_char ('.') != MATCH_YES
)
204 /* Now we have a string "x.y.z" which could be a nested member access
205 (x->y)->z or a binary operation y on x and z. */
207 /* First use any user-defined operators ".y." */
208 if (gfc_find_uop (name
, sym
->ns
) != NULL
)
211 /* Match accesses to existing derived-type components for
212 derived-type vars: "x.y.z" = (x->y)->z */
213 c
= gfc_find_component(tsym
, name
, false, true, NULL
);
214 if (c
&& (gfc_bt_struct (c
->ts
.type
) || c
->ts
.type
== BT_CLASS
))
217 /* If y is not a component or has no members, try intrinsic operators. */
218 gfc_current_locus
= start_loc
;
219 if (gfc_match_intrinsic_op (&iop
) != MATCH_YES
)
221 /* If ".y." is not an intrinsic operator but y was a valid non-
222 structure component, match and leave the trailing dot to be
227 gfc_error ("%qs is neither a defined operator nor a "
228 "structure component in dotted string at %C", name
);
232 /* .y. is an intrinsic operator, overriding any possible member access. */
235 /* Return keeping the current locus consistent with the match result. */
239 gfc_current_locus
= start_loc
;
242 gfc_current_locus
= dot_loc
;
247 /* This function scans the current statement counting the opened and closed
248 parenthesis to make sure they are balanced. */
251 gfc_match_parens (void)
253 locus old_loc
, where
;
255 gfc_instring instring
;
258 old_loc
= gfc_current_locus
;
260 instring
= NONSTRING
;
265 c
= gfc_next_char_literal (instring
);
268 if (quote
== ' ' && ((c
== '\'') || (c
== '"')))
271 instring
= INSTRING_WARN
;
274 if (quote
!= ' ' && c
== quote
)
277 instring
= NONSTRING
;
281 if (c
== '(' && quote
== ' ')
284 where
= gfc_current_locus
;
286 if (c
== ')' && quote
== ' ')
289 where
= gfc_current_locus
;
293 gfc_current_locus
= old_loc
;
297 gfc_error ("Missing %<)%> in statement at or before %L", &where
);
302 gfc_error ("Missing %<(%> in statement at or before %L", &where
);
310 /* See if the next character is a special character that has
311 escaped by a \ via the -fbackslash option. */
314 gfc_match_special_char (gfc_char_t
*res
)
322 switch ((c
= gfc_next_char_literal (INSTRING_WARN
)))
355 /* Hexadecimal form of wide characters. */
356 len
= (c
== 'x' ? 2 : (c
== 'u' ? 4 : 8));
358 for (i
= 0; i
< len
; i
++)
360 char buf
[2] = { '\0', '\0' };
362 c
= gfc_next_char_literal (INSTRING_WARN
);
363 if (!gfc_wide_fits_in_byte (c
)
364 || !gfc_check_digit ((unsigned char) c
, 16))
367 buf
[0] = (unsigned char) c
;
369 n
+= strtol (buf
, NULL
, 16);
375 /* Unknown backslash codes are simply not expanded. */
384 /* In free form, match at least one space. Always matches in fixed
388 gfc_match_space (void)
393 if (gfc_current_form
== FORM_FIXED
)
396 old_loc
= gfc_current_locus
;
398 c
= gfc_next_ascii_char ();
399 if (!gfc_is_whitespace (c
))
401 gfc_current_locus
= old_loc
;
405 gfc_gobble_whitespace ();
411 /* Match an end of statement. End of statement is optional
412 whitespace, followed by a ';' or '\n' or comment '!'. If a
413 semicolon is found, we continue to eat whitespace and semicolons. */
426 old_loc
= gfc_current_locus
;
427 gfc_gobble_whitespace ();
429 c
= gfc_next_ascii_char ();
435 c
= gfc_next_ascii_char ();
452 gfc_current_locus
= old_loc
;
453 return (flag
) ? MATCH_YES
: MATCH_NO
;
457 /* Match a literal integer on the input, setting the value on
458 MATCH_YES. Literal ints occur in kind-parameters as well as
459 old-style character length specifications. If cnt is non-NULL it
460 will be set to the number of digits. */
463 gfc_match_small_literal_int (int *value
, int *cnt
)
469 old_loc
= gfc_current_locus
;
472 gfc_gobble_whitespace ();
473 c
= gfc_next_ascii_char ();
479 gfc_current_locus
= old_loc
;
488 old_loc
= gfc_current_locus
;
489 c
= gfc_next_ascii_char ();
494 i
= 10 * i
+ c
- '0';
499 gfc_error ("Integer too large at %C");
504 gfc_current_locus
= old_loc
;
513 /* Match a small, constant integer expression, like in a kind
514 statement. On MATCH_YES, 'value' is set. */
517 gfc_match_small_int (int *value
)
523 m
= gfc_match_expr (&expr
);
527 if (gfc_extract_int (expr
, &i
, 1))
529 gfc_free_expr (expr
);
536 /* This function is the same as the gfc_match_small_int, except that
537 we're keeping the pointer to the expr. This function could just be
538 removed and the previously mentioned one modified, though all calls
539 to it would have to be modified then (and there were a number of
540 them). Return MATCH_ERROR if fail to extract the int; otherwise,
541 return the result of gfc_match_expr(). The expr (if any) that was
542 matched is returned in the parameter expr. */
545 gfc_match_small_int_expr (int *value
, gfc_expr
**expr
)
550 m
= gfc_match_expr (expr
);
554 if (gfc_extract_int (*expr
, &i
, 1))
562 /* Matches a statement label. Uses gfc_match_small_literal_int() to
563 do most of the work. */
566 gfc_match_st_label (gfc_st_label
**label
)
572 old_loc
= gfc_current_locus
;
574 m
= gfc_match_small_literal_int (&i
, &cnt
);
580 gfc_error ("Too many digits in statement label at %C");
586 gfc_error ("Statement label at %C is zero");
590 *label
= gfc_get_st_label (i
);
595 gfc_current_locus
= old_loc
;
600 /* Match and validate a label associated with a named IF, DO or SELECT
601 statement. If the symbol does not have the label attribute, we add
602 it. We also make sure the symbol does not refer to another
603 (active) block. A matched label is pointed to by gfc_new_block. */
606 gfc_match_label (void)
608 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
611 gfc_new_block
= NULL
;
613 m
= gfc_match (" %n :", name
);
617 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
619 gfc_error ("Label name %qs at %C is ambiguous", name
);
623 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
625 gfc_error ("Duplicate construct label %qs at %C", name
);
629 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
630 gfc_new_block
->name
, NULL
))
637 /* See if the current input looks like a name of some sort. Modifies
638 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
639 Note that options.c restricts max_identifier_length to not more
640 than GFC_MAX_SYMBOL_LEN. */
643 gfc_match_name (char *buffer
)
649 old_loc
= gfc_current_locus
;
650 gfc_gobble_whitespace ();
652 c
= gfc_next_ascii_char ();
653 if (!(ISALPHA (c
) || (c
== '_' && flag_allow_leading_underscore
)))
655 /* Special cases for unary minus and plus, which allows for a sensible
656 error message for code of the form 'c = exp(-a*b) )' where an
657 extra ')' appears at the end of statement. */
658 if (!gfc_error_flag_test () && c
!= '(' && c
!= '-' && c
!= '+')
659 gfc_error ("Invalid character in name at %C");
660 gfc_current_locus
= old_loc
;
670 if (i
> gfc_option
.max_identifier_length
)
672 gfc_error ("Name at %C is too long");
676 old_loc
= gfc_current_locus
;
677 c
= gfc_next_ascii_char ();
679 while (ISALNUM (c
) || c
== '_' || (flag_dollar_ok
&& c
== '$'));
681 if (c
== '$' && !flag_dollar_ok
)
683 gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to "
684 "allow it as an extension", &old_loc
);
689 gfc_current_locus
= old_loc
;
695 /* Match a symbol on the input. Modifies the pointer to the symbol
696 pointer if successful. */
699 gfc_match_sym_tree (gfc_symtree
**matched_symbol
, int host_assoc
)
701 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
704 m
= gfc_match_name (buffer
);
709 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
710 ? MATCH_ERROR
: MATCH_YES
;
712 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
, false))
720 gfc_match_symbol (gfc_symbol
**matched_symbol
, int host_assoc
)
725 m
= gfc_match_sym_tree (&st
, host_assoc
);
730 *matched_symbol
= st
->n
.sym
;
732 *matched_symbol
= NULL
;
735 *matched_symbol
= NULL
;
740 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
741 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
745 gfc_match_intrinsic_op (gfc_intrinsic_op
*result
)
747 locus orig_loc
= gfc_current_locus
;
750 gfc_gobble_whitespace ();
751 ch
= gfc_next_ascii_char ();
756 *result
= INTRINSIC_PLUS
;
761 *result
= INTRINSIC_MINUS
;
765 if (gfc_next_ascii_char () == '=')
768 *result
= INTRINSIC_EQ
;
774 if (gfc_peek_ascii_char () == '=')
777 gfc_next_ascii_char ();
778 *result
= INTRINSIC_LE
;
782 *result
= INTRINSIC_LT
;
786 if (gfc_peek_ascii_char () == '=')
789 gfc_next_ascii_char ();
790 *result
= INTRINSIC_GE
;
794 *result
= INTRINSIC_GT
;
798 if (gfc_peek_ascii_char () == '*')
801 gfc_next_ascii_char ();
802 *result
= INTRINSIC_POWER
;
806 *result
= INTRINSIC_TIMES
;
810 ch
= gfc_peek_ascii_char ();
814 gfc_next_ascii_char ();
815 *result
= INTRINSIC_NE
;
821 gfc_next_ascii_char ();
822 *result
= INTRINSIC_CONCAT
;
826 *result
= INTRINSIC_DIVIDE
;
830 ch
= gfc_next_ascii_char ();
834 if (gfc_next_ascii_char () == 'n'
835 && gfc_next_ascii_char () == 'd'
836 && gfc_next_ascii_char () == '.')
838 /* Matched ".and.". */
839 *result
= INTRINSIC_AND
;
845 if (gfc_next_ascii_char () == 'q')
847 ch
= gfc_next_ascii_char ();
850 /* Matched ".eq.". */
851 *result
= INTRINSIC_EQ_OS
;
856 if (gfc_next_ascii_char () == '.')
858 /* Matched ".eqv.". */
859 *result
= INTRINSIC_EQV
;
867 ch
= gfc_next_ascii_char ();
870 if (gfc_next_ascii_char () == '.')
872 /* Matched ".ge.". */
873 *result
= INTRINSIC_GE_OS
;
879 if (gfc_next_ascii_char () == '.')
881 /* Matched ".gt.". */
882 *result
= INTRINSIC_GT_OS
;
889 ch
= gfc_next_ascii_char ();
892 if (gfc_next_ascii_char () == '.')
894 /* Matched ".le.". */
895 *result
= INTRINSIC_LE_OS
;
901 if (gfc_next_ascii_char () == '.')
903 /* Matched ".lt.". */
904 *result
= INTRINSIC_LT_OS
;
911 ch
= gfc_next_ascii_char ();
914 ch
= gfc_next_ascii_char ();
917 /* Matched ".ne.". */
918 *result
= INTRINSIC_NE_OS
;
923 if (gfc_next_ascii_char () == 'v'
924 && gfc_next_ascii_char () == '.')
926 /* Matched ".neqv.". */
927 *result
= INTRINSIC_NEQV
;
934 if (gfc_next_ascii_char () == 't'
935 && gfc_next_ascii_char () == '.')
937 /* Matched ".not.". */
938 *result
= INTRINSIC_NOT
;
945 if (gfc_next_ascii_char () == 'r'
946 && gfc_next_ascii_char () == '.')
948 /* Matched ".or.". */
949 *result
= INTRINSIC_OR
;
955 if (gfc_next_ascii_char () == 'o'
956 && gfc_next_ascii_char () == 'r'
957 && gfc_next_ascii_char () == '.')
959 if (!gfc_notify_std (GFC_STD_LEGACY
, ".XOR. operator at %C"))
961 /* Matched ".xor." - equivalent to ".neqv.". */
962 *result
= INTRINSIC_NEQV
;
976 gfc_current_locus
= orig_loc
;
981 /* Match a loop control phrase:
983 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
985 If the final integer expression is not present, a constant unity
986 expression is returned. We don't return MATCH_ERROR until after
987 the equals sign is seen. */
990 gfc_match_iterator (gfc_iterator
*iter
, int init_flag
)
992 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
993 gfc_expr
*var
, *e1
, *e2
, *e3
;
999 /* Match the start of an iterator without affecting the symbol table. */
1001 start
= gfc_current_locus
;
1002 m
= gfc_match (" %n =", name
);
1003 gfc_current_locus
= start
;
1008 m
= gfc_match_variable (&var
, 0);
1012 if (var
->symtree
->n
.sym
->attr
.dimension
)
1014 gfc_error ("Loop variable at %C cannot be an array");
1018 /* F2008, C617 & C565. */
1019 if (var
->symtree
->n
.sym
->attr
.codimension
)
1021 gfc_error ("Loop variable at %C cannot be a coarray");
1025 if (var
->ref
!= NULL
)
1027 gfc_error ("Loop variable at %C cannot be a sub-component");
1031 gfc_match_char ('=');
1033 var
->symtree
->n
.sym
->attr
.implied_index
= 1;
1035 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
1038 if (m
== MATCH_ERROR
)
1041 if (gfc_match_char (',') != MATCH_YES
)
1044 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
1047 if (m
== MATCH_ERROR
)
1050 if (gfc_match_char (',') != MATCH_YES
)
1052 e3
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1056 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
1057 if (m
== MATCH_ERROR
)
1061 gfc_error ("Expected a step value in iterator at %C");
1073 gfc_error ("Syntax error in iterator at %C");
1084 /* Tries to match the next non-whitespace character on the input.
1085 This subroutine does not return MATCH_ERROR. */
1088 gfc_match_char (char c
)
1092 where
= gfc_current_locus
;
1093 gfc_gobble_whitespace ();
1095 if (gfc_next_ascii_char () == c
)
1098 gfc_current_locus
= where
;
1103 /* General purpose matching subroutine. The target string is a
1104 scanf-like format string in which spaces correspond to arbitrary
1105 whitespace (including no whitespace), characters correspond to
1106 themselves. The %-codes are:
1108 %% Literal percent sign
1109 %e Expression, pointer to a pointer is set
1110 %s Symbol, pointer to the symbol is set
1111 %n Name, character buffer is set to name
1112 %t Matches end of statement.
1113 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1114 %l Matches a statement label
1115 %v Matches a variable expression (an lvalue)
1116 % Matches a required space (in free form) and optional spaces. */
1119 gfc_match (const char *target
, ...)
1121 gfc_st_label
**label
;
1130 old_loc
= gfc_current_locus
;
1131 va_start (argp
, target
);
1141 gfc_gobble_whitespace ();
1152 vp
= va_arg (argp
, void **);
1153 n
= gfc_match_expr ((gfc_expr
**) vp
);
1164 vp
= va_arg (argp
, void **);
1165 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
1176 vp
= va_arg (argp
, void **);
1177 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
1188 np
= va_arg (argp
, char *);
1189 n
= gfc_match_name (np
);
1200 label
= va_arg (argp
, gfc_st_label
**);
1201 n
= gfc_match_st_label (label
);
1212 ip
= va_arg (argp
, int *);
1213 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
1224 if (gfc_match_eos () != MATCH_YES
)
1232 if (gfc_match_space () == MATCH_YES
)
1238 break; /* Fall through to character matcher. */
1241 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
1247 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1248 expect an upper case character here! */
1249 gcc_assert (TOLOWER (c
) == c
);
1251 if (c
== gfc_next_ascii_char ())
1261 /* Clean up after a failed match. */
1262 gfc_current_locus
= old_loc
;
1263 va_start (argp
, target
);
1266 for (; matches
> 0; matches
--)
1268 while (*p
++ != '%');
1276 /* Matches that don't have to be undone */
1281 (void) va_arg (argp
, void **);
1286 vp
= va_arg (argp
, void **);
1287 gfc_free_expr ((struct gfc_expr
*)*vp
);
1300 /*********************** Statement level matching **********************/
1302 /* Matches the start of a program unit, which is the program keyword
1303 followed by an obligatory symbol. */
1306 gfc_match_program (void)
1311 m
= gfc_match ("% %s%t", &sym
);
1315 gfc_error ("Invalid form of PROGRAM statement at %C");
1319 if (m
== MATCH_ERROR
)
1322 if (!gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
))
1325 gfc_new_block
= sym
;
1331 /* Match a simple assignment statement. */
1334 gfc_match_assignment (void)
1336 gfc_expr
*lvalue
, *rvalue
;
1340 old_loc
= gfc_current_locus
;
1343 m
= gfc_match (" %v =", &lvalue
);
1346 gfc_current_locus
= old_loc
;
1347 gfc_free_expr (lvalue
);
1352 m
= gfc_match (" %e%t", &rvalue
);
1355 gfc_current_locus
= old_loc
;
1356 gfc_free_expr (lvalue
);
1357 gfc_free_expr (rvalue
);
1361 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1363 new_st
.op
= EXEC_ASSIGN
;
1364 new_st
.expr1
= lvalue
;
1365 new_st
.expr2
= rvalue
;
1367 gfc_check_do_variable (lvalue
->symtree
);
1373 /* Match a pointer assignment statement. */
1376 gfc_match_pointer_assignment (void)
1378 gfc_expr
*lvalue
, *rvalue
;
1382 old_loc
= gfc_current_locus
;
1384 lvalue
= rvalue
= NULL
;
1385 gfc_matching_ptr_assignment
= 0;
1386 gfc_matching_procptr_assignment
= 0;
1388 m
= gfc_match (" %v =>", &lvalue
);
1395 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1396 || gfc_is_proc_ptr_comp (lvalue
))
1397 gfc_matching_procptr_assignment
= 1;
1399 gfc_matching_ptr_assignment
= 1;
1401 m
= gfc_match (" %e%t", &rvalue
);
1402 gfc_matching_ptr_assignment
= 0;
1403 gfc_matching_procptr_assignment
= 0;
1407 new_st
.op
= EXEC_POINTER_ASSIGN
;
1408 new_st
.expr1
= lvalue
;
1409 new_st
.expr2
= rvalue
;
1414 gfc_current_locus
= old_loc
;
1415 gfc_free_expr (lvalue
);
1416 gfc_free_expr (rvalue
);
1421 /* We try to match an easy arithmetic IF statement. This only happens
1422 when just after having encountered a simple IF statement. This code
1423 is really duplicate with parts of the gfc_match_if code, but this is
1427 match_arithmetic_if (void)
1429 gfc_st_label
*l1
, *l2
, *l3
;
1433 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1437 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1438 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1439 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1441 gfc_free_expr (expr
);
1445 if (!gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
1446 "Arithmetic IF statement at %C"))
1449 new_st
.op
= EXEC_ARITHMETIC_IF
;
1450 new_st
.expr1
= expr
;
1459 /* The IF statement is a bit of a pain. First of all, there are three
1460 forms of it, the simple IF, the IF that starts a block and the
1463 There is a problem with the simple IF and that is the fact that we
1464 only have a single level of undo information on symbols. What this
1465 means is for a simple IF, we must re-match the whole IF statement
1466 multiple times in order to guarantee that the symbol table ends up
1467 in the proper state. */
1469 static match
match_simple_forall (void);
1470 static match
match_simple_where (void);
1473 gfc_match_if (gfc_statement
*if_type
)
1476 gfc_st_label
*l1
, *l2
, *l3
;
1477 locus old_loc
, old_loc2
;
1481 n
= gfc_match_label ();
1482 if (n
== MATCH_ERROR
)
1485 old_loc
= gfc_current_locus
;
1487 m
= gfc_match (" if ( %e", &expr
);
1491 old_loc2
= gfc_current_locus
;
1492 gfc_current_locus
= old_loc
;
1494 if (gfc_match_parens () == MATCH_ERROR
)
1497 gfc_current_locus
= old_loc2
;
1499 if (gfc_match_char (')') != MATCH_YES
)
1501 gfc_error ("Syntax error in IF-expression at %C");
1502 gfc_free_expr (expr
);
1506 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1512 gfc_error ("Block label not appropriate for arithmetic IF "
1514 gfc_free_expr (expr
);
1518 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1519 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1520 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1522 gfc_free_expr (expr
);
1526 if (!gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
1527 "Arithmetic IF statement at %C"))
1530 new_st
.op
= EXEC_ARITHMETIC_IF
;
1531 new_st
.expr1
= expr
;
1536 *if_type
= ST_ARITHMETIC_IF
;
1540 if (gfc_match (" then%t") == MATCH_YES
)
1542 new_st
.op
= EXEC_IF
;
1543 new_st
.expr1
= expr
;
1544 *if_type
= ST_IF_BLOCK
;
1550 gfc_error ("Block label is not appropriate for IF statement at %C");
1551 gfc_free_expr (expr
);
1555 /* At this point the only thing left is a simple IF statement. At
1556 this point, n has to be MATCH_NO, so we don't have to worry about
1557 re-matching a block label. From what we've got so far, try
1558 matching an assignment. */
1560 *if_type
= ST_SIMPLE_IF
;
1562 m
= gfc_match_assignment ();
1566 gfc_free_expr (expr
);
1567 gfc_undo_symbols ();
1568 gfc_current_locus
= old_loc
;
1570 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1571 assignment was found. For MATCH_NO, continue to call the various
1573 if (m
== MATCH_ERROR
)
1576 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1578 m
= gfc_match_pointer_assignment ();
1582 gfc_free_expr (expr
);
1583 gfc_undo_symbols ();
1584 gfc_current_locus
= old_loc
;
1586 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1588 /* Look at the next keyword to see which matcher to call. Matching
1589 the keyword doesn't affect the symbol table, so we don't have to
1590 restore between tries. */
1592 #define match(string, subr, statement) \
1593 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1597 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1598 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1599 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1600 match ("call", gfc_match_call
, ST_CALL
)
1601 match ("change team", gfc_match_change_team
, ST_CHANGE_TEAM
)
1602 match ("close", gfc_match_close
, ST_CLOSE
)
1603 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1604 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1605 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1606 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1607 match ("end team", gfc_match_end_team
, ST_END_TEAM
)
1608 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
)
1609 match ("event post", gfc_match_event_post
, ST_EVENT_POST
)
1610 match ("event wait", gfc_match_event_wait
, ST_EVENT_WAIT
)
1611 match ("exit", gfc_match_exit
, ST_EXIT
)
1612 match ("fail image", gfc_match_fail_image
, ST_FAIL_IMAGE
)
1613 match ("flush", gfc_match_flush
, ST_FLUSH
)
1614 match ("forall", match_simple_forall
, ST_FORALL
)
1615 match ("form team", gfc_match_form_team
, ST_FORM_TEAM
)
1616 match ("go to", gfc_match_goto
, ST_GOTO
)
1617 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1618 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1619 match ("lock", gfc_match_lock
, ST_LOCK
)
1620 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1621 match ("open", gfc_match_open
, ST_OPEN
)
1622 match ("pause", gfc_match_pause
, ST_NONE
)
1623 match ("print", gfc_match_print
, ST_WRITE
)
1624 match ("read", gfc_match_read
, ST_READ
)
1625 match ("return", gfc_match_return
, ST_RETURN
)
1626 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1627 match ("stop", gfc_match_stop
, ST_STOP
)
1628 match ("wait", gfc_match_wait
, ST_WAIT
)
1629 match ("sync all", gfc_match_sync_all
, ST_SYNC_CALL
);
1630 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
1631 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
1632 match ("sync team", gfc_match_sync_team
, ST_SYNC_TEAM
)
1633 match ("unlock", gfc_match_unlock
, ST_UNLOCK
)
1634 match ("where", match_simple_where
, ST_WHERE
)
1635 match ("write", gfc_match_write
, ST_WRITE
)
1638 match ("type", gfc_match_print
, ST_WRITE
)
1640 /* The gfc_match_assignment() above may have returned a MATCH_NO
1641 where the assignment was to a named constant. Check that
1642 special case here. */
1643 m
= gfc_match_assignment ();
1646 gfc_error ("Cannot assign to a named constant at %C");
1647 gfc_free_expr (expr
);
1648 gfc_undo_symbols ();
1649 gfc_current_locus
= old_loc
;
1653 /* All else has failed, so give up. See if any of the matchers has
1654 stored an error message of some sort. */
1655 if (!gfc_error_check ())
1656 gfc_error ("Unclassifiable statement in IF-clause at %C");
1658 gfc_free_expr (expr
);
1663 gfc_error ("Syntax error in IF-clause at %C");
1666 gfc_free_expr (expr
);
1670 /* At this point, we've matched the single IF and the action clause
1671 is in new_st. Rearrange things so that the IF statement appears
1674 p
= gfc_get_code (EXEC_IF
);
1675 p
->next
= XCNEW (gfc_code
);
1677 p
->next
->loc
= gfc_current_locus
;
1681 gfc_clear_new_st ();
1683 new_st
.op
= EXEC_IF
;
1692 /* Match an ELSE statement. */
1695 gfc_match_else (void)
1697 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1699 if (gfc_match_eos () == MATCH_YES
)
1702 if (gfc_match_name (name
) != MATCH_YES
1703 || gfc_current_block () == NULL
1704 || gfc_match_eos () != MATCH_YES
)
1706 gfc_error ("Unexpected junk after ELSE statement at %C");
1710 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1712 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1713 name
, gfc_current_block ()->name
);
1721 /* Match an ELSE IF statement. */
1724 gfc_match_elseif (void)
1726 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1730 m
= gfc_match (" ( %e ) then", &expr
);
1734 if (gfc_match_eos () == MATCH_YES
)
1737 if (gfc_match_name (name
) != MATCH_YES
1738 || gfc_current_block () == NULL
1739 || gfc_match_eos () != MATCH_YES
)
1741 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1745 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1747 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1748 name
, gfc_current_block ()->name
);
1753 new_st
.op
= EXEC_IF
;
1754 new_st
.expr1
= expr
;
1758 gfc_free_expr (expr
);
1763 /* Free a gfc_iterator structure. */
1766 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1772 gfc_free_expr (iter
->var
);
1773 gfc_free_expr (iter
->start
);
1774 gfc_free_expr (iter
->end
);
1775 gfc_free_expr (iter
->step
);
1782 /* Match a CRITICAL statement. */
1784 gfc_match_critical (void)
1786 gfc_st_label
*label
= NULL
;
1788 if (gfc_match_label () == MATCH_ERROR
)
1791 if (gfc_match (" critical") != MATCH_YES
)
1794 if (gfc_match_st_label (&label
) == MATCH_ERROR
)
1797 if (gfc_match_eos () != MATCH_YES
)
1799 gfc_syntax_error (ST_CRITICAL
);
1803 if (gfc_pure (NULL
))
1805 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1809 if (gfc_find_state (COMP_DO_CONCURRENT
))
1811 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1816 gfc_unset_implicit_pure (NULL
);
1818 if (!gfc_notify_std (GFC_STD_F2008
, "CRITICAL statement at %C"))
1821 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1823 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1828 if (gfc_find_state (COMP_CRITICAL
))
1830 gfc_error ("Nested CRITICAL block at %C");
1834 new_st
.op
= EXEC_CRITICAL
;
1837 && !gfc_reference_st_label (label
, ST_LABEL_TARGET
))
1844 /* Match a BLOCK statement. */
1847 gfc_match_block (void)
1851 if (gfc_match_label () == MATCH_ERROR
)
1854 if (gfc_match (" block") != MATCH_YES
)
1857 /* For this to be a correct BLOCK statement, the line must end now. */
1858 m
= gfc_match_eos ();
1859 if (m
== MATCH_ERROR
)
1868 /* Match an ASSOCIATE statement. */
1871 gfc_match_associate (void)
1873 if (gfc_match_label () == MATCH_ERROR
)
1876 if (gfc_match (" associate") != MATCH_YES
)
1879 /* Match the association list. */
1880 if (gfc_match_char ('(') != MATCH_YES
)
1882 gfc_error ("Expected association list at %C");
1885 new_st
.ext
.block
.assoc
= NULL
;
1888 gfc_association_list
* newAssoc
= gfc_get_association_list ();
1889 gfc_association_list
* a
;
1891 /* Match the next association. */
1892 if (gfc_match (" %n =>", newAssoc
->name
) != MATCH_YES
)
1894 gfc_error ("Expected association at %C");
1895 goto assocListError
;
1898 if (gfc_match (" %e", &newAssoc
->target
) != MATCH_YES
)
1900 /* Have another go, allowing for procedure pointer selectors. */
1901 gfc_matching_procptr_assignment
= 1;
1902 if (gfc_match (" %e", &newAssoc
->target
) != MATCH_YES
)
1904 gfc_error ("Invalid association target at %C");
1905 goto assocListError
;
1907 gfc_matching_procptr_assignment
= 0;
1909 newAssoc
->where
= gfc_current_locus
;
1911 /* Check that the current name is not yet in the list. */
1912 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
1913 if (!strcmp (a
->name
, newAssoc
->name
))
1915 gfc_error ("Duplicate name %qs in association at %C",
1917 goto assocListError
;
1920 /* The target expression must not be coindexed. */
1921 if (gfc_is_coindexed (newAssoc
->target
))
1923 gfc_error ("Association target at %C must not be coindexed");
1924 goto assocListError
;
1927 /* The `variable' field is left blank for now; because the target is not
1928 yet resolved, we can't use gfc_has_vector_subscript to determine it
1929 for now. This is set during resolution. */
1931 /* Put it into the list. */
1932 newAssoc
->next
= new_st
.ext
.block
.assoc
;
1933 new_st
.ext
.block
.assoc
= newAssoc
;
1935 /* Try next one or end if closing parenthesis is found. */
1936 gfc_gobble_whitespace ();
1937 if (gfc_peek_char () == ')')
1939 if (gfc_match_char (',') != MATCH_YES
)
1941 gfc_error ("Expected %<)%> or %<,%> at %C");
1951 if (gfc_match_char (')') != MATCH_YES
)
1953 /* This should never happen as we peek above. */
1957 if (gfc_match_eos () != MATCH_YES
)
1959 gfc_error ("Junk after ASSOCIATE statement at %C");
1966 gfc_free_association_list (new_st
.ext
.block
.assoc
);
1971 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1972 an accessible derived type. */
1975 match_derived_type_spec (gfc_typespec
*ts
)
1977 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1979 gfc_symbol
*derived
, *der_type
;
1980 match m
= MATCH_YES
;
1981 gfc_actual_arglist
*decl_type_param_list
= NULL
;
1982 bool is_pdt_template
= false;
1984 old_locus
= gfc_current_locus
;
1986 if (gfc_match ("%n", name
) != MATCH_YES
)
1988 gfc_current_locus
= old_locus
;
1992 gfc_find_symbol (name
, NULL
, 1, &derived
);
1994 /* Match the PDT spec list, if there. */
1995 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
)
1997 gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &der_type
);
1998 is_pdt_template
= der_type
1999 && der_type
->attr
.flavor
== FL_DERIVED
2000 && der_type
->attr
.pdt_template
;
2003 if (is_pdt_template
)
2004 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
2006 if (m
== MATCH_ERROR
)
2008 gfc_free_actual_arglist (decl_type_param_list
);
2012 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
&& derived
->attr
.generic
)
2013 derived
= gfc_find_dt_in_generic (derived
);
2015 /* If this is a PDT, find the specific instance. */
2016 if (m
== MATCH_YES
&& is_pdt_template
)
2018 gfc_namespace
*old_ns
;
2020 old_ns
= gfc_current_ns
;
2021 while (gfc_current_ns
&& gfc_current_ns
->parent
)
2022 gfc_current_ns
= gfc_current_ns
->parent
;
2024 if (type_param_spec_list
)
2025 gfc_free_actual_arglist (type_param_spec_list
);
2026 m
= gfc_get_pdt_instance (decl_type_param_list
, &der_type
,
2027 &type_param_spec_list
);
2028 gfc_free_actual_arglist (decl_type_param_list
);
2033 gcc_assert (!derived
->attr
.pdt_template
&& derived
->attr
.pdt_type
);
2034 gfc_set_sym_referenced (derived
);
2036 gfc_current_ns
= old_ns
;
2039 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
2041 ts
->type
= BT_DERIVED
;
2042 ts
->u
.derived
= derived
;
2046 gfc_current_locus
= old_locus
;
2051 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2052 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2053 It only includes the intrinsic types from the Fortran 2003 standard
2054 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2055 the implicit_flag is not needed, so it was removed. Derived types are
2056 identified by their name alone. */
2059 gfc_match_type_spec (gfc_typespec
*ts
)
2063 char c
, name
[GFC_MAX_SYMBOL_LEN
+ 1];
2066 gfc_gobble_whitespace ();
2067 old_locus
= gfc_current_locus
;
2069 /* If c isn't [a-z], then return immediately. */
2070 c
= gfc_peek_ascii_char ();
2074 type_param_spec_list
= NULL
;
2076 if (match_derived_type_spec (ts
) == MATCH_YES
)
2078 /* Enforce F03:C401. */
2079 if (ts
->u
.derived
->attr
.abstract
)
2081 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
2082 ts
->u
.derived
->name
, &old_locus
);
2088 if (gfc_match ("integer") == MATCH_YES
)
2090 ts
->type
= BT_INTEGER
;
2091 ts
->kind
= gfc_default_integer_kind
;
2095 if (gfc_match ("double precision") == MATCH_YES
)
2098 ts
->kind
= gfc_default_double_kind
;
2102 if (gfc_match ("complex") == MATCH_YES
)
2104 ts
->type
= BT_COMPLEX
;
2105 ts
->kind
= gfc_default_complex_kind
;
2109 if (gfc_match ("character") == MATCH_YES
)
2111 ts
->type
= BT_CHARACTER
;
2113 m
= gfc_match_char_spec (ts
);
2114 if (ts
->u
.cl
&& ts
->u
.cl
->length
)
2115 gfc_resolve_expr (ts
->u
.cl
->length
);
2123 /* REAL is a real pain because it can be a type, intrinsic subprogram,
2124 or list item in a type-list of an OpenMP reduction clause. Need to
2125 differentiate REAL([KIND]=scalar-int-initialization-expr) from
2126 REAL(A,[KIND]) and REAL(KIND,A). Logically, when this code was
2127 written the use of LOGICAL as a type-spec or intrinsic subprogram
2130 m
= gfc_match (" %n", name
);
2132 && (strcmp (name
, "real") == 0 || strcmp (name
, "logical") == 0))
2141 ts
->kind
= gfc_default_real_kind
;
2145 ts
->type
= BT_LOGICAL
;
2146 ts
->kind
= gfc_default_logical_kind
;
2149 gfc_gobble_whitespace ();
2151 /* Prevent REAL*4, etc. */
2152 c
= gfc_peek_ascii_char ();
2155 gfc_error ("Invalid type-spec at %C");
2159 /* Found leading colon in REAL::, a trailing ')' in for example
2160 TYPE IS (REAL), or REAL, for an OpenMP list-item. */
2161 if (c
== ':' || c
== ')' || (flag_openmp
&& c
== ','))
2164 /* Found something other than the opening '(' in REAL(... */
2168 gfc_next_char (); /* Burn the '('. */
2170 /* Look for the optional KIND=. */
2171 where
= gfc_current_locus
;
2172 m
= gfc_match ("%n", name
);
2175 gfc_gobble_whitespace ();
2176 c
= gfc_next_char ();
2179 if (strcmp(name
, "a") == 0 || strcmp(name
, "l") == 0)
2181 else if (strcmp(name
, "kind") == 0)
2187 gfc_current_locus
= where
;
2190 gfc_current_locus
= where
;
2194 m
= gfc_match_init_expr (&e
);
2195 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
2198 /* If a comma appears, it is an intrinsic subprogram. */
2199 gfc_gobble_whitespace ();
2200 c
= gfc_peek_ascii_char ();
2207 /* If ')' appears, we have REAL(initialization-expr), here check for
2208 a scalar integer initialization-expr and valid kind parameter. */
2211 if (e
->ts
.type
!= BT_INTEGER
|| e
->rank
> 0)
2217 gfc_next_char (); /* Burn the ')'. */
2218 ts
->kind
= (int) mpz_get_si (e
->value
.integer
);
2219 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
2221 gfc_error ("Invalid type-spec at %C");
2231 /* If a type is not matched, simply return MATCH_NO. */
2232 gfc_current_locus
= old_locus
;
2237 gfc_gobble_whitespace ();
2239 /* This prevents INTEGER*4, etc. */
2240 if (gfc_peek_ascii_char () == '*')
2242 gfc_error ("Invalid type-spec at %C");
2246 m
= gfc_match_kind_spec (ts
, false);
2248 /* No kind specifier found. */
2256 /******************** FORALL subroutines ********************/
2258 /* Free a list of FORALL iterators. */
2261 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
2263 gfc_forall_iterator
*next
;
2268 gfc_free_expr (iter
->var
);
2269 gfc_free_expr (iter
->start
);
2270 gfc_free_expr (iter
->end
);
2271 gfc_free_expr (iter
->stride
);
2278 /* Match an iterator as part of a FORALL statement. The format is:
2280 <var> = <start>:<end>[:<stride>]
2282 On MATCH_NO, the caller tests for the possibility that there is a
2283 scalar mask expression. */
2286 match_forall_iterator (gfc_forall_iterator
**result
)
2288 gfc_forall_iterator
*iter
;
2292 where
= gfc_current_locus
;
2293 iter
= XCNEW (gfc_forall_iterator
);
2295 m
= gfc_match_expr (&iter
->var
);
2299 if (gfc_match_char ('=') != MATCH_YES
2300 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
2306 m
= gfc_match_expr (&iter
->start
);
2310 if (gfc_match_char (':') != MATCH_YES
)
2313 m
= gfc_match_expr (&iter
->end
);
2316 if (m
== MATCH_ERROR
)
2319 if (gfc_match_char (':') == MATCH_NO
)
2320 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2323 m
= gfc_match_expr (&iter
->stride
);
2326 if (m
== MATCH_ERROR
)
2330 /* Mark the iteration variable's symbol as used as a FORALL index. */
2331 iter
->var
->symtree
->n
.sym
->forall_index
= true;
2337 gfc_error ("Syntax error in FORALL iterator at %C");
2342 gfc_current_locus
= where
;
2343 gfc_free_forall_iterator (iter
);
2348 /* Match the header of a FORALL statement. */
2351 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
2353 gfc_forall_iterator
*head
, *tail
, *new_iter
;
2357 gfc_gobble_whitespace ();
2362 if (gfc_match_char ('(') != MATCH_YES
)
2365 m
= match_forall_iterator (&new_iter
);
2366 if (m
== MATCH_ERROR
)
2371 head
= tail
= new_iter
;
2375 if (gfc_match_char (',') != MATCH_YES
)
2378 m
= match_forall_iterator (&new_iter
);
2379 if (m
== MATCH_ERROR
)
2384 tail
->next
= new_iter
;
2389 /* Have to have a mask expression. */
2391 m
= gfc_match_expr (&msk
);
2394 if (m
== MATCH_ERROR
)
2400 if (gfc_match_char (')') == MATCH_NO
)
2408 gfc_syntax_error (ST_FORALL
);
2411 gfc_free_expr (msk
);
2412 gfc_free_forall_iterator (head
);
2417 /* Match the rest of a simple FORALL statement that follows an
2421 match_simple_forall (void)
2423 gfc_forall_iterator
*head
;
2432 m
= match_forall_header (&head
, &mask
);
2439 m
= gfc_match_assignment ();
2441 if (m
== MATCH_ERROR
)
2445 m
= gfc_match_pointer_assignment ();
2446 if (m
== MATCH_ERROR
)
2452 c
= XCNEW (gfc_code
);
2454 c
->loc
= gfc_current_locus
;
2456 if (gfc_match_eos () != MATCH_YES
)
2459 gfc_clear_new_st ();
2460 new_st
.op
= EXEC_FORALL
;
2461 new_st
.expr1
= mask
;
2462 new_st
.ext
.forall_iterator
= head
;
2463 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2464 new_st
.block
->next
= c
;
2469 gfc_syntax_error (ST_FORALL
);
2472 gfc_free_forall_iterator (head
);
2473 gfc_free_expr (mask
);
2479 /* Match a FORALL statement. */
2482 gfc_match_forall (gfc_statement
*st
)
2484 gfc_forall_iterator
*head
;
2493 m0
= gfc_match_label ();
2494 if (m0
== MATCH_ERROR
)
2497 m
= gfc_match (" forall");
2501 m
= match_forall_header (&head
, &mask
);
2502 if (m
== MATCH_ERROR
)
2507 if (gfc_match_eos () == MATCH_YES
)
2509 *st
= ST_FORALL_BLOCK
;
2510 new_st
.op
= EXEC_FORALL
;
2511 new_st
.expr1
= mask
;
2512 new_st
.ext
.forall_iterator
= head
;
2516 m
= gfc_match_assignment ();
2517 if (m
== MATCH_ERROR
)
2521 m
= gfc_match_pointer_assignment ();
2522 if (m
== MATCH_ERROR
)
2528 c
= XCNEW (gfc_code
);
2530 c
->loc
= gfc_current_locus
;
2532 gfc_clear_new_st ();
2533 new_st
.op
= EXEC_FORALL
;
2534 new_st
.expr1
= mask
;
2535 new_st
.ext
.forall_iterator
= head
;
2536 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2537 new_st
.block
->next
= c
;
2543 gfc_syntax_error (ST_FORALL
);
2546 gfc_free_forall_iterator (head
);
2547 gfc_free_expr (mask
);
2548 gfc_free_statements (c
);
2553 /* Match a DO statement. */
2558 gfc_iterator iter
, *ip
;
2560 gfc_st_label
*label
;
2563 old_loc
= gfc_current_locus
;
2565 memset (&iter
, '\0', sizeof (gfc_iterator
));
2568 m
= gfc_match_label ();
2569 if (m
== MATCH_ERROR
)
2572 if (gfc_match (" do") != MATCH_YES
)
2575 m
= gfc_match_st_label (&label
);
2576 if (m
== MATCH_ERROR
)
2579 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2581 if (gfc_match_eos () == MATCH_YES
)
2583 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
2584 new_st
.op
= EXEC_DO_WHILE
;
2588 /* Match an optional comma, if no comma is found, a space is obligatory. */
2589 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
2592 /* Check for balanced parens. */
2594 if (gfc_match_parens () == MATCH_ERROR
)
2597 if (gfc_match (" concurrent") == MATCH_YES
)
2599 gfc_forall_iterator
*head
;
2602 if (!gfc_notify_std (GFC_STD_F2008
, "DO CONCURRENT construct at %C"))
2608 m
= match_forall_header (&head
, &mask
);
2612 if (m
== MATCH_ERROR
)
2613 goto concurr_cleanup
;
2615 if (gfc_match_eos () != MATCH_YES
)
2616 goto concurr_cleanup
;
2619 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2620 goto concurr_cleanup
;
2622 new_st
.label1
= label
;
2623 new_st
.op
= EXEC_DO_CONCURRENT
;
2624 new_st
.expr1
= mask
;
2625 new_st
.ext
.forall_iterator
= head
;
2630 gfc_syntax_error (ST_DO
);
2631 gfc_free_expr (mask
);
2632 gfc_free_forall_iterator (head
);
2636 /* See if we have a DO WHILE. */
2637 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
2639 new_st
.op
= EXEC_DO_WHILE
;
2643 /* The abortive DO WHILE may have done something to the symbol
2644 table, so we start over. */
2645 gfc_undo_symbols ();
2646 gfc_current_locus
= old_loc
;
2648 gfc_match_label (); /* This won't error. */
2649 gfc_match (" do "); /* This will work. */
2651 gfc_match_st_label (&label
); /* Can't error out. */
2652 gfc_match_char (','); /* Optional comma. */
2654 m
= gfc_match_iterator (&iter
, 0);
2657 if (m
== MATCH_ERROR
)
2660 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
2661 gfc_check_do_variable (iter
.var
->symtree
);
2663 if (gfc_match_eos () != MATCH_YES
)
2665 gfc_syntax_error (ST_DO
);
2669 new_st
.op
= EXEC_DO
;
2673 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2676 new_st
.label1
= label
;
2678 if (new_st
.op
== EXEC_DO_WHILE
)
2679 new_st
.expr1
= iter
.end
;
2682 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
2689 gfc_free_iterator (&iter
, 0);
2695 /* Match an EXIT or CYCLE statement. */
2698 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2700 gfc_state_data
*p
, *o
;
2705 if (gfc_match_eos () == MATCH_YES
)
2709 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2712 m
= gfc_match ("% %n%t", name
);
2713 if (m
== MATCH_ERROR
)
2717 gfc_syntax_error (st
);
2721 /* Find the corresponding symbol. If there's a BLOCK statement
2722 between here and the label, it is not in gfc_current_ns but a parent
2724 stree
= gfc_find_symtree_in_proc (name
, gfc_current_ns
);
2727 gfc_error ("Name %qs in %s statement at %C is unknown",
2728 name
, gfc_ascii_statement (st
));
2733 if (sym
->attr
.flavor
!= FL_LABEL
)
2735 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2736 name
, gfc_ascii_statement (st
));
2741 /* Find the loop specified by the label (or lack of a label). */
2742 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2743 if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2745 else if (p
->state
== COMP_CRITICAL
)
2747 gfc_error("%s statement at %C leaves CRITICAL construct",
2748 gfc_ascii_statement (st
));
2751 else if (p
->state
== COMP_DO_CONCURRENT
2752 && (op
== EXEC_EXIT
|| (sym
&& sym
!= p
->sym
)))
2754 /* F2008, C821 & C845. */
2755 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2756 gfc_ascii_statement (st
));
2759 else if ((sym
&& sym
== p
->sym
)
2760 || (!sym
&& (p
->state
== COMP_DO
2761 || p
->state
== COMP_DO_CONCURRENT
)))
2767 gfc_error ("%s statement at %C is not within a construct",
2768 gfc_ascii_statement (st
));
2770 gfc_error ("%s statement at %C is not within construct %qs",
2771 gfc_ascii_statement (st
), sym
->name
);
2776 /* Special checks for EXIT from non-loop constructs. */
2780 case COMP_DO_CONCURRENT
:
2784 /* This is already handled above. */
2787 case COMP_ASSOCIATE
:
2791 case COMP_SELECT_TYPE
:
2793 if (op
== EXEC_CYCLE
)
2795 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2796 " construct %qs", sym
->name
);
2799 gcc_assert (op
== EXEC_EXIT
);
2800 if (!gfc_notify_std (GFC_STD_F2008
, "EXIT statement with no"
2801 " do-construct-name at %C"))
2806 gfc_error ("%s statement at %C is not applicable to construct %qs",
2807 gfc_ascii_statement (st
), sym
->name
);
2813 gfc_error (is_oacc (p
)
2814 ? G_("%s statement at %C leaving OpenACC structured block")
2815 : G_("%s statement at %C leaving OpenMP structured block"),
2816 gfc_ascii_statement (st
));
2820 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2824 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
2825 && (o
->head
->op
== EXEC_OACC_LOOP
2826 || o
->head
->op
== EXEC_OACC_PARALLEL_LOOP
))
2829 gcc_assert (o
->head
->next
!= NULL
2830 && (o
->head
->next
->op
== EXEC_DO
2831 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2832 && o
->previous
!= NULL
2833 && o
->previous
->tail
->op
== o
->head
->op
);
2834 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2835 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2836 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2837 if (st
== ST_EXIT
&& cnt
<= collapse
)
2839 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2842 if (st
== ST_CYCLE
&& cnt
< collapse
)
2844 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2845 " !$ACC LOOP loop");
2851 && (o
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2852 && (o
->head
->op
== EXEC_OMP_DO
2853 || o
->head
->op
== EXEC_OMP_PARALLEL_DO
2854 || o
->head
->op
== EXEC_OMP_SIMD
2855 || o
->head
->op
== EXEC_OMP_DO_SIMD
2856 || o
->head
->op
== EXEC_OMP_PARALLEL_DO_SIMD
))
2859 gcc_assert (o
->head
->next
!= NULL
2860 && (o
->head
->next
->op
== EXEC_DO
2861 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2862 && o
->previous
!= NULL
2863 && o
->previous
->tail
->op
== o
->head
->op
);
2864 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
)
2866 if (o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2867 count
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2868 if (o
->previous
->tail
->ext
.omp_clauses
->orderedc
)
2869 count
= o
->previous
->tail
->ext
.omp_clauses
->orderedc
;
2871 if (st
== ST_EXIT
&& cnt
<= count
)
2873 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2876 if (st
== ST_CYCLE
&& cnt
< count
)
2878 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2884 /* Save the first statement in the construct - needed by the backend. */
2885 new_st
.ext
.which_construct
= p
->construct
;
2893 /* Match the EXIT statement. */
2896 gfc_match_exit (void)
2898 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2902 /* Match the CYCLE statement. */
2905 gfc_match_cycle (void)
2907 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2911 /* Match a stop-code after an (ERROR) STOP or PAUSE statement. The
2912 requirements for a stop-code differ in the standards.
2916 R840 stop-stmt is STOP [ stop-code ]
2917 R841 stop-code is scalar-char-constant
2918 or digit [ digit [ digit [ digit [ digit ] ] ] ]
2920 Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
2923 R855 stop-stmt is STOP [ stop-code ]
2924 R856 allstop-stmt is ALL STOP [ stop-code ]
2925 R857 stop-code is scalar-default-char-constant-expr
2926 or scalar-int-constant-expr
2928 For free-form source code, all standards contain a statement of the form:
2930 A blank shall be used to separate names, constants, or labels from
2931 adjacent keywords, names, constants, or labels.
2933 A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003,
2937 is valid, but it is invalid Fortran 2008. */
2940 gfc_match_stopcode (gfc_statement st
)
2946 /* Set f95 for -std=f95. */
2947 f95
= (gfc_option
.allow_std
== GFC_STD_OPT_F95
);
2949 /* Set f03 for -std=f2003. */
2950 f03
= (gfc_option
.allow_std
== GFC_STD_OPT_F03
);
2952 /* Look for a blank between STOP and the stop-code for F2008 or later. */
2953 if (gfc_current_form
!= FORM_FIXED
&& !(f95
|| f03
))
2955 char c
= gfc_peek_ascii_char ();
2957 /* Look for end-of-statement. There is no stop-code. */
2958 if (c
== '\n' || c
== '!' || c
== ';')
2963 gfc_error ("Blank required in %s statement near %C",
2964 gfc_ascii_statement (st
));
2969 if (gfc_match_eos () != MATCH_YES
)
2974 /* First look for the F95 or F2003 digit [...] construct. */
2975 old_locus
= gfc_current_locus
;
2976 m
= gfc_match_small_int (&stopcode
);
2977 if (m
== MATCH_YES
&& (f95
|| f03
))
2981 gfc_error ("STOP code at %C cannot be negative");
2985 if (stopcode
> 99999)
2987 gfc_error ("STOP code at %C contains too many digits");
2992 /* Reset the locus and now load gfc_expr. */
2993 gfc_current_locus
= old_locus
;
2994 m
= gfc_match_expr (&e
);
2995 if (m
== MATCH_ERROR
)
3000 if (gfc_match_eos () != MATCH_YES
)
3004 if (gfc_pure (NULL
))
3006 if (st
== ST_ERROR_STOP
)
3008 if (!gfc_notify_std (GFC_STD_F2018
, "%s statement at %C in PURE "
3009 "procedure", gfc_ascii_statement (st
)))
3014 gfc_error ("%s statement not allowed in PURE procedure at %C",
3015 gfc_ascii_statement (st
));
3020 gfc_unset_implicit_pure (NULL
);
3022 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
))
3024 gfc_error ("Image control statement STOP at %C in CRITICAL block");
3027 if (st
== ST_STOP
&& gfc_find_state (COMP_DO_CONCURRENT
))
3029 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
3035 gfc_simplify_expr (e
, 0);
3037 /* Test for F95 and F2003 style STOP stop-code. */
3038 if (e
->expr_type
!= EXPR_CONSTANT
&& (f95
|| f03
))
3040 gfc_error ("STOP code at %L must be a scalar CHARACTER constant or "
3041 "digit[digit[digit[digit[digit]]]]", &e
->where
);
3045 /* Use the machinery for an initialization expression to reduce the
3046 stop-code to a constant. */
3047 gfc_init_expr_flag
= true;
3048 gfc_reduce_init_expr (e
);
3049 gfc_init_expr_flag
= false;
3051 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
3053 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
3060 gfc_error ("STOP code at %L must be scalar", &e
->where
);
3064 if (e
->ts
.type
== BT_CHARACTER
3065 && e
->ts
.kind
!= gfc_default_character_kind
)
3067 gfc_error ("STOP code at %L must be default character KIND=%d",
3068 &e
->where
, (int) gfc_default_character_kind
);
3072 if (e
->ts
.type
== BT_INTEGER
&& e
->ts
.kind
!= gfc_default_integer_kind
)
3074 gfc_error ("STOP code at %L must be default integer KIND=%d",
3075 &e
->where
, (int) gfc_default_integer_kind
);
3085 new_st
.op
= EXEC_STOP
;
3088 new_st
.op
= EXEC_ERROR_STOP
;
3091 new_st
.op
= EXEC_PAUSE
;
3098 new_st
.ext
.stop_code
= -1;
3103 gfc_syntax_error (st
);
3112 /* Match the (deprecated) PAUSE statement. */
3115 gfc_match_pause (void)
3119 m
= gfc_match_stopcode (ST_PAUSE
);
3122 if (!gfc_notify_std (GFC_STD_F95_DEL
, "PAUSE statement at %C"))
3129 /* Match the STOP statement. */
3132 gfc_match_stop (void)
3134 return gfc_match_stopcode (ST_STOP
);
3138 /* Match the ERROR STOP statement. */
3141 gfc_match_error_stop (void)
3143 if (!gfc_notify_std (GFC_STD_F2008
, "ERROR STOP statement at %C"))
3146 return gfc_match_stopcode (ST_ERROR_STOP
);
3149 /* Match EVENT POST/WAIT statement. Syntax:
3150 EVENT POST ( event-variable [, sync-stat-list] )
3151 EVENT WAIT ( event-variable [, wait-spec-list] )
3153 wait-spec-list is sync-stat-list or until-spec
3154 until-spec is UNTIL_COUNT = scalar-int-expr
3155 sync-stat is STAT= or ERRMSG=. */
3158 event_statement (gfc_statement st
)
3161 gfc_expr
*tmp
, *eventvar
, *until_count
, *stat
, *errmsg
;
3162 bool saw_until_count
, saw_stat
, saw_errmsg
;
3164 tmp
= eventvar
= until_count
= stat
= errmsg
= NULL
;
3165 saw_until_count
= saw_stat
= saw_errmsg
= false;
3167 if (gfc_pure (NULL
))
3169 gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
3170 st
== ST_EVENT_POST
? "POST" : "WAIT");
3174 gfc_unset_implicit_pure (NULL
);
3176 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3178 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3182 if (gfc_find_state (COMP_CRITICAL
))
3184 gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
3185 st
== ST_EVENT_POST
? "POST" : "WAIT");
3189 if (gfc_find_state (COMP_DO_CONCURRENT
))
3191 gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
3192 "block", st
== ST_EVENT_POST
? "POST" : "WAIT");
3196 if (gfc_match_char ('(') != MATCH_YES
)
3199 if (gfc_match ("%e", &eventvar
) != MATCH_YES
)
3201 m
= gfc_match_char (',');
3202 if (m
== MATCH_ERROR
)
3206 m
= gfc_match_char (')');
3214 m
= gfc_match (" stat = %v", &tmp
);
3215 if (m
== MATCH_ERROR
)
3221 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3227 m
= gfc_match_char (',');
3235 m
= gfc_match (" errmsg = %v", &tmp
);
3236 if (m
== MATCH_ERROR
)
3242 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3248 m
= gfc_match_char (',');
3256 m
= gfc_match (" until_count = %e", &tmp
);
3257 if (m
== MATCH_ERROR
|| st
== ST_EVENT_POST
)
3261 if (saw_until_count
)
3263 gfc_error ("Redundant UNTIL_COUNT tag found at %L",
3268 saw_until_count
= true;
3270 m
= gfc_match_char (',');
3281 if (m
== MATCH_ERROR
)
3284 if (gfc_match (" )%t") != MATCH_YES
)
3291 new_st
.op
= EXEC_EVENT_POST
;
3294 new_st
.op
= EXEC_EVENT_WAIT
;
3300 new_st
.expr1
= eventvar
;
3301 new_st
.expr2
= stat
;
3302 new_st
.expr3
= errmsg
;
3303 new_st
.expr4
= until_count
;
3308 gfc_syntax_error (st
);
3311 if (until_count
!= tmp
)
3312 gfc_free_expr (until_count
);
3314 gfc_free_expr (errmsg
);
3316 gfc_free_expr (stat
);
3318 gfc_free_expr (tmp
);
3319 gfc_free_expr (eventvar
);
3327 gfc_match_event_post (void)
3329 if (!gfc_notify_std (GFC_STD_F2018
, "EVENT POST statement at %C"))
3332 return event_statement (ST_EVENT_POST
);
3337 gfc_match_event_wait (void)
3339 if (!gfc_notify_std (GFC_STD_F2018
, "EVENT WAIT statement at %C"))
3342 return event_statement (ST_EVENT_WAIT
);
3346 /* Match a FAIL IMAGE statement. */
3349 gfc_match_fail_image (void)
3351 if (!gfc_notify_std (GFC_STD_F2018
, "FAIL IMAGE statement at %C"))
3354 if (gfc_match_char ('(') == MATCH_YES
)
3357 new_st
.op
= EXEC_FAIL_IMAGE
;
3362 gfc_syntax_error (ST_FAIL_IMAGE
);
3367 /* Match a FORM TEAM statement. */
3370 gfc_match_form_team (void)
3373 gfc_expr
*teamid
,*team
;
3375 if (!gfc_notify_std (GFC_STD_F2018
, "FORM TEAM statement at %C"))
3378 if (gfc_match_char ('(') == MATCH_NO
)
3381 new_st
.op
= EXEC_FORM_TEAM
;
3383 if (gfc_match ("%e", &teamid
) != MATCH_YES
)
3385 m
= gfc_match_char (',');
3386 if (m
== MATCH_ERROR
)
3388 if (gfc_match ("%e", &team
) != MATCH_YES
)
3391 m
= gfc_match_char (')');
3395 new_st
.expr1
= teamid
;
3396 new_st
.expr2
= team
;
3401 gfc_syntax_error (ST_FORM_TEAM
);
3406 /* Match a CHANGE TEAM statement. */
3409 gfc_match_change_team (void)
3414 if (!gfc_notify_std (GFC_STD_F2018
, "CHANGE TEAM statement at %C"))
3417 if (gfc_match_char ('(') == MATCH_NO
)
3420 new_st
.op
= EXEC_CHANGE_TEAM
;
3422 if (gfc_match ("%e", &team
) != MATCH_YES
)
3425 m
= gfc_match_char (')');
3429 new_st
.expr1
= team
;
3434 gfc_syntax_error (ST_CHANGE_TEAM
);
3439 /* Match a END TEAM statement. */
3442 gfc_match_end_team (void)
3444 if (!gfc_notify_std (GFC_STD_F2018
, "END TEAM statement at %C"))
3447 if (gfc_match_char ('(') == MATCH_YES
)
3450 new_st
.op
= EXEC_END_TEAM
;
3455 gfc_syntax_error (ST_END_TEAM
);
3460 /* Match a SYNC TEAM statement. */
3463 gfc_match_sync_team (void)
3468 if (!gfc_notify_std (GFC_STD_F2018
, "SYNC TEAM statement at %C"))
3471 if (gfc_match_char ('(') == MATCH_NO
)
3474 new_st
.op
= EXEC_SYNC_TEAM
;
3476 if (gfc_match ("%e", &team
) != MATCH_YES
)
3479 m
= gfc_match_char (')');
3483 new_st
.expr1
= team
;
3488 gfc_syntax_error (ST_SYNC_TEAM
);
3493 /* Match LOCK/UNLOCK statement. Syntax:
3494 LOCK ( lock-variable [ , lock-stat-list ] )
3495 UNLOCK ( lock-variable [ , sync-stat-list ] )
3496 where lock-stat is ACQUIRED_LOCK or sync-stat
3497 and sync-stat is STAT= or ERRMSG=. */
3500 lock_unlock_statement (gfc_statement st
)
3503 gfc_expr
*tmp
, *lockvar
, *acq_lock
, *stat
, *errmsg
;
3504 bool saw_acq_lock
, saw_stat
, saw_errmsg
;
3506 tmp
= lockvar
= acq_lock
= stat
= errmsg
= NULL
;
3507 saw_acq_lock
= saw_stat
= saw_errmsg
= false;
3509 if (gfc_pure (NULL
))
3511 gfc_error ("Image control statement %s at %C in PURE procedure",
3512 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3516 gfc_unset_implicit_pure (NULL
);
3518 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3520 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3524 if (gfc_find_state (COMP_CRITICAL
))
3526 gfc_error ("Image control statement %s at %C in CRITICAL block",
3527 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3531 if (gfc_find_state (COMP_DO_CONCURRENT
))
3533 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
3534 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3538 if (gfc_match_char ('(') != MATCH_YES
)
3541 if (gfc_match ("%e", &lockvar
) != MATCH_YES
)
3543 m
= gfc_match_char (',');
3544 if (m
== MATCH_ERROR
)
3548 m
= gfc_match_char (')');
3556 m
= gfc_match (" stat = %v", &tmp
);
3557 if (m
== MATCH_ERROR
)
3563 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3569 m
= gfc_match_char (',');
3577 m
= gfc_match (" errmsg = %v", &tmp
);
3578 if (m
== MATCH_ERROR
)
3584 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3590 m
= gfc_match_char (',');
3598 m
= gfc_match (" acquired_lock = %v", &tmp
);
3599 if (m
== MATCH_ERROR
|| st
== ST_UNLOCK
)
3605 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L",
3610 saw_acq_lock
= true;
3612 m
= gfc_match_char (',');
3623 if (m
== MATCH_ERROR
)
3626 if (gfc_match (" )%t") != MATCH_YES
)
3633 new_st
.op
= EXEC_LOCK
;
3636 new_st
.op
= EXEC_UNLOCK
;
3642 new_st
.expr1
= lockvar
;
3643 new_st
.expr2
= stat
;
3644 new_st
.expr3
= errmsg
;
3645 new_st
.expr4
= acq_lock
;
3650 gfc_syntax_error (st
);
3653 if (acq_lock
!= tmp
)
3654 gfc_free_expr (acq_lock
);
3656 gfc_free_expr (errmsg
);
3658 gfc_free_expr (stat
);
3660 gfc_free_expr (tmp
);
3661 gfc_free_expr (lockvar
);
3668 gfc_match_lock (void)
3670 if (!gfc_notify_std (GFC_STD_F2008
, "LOCK statement at %C"))
3673 return lock_unlock_statement (ST_LOCK
);
3678 gfc_match_unlock (void)
3680 if (!gfc_notify_std (GFC_STD_F2008
, "UNLOCK statement at %C"))
3683 return lock_unlock_statement (ST_UNLOCK
);
3687 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
3688 SYNC ALL [(sync-stat-list)]
3689 SYNC MEMORY [(sync-stat-list)]
3690 SYNC IMAGES (image-set [, sync-stat-list] )
3691 with sync-stat is int-expr or *. */
3694 sync_statement (gfc_statement st
)
3697 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
3698 bool saw_stat
, saw_errmsg
;
3700 tmp
= imageset
= stat
= errmsg
= NULL
;
3701 saw_stat
= saw_errmsg
= false;
3703 if (gfc_pure (NULL
))
3705 gfc_error ("Image control statement SYNC at %C in PURE procedure");
3709 gfc_unset_implicit_pure (NULL
);
3711 if (!gfc_notify_std (GFC_STD_F2008
, "SYNC statement at %C"))
3714 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3716 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
3721 if (gfc_find_state (COMP_CRITICAL
))
3723 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3727 if (gfc_find_state (COMP_DO_CONCURRENT
))
3729 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3733 if (gfc_match_eos () == MATCH_YES
)
3735 if (st
== ST_SYNC_IMAGES
)
3740 if (gfc_match_char ('(') != MATCH_YES
)
3743 if (st
== ST_SYNC_IMAGES
)
3745 /* Denote '*' as imageset == NULL. */
3746 m
= gfc_match_char ('*');
3747 if (m
== MATCH_ERROR
)
3751 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
3754 m
= gfc_match_char (',');
3755 if (m
== MATCH_ERROR
)
3759 m
= gfc_match_char (')');
3768 m
= gfc_match (" stat = %v", &tmp
);
3769 if (m
== MATCH_ERROR
)
3775 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3781 if (gfc_match_char (',') == MATCH_YES
)
3788 m
= gfc_match (" errmsg = %v", &tmp
);
3789 if (m
== MATCH_ERROR
)
3795 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3801 if (gfc_match_char (',') == MATCH_YES
)
3811 if (gfc_match (" )%t") != MATCH_YES
)
3818 new_st
.op
= EXEC_SYNC_ALL
;
3820 case ST_SYNC_IMAGES
:
3821 new_st
.op
= EXEC_SYNC_IMAGES
;
3823 case ST_SYNC_MEMORY
:
3824 new_st
.op
= EXEC_SYNC_MEMORY
;
3830 new_st
.expr1
= imageset
;
3831 new_st
.expr2
= stat
;
3832 new_st
.expr3
= errmsg
;
3837 gfc_syntax_error (st
);
3841 gfc_free_expr (stat
);
3843 gfc_free_expr (errmsg
);
3845 gfc_free_expr (tmp
);
3846 gfc_free_expr (imageset
);
3852 /* Match SYNC ALL statement. */
3855 gfc_match_sync_all (void)
3857 return sync_statement (ST_SYNC_ALL
);
3861 /* Match SYNC IMAGES statement. */
3864 gfc_match_sync_images (void)
3866 return sync_statement (ST_SYNC_IMAGES
);
3870 /* Match SYNC MEMORY statement. */
3873 gfc_match_sync_memory (void)
3875 return sync_statement (ST_SYNC_MEMORY
);
3879 /* Match a CONTINUE statement. */
3882 gfc_match_continue (void)
3884 if (gfc_match_eos () != MATCH_YES
)
3886 gfc_syntax_error (ST_CONTINUE
);
3890 new_st
.op
= EXEC_CONTINUE
;
3895 /* Match the (deprecated) ASSIGN statement. */
3898 gfc_match_assign (void)
3901 gfc_st_label
*label
;
3903 if (gfc_match (" %l", &label
) == MATCH_YES
)
3905 if (!gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
))
3907 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
3909 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGN statement at %C"))
3912 expr
->symtree
->n
.sym
->attr
.assign
= 1;
3914 new_st
.op
= EXEC_LABEL_ASSIGN
;
3915 new_st
.label1
= label
;
3916 new_st
.expr1
= expr
;
3924 /* Match the GO TO statement. As a computed GOTO statement is
3925 matched, it is transformed into an equivalent SELECT block. No
3926 tree is necessary, and the resulting jumps-to-jumps are
3927 specifically optimized away by the back end. */
3930 gfc_match_goto (void)
3932 gfc_code
*head
, *tail
;
3935 gfc_st_label
*label
;
3939 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
3941 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3944 new_st
.op
= EXEC_GOTO
;
3945 new_st
.label1
= label
;
3949 /* The assigned GO TO statement. */
3951 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
3953 if (!gfc_notify_std (GFC_STD_F95_DEL
, "Assigned GOTO statement at %C"))
3956 new_st
.op
= EXEC_GOTO
;
3957 new_st
.expr1
= expr
;
3959 if (gfc_match_eos () == MATCH_YES
)
3962 /* Match label list. */
3963 gfc_match_char (',');
3964 if (gfc_match_char ('(') != MATCH_YES
)
3966 gfc_syntax_error (ST_GOTO
);
3973 m
= gfc_match_st_label (&label
);
3977 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3981 head
= tail
= gfc_get_code (EXEC_GOTO
);
3984 tail
->block
= gfc_get_code (EXEC_GOTO
);
3988 tail
->label1
= label
;
3990 while (gfc_match_char (',') == MATCH_YES
);
3992 if (gfc_match (")%t") != MATCH_YES
)
3997 gfc_error ("Statement label list in GOTO at %C cannot be empty");
4000 new_st
.block
= head
;
4005 /* Last chance is a computed GO TO statement. */
4006 if (gfc_match_char ('(') != MATCH_YES
)
4008 gfc_syntax_error (ST_GOTO
);
4017 m
= gfc_match_st_label (&label
);
4021 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
4025 head
= tail
= gfc_get_code (EXEC_SELECT
);
4028 tail
->block
= gfc_get_code (EXEC_SELECT
);
4032 cp
= gfc_get_case ();
4033 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
4036 tail
->ext
.block
.case_list
= cp
;
4038 tail
->next
= gfc_get_code (EXEC_GOTO
);
4039 tail
->next
->label1
= label
;
4041 while (gfc_match_char (',') == MATCH_YES
);
4043 if (gfc_match_char (')') != MATCH_YES
)
4048 gfc_error ("Statement label list in GOTO at %C cannot be empty");
4052 /* Get the rest of the statement. */
4053 gfc_match_char (',');
4055 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
4058 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Computed GOTO at %C"))
4061 /* At this point, a computed GOTO has been fully matched and an
4062 equivalent SELECT statement constructed. */
4064 new_st
.op
= EXEC_SELECT
;
4065 new_st
.expr1
= NULL
;
4067 /* Hack: For a "real" SELECT, the expression is in expr. We put
4068 it in expr2 so we can distinguish then and produce the correct
4070 new_st
.expr2
= expr
;
4071 new_st
.block
= head
;
4075 gfc_syntax_error (ST_GOTO
);
4077 gfc_free_statements (head
);
4082 /* Frees a list of gfc_alloc structures. */
4085 gfc_free_alloc_list (gfc_alloc
*p
)
4092 gfc_free_expr (p
->expr
);
4098 /* Match an ALLOCATE statement. */
4101 gfc_match_allocate (void)
4103 gfc_alloc
*head
, *tail
;
4104 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
4108 locus old_locus
, deferred_locus
, assumed_locus
;
4109 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, saw_deferred
, b1
, b2
, b3
;
4110 bool saw_unlimited
= false, saw_assumed
= false;
4113 stat
= errmsg
= source
= mold
= tmp
= NULL
;
4114 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= saw_deferred
= false;
4116 if (gfc_match_char ('(') != MATCH_YES
)
4118 gfc_syntax_error (ST_ALLOCATE
);
4122 /* Match an optional type-spec. */
4123 old_locus
= gfc_current_locus
;
4124 m
= gfc_match_type_spec (&ts
);
4125 if (m
== MATCH_ERROR
)
4127 else if (m
== MATCH_NO
)
4129 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
4131 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
4133 gfc_error ("Error in type-spec at %L", &old_locus
);
4137 ts
.type
= BT_UNKNOWN
;
4141 /* Needed for the F2008:C631 check below. */
4142 assumed_locus
= gfc_current_locus
;
4144 if (gfc_match (" :: ") == MATCH_YES
)
4146 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
4152 gfc_error ("Type-spec at %L cannot contain a deferred "
4153 "type parameter", &old_locus
);
4157 if (ts
.type
== BT_CHARACTER
)
4159 if (!ts
.u
.cl
->length
)
4162 ts
.u
.cl
->length_from_typespec
= true;
4165 if (type_param_spec_list
4166 && gfc_spec_list_type (type_param_spec_list
, NULL
)
4169 gfc_error ("The type parameter spec list in the type-spec at "
4170 "%L cannot contain DEFERRED parameters", &old_locus
);
4176 ts
.type
= BT_UNKNOWN
;
4177 gfc_current_locus
= old_locus
;
4184 head
= tail
= gfc_get_alloc ();
4187 tail
->next
= gfc_get_alloc ();
4191 m
= gfc_match_variable (&tail
->expr
, 0);
4194 if (m
== MATCH_ERROR
)
4197 if (gfc_check_do_variable (tail
->expr
->symtree
))
4200 bool impure
= gfc_impure_variable (tail
->expr
->symtree
->n
.sym
);
4201 if (impure
&& gfc_pure (NULL
))
4203 gfc_error ("Bad allocate-object at %C for a PURE procedure");
4208 gfc_unset_implicit_pure (NULL
);
4210 /* F2008:C631 (R626) A type-param-value in a type-spec shall be an
4211 asterisk if and only if each allocate-object is a dummy argument
4212 for which the corresponding type parameter is assumed. */
4214 && (tail
->expr
->ts
.deferred
4215 || (tail
->expr
->ts
.u
.cl
&& tail
->expr
->ts
.u
.cl
->length
)
4216 || tail
->expr
->symtree
->n
.sym
->attr
.dummy
== 0))
4218 gfc_error ("Incompatible allocate-object at %C for CHARACTER "
4219 "type-spec at %L", &assumed_locus
);
4223 if (tail
->expr
->ts
.deferred
)
4225 saw_deferred
= true;
4226 deferred_locus
= tail
->expr
->where
;
4229 if (gfc_find_state (COMP_DO_CONCURRENT
)
4230 || gfc_find_state (COMP_CRITICAL
))
4233 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
4234 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
4235 if (ref
->type
== REF_COMPONENT
)
4236 coarray
= ref
->u
.c
.component
->attr
.codimension
;
4238 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
4240 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
4243 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
4245 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
4250 /* Check for F08:C628. */
4251 sym
= tail
->expr
->symtree
->n
.sym
;
4252 b1
= !(tail
->expr
->ref
4253 && (tail
->expr
->ref
->type
== REF_COMPONENT
4254 || tail
->expr
->ref
->type
== REF_ARRAY
));
4255 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4256 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
4257 || CLASS_DATA (sym
)->attr
.class_pointer
);
4259 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4260 || sym
->attr
.proc_pointer
);
4261 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
4262 && (sym
->ns
->proc_name
->attr
.allocatable
4263 || sym
->ns
->proc_name
->attr
.pointer
4264 || sym
->ns
->proc_name
->attr
.proc_pointer
);
4265 if (b1
&& b2
&& !b3
)
4267 gfc_error ("Allocate-object at %L is neither a data pointer "
4268 "nor an allocatable variable", &tail
->expr
->where
);
4272 /* The ALLOCATE statement had an optional typespec. Check the
4274 if (ts
.type
!= BT_UNKNOWN
)
4276 /* Enforce F03:C624. */
4277 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
4279 gfc_error ("Type of entity at %L is type incompatible with "
4280 "typespec", &tail
->expr
->where
);
4284 /* Enforce F03:C627. */
4285 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
4287 gfc_error ("Kind type parameter for entity at %L differs from "
4288 "the kind type parameter of the typespec",
4289 &tail
->expr
->where
);
4294 if (tail
->expr
->ts
.type
== BT_DERIVED
)
4295 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
4297 if (type_param_spec_list
)
4298 tail
->expr
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
4300 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
4302 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
4304 gfc_error ("Shape specification for allocatable scalar at %C");
4308 if (gfc_match_char (',') != MATCH_YES
)
4313 m
= gfc_match (" stat = %v", &tmp
);
4314 if (m
== MATCH_ERROR
)
4321 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4329 if (gfc_check_do_variable (stat
->symtree
))
4332 if (gfc_match_char (',') == MATCH_YES
)
4333 goto alloc_opt_list
;
4336 m
= gfc_match (" errmsg = %v", &tmp
);
4337 if (m
== MATCH_ERROR
)
4341 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
4347 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4355 if (gfc_match_char (',') == MATCH_YES
)
4356 goto alloc_opt_list
;
4359 m
= gfc_match (" source = %e", &tmp
);
4360 if (m
== MATCH_ERROR
)
4364 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
4370 gfc_error ("Redundant SOURCE tag found at %L", &tmp
->where
);
4374 /* The next 2 conditionals check C631. */
4375 if (ts
.type
!= BT_UNKNOWN
)
4377 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
4378 &tmp
->where
, &old_locus
);
4383 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
4384 " with more than a single allocate object",
4392 if (gfc_match_char (',') == MATCH_YES
)
4393 goto alloc_opt_list
;
4396 m
= gfc_match (" mold = %e", &tmp
);
4397 if (m
== MATCH_ERROR
)
4401 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
4404 /* Check F08:C636. */
4407 gfc_error ("Redundant MOLD tag found at %L", &tmp
->where
);
4411 /* Check F08:C637. */
4412 if (ts
.type
!= BT_UNKNOWN
)
4414 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
4415 &tmp
->where
, &old_locus
);
4424 if (gfc_match_char (',') == MATCH_YES
)
4425 goto alloc_opt_list
;
4428 gfc_gobble_whitespace ();
4430 if (gfc_peek_char () == ')')
4434 if (gfc_match (" )%t") != MATCH_YES
)
4437 /* Check F08:C637. */
4440 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
4441 &mold
->where
, &source
->where
);
4445 /* Check F03:C623, */
4446 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4448 gfc_error ("Allocate-object at %L with a deferred type parameter "
4449 "requires either a type-spec or SOURCE tag or a MOLD tag",
4454 /* Check F03:C625, */
4455 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4457 for (tail
= head
; tail
; tail
= tail
->next
)
4459 if (UNLIMITED_POLY (tail
->expr
))
4460 gfc_error ("Unlimited polymorphic allocate-object at %L "
4461 "requires either a type-spec or SOURCE tag "
4462 "or a MOLD tag", &tail
->expr
->where
);
4467 new_st
.op
= EXEC_ALLOCATE
;
4468 new_st
.expr1
= stat
;
4469 new_st
.expr2
= errmsg
;
4471 new_st
.expr3
= source
;
4473 new_st
.expr3
= mold
;
4474 new_st
.ext
.alloc
.list
= head
;
4475 new_st
.ext
.alloc
.ts
= ts
;
4477 if (type_param_spec_list
)
4478 gfc_free_actual_arglist (type_param_spec_list
);
4483 gfc_syntax_error (ST_ALLOCATE
);
4486 gfc_free_expr (errmsg
);
4487 gfc_free_expr (source
);
4488 gfc_free_expr (stat
);
4489 gfc_free_expr (mold
);
4490 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
4491 gfc_free_alloc_list (head
);
4492 if (type_param_spec_list
)
4493 gfc_free_actual_arglist (type_param_spec_list
);
4498 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
4499 a set of pointer assignments to intrinsic NULL(). */
4502 gfc_match_nullify (void)
4510 if (gfc_match_char ('(') != MATCH_YES
)
4515 m
= gfc_match_variable (&p
, 0);
4516 if (m
== MATCH_ERROR
)
4521 if (gfc_check_do_variable (p
->symtree
))
4525 if (gfc_is_coindexed (p
))
4527 gfc_error ("Pointer object at %C shall not be coindexed");
4531 /* build ' => NULL() '. */
4532 e
= gfc_get_null_expr (&gfc_current_locus
);
4534 /* Chain to list. */
4538 tail
->op
= EXEC_POINTER_ASSIGN
;
4542 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
4549 if (gfc_match (" )%t") == MATCH_YES
)
4551 if (gfc_match_char (',') != MATCH_YES
)
4558 gfc_syntax_error (ST_NULLIFY
);
4561 gfc_free_statements (new_st
.next
);
4563 gfc_free_expr (new_st
.expr1
);
4564 new_st
.expr1
= NULL
;
4565 gfc_free_expr (new_st
.expr2
);
4566 new_st
.expr2
= NULL
;
4571 /* Match a DEALLOCATE statement. */
4574 gfc_match_deallocate (void)
4576 gfc_alloc
*head
, *tail
;
4577 gfc_expr
*stat
, *errmsg
, *tmp
;
4580 bool saw_stat
, saw_errmsg
, b1
, b2
;
4583 stat
= errmsg
= tmp
= NULL
;
4584 saw_stat
= saw_errmsg
= false;
4586 if (gfc_match_char ('(') != MATCH_YES
)
4592 head
= tail
= gfc_get_alloc ();
4595 tail
->next
= gfc_get_alloc ();
4599 m
= gfc_match_variable (&tail
->expr
, 0);
4600 if (m
== MATCH_ERROR
)
4605 if (gfc_check_do_variable (tail
->expr
->symtree
))
4608 sym
= tail
->expr
->symtree
->n
.sym
;
4610 bool impure
= gfc_impure_variable (sym
);
4611 if (impure
&& gfc_pure (NULL
))
4613 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
4618 gfc_unset_implicit_pure (NULL
);
4620 if (gfc_is_coarray (tail
->expr
)
4621 && gfc_find_state (COMP_DO_CONCURRENT
))
4623 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
4627 if (gfc_is_coarray (tail
->expr
)
4628 && gfc_find_state (COMP_CRITICAL
))
4630 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
4634 /* FIXME: disable the checking on derived types. */
4635 b1
= !(tail
->expr
->ref
4636 && (tail
->expr
->ref
->type
== REF_COMPONENT
4637 || tail
->expr
->ref
->type
== REF_ARRAY
));
4638 if (sym
&& sym
->ts
.type
== BT_CLASS
)
4639 b2
= !(CLASS_DATA (sym
) && (CLASS_DATA (sym
)->attr
.allocatable
4640 || CLASS_DATA (sym
)->attr
.class_pointer
));
4642 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4643 || sym
->attr
.proc_pointer
);
4646 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
4647 "nor an allocatable variable");
4651 if (gfc_match_char (',') != MATCH_YES
)
4656 m
= gfc_match (" stat = %v", &tmp
);
4657 if (m
== MATCH_ERROR
)
4663 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4664 gfc_free_expr (tmp
);
4671 if (gfc_check_do_variable (stat
->symtree
))
4674 if (gfc_match_char (',') == MATCH_YES
)
4675 goto dealloc_opt_list
;
4678 m
= gfc_match (" errmsg = %v", &tmp
);
4679 if (m
== MATCH_ERROR
)
4683 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
4688 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4689 gfc_free_expr (tmp
);
4696 if (gfc_match_char (',') == MATCH_YES
)
4697 goto dealloc_opt_list
;
4700 gfc_gobble_whitespace ();
4702 if (gfc_peek_char () == ')')
4706 if (gfc_match (" )%t") != MATCH_YES
)
4709 new_st
.op
= EXEC_DEALLOCATE
;
4710 new_st
.expr1
= stat
;
4711 new_st
.expr2
= errmsg
;
4712 new_st
.ext
.alloc
.list
= head
;
4717 gfc_syntax_error (ST_DEALLOCATE
);
4720 gfc_free_expr (errmsg
);
4721 gfc_free_expr (stat
);
4722 gfc_free_alloc_list (head
);
4727 /* Match a RETURN statement. */
4730 gfc_match_return (void)
4734 gfc_compile_state s
;
4738 if (gfc_find_state (COMP_CRITICAL
))
4740 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4744 if (gfc_find_state (COMP_DO_CONCURRENT
))
4746 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4750 if (gfc_match_eos () == MATCH_YES
)
4753 if (!gfc_find_state (COMP_SUBROUTINE
))
4755 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4760 if (gfc_current_form
== FORM_FREE
)
4762 /* The following are valid, so we can't require a blank after the
4766 char c
= gfc_peek_ascii_char ();
4767 if (ISALPHA (c
) || ISDIGIT (c
))
4771 m
= gfc_match (" %e%t", &e
);
4774 if (m
== MATCH_ERROR
)
4777 gfc_syntax_error (ST_RETURN
);
4784 gfc_enclosing_unit (&s
);
4785 if (s
== COMP_PROGRAM
4786 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
4787 "main program at %C"))
4790 new_st
.op
= EXEC_RETURN
;
4797 /* Match the call of a type-bound procedure, if CALL%var has already been
4798 matched and var found to be a derived-type variable. */
4801 match_typebound_call (gfc_symtree
* varst
)
4806 base
= gfc_get_expr ();
4807 base
->expr_type
= EXPR_VARIABLE
;
4808 base
->symtree
= varst
;
4809 base
->where
= gfc_current_locus
;
4810 gfc_set_sym_referenced (varst
->n
.sym
);
4812 m
= gfc_match_varspec (base
, 0, true, true);
4814 gfc_error ("Expected component reference at %C");
4817 gfc_free_expr (base
);
4821 if (gfc_match_eos () != MATCH_YES
)
4823 gfc_error ("Junk after CALL at %C");
4824 gfc_free_expr (base
);
4828 if (base
->expr_type
== EXPR_COMPCALL
)
4829 new_st
.op
= EXEC_COMPCALL
;
4830 else if (base
->expr_type
== EXPR_PPC
)
4831 new_st
.op
= EXEC_CALL_PPC
;
4834 gfc_error ("Expected type-bound procedure or procedure pointer component "
4836 gfc_free_expr (base
);
4839 new_st
.expr1
= base
;
4845 /* Match a CALL statement. The tricky part here are possible
4846 alternate return specifiers. We handle these by having all
4847 "subroutines" actually return an integer via a register that gives
4848 the return number. If the call specifies alternate returns, we
4849 generate code for a SELECT statement whose case clauses contain
4850 GOTOs to the various labels. */
4853 gfc_match_call (void)
4855 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4856 gfc_actual_arglist
*a
, *arglist
;
4866 m
= gfc_match ("% %n", name
);
4872 if (gfc_get_ha_sym_tree (name
, &st
))
4877 /* If this is a variable of derived-type, it probably starts a type-bound
4879 if ((sym
->attr
.flavor
!= FL_PROCEDURE
4880 || gfc_is_function_return_value (sym
, gfc_current_ns
))
4881 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
4882 return match_typebound_call (st
);
4884 /* If it does not seem to be callable (include functions so that the
4885 right association is made. They are thrown out in resolution.)
4887 if (!sym
->attr
.generic
4888 && !sym
->attr
.subroutine
4889 && !sym
->attr
.function
)
4891 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
4893 /* ...create a symbol in this scope... */
4894 if (sym
->ns
!= gfc_current_ns
4895 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
4898 if (sym
!= st
->n
.sym
)
4902 /* ...and then to try to make the symbol into a subroutine. */
4903 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
4907 gfc_set_sym_referenced (sym
);
4909 if (gfc_match_eos () != MATCH_YES
)
4911 m
= gfc_match_actual_arglist (1, &arglist
);
4914 if (m
== MATCH_ERROR
)
4917 if (gfc_match_eos () != MATCH_YES
)
4921 /* If any alternate return labels were found, construct a SELECT
4922 statement that will jump to the right place. */
4925 for (a
= arglist
; a
; a
= a
->next
)
4926 if (a
->expr
== NULL
)
4934 gfc_symtree
*select_st
;
4935 gfc_symbol
*select_sym
;
4936 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4938 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
4939 sprintf (name
, "_result_%s", sym
->name
);
4940 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
4942 select_sym
= select_st
->n
.sym
;
4943 select_sym
->ts
.type
= BT_INTEGER
;
4944 select_sym
->ts
.kind
= gfc_default_integer_kind
;
4945 gfc_set_sym_referenced (select_sym
);
4946 c
->expr1
= gfc_get_expr ();
4947 c
->expr1
->expr_type
= EXPR_VARIABLE
;
4948 c
->expr1
->symtree
= select_st
;
4949 c
->expr1
->ts
= select_sym
->ts
;
4950 c
->expr1
->where
= gfc_current_locus
;
4953 for (a
= arglist
; a
; a
= a
->next
)
4955 if (a
->expr
!= NULL
)
4958 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
4963 c
->block
= gfc_get_code (EXEC_SELECT
);
4966 new_case
= gfc_get_case ();
4967 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
4968 new_case
->low
= new_case
->high
;
4969 c
->ext
.block
.case_list
= new_case
;
4971 c
->next
= gfc_get_code (EXEC_GOTO
);
4972 c
->next
->label1
= a
->label
;
4976 new_st
.op
= EXEC_CALL
;
4977 new_st
.symtree
= st
;
4978 new_st
.ext
.actual
= arglist
;
4983 gfc_syntax_error (ST_CALL
);
4986 gfc_free_actual_arglist (arglist
);
4991 /* Given a name, return a pointer to the common head structure,
4992 creating it if it does not exist. If FROM_MODULE is nonzero, we
4993 mangle the name so that it doesn't interfere with commons defined
4994 in the using namespace.
4995 TODO: Add to global symbol tree. */
4998 gfc_get_common (const char *name
, int from_module
)
5001 static int serial
= 0;
5002 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
5006 /* A use associated common block is only needed to correctly layout
5007 the variables it contains. */
5008 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
5009 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
5013 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
5016 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
5019 if (st
->n
.common
== NULL
)
5021 st
->n
.common
= gfc_get_common_head ();
5022 st
->n
.common
->where
= gfc_current_locus
;
5023 strcpy (st
->n
.common
->name
, name
);
5026 return st
->n
.common
;
5030 /* Match a common block name. */
5032 match
match_common_name (char *name
)
5036 if (gfc_match_char ('/') == MATCH_NO
)
5042 if (gfc_match_char ('/') == MATCH_YES
)
5048 m
= gfc_match_name (name
);
5050 if (m
== MATCH_ERROR
)
5052 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
5055 gfc_error ("Syntax error in common block name at %C");
5060 /* Match a COMMON statement. */
5063 gfc_match_common (void)
5065 gfc_symbol
*sym
, **head
, *tail
, *other
;
5066 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5076 m
= match_common_name (name
);
5077 if (m
== MATCH_ERROR
)
5080 if (name
[0] == '\0')
5082 t
= &gfc_current_ns
->blank_common
;
5083 if (t
->head
== NULL
)
5084 t
->where
= gfc_current_locus
;
5088 t
= gfc_get_common (name
, 0);
5097 while (tail
->common_next
)
5098 tail
= tail
->common_next
;
5101 /* Grab the list of symbols. */
5104 m
= gfc_match_symbol (&sym
, 0);
5105 if (m
== MATCH_ERROR
)
5110 /* See if we know the current common block is bind(c), and if
5111 so, then see if we can check if the symbol is (which it'll
5112 need to be). This can happen if the bind(c) attr stmt was
5113 applied to the common block, and the variable(s) already
5114 defined, before declaring the common block. */
5115 if (t
->is_bind_c
== 1)
5117 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
5119 /* If we find an error, just print it and continue,
5120 cause it's just semantic, and we can see if there
5122 gfc_error_now ("Variable %qs at %L in common block %qs "
5123 "at %C must be declared with a C "
5124 "interoperable kind since common block "
5126 sym
->name
, &(sym
->declared_at
), t
->name
,
5130 if (sym
->attr
.is_bind_c
== 1)
5131 gfc_error_now ("Variable %qs in common block %qs at %C can not "
5132 "be bind(c) since it is not global", sym
->name
,
5136 if (sym
->attr
.in_common
)
5138 gfc_error ("Symbol %qs at %C is already in a COMMON block",
5143 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
5144 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
5146 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol %qs at "
5147 "%C can only be COMMON in BLOCK DATA",
5152 /* Deal with an optional array specification after the
5154 m
= gfc_match_array_spec (&as
, true, true);
5155 if (m
== MATCH_ERROR
)
5160 if (as
->type
!= AS_EXPLICIT
)
5162 gfc_error ("Array specification for symbol %qs in COMMON "
5163 "at %C must be explicit", sym
->name
);
5167 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
5170 if (sym
->attr
.pointer
)
5172 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
5173 "POINTER array", sym
->name
);
5182 /* Add the in_common attribute, but ignore the reported errors
5183 if any, and continue matching. */
5184 gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
);
5186 sym
->common_block
= t
;
5187 sym
->common_block
->refs
++;
5190 tail
->common_next
= sym
;
5196 sym
->common_head
= t
;
5198 /* Check to see if the symbol is already in an equivalence group.
5199 If it is, set the other members as being in common. */
5200 if (sym
->attr
.in_equivalence
)
5202 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
5204 for (e2
= e1
; e2
; e2
= e2
->eq
)
5205 if (e2
->expr
->symtree
->n
.sym
== sym
)
5212 for (e2
= e1
; e2
; e2
= e2
->eq
)
5214 other
= e2
->expr
->symtree
->n
.sym
;
5215 if (other
->common_head
5216 && other
->common_head
!= sym
->common_head
)
5218 gfc_error ("Symbol %qs, in COMMON block %qs at "
5219 "%C is being indirectly equivalenced to "
5220 "another COMMON block %qs",
5221 sym
->name
, sym
->common_head
->name
,
5222 other
->common_head
->name
);
5225 other
->attr
.in_common
= 1;
5226 other
->common_head
= t
;
5232 gfc_gobble_whitespace ();
5233 if (gfc_match_eos () == MATCH_YES
)
5235 if (gfc_peek_ascii_char () == '/')
5237 if (gfc_match_char (',') != MATCH_YES
)
5239 gfc_gobble_whitespace ();
5240 if (gfc_peek_ascii_char () == '/')
5249 gfc_syntax_error (ST_COMMON
);
5252 gfc_free_array_spec (as
);
5257 /* Match a BLOCK DATA program unit. */
5260 gfc_match_block_data (void)
5262 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5266 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "BLOCK DATA construct at %L",
5267 &gfc_current_locus
))
5270 if (gfc_match_eos () == MATCH_YES
)
5272 gfc_new_block
= NULL
;
5276 m
= gfc_match ("% %n%t", name
);
5280 if (gfc_get_symbol (name
, NULL
, &sym
))
5283 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
5286 gfc_new_block
= sym
;
5292 /* Free a namelist structure. */
5295 gfc_free_namelist (gfc_namelist
*name
)
5299 for (; name
; name
= n
)
5307 /* Free an OpenMP namelist structure. */
5310 gfc_free_omp_namelist (gfc_omp_namelist
*name
)
5312 gfc_omp_namelist
*n
;
5314 for (; name
; name
= n
)
5316 gfc_free_expr (name
->expr
);
5319 if (name
->udr
->combiner
)
5320 gfc_free_statement (name
->udr
->combiner
);
5321 if (name
->udr
->initializer
)
5322 gfc_free_statement (name
->udr
->initializer
);
5331 /* Match a NAMELIST statement. */
5334 gfc_match_namelist (void)
5336 gfc_symbol
*group_name
, *sym
;
5340 m
= gfc_match (" / %s /", &group_name
);
5343 if (m
== MATCH_ERROR
)
5348 if (group_name
->ts
.type
!= BT_UNKNOWN
)
5350 gfc_error ("Namelist group name %qs at %C already has a basic "
5351 "type of %s", group_name
->name
,
5352 gfc_typename (&group_name
->ts
));
5356 if (group_name
->attr
.flavor
== FL_NAMELIST
5357 && group_name
->attr
.use_assoc
5358 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name %qs "
5359 "at %C already is USE associated and can"
5360 "not be respecified.", group_name
->name
))
5363 if (group_name
->attr
.flavor
!= FL_NAMELIST
5364 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
5365 group_name
->name
, NULL
))
5370 m
= gfc_match_symbol (&sym
, 1);
5373 if (m
== MATCH_ERROR
)
5376 if (sym
->attr
.in_namelist
== 0
5377 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
5380 /* Use gfc_error_check here, rather than goto error, so that
5381 these are the only errors for the next two lines. */
5382 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
5384 gfc_error ("Assumed size array %qs in namelist %qs at "
5385 "%C is not allowed", sym
->name
, group_name
->name
);
5389 nl
= gfc_get_namelist ();
5393 if (group_name
->namelist
== NULL
)
5394 group_name
->namelist
= group_name
->namelist_tail
= nl
;
5397 group_name
->namelist_tail
->next
= nl
;
5398 group_name
->namelist_tail
= nl
;
5401 if (gfc_match_eos () == MATCH_YES
)
5404 m
= gfc_match_char (',');
5406 if (gfc_match_char ('/') == MATCH_YES
)
5408 m2
= gfc_match (" %s /", &group_name
);
5409 if (m2
== MATCH_YES
)
5411 if (m2
== MATCH_ERROR
)
5425 gfc_syntax_error (ST_NAMELIST
);
5432 /* Match a MODULE statement. */
5435 gfc_match_module (void)
5439 m
= gfc_match (" %s%t", &gfc_new_block
);
5443 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
5444 gfc_new_block
->name
, NULL
))
5451 /* Free equivalence sets and lists. Recursively is the easiest way to
5455 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
5460 gfc_free_equiv (eq
->eq
);
5461 gfc_free_equiv_until (eq
->next
, stop
);
5462 gfc_free_expr (eq
->expr
);
5468 gfc_free_equiv (gfc_equiv
*eq
)
5470 gfc_free_equiv_until (eq
, NULL
);
5474 /* Match an EQUIVALENCE statement. */
5477 gfc_match_equivalence (void)
5479 gfc_equiv
*eq
, *set
, *tail
;
5483 gfc_common_head
*common_head
= NULL
;
5491 eq
= gfc_get_equiv ();
5495 eq
->next
= gfc_current_ns
->equiv
;
5496 gfc_current_ns
->equiv
= eq
;
5498 if (gfc_match_char ('(') != MATCH_YES
)
5502 common_flag
= FALSE
;
5507 m
= gfc_match_equiv_variable (&set
->expr
);
5508 if (m
== MATCH_ERROR
)
5513 /* count the number of objects. */
5516 if (gfc_match_char ('%') == MATCH_YES
)
5518 gfc_error ("Derived type component %C is not a "
5519 "permitted EQUIVALENCE member");
5523 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
5524 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5526 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
5527 "be an array section");
5531 sym
= set
->expr
->symtree
->n
.sym
;
5533 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
5536 if (sym
->attr
.in_common
)
5539 common_head
= sym
->common_head
;
5542 if (gfc_match_char (')') == MATCH_YES
)
5545 if (gfc_match_char (',') != MATCH_YES
)
5548 set
->eq
= gfc_get_equiv ();
5554 gfc_error ("EQUIVALENCE at %C requires two or more objects");
5558 /* If one of the members of an equivalence is in common, then
5559 mark them all as being in common. Before doing this, check
5560 that members of the equivalence group are not in different
5563 for (set
= eq
; set
; set
= set
->eq
)
5565 sym
= set
->expr
->symtree
->n
.sym
;
5566 if (sym
->common_head
&& sym
->common_head
!= common_head
)
5568 gfc_error ("Attempt to indirectly overlap COMMON "
5569 "blocks %s and %s by EQUIVALENCE at %C",
5570 sym
->common_head
->name
, common_head
->name
);
5573 sym
->attr
.in_common
= 1;
5574 sym
->common_head
= common_head
;
5577 if (gfc_match_eos () == MATCH_YES
)
5579 if (gfc_match_char (',') != MATCH_YES
)
5581 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
5586 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "EQUIVALENCE statement at %C"))
5592 gfc_syntax_error (ST_EQUIVALENCE
);
5598 gfc_free_equiv (gfc_current_ns
->equiv
);
5599 gfc_current_ns
->equiv
= eq
;
5605 /* Check that a statement function is not recursive. This is done by looking
5606 for the statement function symbol(sym) by looking recursively through its
5607 expression(e). If a reference to sym is found, true is returned.
5608 12.5.4 requires that any variable of function that is implicitly typed
5609 shall have that type confirmed by any subsequent type declaration. The
5610 implicit typing is conveniently done here. */
5612 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
5615 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
5621 switch (e
->expr_type
)
5624 if (e
->symtree
== NULL
)
5627 /* Check the name before testing for nested recursion! */
5628 if (sym
->name
== e
->symtree
->n
.sym
->name
)
5631 /* Catch recursion via other statement functions. */
5632 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
5633 && e
->symtree
->n
.sym
->value
5634 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
5637 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5638 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5643 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
5646 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5647 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5659 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
5661 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
5665 /* Match a statement function declaration. It is so easy to match
5666 non-statement function statements with a MATCH_ERROR as opposed to
5667 MATCH_NO that we suppress error message in most cases. */
5670 gfc_match_st_function (void)
5672 gfc_error_buffer old_error
;
5677 m
= gfc_match_symbol (&sym
, 0);
5681 gfc_push_error (&old_error
);
5683 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
5686 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
5689 m
= gfc_match (" = %e%t", &expr
);
5693 gfc_free_error (&old_error
);
5695 if (m
== MATCH_ERROR
)
5698 if (recursive_stmt_fcn (expr
, sym
))
5700 gfc_error ("Statement function at %L is recursive", &expr
->where
);
5706 if ((gfc_current_state () == COMP_FUNCTION
5707 || gfc_current_state () == COMP_SUBROUTINE
)
5708 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
5710 gfc_error ("Statement function at %L cannot appear within an INTERFACE",
5715 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
5721 gfc_pop_error (&old_error
);
5726 /* Match an assignment to a pointer function (F2008). This could, in
5727 general be ambiguous with a statement function. In this implementation
5728 it remains so if it is the first statement after the specification
5732 gfc_match_ptr_fcn_assign (void)
5734 gfc_error_buffer old_error
;
5739 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5741 old_loc
= gfc_current_locus
;
5742 m
= gfc_match_name (name
);
5746 gfc_find_symbol (name
, NULL
, 1, &sym
);
5747 if (sym
&& sym
->attr
.flavor
!= FL_PROCEDURE
)
5750 gfc_push_error (&old_error
);
5752 if (sym
&& sym
->attr
.function
)
5753 goto match_actual_arglist
;
5755 gfc_current_locus
= old_loc
;
5756 m
= gfc_match_symbol (&sym
, 0);
5760 if (!gfc_add_procedure (&sym
->attr
, PROC_UNKNOWN
, sym
->name
, NULL
))
5763 match_actual_arglist
:
5764 gfc_current_locus
= old_loc
;
5765 m
= gfc_match (" %e", &expr
);
5769 new_st
.op
= EXEC_ASSIGN
;
5770 new_st
.expr1
= expr
;
5773 m
= gfc_match (" = %e%t", &expr
);
5777 new_st
.expr2
= expr
;
5781 gfc_pop_error (&old_error
);
5786 /***************** SELECT CASE subroutines ******************/
5788 /* Free a single case structure. */
5791 free_case (gfc_case
*p
)
5793 if (p
->low
== p
->high
)
5795 gfc_free_expr (p
->low
);
5796 gfc_free_expr (p
->high
);
5801 /* Free a list of case structures. */
5804 gfc_free_case_list (gfc_case
*p
)
5816 /* Match a single case selector. Combining the requirements of F08:C830
5817 and F08:C832 (R838) means that the case-value must have either CHARACTER,
5818 INTEGER, or LOGICAL type. */
5821 match_case_selector (gfc_case
**cp
)
5826 c
= gfc_get_case ();
5827 c
->where
= gfc_current_locus
;
5829 if (gfc_match_char (':') == MATCH_YES
)
5831 m
= gfc_match_init_expr (&c
->high
);
5834 if (m
== MATCH_ERROR
)
5837 if (c
->high
->ts
.type
!= BT_LOGICAL
&& c
->high
->ts
.type
!= BT_INTEGER
5838 && c
->high
->ts
.type
!= BT_CHARACTER
)
5840 gfc_error ("Expression in CASE selector at %L cannot be %s",
5841 &c
->high
->where
, gfc_typename (&c
->high
->ts
));
5847 m
= gfc_match_init_expr (&c
->low
);
5848 if (m
== MATCH_ERROR
)
5853 if (c
->low
->ts
.type
!= BT_LOGICAL
&& c
->low
->ts
.type
!= BT_INTEGER
5854 && c
->low
->ts
.type
!= BT_CHARACTER
)
5856 gfc_error ("Expression in CASE selector at %L cannot be %s",
5857 &c
->low
->where
, gfc_typename (&c
->low
->ts
));
5861 /* If we're not looking at a ':' now, make a range out of a single
5862 target. Else get the upper bound for the case range. */
5863 if (gfc_match_char (':') != MATCH_YES
)
5867 m
= gfc_match_init_expr (&c
->high
);
5868 if (m
== MATCH_ERROR
)
5870 /* MATCH_NO is fine. It's OK if nothing is there! */
5878 gfc_error ("Expected initialization expression in CASE at %C");
5886 /* Match the end of a case statement. */
5889 match_case_eos (void)
5891 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5894 if (gfc_match_eos () == MATCH_YES
)
5897 /* If the case construct doesn't have a case-construct-name, we
5898 should have matched the EOS. */
5899 if (!gfc_current_block ())
5902 gfc_gobble_whitespace ();
5904 m
= gfc_match_name (name
);
5908 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5910 gfc_error ("Expected block name %qs of SELECT construct at %C",
5911 gfc_current_block ()->name
);
5915 return gfc_match_eos ();
5919 /* Match a SELECT statement. */
5922 gfc_match_select (void)
5927 m
= gfc_match_label ();
5928 if (m
== MATCH_ERROR
)
5931 m
= gfc_match (" select case ( %e )%t", &expr
);
5935 new_st
.op
= EXEC_SELECT
;
5936 new_st
.expr1
= expr
;
5942 /* Transfer the selector typespec to the associate name. */
5945 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
)
5948 gfc_symbol
*assoc_sym
;
5951 assoc_sym
= associate
->symtree
->n
.sym
;
5953 /* At this stage the expression rank and arrayspec dimensions have
5954 not been completely sorted out. We must get the expr2->rank
5955 right here, so that the correct class container is obtained. */
5956 ref
= selector
->ref
;
5957 while (ref
&& ref
->next
)
5960 if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
5961 && ref
&& ref
->type
== REF_ARRAY
)
5963 /* Ensure that the array reference type is set. We cannot use
5964 gfc_resolve_expr at this point, so the usable parts of
5965 resolve.c(resolve_array_ref) are employed to do it. */
5966 if (ref
->u
.ar
.type
== AR_UNKNOWN
)
5968 ref
->u
.ar
.type
= AR_ELEMENT
;
5969 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
5970 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5971 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
5972 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
5973 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
5975 ref
->u
.ar
.type
= AR_SECTION
;
5980 if (ref
->u
.ar
.type
== AR_FULL
)
5981 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
5982 else if (ref
->u
.ar
.type
== AR_SECTION
)
5983 selector
->rank
= ref
->u
.ar
.dimen
;
5987 rank
= selector
->rank
;
5992 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
5993 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
5994 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
5995 && ref
->u
.ar
.end
[i
] == NULL
5996 && ref
->u
.ar
.stride
[i
] == NULL
))
6001 assoc_sym
->attr
.dimension
= 1;
6002 assoc_sym
->as
= gfc_get_array_spec ();
6003 assoc_sym
->as
->rank
= rank
;
6004 assoc_sym
->as
->type
= AS_DEFERRED
;
6007 assoc_sym
->as
= NULL
;
6010 assoc_sym
->as
= NULL
;
6012 if (selector
->ts
.type
== BT_CLASS
)
6014 /* The correct class container has to be available. */
6015 assoc_sym
->ts
.type
= BT_CLASS
;
6016 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
6017 assoc_sym
->attr
.pointer
= 1;
6018 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
6023 /* Push the current selector onto the SELECT TYPE stack. */
6026 select_type_push (gfc_symbol
*sel
)
6028 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
6029 top
->selector
= sel
;
6031 top
->prev
= select_type_stack
;
6033 select_type_stack
= top
;
6037 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
6039 static gfc_symtree
*
6040 select_intrinsic_set_tmp (gfc_typespec
*ts
)
6042 char name
[GFC_MAX_SYMBOL_LEN
];
6044 HOST_WIDE_INT charlen
= 0;
6046 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
6049 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
6050 && !select_type_stack
->selector
->attr
.class_ok
)
6053 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
6054 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6055 charlen
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
6057 if (ts
->type
!= BT_CHARACTER
)
6058 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
6061 snprintf (name
, sizeof (name
), "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
6062 gfc_basic_typename (ts
->type
), charlen
, ts
->kind
);
6064 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6065 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
6067 /* Copy across the array spec to the selector. */
6068 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
6069 && (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
6070 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
))
6072 tmp
->n
.sym
->attr
.pointer
= 1;
6073 tmp
->n
.sym
->attr
.dimension
6074 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
6075 tmp
->n
.sym
->attr
.codimension
6076 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
6078 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
6081 gfc_set_sym_referenced (tmp
->n
.sym
);
6082 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
6083 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
6089 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
6092 select_type_set_tmp (gfc_typespec
*ts
)
6094 char name
[GFC_MAX_SYMBOL_LEN
];
6095 gfc_symtree
*tmp
= NULL
;
6099 select_type_stack
->tmp
= NULL
;
6103 tmp
= select_intrinsic_set_tmp (ts
);
6110 if (ts
->type
== BT_CLASS
)
6111 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
6113 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
6114 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6115 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
6117 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
6118 && select_type_stack
->selector
->attr
.class_ok
)
6120 tmp
->n
.sym
->attr
.pointer
6121 = CLASS_DATA (select_type_stack
->selector
)->attr
.class_pointer
;
6123 /* Copy across the array spec to the selector. */
6124 if (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
6125 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
)
6127 tmp
->n
.sym
->attr
.dimension
6128 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
6129 tmp
->n
.sym
->attr
.codimension
6130 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
6132 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
6136 gfc_set_sym_referenced (tmp
->n
.sym
);
6137 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
6138 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
6140 if (ts
->type
== BT_CLASS
)
6141 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
6145 /* Add an association for it, so the rest of the parser knows it is
6146 an associate-name. The target will be set during resolution. */
6147 tmp
->n
.sym
->assoc
= gfc_get_association_list ();
6148 tmp
->n
.sym
->assoc
->dangling
= 1;
6149 tmp
->n
.sym
->assoc
->st
= tmp
;
6151 select_type_stack
->tmp
= tmp
;
6155 /* Match a SELECT TYPE statement. */
6158 gfc_match_select_type (void)
6160 gfc_expr
*expr1
, *expr2
= NULL
;
6162 char name
[GFC_MAX_SYMBOL_LEN
];
6165 gfc_namespace
*ns
= gfc_current_ns
;
6167 m
= gfc_match_label ();
6168 if (m
== MATCH_ERROR
)
6171 m
= gfc_match (" select type ( ");
6175 gfc_current_ns
= gfc_build_block_ns (ns
);
6176 m
= gfc_match (" %n => %e", name
, &expr2
);
6179 expr1
= gfc_get_expr ();
6180 expr1
->expr_type
= EXPR_VARIABLE
;
6181 expr1
->where
= expr2
->where
;
6182 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
6188 sym
= expr1
->symtree
->n
.sym
;
6189 if (expr2
->ts
.type
== BT_UNKNOWN
)
6190 sym
->attr
.untyped
= 1;
6192 copy_ts_from_selector_to_associate (expr1
, expr2
);
6194 sym
->attr
.flavor
= FL_VARIABLE
;
6195 sym
->attr
.referenced
= 1;
6196 sym
->attr
.class_ok
= 1;
6200 m
= gfc_match (" %e ", &expr1
);
6203 std::swap (ns
, gfc_current_ns
);
6204 gfc_free_namespace (ns
);
6209 m
= gfc_match (" )%t");
6212 gfc_error ("parse error in SELECT TYPE statement at %C");
6216 /* This ghastly expression seems to be needed to distinguish a CLASS
6217 array, which can have a reference, from other expressions that
6218 have references, such as derived type components, and are not
6219 allowed by the standard.
6220 TODO: see if it is sufficient to exclude component and substring
6222 class_array
= (expr1
->expr_type
== EXPR_VARIABLE
6223 && expr1
->ts
.type
== BT_CLASS
6224 && CLASS_DATA (expr1
)
6225 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
6226 && (CLASS_DATA (expr1
)->attr
.dimension
6227 || CLASS_DATA (expr1
)->attr
.codimension
)
6229 && expr1
->ref
->type
== REF_ARRAY
6230 && expr1
->ref
->u
.ar
.type
== AR_FULL
6231 && expr1
->ref
->next
== NULL
);
6233 /* Check for F03:C811 (F08:C835). */
6234 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
6235 || (!class_array
&& expr1
->ref
!= NULL
)))
6237 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
6238 "use associate-name=>");
6243 new_st
.op
= EXEC_SELECT_TYPE
;
6244 new_st
.expr1
= expr1
;
6245 new_st
.expr2
= expr2
;
6246 new_st
.ext
.block
.ns
= gfc_current_ns
;
6248 select_type_push (expr1
->symtree
->n
.sym
);
6249 gfc_current_ns
= ns
;
6254 gfc_free_expr (expr1
);
6255 gfc_free_expr (expr2
);
6256 gfc_undo_symbols ();
6257 std::swap (ns
, gfc_current_ns
);
6258 gfc_free_namespace (ns
);
6263 /* Match a CASE statement. */
6266 gfc_match_case (void)
6268 gfc_case
*c
, *head
, *tail
;
6273 if (gfc_current_state () != COMP_SELECT
)
6275 gfc_error ("Unexpected CASE statement at %C");
6279 if (gfc_match ("% default") == MATCH_YES
)
6281 m
= match_case_eos ();
6284 if (m
== MATCH_ERROR
)
6287 new_st
.op
= EXEC_SELECT
;
6288 c
= gfc_get_case ();
6289 c
->where
= gfc_current_locus
;
6290 new_st
.ext
.block
.case_list
= c
;
6294 if (gfc_match_char ('(') != MATCH_YES
)
6299 if (match_case_selector (&c
) == MATCH_ERROR
)
6309 if (gfc_match_char (')') == MATCH_YES
)
6311 if (gfc_match_char (',') != MATCH_YES
)
6315 m
= match_case_eos ();
6318 if (m
== MATCH_ERROR
)
6321 new_st
.op
= EXEC_SELECT
;
6322 new_st
.ext
.block
.case_list
= head
;
6327 gfc_error ("Syntax error in CASE specification at %C");
6330 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
6335 /* Match a TYPE IS statement. */
6338 gfc_match_type_is (void)
6343 if (gfc_current_state () != COMP_SELECT_TYPE
)
6345 gfc_error ("Unexpected TYPE IS statement at %C");
6349 if (gfc_match_char ('(') != MATCH_YES
)
6352 c
= gfc_get_case ();
6353 c
->where
= gfc_current_locus
;
6355 m
= gfc_match_type_spec (&c
->ts
);
6358 if (m
== MATCH_ERROR
)
6361 if (gfc_match_char (')') != MATCH_YES
)
6364 m
= match_case_eos ();
6367 if (m
== MATCH_ERROR
)
6370 new_st
.op
= EXEC_SELECT_TYPE
;
6371 new_st
.ext
.block
.case_list
= c
;
6373 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
6374 && (c
->ts
.u
.derived
->attr
.sequence
6375 || c
->ts
.u
.derived
->attr
.is_bind_c
))
6377 gfc_error ("The type-spec shall not specify a sequence derived "
6378 "type or a type with the BIND attribute in SELECT "
6379 "TYPE at %C [F2003:C815]");
6383 if (c
->ts
.type
== BT_DERIVED
6384 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
6385 && gfc_spec_list_type (type_param_spec_list
, c
->ts
.u
.derived
)
6388 gfc_error ("All the LEN type parameters in the TYPE IS statement "
6389 "at %C must be ASSUMED");
6393 /* Create temporary variable. */
6394 select_type_set_tmp (&c
->ts
);
6399 gfc_error ("Syntax error in TYPE IS specification at %C");
6403 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6408 /* Match a CLASS IS or CLASS DEFAULT statement. */
6411 gfc_match_class_is (void)
6416 if (gfc_current_state () != COMP_SELECT_TYPE
)
6419 if (gfc_match ("% default") == MATCH_YES
)
6421 m
= match_case_eos ();
6424 if (m
== MATCH_ERROR
)
6427 new_st
.op
= EXEC_SELECT_TYPE
;
6428 c
= gfc_get_case ();
6429 c
->where
= gfc_current_locus
;
6430 c
->ts
.type
= BT_UNKNOWN
;
6431 new_st
.ext
.block
.case_list
= c
;
6432 select_type_set_tmp (NULL
);
6436 m
= gfc_match ("% is");
6439 if (m
== MATCH_ERROR
)
6442 if (gfc_match_char ('(') != MATCH_YES
)
6445 c
= gfc_get_case ();
6446 c
->where
= gfc_current_locus
;
6448 m
= match_derived_type_spec (&c
->ts
);
6451 if (m
== MATCH_ERROR
)
6454 if (c
->ts
.type
== BT_DERIVED
)
6455 c
->ts
.type
= BT_CLASS
;
6457 if (gfc_match_char (')') != MATCH_YES
)
6460 m
= match_case_eos ();
6463 if (m
== MATCH_ERROR
)
6466 new_st
.op
= EXEC_SELECT_TYPE
;
6467 new_st
.ext
.block
.case_list
= c
;
6469 /* Create temporary variable. */
6470 select_type_set_tmp (&c
->ts
);
6475 gfc_error ("Syntax error in CLASS IS specification at %C");
6479 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6484 /********************* WHERE subroutines ********************/
6486 /* Match the rest of a simple WHERE statement that follows an IF statement.
6490 match_simple_where (void)
6496 m
= gfc_match (" ( %e )", &expr
);
6500 m
= gfc_match_assignment ();
6503 if (m
== MATCH_ERROR
)
6506 if (gfc_match_eos () != MATCH_YES
)
6509 c
= gfc_get_code (EXEC_WHERE
);
6512 c
->next
= XCNEW (gfc_code
);
6514 c
->next
->loc
= gfc_current_locus
;
6515 gfc_clear_new_st ();
6517 new_st
.op
= EXEC_WHERE
;
6523 gfc_syntax_error (ST_WHERE
);
6526 gfc_free_expr (expr
);
6531 /* Match a WHERE statement. */
6534 gfc_match_where (gfc_statement
*st
)
6540 m0
= gfc_match_label ();
6541 if (m0
== MATCH_ERROR
)
6544 m
= gfc_match (" where ( %e )", &expr
);
6548 if (gfc_match_eos () == MATCH_YES
)
6550 *st
= ST_WHERE_BLOCK
;
6551 new_st
.op
= EXEC_WHERE
;
6552 new_st
.expr1
= expr
;
6556 m
= gfc_match_assignment ();
6558 gfc_syntax_error (ST_WHERE
);
6562 gfc_free_expr (expr
);
6566 /* We've got a simple WHERE statement. */
6568 c
= gfc_get_code (EXEC_WHERE
);
6571 /* Put in the assignment. It will not be processed by add_statement, so we
6572 need to copy the location here. */
6574 c
->next
= XCNEW (gfc_code
);
6576 c
->next
->loc
= gfc_current_locus
;
6577 gfc_clear_new_st ();
6579 new_st
.op
= EXEC_WHERE
;
6586 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
6587 new_st if successful. */
6590 gfc_match_elsewhere (void)
6592 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6596 if (gfc_current_state () != COMP_WHERE
)
6598 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
6604 if (gfc_match_char ('(') == MATCH_YES
)
6606 m
= gfc_match_expr (&expr
);
6609 if (m
== MATCH_ERROR
)
6612 if (gfc_match_char (')') != MATCH_YES
)
6616 if (gfc_match_eos () != MATCH_YES
)
6618 /* Only makes sense if we have a where-construct-name. */
6619 if (!gfc_current_block ())
6624 /* Better be a name at this point. */
6625 m
= gfc_match_name (name
);
6628 if (m
== MATCH_ERROR
)
6631 if (gfc_match_eos () != MATCH_YES
)
6634 if (strcmp (name
, gfc_current_block ()->name
) != 0)
6636 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
6637 name
, gfc_current_block ()->name
);
6642 new_st
.op
= EXEC_WHERE
;
6643 new_st
.expr1
= expr
;
6647 gfc_syntax_error (ST_ELSEWHERE
);
6650 gfc_free_expr (expr
);