1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000-2019 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
);
1354 if (lvalue
->expr_type
== EXPR_CONSTANT
)
1356 /* This clobbers %len and %kind. */
1358 gfc_error ("Assignment to a constant expression at %C");
1363 gfc_current_locus
= old_loc
;
1364 gfc_free_expr (lvalue
);
1365 gfc_free_expr (rvalue
);
1369 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1371 new_st
.op
= EXEC_ASSIGN
;
1372 new_st
.expr1
= lvalue
;
1373 new_st
.expr2
= rvalue
;
1375 gfc_check_do_variable (lvalue
->symtree
);
1377 if (lvalue
->ts
.type
== BT_CLASS
)
1378 gfc_find_vtab (&rvalue
->ts
);
1384 /* Match a pointer assignment statement. */
1387 gfc_match_pointer_assignment (void)
1389 gfc_expr
*lvalue
, *rvalue
;
1393 old_loc
= gfc_current_locus
;
1395 lvalue
= rvalue
= NULL
;
1396 gfc_matching_ptr_assignment
= 0;
1397 gfc_matching_procptr_assignment
= 0;
1399 m
= gfc_match (" %v =>", &lvalue
);
1406 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1407 || gfc_is_proc_ptr_comp (lvalue
))
1408 gfc_matching_procptr_assignment
= 1;
1410 gfc_matching_ptr_assignment
= 1;
1412 m
= gfc_match (" %e%t", &rvalue
);
1413 gfc_matching_ptr_assignment
= 0;
1414 gfc_matching_procptr_assignment
= 0;
1418 new_st
.op
= EXEC_POINTER_ASSIGN
;
1419 new_st
.expr1
= lvalue
;
1420 new_st
.expr2
= rvalue
;
1425 gfc_current_locus
= old_loc
;
1426 gfc_free_expr (lvalue
);
1427 gfc_free_expr (rvalue
);
1432 /* We try to match an easy arithmetic IF statement. This only happens
1433 when just after having encountered a simple IF statement. This code
1434 is really duplicate with parts of the gfc_match_if code, but this is
1438 match_arithmetic_if (void)
1440 gfc_st_label
*l1
, *l2
, *l3
;
1444 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1448 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1449 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1450 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1452 gfc_free_expr (expr
);
1456 if (!gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
1457 "Arithmetic IF statement at %C"))
1460 new_st
.op
= EXEC_ARITHMETIC_IF
;
1461 new_st
.expr1
= expr
;
1470 /* The IF statement is a bit of a pain. First of all, there are three
1471 forms of it, the simple IF, the IF that starts a block and the
1474 There is a problem with the simple IF and that is the fact that we
1475 only have a single level of undo information on symbols. What this
1476 means is for a simple IF, we must re-match the whole IF statement
1477 multiple times in order to guarantee that the symbol table ends up
1478 in the proper state. */
1480 static match
match_simple_forall (void);
1481 static match
match_simple_where (void);
1484 gfc_match_if (gfc_statement
*if_type
)
1487 gfc_st_label
*l1
, *l2
, *l3
;
1488 locus old_loc
, old_loc2
;
1492 n
= gfc_match_label ();
1493 if (n
== MATCH_ERROR
)
1496 old_loc
= gfc_current_locus
;
1498 m
= gfc_match (" if ( %e", &expr
);
1502 old_loc2
= gfc_current_locus
;
1503 gfc_current_locus
= old_loc
;
1505 if (gfc_match_parens () == MATCH_ERROR
)
1508 gfc_current_locus
= old_loc2
;
1510 if (gfc_match_char (')') != MATCH_YES
)
1512 gfc_error ("Syntax error in IF-expression at %C");
1513 gfc_free_expr (expr
);
1517 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1523 gfc_error ("Block label not appropriate for arithmetic IF "
1525 gfc_free_expr (expr
);
1529 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1530 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1531 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1533 gfc_free_expr (expr
);
1537 if (!gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
1538 "Arithmetic IF statement at %C"))
1541 new_st
.op
= EXEC_ARITHMETIC_IF
;
1542 new_st
.expr1
= expr
;
1547 *if_type
= ST_ARITHMETIC_IF
;
1551 if (gfc_match (" then%t") == MATCH_YES
)
1553 new_st
.op
= EXEC_IF
;
1554 new_st
.expr1
= expr
;
1555 *if_type
= ST_IF_BLOCK
;
1561 gfc_error ("Block label is not appropriate for IF statement at %C");
1562 gfc_free_expr (expr
);
1566 /* At this point the only thing left is a simple IF statement. At
1567 this point, n has to be MATCH_NO, so we don't have to worry about
1568 re-matching a block label. From what we've got so far, try
1569 matching an assignment. */
1571 *if_type
= ST_SIMPLE_IF
;
1573 m
= gfc_match_assignment ();
1577 gfc_free_expr (expr
);
1578 gfc_undo_symbols ();
1579 gfc_current_locus
= old_loc
;
1581 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1582 assignment was found. For MATCH_NO, continue to call the various
1584 if (m
== MATCH_ERROR
)
1587 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1589 m
= gfc_match_pointer_assignment ();
1593 gfc_free_expr (expr
);
1594 gfc_undo_symbols ();
1595 gfc_current_locus
= old_loc
;
1597 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1599 /* Look at the next keyword to see which matcher to call. Matching
1600 the keyword doesn't affect the symbol table, so we don't have to
1601 restore between tries. */
1603 #define match(string, subr, statement) \
1604 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1608 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1609 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1610 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1611 match ("call", gfc_match_call
, ST_CALL
)
1612 match ("change team", gfc_match_change_team
, ST_CHANGE_TEAM
)
1613 match ("close", gfc_match_close
, ST_CLOSE
)
1614 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1615 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1616 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1617 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1618 match ("end team", gfc_match_end_team
, ST_END_TEAM
)
1619 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
)
1620 match ("event post", gfc_match_event_post
, ST_EVENT_POST
)
1621 match ("event wait", gfc_match_event_wait
, ST_EVENT_WAIT
)
1622 match ("exit", gfc_match_exit
, ST_EXIT
)
1623 match ("fail image", gfc_match_fail_image
, ST_FAIL_IMAGE
)
1624 match ("flush", gfc_match_flush
, ST_FLUSH
)
1625 match ("forall", match_simple_forall
, ST_FORALL
)
1626 match ("form team", gfc_match_form_team
, ST_FORM_TEAM
)
1627 match ("go to", gfc_match_goto
, ST_GOTO
)
1628 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1629 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1630 match ("lock", gfc_match_lock
, ST_LOCK
)
1631 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1632 match ("open", gfc_match_open
, ST_OPEN
)
1633 match ("pause", gfc_match_pause
, ST_NONE
)
1634 match ("print", gfc_match_print
, ST_WRITE
)
1635 match ("read", gfc_match_read
, ST_READ
)
1636 match ("return", gfc_match_return
, ST_RETURN
)
1637 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1638 match ("stop", gfc_match_stop
, ST_STOP
)
1639 match ("wait", gfc_match_wait
, ST_WAIT
)
1640 match ("sync all", gfc_match_sync_all
, ST_SYNC_CALL
);
1641 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
1642 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
1643 match ("sync team", gfc_match_sync_team
, ST_SYNC_TEAM
)
1644 match ("unlock", gfc_match_unlock
, ST_UNLOCK
)
1645 match ("where", match_simple_where
, ST_WHERE
)
1646 match ("write", gfc_match_write
, ST_WRITE
)
1649 match ("type", gfc_match_print
, ST_WRITE
)
1651 /* The gfc_match_assignment() above may have returned a MATCH_NO
1652 where the assignment was to a named constant. Check that
1653 special case here. */
1654 m
= gfc_match_assignment ();
1657 gfc_error ("Cannot assign to a named constant at %C");
1658 gfc_free_expr (expr
);
1659 gfc_undo_symbols ();
1660 gfc_current_locus
= old_loc
;
1664 /* All else has failed, so give up. See if any of the matchers has
1665 stored an error message of some sort. */
1666 if (!gfc_error_check ())
1667 gfc_error ("Unclassifiable statement in IF-clause at %C");
1669 gfc_free_expr (expr
);
1674 gfc_error ("Syntax error in IF-clause at %C");
1677 gfc_free_expr (expr
);
1681 /* At this point, we've matched the single IF and the action clause
1682 is in new_st. Rearrange things so that the IF statement appears
1685 p
= gfc_get_code (EXEC_IF
);
1686 p
->next
= XCNEW (gfc_code
);
1688 p
->next
->loc
= gfc_current_locus
;
1692 gfc_clear_new_st ();
1694 new_st
.op
= EXEC_IF
;
1703 /* Match an ELSE statement. */
1706 gfc_match_else (void)
1708 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1710 if (gfc_match_eos () == MATCH_YES
)
1713 if (gfc_match_name (name
) != MATCH_YES
1714 || gfc_current_block () == NULL
1715 || gfc_match_eos () != MATCH_YES
)
1717 gfc_error ("Unexpected junk after ELSE statement at %C");
1721 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1723 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1724 name
, gfc_current_block ()->name
);
1732 /* Match an ELSE IF statement. */
1735 gfc_match_elseif (void)
1737 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1741 m
= gfc_match (" ( %e ) then", &expr
);
1745 if (gfc_match_eos () == MATCH_YES
)
1748 if (gfc_match_name (name
) != MATCH_YES
1749 || gfc_current_block () == NULL
1750 || gfc_match_eos () != MATCH_YES
)
1752 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1756 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1758 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1759 name
, gfc_current_block ()->name
);
1764 new_st
.op
= EXEC_IF
;
1765 new_st
.expr1
= expr
;
1769 gfc_free_expr (expr
);
1774 /* Free a gfc_iterator structure. */
1777 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1783 gfc_free_expr (iter
->var
);
1784 gfc_free_expr (iter
->start
);
1785 gfc_free_expr (iter
->end
);
1786 gfc_free_expr (iter
->step
);
1793 /* Match a CRITICAL statement. */
1795 gfc_match_critical (void)
1797 gfc_st_label
*label
= NULL
;
1799 if (gfc_match_label () == MATCH_ERROR
)
1802 if (gfc_match (" critical") != MATCH_YES
)
1805 if (gfc_match_st_label (&label
) == MATCH_ERROR
)
1808 if (gfc_match_eos () != MATCH_YES
)
1810 gfc_syntax_error (ST_CRITICAL
);
1814 if (gfc_pure (NULL
))
1816 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1820 if (gfc_find_state (COMP_DO_CONCURRENT
))
1822 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1827 gfc_unset_implicit_pure (NULL
);
1829 if (!gfc_notify_std (GFC_STD_F2008
, "CRITICAL statement at %C"))
1832 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1834 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1839 if (gfc_find_state (COMP_CRITICAL
))
1841 gfc_error ("Nested CRITICAL block at %C");
1845 new_st
.op
= EXEC_CRITICAL
;
1848 && !gfc_reference_st_label (label
, ST_LABEL_TARGET
))
1855 /* Match a BLOCK statement. */
1858 gfc_match_block (void)
1862 if (gfc_match_label () == MATCH_ERROR
)
1865 if (gfc_match (" block") != MATCH_YES
)
1868 /* For this to be a correct BLOCK statement, the line must end now. */
1869 m
= gfc_match_eos ();
1870 if (m
== MATCH_ERROR
)
1879 /* Match an ASSOCIATE statement. */
1882 gfc_match_associate (void)
1884 if (gfc_match_label () == MATCH_ERROR
)
1887 if (gfc_match (" associate") != MATCH_YES
)
1890 /* Match the association list. */
1891 if (gfc_match_char ('(') != MATCH_YES
)
1893 gfc_error ("Expected association list at %C");
1896 new_st
.ext
.block
.assoc
= NULL
;
1899 gfc_association_list
* newAssoc
= gfc_get_association_list ();
1900 gfc_association_list
* a
;
1902 /* Match the next association. */
1903 if (gfc_match (" %n =>", newAssoc
->name
) != MATCH_YES
)
1905 gfc_error ("Expected association at %C");
1906 goto assocListError
;
1909 if (gfc_match (" %e", &newAssoc
->target
) != MATCH_YES
)
1911 /* Have another go, allowing for procedure pointer selectors. */
1912 gfc_matching_procptr_assignment
= 1;
1913 if (gfc_match (" %e", &newAssoc
->target
) != MATCH_YES
)
1915 gfc_error ("Invalid association target at %C");
1916 goto assocListError
;
1918 gfc_matching_procptr_assignment
= 0;
1920 newAssoc
->where
= gfc_current_locus
;
1922 /* Check that the current name is not yet in the list. */
1923 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
1924 if (!strcmp (a
->name
, newAssoc
->name
))
1926 gfc_error ("Duplicate name %qs in association at %C",
1928 goto assocListError
;
1931 /* The target expression must not be coindexed. */
1932 if (gfc_is_coindexed (newAssoc
->target
))
1934 gfc_error ("Association target at %C must not be coindexed");
1935 goto assocListError
;
1938 /* The `variable' field is left blank for now; because the target is not
1939 yet resolved, we can't use gfc_has_vector_subscript to determine it
1940 for now. This is set during resolution. */
1942 /* Put it into the list. */
1943 newAssoc
->next
= new_st
.ext
.block
.assoc
;
1944 new_st
.ext
.block
.assoc
= newAssoc
;
1946 /* Try next one or end if closing parenthesis is found. */
1947 gfc_gobble_whitespace ();
1948 if (gfc_peek_char () == ')')
1950 if (gfc_match_char (',') != MATCH_YES
)
1952 gfc_error ("Expected %<)%> or %<,%> at %C");
1962 if (gfc_match_char (')') != MATCH_YES
)
1964 /* This should never happen as we peek above. */
1968 if (gfc_match_eos () != MATCH_YES
)
1970 gfc_error ("Junk after ASSOCIATE statement at %C");
1977 gfc_free_association_list (new_st
.ext
.block
.assoc
);
1982 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1983 an accessible derived type. */
1986 match_derived_type_spec (gfc_typespec
*ts
)
1988 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1990 gfc_symbol
*derived
, *der_type
;
1991 match m
= MATCH_YES
;
1992 gfc_actual_arglist
*decl_type_param_list
= NULL
;
1993 bool is_pdt_template
= false;
1995 old_locus
= gfc_current_locus
;
1997 if (gfc_match ("%n", name
) != MATCH_YES
)
1999 gfc_current_locus
= old_locus
;
2003 gfc_find_symbol (name
, NULL
, 1, &derived
);
2005 /* Match the PDT spec list, if there. */
2006 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
)
2008 gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &der_type
);
2009 is_pdt_template
= der_type
2010 && der_type
->attr
.flavor
== FL_DERIVED
2011 && der_type
->attr
.pdt_template
;
2014 if (is_pdt_template
)
2015 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
2017 if (m
== MATCH_ERROR
)
2019 gfc_free_actual_arglist (decl_type_param_list
);
2023 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
&& derived
->attr
.generic
)
2024 derived
= gfc_find_dt_in_generic (derived
);
2026 /* If this is a PDT, find the specific instance. */
2027 if (m
== MATCH_YES
&& is_pdt_template
)
2029 gfc_namespace
*old_ns
;
2031 old_ns
= gfc_current_ns
;
2032 while (gfc_current_ns
&& gfc_current_ns
->parent
)
2033 gfc_current_ns
= gfc_current_ns
->parent
;
2035 if (type_param_spec_list
)
2036 gfc_free_actual_arglist (type_param_spec_list
);
2037 m
= gfc_get_pdt_instance (decl_type_param_list
, &der_type
,
2038 &type_param_spec_list
);
2039 gfc_free_actual_arglist (decl_type_param_list
);
2044 gcc_assert (!derived
->attr
.pdt_template
&& derived
->attr
.pdt_type
);
2045 gfc_set_sym_referenced (derived
);
2047 gfc_current_ns
= old_ns
;
2050 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
2052 ts
->type
= BT_DERIVED
;
2053 ts
->u
.derived
= derived
;
2057 gfc_current_locus
= old_locus
;
2062 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2063 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2064 It only includes the intrinsic types from the Fortran 2003 standard
2065 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2066 the implicit_flag is not needed, so it was removed. Derived types are
2067 identified by their name alone. */
2070 gfc_match_type_spec (gfc_typespec
*ts
)
2074 char c
, name
[GFC_MAX_SYMBOL_LEN
+ 1];
2077 gfc_gobble_whitespace ();
2078 old_locus
= gfc_current_locus
;
2080 /* If c isn't [a-z], then return immediately. */
2081 c
= gfc_peek_ascii_char ();
2085 type_param_spec_list
= NULL
;
2087 if (match_derived_type_spec (ts
) == MATCH_YES
)
2089 /* Enforce F03:C401. */
2090 if (ts
->u
.derived
->attr
.abstract
)
2092 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
2093 ts
->u
.derived
->name
, &old_locus
);
2099 if (gfc_match ("integer") == MATCH_YES
)
2101 ts
->type
= BT_INTEGER
;
2102 ts
->kind
= gfc_default_integer_kind
;
2106 if (gfc_match ("double precision") == MATCH_YES
)
2109 ts
->kind
= gfc_default_double_kind
;
2113 if (gfc_match ("complex") == MATCH_YES
)
2115 ts
->type
= BT_COMPLEX
;
2116 ts
->kind
= gfc_default_complex_kind
;
2120 if (gfc_match ("character") == MATCH_YES
)
2122 ts
->type
= BT_CHARACTER
;
2124 m
= gfc_match_char_spec (ts
);
2132 /* REAL is a real pain because it can be a type, intrinsic subprogram,
2133 or list item in a type-list of an OpenMP reduction clause. Need to
2134 differentiate REAL([KIND]=scalar-int-initialization-expr) from
2135 REAL(A,[KIND]) and REAL(KIND,A). Logically, when this code was
2136 written the use of LOGICAL as a type-spec or intrinsic subprogram
2139 m
= gfc_match (" %n", name
);
2141 && (strcmp (name
, "real") == 0 || strcmp (name
, "logical") == 0))
2150 ts
->kind
= gfc_default_real_kind
;
2154 ts
->type
= BT_LOGICAL
;
2155 ts
->kind
= gfc_default_logical_kind
;
2158 gfc_gobble_whitespace ();
2160 /* Prevent REAL*4, etc. */
2161 c
= gfc_peek_ascii_char ();
2164 gfc_error ("Invalid type-spec at %C");
2168 /* Found leading colon in REAL::, a trailing ')' in for example
2169 TYPE IS (REAL), or REAL, for an OpenMP list-item. */
2170 if (c
== ':' || c
== ')' || (flag_openmp
&& c
== ','))
2173 /* Found something other than the opening '(' in REAL(... */
2177 gfc_next_char (); /* Burn the '('. */
2179 /* Look for the optional KIND=. */
2180 where
= gfc_current_locus
;
2181 m
= gfc_match ("%n", name
);
2184 gfc_gobble_whitespace ();
2185 c
= gfc_next_char ();
2188 if (strcmp(name
, "a") == 0 || strcmp(name
, "l") == 0)
2190 else if (strcmp(name
, "kind") == 0)
2196 gfc_current_locus
= where
;
2199 gfc_current_locus
= where
;
2203 m
= gfc_match_init_expr (&e
);
2204 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
2207 /* If a comma appears, it is an intrinsic subprogram. */
2208 gfc_gobble_whitespace ();
2209 c
= gfc_peek_ascii_char ();
2216 /* If ')' appears, we have REAL(initialization-expr), here check for
2217 a scalar integer initialization-expr and valid kind parameter. */
2220 if (e
->ts
.type
!= BT_INTEGER
|| e
->rank
> 0)
2226 if (e
->expr_type
!= EXPR_CONSTANT
)
2229 gfc_next_char (); /* Burn the ')'. */
2230 ts
->kind
= (int) mpz_get_si (e
->value
.integer
);
2231 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
2233 gfc_error ("Invalid type-spec at %C");
2245 /* If a type is not matched, simply return MATCH_NO. */
2246 gfc_current_locus
= old_locus
;
2251 gfc_gobble_whitespace ();
2253 /* This prevents INTEGER*4, etc. */
2254 if (gfc_peek_ascii_char () == '*')
2256 gfc_error ("Invalid type-spec at %C");
2260 m
= gfc_match_kind_spec (ts
, false);
2262 /* No kind specifier found. */
2270 /******************** FORALL subroutines ********************/
2272 /* Free a list of FORALL iterators. */
2275 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
2277 gfc_forall_iterator
*next
;
2282 gfc_free_expr (iter
->var
);
2283 gfc_free_expr (iter
->start
);
2284 gfc_free_expr (iter
->end
);
2285 gfc_free_expr (iter
->stride
);
2292 /* Match an iterator as part of a FORALL statement. The format is:
2294 <var> = <start>:<end>[:<stride>]
2296 On MATCH_NO, the caller tests for the possibility that there is a
2297 scalar mask expression. */
2300 match_forall_iterator (gfc_forall_iterator
**result
)
2302 gfc_forall_iterator
*iter
;
2306 where
= gfc_current_locus
;
2307 iter
= XCNEW (gfc_forall_iterator
);
2309 m
= gfc_match_expr (&iter
->var
);
2313 if (gfc_match_char ('=') != MATCH_YES
2314 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
2320 m
= gfc_match_expr (&iter
->start
);
2324 if (gfc_match_char (':') != MATCH_YES
)
2327 m
= gfc_match_expr (&iter
->end
);
2330 if (m
== MATCH_ERROR
)
2333 if (gfc_match_char (':') == MATCH_NO
)
2334 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2337 m
= gfc_match_expr (&iter
->stride
);
2340 if (m
== MATCH_ERROR
)
2344 /* Mark the iteration variable's symbol as used as a FORALL index. */
2345 iter
->var
->symtree
->n
.sym
->forall_index
= true;
2351 gfc_error ("Syntax error in FORALL iterator at %C");
2356 gfc_current_locus
= where
;
2357 gfc_free_forall_iterator (iter
);
2362 /* Match the header of a FORALL statement. */
2365 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
2367 gfc_forall_iterator
*head
, *tail
, *new_iter
;
2371 gfc_gobble_whitespace ();
2376 if (gfc_match_char ('(') != MATCH_YES
)
2379 m
= match_forall_iterator (&new_iter
);
2380 if (m
== MATCH_ERROR
)
2385 head
= tail
= new_iter
;
2389 if (gfc_match_char (',') != MATCH_YES
)
2392 m
= match_forall_iterator (&new_iter
);
2393 if (m
== MATCH_ERROR
)
2398 tail
->next
= new_iter
;
2403 /* Have to have a mask expression. */
2405 m
= gfc_match_expr (&msk
);
2408 if (m
== MATCH_ERROR
)
2414 if (gfc_match_char (')') == MATCH_NO
)
2422 gfc_syntax_error (ST_FORALL
);
2425 gfc_free_expr (msk
);
2426 gfc_free_forall_iterator (head
);
2431 /* Match the rest of a simple FORALL statement that follows an
2435 match_simple_forall (void)
2437 gfc_forall_iterator
*head
;
2446 m
= match_forall_header (&head
, &mask
);
2453 m
= gfc_match_assignment ();
2455 if (m
== MATCH_ERROR
)
2459 m
= gfc_match_pointer_assignment ();
2460 if (m
== MATCH_ERROR
)
2466 c
= XCNEW (gfc_code
);
2468 c
->loc
= gfc_current_locus
;
2470 if (gfc_match_eos () != MATCH_YES
)
2473 gfc_clear_new_st ();
2474 new_st
.op
= EXEC_FORALL
;
2475 new_st
.expr1
= mask
;
2476 new_st
.ext
.forall_iterator
= head
;
2477 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2478 new_st
.block
->next
= c
;
2483 gfc_syntax_error (ST_FORALL
);
2486 gfc_free_forall_iterator (head
);
2487 gfc_free_expr (mask
);
2493 /* Match a FORALL statement. */
2496 gfc_match_forall (gfc_statement
*st
)
2498 gfc_forall_iterator
*head
;
2507 m0
= gfc_match_label ();
2508 if (m0
== MATCH_ERROR
)
2511 m
= gfc_match (" forall");
2515 m
= match_forall_header (&head
, &mask
);
2516 if (m
== MATCH_ERROR
)
2521 if (gfc_match_eos () == MATCH_YES
)
2523 *st
= ST_FORALL_BLOCK
;
2524 new_st
.op
= EXEC_FORALL
;
2525 new_st
.expr1
= mask
;
2526 new_st
.ext
.forall_iterator
= head
;
2530 m
= gfc_match_assignment ();
2531 if (m
== MATCH_ERROR
)
2535 m
= gfc_match_pointer_assignment ();
2536 if (m
== MATCH_ERROR
)
2542 c
= XCNEW (gfc_code
);
2544 c
->loc
= gfc_current_locus
;
2546 gfc_clear_new_st ();
2547 new_st
.op
= EXEC_FORALL
;
2548 new_st
.expr1
= mask
;
2549 new_st
.ext
.forall_iterator
= head
;
2550 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2551 new_st
.block
->next
= c
;
2557 gfc_syntax_error (ST_FORALL
);
2560 gfc_free_forall_iterator (head
);
2561 gfc_free_expr (mask
);
2562 gfc_free_statements (c
);
2567 /* Match a DO statement. */
2572 gfc_iterator iter
, *ip
;
2574 gfc_st_label
*label
;
2577 old_loc
= gfc_current_locus
;
2579 memset (&iter
, '\0', sizeof (gfc_iterator
));
2582 m
= gfc_match_label ();
2583 if (m
== MATCH_ERROR
)
2586 if (gfc_match (" do") != MATCH_YES
)
2589 m
= gfc_match_st_label (&label
);
2590 if (m
== MATCH_ERROR
)
2593 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2595 if (gfc_match_eos () == MATCH_YES
)
2597 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
2598 new_st
.op
= EXEC_DO_WHILE
;
2602 /* Match an optional comma, if no comma is found, a space is obligatory. */
2603 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
2606 /* Check for balanced parens. */
2608 if (gfc_match_parens () == MATCH_ERROR
)
2611 if (gfc_match (" concurrent") == MATCH_YES
)
2613 gfc_forall_iterator
*head
;
2616 if (!gfc_notify_std (GFC_STD_F2008
, "DO CONCURRENT construct at %C"))
2622 m
= match_forall_header (&head
, &mask
);
2626 if (m
== MATCH_ERROR
)
2627 goto concurr_cleanup
;
2629 if (gfc_match_eos () != MATCH_YES
)
2630 goto concurr_cleanup
;
2633 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2634 goto concurr_cleanup
;
2636 new_st
.label1
= label
;
2637 new_st
.op
= EXEC_DO_CONCURRENT
;
2638 new_st
.expr1
= mask
;
2639 new_st
.ext
.forall_iterator
= head
;
2644 gfc_syntax_error (ST_DO
);
2645 gfc_free_expr (mask
);
2646 gfc_free_forall_iterator (head
);
2650 /* See if we have a DO WHILE. */
2651 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
2653 new_st
.op
= EXEC_DO_WHILE
;
2657 /* The abortive DO WHILE may have done something to the symbol
2658 table, so we start over. */
2659 gfc_undo_symbols ();
2660 gfc_current_locus
= old_loc
;
2662 gfc_match_label (); /* This won't error. */
2663 gfc_match (" do "); /* This will work. */
2665 gfc_match_st_label (&label
); /* Can't error out. */
2666 gfc_match_char (','); /* Optional comma. */
2668 m
= gfc_match_iterator (&iter
, 0);
2671 if (m
== MATCH_ERROR
)
2674 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
2675 gfc_check_do_variable (iter
.var
->symtree
);
2677 if (gfc_match_eos () != MATCH_YES
)
2679 gfc_syntax_error (ST_DO
);
2683 new_st
.op
= EXEC_DO
;
2687 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2690 new_st
.label1
= label
;
2692 if (new_st
.op
== EXEC_DO_WHILE
)
2693 new_st
.expr1
= iter
.end
;
2696 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
2703 gfc_free_iterator (&iter
, 0);
2709 /* Match an EXIT or CYCLE statement. */
2712 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2714 gfc_state_data
*p
, *o
;
2719 if (gfc_match_eos () == MATCH_YES
)
2723 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2726 m
= gfc_match ("% %n%t", name
);
2727 if (m
== MATCH_ERROR
)
2731 gfc_syntax_error (st
);
2735 /* Find the corresponding symbol. If there's a BLOCK statement
2736 between here and the label, it is not in gfc_current_ns but a parent
2738 stree
= gfc_find_symtree_in_proc (name
, gfc_current_ns
);
2741 gfc_error ("Name %qs in %s statement at %C is unknown",
2742 name
, gfc_ascii_statement (st
));
2747 if (sym
->attr
.flavor
!= FL_LABEL
)
2749 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2750 name
, gfc_ascii_statement (st
));
2755 /* Find the loop specified by the label (or lack of a label). */
2756 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2757 if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2759 else if (p
->state
== COMP_CRITICAL
)
2761 gfc_error("%s statement at %C leaves CRITICAL construct",
2762 gfc_ascii_statement (st
));
2765 else if (p
->state
== COMP_DO_CONCURRENT
2766 && (op
== EXEC_EXIT
|| (sym
&& sym
!= p
->sym
)))
2768 /* F2008, C821 & C845. */
2769 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2770 gfc_ascii_statement (st
));
2773 else if ((sym
&& sym
== p
->sym
)
2774 || (!sym
&& (p
->state
== COMP_DO
2775 || p
->state
== COMP_DO_CONCURRENT
)))
2781 gfc_error ("%s statement at %C is not within a construct",
2782 gfc_ascii_statement (st
));
2784 gfc_error ("%s statement at %C is not within construct %qs",
2785 gfc_ascii_statement (st
), sym
->name
);
2790 /* Special checks for EXIT from non-loop constructs. */
2794 case COMP_DO_CONCURRENT
:
2798 /* This is already handled above. */
2801 case COMP_ASSOCIATE
:
2805 case COMP_SELECT_TYPE
:
2807 if (op
== EXEC_CYCLE
)
2809 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2810 " construct %qs", sym
->name
);
2813 gcc_assert (op
== EXEC_EXIT
);
2814 if (!gfc_notify_std (GFC_STD_F2008
, "EXIT statement with no"
2815 " do-construct-name at %C"))
2820 gfc_error ("%s statement at %C is not applicable to construct %qs",
2821 gfc_ascii_statement (st
), sym
->name
);
2827 gfc_error (is_oacc (p
)
2828 ? G_("%s statement at %C leaving OpenACC structured block")
2829 : G_("%s statement at %C leaving OpenMP structured block"),
2830 gfc_ascii_statement (st
));
2834 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2838 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
2839 && (o
->head
->op
== EXEC_OACC_LOOP
2840 || o
->head
->op
== EXEC_OACC_PARALLEL_LOOP
))
2843 gcc_assert (o
->head
->next
!= NULL
2844 && (o
->head
->next
->op
== EXEC_DO
2845 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2846 && o
->previous
!= NULL
2847 && o
->previous
->tail
->op
== o
->head
->op
);
2848 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2849 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2850 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2851 if (st
== ST_EXIT
&& cnt
<= collapse
)
2853 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2856 if (st
== ST_CYCLE
&& cnt
< collapse
)
2858 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2859 " !$ACC LOOP loop");
2865 && (o
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2866 && (o
->head
->op
== EXEC_OMP_DO
2867 || o
->head
->op
== EXEC_OMP_PARALLEL_DO
2868 || o
->head
->op
== EXEC_OMP_SIMD
2869 || o
->head
->op
== EXEC_OMP_DO_SIMD
2870 || o
->head
->op
== EXEC_OMP_PARALLEL_DO_SIMD
))
2873 gcc_assert (o
->head
->next
!= NULL
2874 && (o
->head
->next
->op
== EXEC_DO
2875 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2876 && o
->previous
!= NULL
2877 && o
->previous
->tail
->op
== o
->head
->op
);
2878 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
)
2880 if (o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2881 count
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2882 if (o
->previous
->tail
->ext
.omp_clauses
->orderedc
)
2883 count
= o
->previous
->tail
->ext
.omp_clauses
->orderedc
;
2885 if (st
== ST_EXIT
&& cnt
<= count
)
2887 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2890 if (st
== ST_CYCLE
&& cnt
< count
)
2892 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2898 /* Save the first statement in the construct - needed by the backend. */
2899 new_st
.ext
.which_construct
= p
->construct
;
2907 /* Match the EXIT statement. */
2910 gfc_match_exit (void)
2912 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2916 /* Match the CYCLE statement. */
2919 gfc_match_cycle (void)
2921 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2925 /* Match a stop-code after an (ERROR) STOP or PAUSE statement. The
2926 requirements for a stop-code differ in the standards.
2930 R840 stop-stmt is STOP [ stop-code ]
2931 R841 stop-code is scalar-char-constant
2932 or digit [ digit [ digit [ digit [ digit ] ] ] ]
2934 Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
2937 R855 stop-stmt is STOP [ stop-code ]
2938 R856 allstop-stmt is ALL STOP [ stop-code ]
2939 R857 stop-code is scalar-default-char-constant-expr
2940 or scalar-int-constant-expr
2942 For free-form source code, all standards contain a statement of the form:
2944 A blank shall be used to separate names, constants, or labels from
2945 adjacent keywords, names, constants, or labels.
2947 A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003,
2951 is valid, but it is invalid Fortran 2008. */
2954 gfc_match_stopcode (gfc_statement st
)
2960 /* Set f95 for -std=f95. */
2961 f95
= (gfc_option
.allow_std
== GFC_STD_OPT_F95
);
2963 /* Set f03 for -std=f2003. */
2964 f03
= (gfc_option
.allow_std
== GFC_STD_OPT_F03
);
2966 /* Look for a blank between STOP and the stop-code for F2008 or later. */
2967 if (gfc_current_form
!= FORM_FIXED
&& !(f95
|| f03
))
2969 char c
= gfc_peek_ascii_char ();
2971 /* Look for end-of-statement. There is no stop-code. */
2972 if (c
== '\n' || c
== '!' || c
== ';')
2977 gfc_error ("Blank required in %s statement near %C",
2978 gfc_ascii_statement (st
));
2983 if (gfc_match_eos () != MATCH_YES
)
2988 /* First look for the F95 or F2003 digit [...] construct. */
2989 old_locus
= gfc_current_locus
;
2990 m
= gfc_match_small_int (&stopcode
);
2991 if (m
== MATCH_YES
&& (f95
|| f03
))
2995 gfc_error ("STOP code at %C cannot be negative");
2999 if (stopcode
> 99999)
3001 gfc_error ("STOP code at %C contains too many digits");
3006 /* Reset the locus and now load gfc_expr. */
3007 gfc_current_locus
= old_locus
;
3008 m
= gfc_match_expr (&e
);
3009 if (m
== MATCH_ERROR
)
3014 if (gfc_match_eos () != MATCH_YES
)
3018 if (gfc_pure (NULL
))
3020 if (st
== ST_ERROR_STOP
)
3022 if (!gfc_notify_std (GFC_STD_F2018
, "%s statement at %C in PURE "
3023 "procedure", gfc_ascii_statement (st
)))
3028 gfc_error ("%s statement not allowed in PURE procedure at %C",
3029 gfc_ascii_statement (st
));
3034 gfc_unset_implicit_pure (NULL
);
3036 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
))
3038 gfc_error ("Image control statement STOP at %C in CRITICAL block");
3041 if (st
== ST_STOP
&& gfc_find_state (COMP_DO_CONCURRENT
))
3043 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
3049 gfc_simplify_expr (e
, 0);
3051 /* Test for F95 and F2003 style STOP stop-code. */
3052 if (e
->expr_type
!= EXPR_CONSTANT
&& (f95
|| f03
))
3054 gfc_error ("STOP code at %L must be a scalar CHARACTER constant or "
3055 "digit[digit[digit[digit[digit]]]]", &e
->where
);
3059 /* Use the machinery for an initialization expression to reduce the
3060 stop-code to a constant. */
3061 gfc_init_expr_flag
= true;
3062 gfc_reduce_init_expr (e
);
3063 gfc_init_expr_flag
= false;
3065 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
3067 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
3074 gfc_error ("STOP code at %L must be scalar", &e
->where
);
3078 if (e
->ts
.type
== BT_CHARACTER
3079 && e
->ts
.kind
!= gfc_default_character_kind
)
3081 gfc_error ("STOP code at %L must be default character KIND=%d",
3082 &e
->where
, (int) gfc_default_character_kind
);
3086 if (e
->ts
.type
== BT_INTEGER
&& e
->ts
.kind
!= gfc_default_integer_kind
)
3088 gfc_error ("STOP code at %L must be default integer KIND=%d",
3089 &e
->where
, (int) gfc_default_integer_kind
);
3099 new_st
.op
= EXEC_STOP
;
3102 new_st
.op
= EXEC_ERROR_STOP
;
3105 new_st
.op
= EXEC_PAUSE
;
3112 new_st
.ext
.stop_code
= -1;
3117 gfc_syntax_error (st
);
3126 /* Match the (deprecated) PAUSE statement. */
3129 gfc_match_pause (void)
3133 m
= gfc_match_stopcode (ST_PAUSE
);
3136 if (!gfc_notify_std (GFC_STD_F95_DEL
, "PAUSE statement at %C"))
3143 /* Match the STOP statement. */
3146 gfc_match_stop (void)
3148 return gfc_match_stopcode (ST_STOP
);
3152 /* Match the ERROR STOP statement. */
3155 gfc_match_error_stop (void)
3157 if (!gfc_notify_std (GFC_STD_F2008
, "ERROR STOP statement at %C"))
3160 return gfc_match_stopcode (ST_ERROR_STOP
);
3163 /* Match EVENT POST/WAIT statement. Syntax:
3164 EVENT POST ( event-variable [, sync-stat-list] )
3165 EVENT WAIT ( event-variable [, wait-spec-list] )
3167 wait-spec-list is sync-stat-list or until-spec
3168 until-spec is UNTIL_COUNT = scalar-int-expr
3169 sync-stat is STAT= or ERRMSG=. */
3172 event_statement (gfc_statement st
)
3175 gfc_expr
*tmp
, *eventvar
, *until_count
, *stat
, *errmsg
;
3176 bool saw_until_count
, saw_stat
, saw_errmsg
;
3178 tmp
= eventvar
= until_count
= stat
= errmsg
= NULL
;
3179 saw_until_count
= saw_stat
= saw_errmsg
= false;
3181 if (gfc_pure (NULL
))
3183 gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
3184 st
== ST_EVENT_POST
? "POST" : "WAIT");
3188 gfc_unset_implicit_pure (NULL
);
3190 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3192 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3196 if (gfc_find_state (COMP_CRITICAL
))
3198 gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
3199 st
== ST_EVENT_POST
? "POST" : "WAIT");
3203 if (gfc_find_state (COMP_DO_CONCURRENT
))
3205 gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
3206 "block", st
== ST_EVENT_POST
? "POST" : "WAIT");
3210 if (gfc_match_char ('(') != MATCH_YES
)
3213 if (gfc_match ("%e", &eventvar
) != MATCH_YES
)
3215 m
= gfc_match_char (',');
3216 if (m
== MATCH_ERROR
)
3220 m
= gfc_match_char (')');
3228 m
= gfc_match (" stat = %v", &tmp
);
3229 if (m
== MATCH_ERROR
)
3235 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3241 m
= gfc_match_char (',');
3249 m
= gfc_match (" errmsg = %v", &tmp
);
3250 if (m
== MATCH_ERROR
)
3256 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3262 m
= gfc_match_char (',');
3270 m
= gfc_match (" until_count = %e", &tmp
);
3271 if (m
== MATCH_ERROR
|| st
== ST_EVENT_POST
)
3275 if (saw_until_count
)
3277 gfc_error ("Redundant UNTIL_COUNT tag found at %L",
3282 saw_until_count
= true;
3284 m
= gfc_match_char (',');
3295 if (m
== MATCH_ERROR
)
3298 if (gfc_match (" )%t") != MATCH_YES
)
3305 new_st
.op
= EXEC_EVENT_POST
;
3308 new_st
.op
= EXEC_EVENT_WAIT
;
3314 new_st
.expr1
= eventvar
;
3315 new_st
.expr2
= stat
;
3316 new_st
.expr3
= errmsg
;
3317 new_st
.expr4
= until_count
;
3322 gfc_syntax_error (st
);
3325 if (until_count
!= tmp
)
3326 gfc_free_expr (until_count
);
3328 gfc_free_expr (errmsg
);
3330 gfc_free_expr (stat
);
3332 gfc_free_expr (tmp
);
3333 gfc_free_expr (eventvar
);
3341 gfc_match_event_post (void)
3343 if (!gfc_notify_std (GFC_STD_F2018
, "EVENT POST statement at %C"))
3346 return event_statement (ST_EVENT_POST
);
3351 gfc_match_event_wait (void)
3353 if (!gfc_notify_std (GFC_STD_F2018
, "EVENT WAIT statement at %C"))
3356 return event_statement (ST_EVENT_WAIT
);
3360 /* Match a FAIL IMAGE statement. */
3363 gfc_match_fail_image (void)
3365 if (!gfc_notify_std (GFC_STD_F2018
, "FAIL IMAGE statement at %C"))
3368 if (gfc_match_char ('(') == MATCH_YES
)
3371 new_st
.op
= EXEC_FAIL_IMAGE
;
3376 gfc_syntax_error (ST_FAIL_IMAGE
);
3381 /* Match a FORM TEAM statement. */
3384 gfc_match_form_team (void)
3387 gfc_expr
*teamid
,*team
;
3389 if (!gfc_notify_std (GFC_STD_F2018
, "FORM TEAM statement at %C"))
3392 if (gfc_match_char ('(') == MATCH_NO
)
3395 new_st
.op
= EXEC_FORM_TEAM
;
3397 if (gfc_match ("%e", &teamid
) != MATCH_YES
)
3399 m
= gfc_match_char (',');
3400 if (m
== MATCH_ERROR
)
3402 if (gfc_match ("%e", &team
) != MATCH_YES
)
3405 m
= gfc_match_char (')');
3409 new_st
.expr1
= teamid
;
3410 new_st
.expr2
= team
;
3415 gfc_syntax_error (ST_FORM_TEAM
);
3420 /* Match a CHANGE TEAM statement. */
3423 gfc_match_change_team (void)
3428 if (!gfc_notify_std (GFC_STD_F2018
, "CHANGE TEAM statement at %C"))
3431 if (gfc_match_char ('(') == MATCH_NO
)
3434 new_st
.op
= EXEC_CHANGE_TEAM
;
3436 if (gfc_match ("%e", &team
) != MATCH_YES
)
3439 m
= gfc_match_char (')');
3443 new_st
.expr1
= team
;
3448 gfc_syntax_error (ST_CHANGE_TEAM
);
3453 /* Match a END TEAM statement. */
3456 gfc_match_end_team (void)
3458 if (!gfc_notify_std (GFC_STD_F2018
, "END TEAM statement at %C"))
3461 if (gfc_match_char ('(') == MATCH_YES
)
3464 new_st
.op
= EXEC_END_TEAM
;
3469 gfc_syntax_error (ST_END_TEAM
);
3474 /* Match a SYNC TEAM statement. */
3477 gfc_match_sync_team (void)
3482 if (!gfc_notify_std (GFC_STD_F2018
, "SYNC TEAM statement at %C"))
3485 if (gfc_match_char ('(') == MATCH_NO
)
3488 new_st
.op
= EXEC_SYNC_TEAM
;
3490 if (gfc_match ("%e", &team
) != MATCH_YES
)
3493 m
= gfc_match_char (')');
3497 new_st
.expr1
= team
;
3502 gfc_syntax_error (ST_SYNC_TEAM
);
3507 /* Match LOCK/UNLOCK statement. Syntax:
3508 LOCK ( lock-variable [ , lock-stat-list ] )
3509 UNLOCK ( lock-variable [ , sync-stat-list ] )
3510 where lock-stat is ACQUIRED_LOCK or sync-stat
3511 and sync-stat is STAT= or ERRMSG=. */
3514 lock_unlock_statement (gfc_statement st
)
3517 gfc_expr
*tmp
, *lockvar
, *acq_lock
, *stat
, *errmsg
;
3518 bool saw_acq_lock
, saw_stat
, saw_errmsg
;
3520 tmp
= lockvar
= acq_lock
= stat
= errmsg
= NULL
;
3521 saw_acq_lock
= saw_stat
= saw_errmsg
= false;
3523 if (gfc_pure (NULL
))
3525 gfc_error ("Image control statement %s at %C in PURE procedure",
3526 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3530 gfc_unset_implicit_pure (NULL
);
3532 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3534 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3538 if (gfc_find_state (COMP_CRITICAL
))
3540 gfc_error ("Image control statement %s at %C in CRITICAL block",
3541 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3545 if (gfc_find_state (COMP_DO_CONCURRENT
))
3547 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
3548 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3552 if (gfc_match_char ('(') != MATCH_YES
)
3555 if (gfc_match ("%e", &lockvar
) != MATCH_YES
)
3557 m
= gfc_match_char (',');
3558 if (m
== MATCH_ERROR
)
3562 m
= gfc_match_char (')');
3570 m
= gfc_match (" stat = %v", &tmp
);
3571 if (m
== MATCH_ERROR
)
3577 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3583 m
= gfc_match_char (',');
3591 m
= gfc_match (" errmsg = %v", &tmp
);
3592 if (m
== MATCH_ERROR
)
3598 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3604 m
= gfc_match_char (',');
3612 m
= gfc_match (" acquired_lock = %v", &tmp
);
3613 if (m
== MATCH_ERROR
|| st
== ST_UNLOCK
)
3619 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L",
3624 saw_acq_lock
= true;
3626 m
= gfc_match_char (',');
3637 if (m
== MATCH_ERROR
)
3640 if (gfc_match (" )%t") != MATCH_YES
)
3647 new_st
.op
= EXEC_LOCK
;
3650 new_st
.op
= EXEC_UNLOCK
;
3656 new_st
.expr1
= lockvar
;
3657 new_st
.expr2
= stat
;
3658 new_st
.expr3
= errmsg
;
3659 new_st
.expr4
= acq_lock
;
3664 gfc_syntax_error (st
);
3667 if (acq_lock
!= tmp
)
3668 gfc_free_expr (acq_lock
);
3670 gfc_free_expr (errmsg
);
3672 gfc_free_expr (stat
);
3674 gfc_free_expr (tmp
);
3675 gfc_free_expr (lockvar
);
3682 gfc_match_lock (void)
3684 if (!gfc_notify_std (GFC_STD_F2008
, "LOCK statement at %C"))
3687 return lock_unlock_statement (ST_LOCK
);
3692 gfc_match_unlock (void)
3694 if (!gfc_notify_std (GFC_STD_F2008
, "UNLOCK statement at %C"))
3697 return lock_unlock_statement (ST_UNLOCK
);
3701 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
3702 SYNC ALL [(sync-stat-list)]
3703 SYNC MEMORY [(sync-stat-list)]
3704 SYNC IMAGES (image-set [, sync-stat-list] )
3705 with sync-stat is int-expr or *. */
3708 sync_statement (gfc_statement st
)
3711 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
3712 bool saw_stat
, saw_errmsg
;
3714 tmp
= imageset
= stat
= errmsg
= NULL
;
3715 saw_stat
= saw_errmsg
= false;
3717 if (gfc_pure (NULL
))
3719 gfc_error ("Image control statement SYNC at %C in PURE procedure");
3723 gfc_unset_implicit_pure (NULL
);
3725 if (!gfc_notify_std (GFC_STD_F2008
, "SYNC statement at %C"))
3728 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3730 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
3735 if (gfc_find_state (COMP_CRITICAL
))
3737 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3741 if (gfc_find_state (COMP_DO_CONCURRENT
))
3743 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3747 if (gfc_match_eos () == MATCH_YES
)
3749 if (st
== ST_SYNC_IMAGES
)
3754 if (gfc_match_char ('(') != MATCH_YES
)
3757 if (st
== ST_SYNC_IMAGES
)
3759 /* Denote '*' as imageset == NULL. */
3760 m
= gfc_match_char ('*');
3761 if (m
== MATCH_ERROR
)
3765 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
3768 m
= gfc_match_char (',');
3769 if (m
== MATCH_ERROR
)
3773 m
= gfc_match_char (')');
3782 m
= gfc_match (" stat = %v", &tmp
);
3783 if (m
== MATCH_ERROR
)
3789 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3795 if (gfc_match_char (',') == MATCH_YES
)
3802 m
= gfc_match (" errmsg = %v", &tmp
);
3803 if (m
== MATCH_ERROR
)
3809 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3815 if (gfc_match_char (',') == MATCH_YES
)
3825 if (gfc_match (" )%t") != MATCH_YES
)
3832 new_st
.op
= EXEC_SYNC_ALL
;
3834 case ST_SYNC_IMAGES
:
3835 new_st
.op
= EXEC_SYNC_IMAGES
;
3837 case ST_SYNC_MEMORY
:
3838 new_st
.op
= EXEC_SYNC_MEMORY
;
3844 new_st
.expr1
= imageset
;
3845 new_st
.expr2
= stat
;
3846 new_st
.expr3
= errmsg
;
3851 gfc_syntax_error (st
);
3855 gfc_free_expr (stat
);
3857 gfc_free_expr (errmsg
);
3859 gfc_free_expr (tmp
);
3860 gfc_free_expr (imageset
);
3866 /* Match SYNC ALL statement. */
3869 gfc_match_sync_all (void)
3871 return sync_statement (ST_SYNC_ALL
);
3875 /* Match SYNC IMAGES statement. */
3878 gfc_match_sync_images (void)
3880 return sync_statement (ST_SYNC_IMAGES
);
3884 /* Match SYNC MEMORY statement. */
3887 gfc_match_sync_memory (void)
3889 return sync_statement (ST_SYNC_MEMORY
);
3893 /* Match a CONTINUE statement. */
3896 gfc_match_continue (void)
3898 if (gfc_match_eos () != MATCH_YES
)
3900 gfc_syntax_error (ST_CONTINUE
);
3904 new_st
.op
= EXEC_CONTINUE
;
3909 /* Match the (deprecated) ASSIGN statement. */
3912 gfc_match_assign (void)
3915 gfc_st_label
*label
;
3917 if (gfc_match (" %l", &label
) == MATCH_YES
)
3919 if (!gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
))
3921 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
3923 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGN statement at %C"))
3926 expr
->symtree
->n
.sym
->attr
.assign
= 1;
3928 new_st
.op
= EXEC_LABEL_ASSIGN
;
3929 new_st
.label1
= label
;
3930 new_st
.expr1
= expr
;
3938 /* Match the GO TO statement. As a computed GOTO statement is
3939 matched, it is transformed into an equivalent SELECT block. No
3940 tree is necessary, and the resulting jumps-to-jumps are
3941 specifically optimized away by the back end. */
3944 gfc_match_goto (void)
3946 gfc_code
*head
, *tail
;
3949 gfc_st_label
*label
;
3953 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
3955 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3958 new_st
.op
= EXEC_GOTO
;
3959 new_st
.label1
= label
;
3963 /* The assigned GO TO statement. */
3965 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
3967 if (!gfc_notify_std (GFC_STD_F95_DEL
, "Assigned GOTO statement at %C"))
3970 new_st
.op
= EXEC_GOTO
;
3971 new_st
.expr1
= expr
;
3973 if (gfc_match_eos () == MATCH_YES
)
3976 /* Match label list. */
3977 gfc_match_char (',');
3978 if (gfc_match_char ('(') != MATCH_YES
)
3980 gfc_syntax_error (ST_GOTO
);
3987 m
= gfc_match_st_label (&label
);
3991 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3995 head
= tail
= gfc_get_code (EXEC_GOTO
);
3998 tail
->block
= gfc_get_code (EXEC_GOTO
);
4002 tail
->label1
= label
;
4004 while (gfc_match_char (',') == MATCH_YES
);
4006 if (gfc_match (")%t") != MATCH_YES
)
4011 gfc_error ("Statement label list in GOTO at %C cannot be empty");
4014 new_st
.block
= head
;
4019 /* Last chance is a computed GO TO statement. */
4020 if (gfc_match_char ('(') != MATCH_YES
)
4022 gfc_syntax_error (ST_GOTO
);
4031 m
= gfc_match_st_label (&label
);
4035 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
4039 head
= tail
= gfc_get_code (EXEC_SELECT
);
4042 tail
->block
= gfc_get_code (EXEC_SELECT
);
4046 cp
= gfc_get_case ();
4047 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
4050 tail
->ext
.block
.case_list
= cp
;
4052 tail
->next
= gfc_get_code (EXEC_GOTO
);
4053 tail
->next
->label1
= label
;
4055 while (gfc_match_char (',') == MATCH_YES
);
4057 if (gfc_match_char (')') != MATCH_YES
)
4062 gfc_error ("Statement label list in GOTO at %C cannot be empty");
4066 /* Get the rest of the statement. */
4067 gfc_match_char (',');
4069 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
4072 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Computed GOTO at %C"))
4075 /* At this point, a computed GOTO has been fully matched and an
4076 equivalent SELECT statement constructed. */
4078 new_st
.op
= EXEC_SELECT
;
4079 new_st
.expr1
= NULL
;
4081 /* Hack: For a "real" SELECT, the expression is in expr. We put
4082 it in expr2 so we can distinguish then and produce the correct
4084 new_st
.expr2
= expr
;
4085 new_st
.block
= head
;
4089 gfc_syntax_error (ST_GOTO
);
4091 gfc_free_statements (head
);
4096 /* Frees a list of gfc_alloc structures. */
4099 gfc_free_alloc_list (gfc_alloc
*p
)
4106 gfc_free_expr (p
->expr
);
4112 /* Match an ALLOCATE statement. */
4115 gfc_match_allocate (void)
4117 gfc_alloc
*head
, *tail
;
4118 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
4122 locus old_locus
, deferred_locus
, assumed_locus
;
4123 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, saw_deferred
, b1
, b2
, b3
;
4124 bool saw_unlimited
= false, saw_assumed
= false;
4127 stat
= errmsg
= source
= mold
= tmp
= NULL
;
4128 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= saw_deferred
= false;
4130 if (gfc_match_char ('(') != MATCH_YES
)
4132 gfc_syntax_error (ST_ALLOCATE
);
4136 /* Match an optional type-spec. */
4137 old_locus
= gfc_current_locus
;
4138 m
= gfc_match_type_spec (&ts
);
4139 if (m
== MATCH_ERROR
)
4141 else if (m
== MATCH_NO
)
4143 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
4145 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
4147 gfc_error ("Error in type-spec at %L", &old_locus
);
4151 ts
.type
= BT_UNKNOWN
;
4155 /* Needed for the F2008:C631 check below. */
4156 assumed_locus
= gfc_current_locus
;
4158 if (gfc_match (" :: ") == MATCH_YES
)
4160 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
4166 gfc_error ("Type-spec at %L cannot contain a deferred "
4167 "type parameter", &old_locus
);
4171 if (ts
.type
== BT_CHARACTER
)
4173 if (!ts
.u
.cl
->length
)
4176 ts
.u
.cl
->length_from_typespec
= true;
4179 if (type_param_spec_list
4180 && gfc_spec_list_type (type_param_spec_list
, NULL
)
4183 gfc_error ("The type parameter spec list in the type-spec at "
4184 "%L cannot contain DEFERRED parameters", &old_locus
);
4190 ts
.type
= BT_UNKNOWN
;
4191 gfc_current_locus
= old_locus
;
4198 head
= tail
= gfc_get_alloc ();
4201 tail
->next
= gfc_get_alloc ();
4205 m
= gfc_match_variable (&tail
->expr
, 0);
4208 if (m
== MATCH_ERROR
)
4211 if (gfc_check_do_variable (tail
->expr
->symtree
))
4214 bool impure
= gfc_impure_variable (tail
->expr
->symtree
->n
.sym
);
4215 if (impure
&& gfc_pure (NULL
))
4217 gfc_error ("Bad allocate-object at %C for a PURE procedure");
4222 gfc_unset_implicit_pure (NULL
);
4224 /* F2008:C631 (R626) A type-param-value in a type-spec shall be an
4225 asterisk if and only if each allocate-object is a dummy argument
4226 for which the corresponding type parameter is assumed. */
4228 && (tail
->expr
->ts
.deferred
4229 || (tail
->expr
->ts
.u
.cl
&& tail
->expr
->ts
.u
.cl
->length
)
4230 || tail
->expr
->symtree
->n
.sym
->attr
.dummy
== 0))
4232 gfc_error ("Incompatible allocate-object at %C for CHARACTER "
4233 "type-spec at %L", &assumed_locus
);
4237 if (tail
->expr
->ts
.deferred
)
4239 saw_deferred
= true;
4240 deferred_locus
= tail
->expr
->where
;
4243 if (gfc_find_state (COMP_DO_CONCURRENT
)
4244 || gfc_find_state (COMP_CRITICAL
))
4247 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
4248 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
4249 if (ref
->type
== REF_COMPONENT
)
4250 coarray
= ref
->u
.c
.component
->attr
.codimension
;
4252 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
4254 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
4257 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
4259 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
4264 /* Check for F08:C628. */
4265 sym
= tail
->expr
->symtree
->n
.sym
;
4266 b1
= !(tail
->expr
->ref
4267 && (tail
->expr
->ref
->type
== REF_COMPONENT
4268 || tail
->expr
->ref
->type
== REF_ARRAY
));
4269 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4270 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
4271 || CLASS_DATA (sym
)->attr
.class_pointer
);
4273 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4274 || sym
->attr
.proc_pointer
);
4275 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
4276 && (sym
->ns
->proc_name
->attr
.allocatable
4277 || sym
->ns
->proc_name
->attr
.pointer
4278 || sym
->ns
->proc_name
->attr
.proc_pointer
);
4279 if (b1
&& b2
&& !b3
)
4281 gfc_error ("Allocate-object at %L is neither a data pointer "
4282 "nor an allocatable variable", &tail
->expr
->where
);
4286 /* The ALLOCATE statement had an optional typespec. Check the
4288 if (ts
.type
!= BT_UNKNOWN
)
4290 /* Enforce F03:C624. */
4291 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
4293 gfc_error ("Type of entity at %L is type incompatible with "
4294 "typespec", &tail
->expr
->where
);
4298 /* Enforce F03:C627. */
4299 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
4301 gfc_error ("Kind type parameter for entity at %L differs from "
4302 "the kind type parameter of the typespec",
4303 &tail
->expr
->where
);
4308 if (tail
->expr
->ts
.type
== BT_DERIVED
)
4309 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
4311 if (type_param_spec_list
)
4312 tail
->expr
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
4314 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
4316 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
4318 gfc_error ("Shape specification for allocatable scalar at %C");
4322 if (gfc_match_char (',') != MATCH_YES
)
4327 m
= gfc_match (" stat = %v", &tmp
);
4328 if (m
== MATCH_ERROR
)
4335 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4343 if (gfc_check_do_variable (stat
->symtree
))
4346 if (gfc_match_char (',') == MATCH_YES
)
4347 goto alloc_opt_list
;
4350 m
= gfc_match (" errmsg = %v", &tmp
);
4351 if (m
== MATCH_ERROR
)
4355 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
4361 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4369 if (gfc_match_char (',') == MATCH_YES
)
4370 goto alloc_opt_list
;
4373 m
= gfc_match (" source = %e", &tmp
);
4374 if (m
== MATCH_ERROR
)
4378 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
4384 gfc_error ("Redundant SOURCE tag found at %L", &tmp
->where
);
4388 /* The next 2 conditionals check C631. */
4389 if (ts
.type
!= BT_UNKNOWN
)
4391 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
4392 &tmp
->where
, &old_locus
);
4397 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
4398 " with more than a single allocate object",
4406 if (gfc_match_char (',') == MATCH_YES
)
4407 goto alloc_opt_list
;
4410 m
= gfc_match (" mold = %e", &tmp
);
4411 if (m
== MATCH_ERROR
)
4415 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
4418 /* Check F08:C636. */
4421 gfc_error ("Redundant MOLD tag found at %L", &tmp
->where
);
4425 /* Check F08:C637. */
4426 if (ts
.type
!= BT_UNKNOWN
)
4428 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
4429 &tmp
->where
, &old_locus
);
4438 if (gfc_match_char (',') == MATCH_YES
)
4439 goto alloc_opt_list
;
4442 gfc_gobble_whitespace ();
4444 if (gfc_peek_char () == ')')
4448 if (gfc_match (" )%t") != MATCH_YES
)
4451 /* Check F08:C637. */
4454 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
4455 &mold
->where
, &source
->where
);
4459 /* Check F03:C623, */
4460 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4462 gfc_error ("Allocate-object at %L with a deferred type parameter "
4463 "requires either a type-spec or SOURCE tag or a MOLD tag",
4468 /* Check F03:C625, */
4469 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4471 for (tail
= head
; tail
; tail
= tail
->next
)
4473 if (UNLIMITED_POLY (tail
->expr
))
4474 gfc_error ("Unlimited polymorphic allocate-object at %L "
4475 "requires either a type-spec or SOURCE tag "
4476 "or a MOLD tag", &tail
->expr
->where
);
4481 new_st
.op
= EXEC_ALLOCATE
;
4482 new_st
.expr1
= stat
;
4483 new_st
.expr2
= errmsg
;
4485 new_st
.expr3
= source
;
4487 new_st
.expr3
= mold
;
4488 new_st
.ext
.alloc
.list
= head
;
4489 new_st
.ext
.alloc
.ts
= ts
;
4491 if (type_param_spec_list
)
4492 gfc_free_actual_arglist (type_param_spec_list
);
4497 gfc_syntax_error (ST_ALLOCATE
);
4500 gfc_free_expr (errmsg
);
4501 gfc_free_expr (source
);
4502 gfc_free_expr (stat
);
4503 gfc_free_expr (mold
);
4504 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
4505 gfc_free_alloc_list (head
);
4506 if (type_param_spec_list
)
4507 gfc_free_actual_arglist (type_param_spec_list
);
4512 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
4513 a set of pointer assignments to intrinsic NULL(). */
4516 gfc_match_nullify (void)
4524 if (gfc_match_char ('(') != MATCH_YES
)
4529 m
= gfc_match_variable (&p
, 0);
4530 if (m
== MATCH_ERROR
)
4535 if (gfc_check_do_variable (p
->symtree
))
4539 if (gfc_is_coindexed (p
))
4541 gfc_error ("Pointer object at %C shall not be coindexed");
4545 /* build ' => NULL() '. */
4546 e
= gfc_get_null_expr (&gfc_current_locus
);
4548 /* Chain to list. */
4552 tail
->op
= EXEC_POINTER_ASSIGN
;
4556 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
4563 if (gfc_match (" )%t") == MATCH_YES
)
4565 if (gfc_match_char (',') != MATCH_YES
)
4572 gfc_syntax_error (ST_NULLIFY
);
4575 gfc_free_statements (new_st
.next
);
4577 gfc_free_expr (new_st
.expr1
);
4578 new_st
.expr1
= NULL
;
4579 gfc_free_expr (new_st
.expr2
);
4580 new_st
.expr2
= NULL
;
4585 /* Match a DEALLOCATE statement. */
4588 gfc_match_deallocate (void)
4590 gfc_alloc
*head
, *tail
;
4591 gfc_expr
*stat
, *errmsg
, *tmp
;
4594 bool saw_stat
, saw_errmsg
, b1
, b2
;
4597 stat
= errmsg
= tmp
= NULL
;
4598 saw_stat
= saw_errmsg
= false;
4600 if (gfc_match_char ('(') != MATCH_YES
)
4606 head
= tail
= gfc_get_alloc ();
4609 tail
->next
= gfc_get_alloc ();
4613 m
= gfc_match_variable (&tail
->expr
, 0);
4614 if (m
== MATCH_ERROR
)
4619 if (gfc_check_do_variable (tail
->expr
->symtree
))
4622 sym
= tail
->expr
->symtree
->n
.sym
;
4624 bool impure
= gfc_impure_variable (sym
);
4625 if (impure
&& gfc_pure (NULL
))
4627 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
4632 gfc_unset_implicit_pure (NULL
);
4634 if (gfc_is_coarray (tail
->expr
)
4635 && gfc_find_state (COMP_DO_CONCURRENT
))
4637 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
4641 if (gfc_is_coarray (tail
->expr
)
4642 && gfc_find_state (COMP_CRITICAL
))
4644 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
4648 /* FIXME: disable the checking on derived types. */
4649 b1
= !(tail
->expr
->ref
4650 && (tail
->expr
->ref
->type
== REF_COMPONENT
4651 || tail
->expr
->ref
->type
== REF_ARRAY
));
4652 if (sym
&& sym
->ts
.type
== BT_CLASS
)
4653 b2
= !(CLASS_DATA (sym
) && (CLASS_DATA (sym
)->attr
.allocatable
4654 || CLASS_DATA (sym
)->attr
.class_pointer
));
4656 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4657 || sym
->attr
.proc_pointer
);
4660 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
4661 "nor an allocatable variable");
4665 if (gfc_match_char (',') != MATCH_YES
)
4670 m
= gfc_match (" stat = %v", &tmp
);
4671 if (m
== MATCH_ERROR
)
4677 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4678 gfc_free_expr (tmp
);
4685 if (gfc_check_do_variable (stat
->symtree
))
4688 if (gfc_match_char (',') == MATCH_YES
)
4689 goto dealloc_opt_list
;
4692 m
= gfc_match (" errmsg = %v", &tmp
);
4693 if (m
== MATCH_ERROR
)
4697 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
4702 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4703 gfc_free_expr (tmp
);
4710 if (gfc_match_char (',') == MATCH_YES
)
4711 goto dealloc_opt_list
;
4714 gfc_gobble_whitespace ();
4716 if (gfc_peek_char () == ')')
4720 if (gfc_match (" )%t") != MATCH_YES
)
4723 new_st
.op
= EXEC_DEALLOCATE
;
4724 new_st
.expr1
= stat
;
4725 new_st
.expr2
= errmsg
;
4726 new_st
.ext
.alloc
.list
= head
;
4731 gfc_syntax_error (ST_DEALLOCATE
);
4734 gfc_free_expr (errmsg
);
4735 gfc_free_expr (stat
);
4736 gfc_free_alloc_list (head
);
4741 /* Match a RETURN statement. */
4744 gfc_match_return (void)
4748 gfc_compile_state s
;
4752 if (gfc_find_state (COMP_CRITICAL
))
4754 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4758 if (gfc_find_state (COMP_DO_CONCURRENT
))
4760 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4764 if (gfc_match_eos () == MATCH_YES
)
4767 if (!gfc_find_state (COMP_SUBROUTINE
))
4769 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4774 if (gfc_current_form
== FORM_FREE
)
4776 /* The following are valid, so we can't require a blank after the
4780 char c
= gfc_peek_ascii_char ();
4781 if (ISALPHA (c
) || ISDIGIT (c
))
4785 m
= gfc_match (" %e%t", &e
);
4788 if (m
== MATCH_ERROR
)
4791 gfc_syntax_error (ST_RETURN
);
4798 gfc_enclosing_unit (&s
);
4799 if (s
== COMP_PROGRAM
4800 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
4801 "main program at %C"))
4804 new_st
.op
= EXEC_RETURN
;
4811 /* Match the call of a type-bound procedure, if CALL%var has already been
4812 matched and var found to be a derived-type variable. */
4815 match_typebound_call (gfc_symtree
* varst
)
4820 base
= gfc_get_expr ();
4821 base
->expr_type
= EXPR_VARIABLE
;
4822 base
->symtree
= varst
;
4823 base
->where
= gfc_current_locus
;
4824 gfc_set_sym_referenced (varst
->n
.sym
);
4826 m
= gfc_match_varspec (base
, 0, true, true);
4828 gfc_error ("Expected component reference at %C");
4831 gfc_free_expr (base
);
4835 if (gfc_match_eos () != MATCH_YES
)
4837 gfc_error ("Junk after CALL at %C");
4838 gfc_free_expr (base
);
4842 if (base
->expr_type
== EXPR_COMPCALL
)
4843 new_st
.op
= EXEC_COMPCALL
;
4844 else if (base
->expr_type
== EXPR_PPC
)
4845 new_st
.op
= EXEC_CALL_PPC
;
4848 gfc_error ("Expected type-bound procedure or procedure pointer component "
4850 gfc_free_expr (base
);
4853 new_st
.expr1
= base
;
4859 /* Match a CALL statement. The tricky part here are possible
4860 alternate return specifiers. We handle these by having all
4861 "subroutines" actually return an integer via a register that gives
4862 the return number. If the call specifies alternate returns, we
4863 generate code for a SELECT statement whose case clauses contain
4864 GOTOs to the various labels. */
4867 gfc_match_call (void)
4869 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4870 gfc_actual_arglist
*a
, *arglist
;
4880 m
= gfc_match ("% %n", name
);
4886 if (gfc_get_ha_sym_tree (name
, &st
))
4891 /* If this is a variable of derived-type, it probably starts a type-bound
4893 if ((sym
->attr
.flavor
!= FL_PROCEDURE
4894 || gfc_is_function_return_value (sym
, gfc_current_ns
))
4895 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
4896 return match_typebound_call (st
);
4898 /* If it does not seem to be callable (include functions so that the
4899 right association is made. They are thrown out in resolution.)
4901 if (!sym
->attr
.generic
4902 && !sym
->attr
.subroutine
4903 && !sym
->attr
.function
)
4905 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
4907 /* ...create a symbol in this scope... */
4908 if (sym
->ns
!= gfc_current_ns
4909 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
4912 if (sym
!= st
->n
.sym
)
4916 /* ...and then to try to make the symbol into a subroutine. */
4917 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
4921 gfc_set_sym_referenced (sym
);
4923 if (gfc_match_eos () != MATCH_YES
)
4925 m
= gfc_match_actual_arglist (1, &arglist
);
4928 if (m
== MATCH_ERROR
)
4931 if (gfc_match_eos () != MATCH_YES
)
4935 /* If any alternate return labels were found, construct a SELECT
4936 statement that will jump to the right place. */
4939 for (a
= arglist
; a
; a
= a
->next
)
4940 if (a
->expr
== NULL
)
4948 gfc_symtree
*select_st
;
4949 gfc_symbol
*select_sym
;
4950 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4952 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
4953 sprintf (name
, "_result_%s", sym
->name
);
4954 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
4956 select_sym
= select_st
->n
.sym
;
4957 select_sym
->ts
.type
= BT_INTEGER
;
4958 select_sym
->ts
.kind
= gfc_default_integer_kind
;
4959 gfc_set_sym_referenced (select_sym
);
4960 c
->expr1
= gfc_get_expr ();
4961 c
->expr1
->expr_type
= EXPR_VARIABLE
;
4962 c
->expr1
->symtree
= select_st
;
4963 c
->expr1
->ts
= select_sym
->ts
;
4964 c
->expr1
->where
= gfc_current_locus
;
4967 for (a
= arglist
; a
; a
= a
->next
)
4969 if (a
->expr
!= NULL
)
4972 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
4977 c
->block
= gfc_get_code (EXEC_SELECT
);
4980 new_case
= gfc_get_case ();
4981 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
4982 new_case
->low
= new_case
->high
;
4983 c
->ext
.block
.case_list
= new_case
;
4985 c
->next
= gfc_get_code (EXEC_GOTO
);
4986 c
->next
->label1
= a
->label
;
4990 new_st
.op
= EXEC_CALL
;
4991 new_st
.symtree
= st
;
4992 new_st
.ext
.actual
= arglist
;
4997 gfc_syntax_error (ST_CALL
);
5000 gfc_free_actual_arglist (arglist
);
5005 /* Given a name, return a pointer to the common head structure,
5006 creating it if it does not exist. If FROM_MODULE is nonzero, we
5007 mangle the name so that it doesn't interfere with commons defined
5008 in the using namespace.
5009 TODO: Add to global symbol tree. */
5012 gfc_get_common (const char *name
, int from_module
)
5015 static int serial
= 0;
5016 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
5020 /* A use associated common block is only needed to correctly layout
5021 the variables it contains. */
5022 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
5023 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
5027 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
5030 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
5033 if (st
->n
.common
== NULL
)
5035 st
->n
.common
= gfc_get_common_head ();
5036 st
->n
.common
->where
= gfc_current_locus
;
5037 strcpy (st
->n
.common
->name
, name
);
5040 return st
->n
.common
;
5044 /* Match a common block name. */
5046 match
match_common_name (char *name
)
5050 if (gfc_match_char ('/') == MATCH_NO
)
5056 if (gfc_match_char ('/') == MATCH_YES
)
5062 m
= gfc_match_name (name
);
5064 if (m
== MATCH_ERROR
)
5066 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
5069 gfc_error ("Syntax error in common block name at %C");
5074 /* Match a COMMON statement. */
5077 gfc_match_common (void)
5079 gfc_symbol
*sym
, **head
, *tail
, *other
;
5080 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5090 m
= match_common_name (name
);
5091 if (m
== MATCH_ERROR
)
5094 if (name
[0] == '\0')
5096 t
= &gfc_current_ns
->blank_common
;
5097 if (t
->head
== NULL
)
5098 t
->where
= gfc_current_locus
;
5102 t
= gfc_get_common (name
, 0);
5111 while (tail
->common_next
)
5112 tail
= tail
->common_next
;
5115 /* Grab the list of symbols. */
5118 m
= gfc_match_symbol (&sym
, 0);
5119 if (m
== MATCH_ERROR
)
5124 /* See if we know the current common block is bind(c), and if
5125 so, then see if we can check if the symbol is (which it'll
5126 need to be). This can happen if the bind(c) attr stmt was
5127 applied to the common block, and the variable(s) already
5128 defined, before declaring the common block. */
5129 if (t
->is_bind_c
== 1)
5131 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
5133 /* If we find an error, just print it and continue,
5134 cause it's just semantic, and we can see if there
5136 gfc_error_now ("Variable %qs at %L in common block %qs "
5137 "at %C must be declared with a C "
5138 "interoperable kind since common block "
5140 sym
->name
, &(sym
->declared_at
), t
->name
,
5144 if (sym
->attr
.is_bind_c
== 1)
5145 gfc_error_now ("Variable %qs in common block %qs at %C cannot "
5146 "be bind(c) since it is not global", sym
->name
,
5150 if (sym
->attr
.in_common
)
5152 gfc_error ("Symbol %qs at %C is already in a COMMON block",
5157 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
5158 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
5160 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol %qs at "
5161 "%C can only be COMMON in BLOCK DATA",
5166 /* Deal with an optional array specification after the
5168 m
= gfc_match_array_spec (&as
, true, true);
5169 if (m
== MATCH_ERROR
)
5174 if (as
->type
!= AS_EXPLICIT
)
5176 gfc_error ("Array specification for symbol %qs in COMMON "
5177 "at %C must be explicit", sym
->name
);
5181 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
5184 if (sym
->attr
.pointer
)
5186 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
5187 "POINTER array", sym
->name
);
5196 /* Add the in_common attribute, but ignore the reported errors
5197 if any, and continue matching. */
5198 gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
);
5200 sym
->common_block
= t
;
5201 sym
->common_block
->refs
++;
5204 tail
->common_next
= sym
;
5210 sym
->common_head
= t
;
5212 /* Check to see if the symbol is already in an equivalence group.
5213 If it is, set the other members as being in common. */
5214 if (sym
->attr
.in_equivalence
)
5216 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
5218 for (e2
= e1
; e2
; e2
= e2
->eq
)
5219 if (e2
->expr
->symtree
->n
.sym
== sym
)
5226 for (e2
= e1
; e2
; e2
= e2
->eq
)
5228 other
= e2
->expr
->symtree
->n
.sym
;
5229 if (other
->common_head
5230 && other
->common_head
!= sym
->common_head
)
5232 gfc_error ("Symbol %qs, in COMMON block %qs at "
5233 "%C is being indirectly equivalenced to "
5234 "another COMMON block %qs",
5235 sym
->name
, sym
->common_head
->name
,
5236 other
->common_head
->name
);
5239 other
->attr
.in_common
= 1;
5240 other
->common_head
= t
;
5246 gfc_gobble_whitespace ();
5247 if (gfc_match_eos () == MATCH_YES
)
5249 if (gfc_peek_ascii_char () == '/')
5251 if (gfc_match_char (',') != MATCH_YES
)
5253 gfc_gobble_whitespace ();
5254 if (gfc_peek_ascii_char () == '/')
5263 gfc_syntax_error (ST_COMMON
);
5266 gfc_free_array_spec (as
);
5271 /* Match a BLOCK DATA program unit. */
5274 gfc_match_block_data (void)
5276 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5280 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "BLOCK DATA construct at %L",
5281 &gfc_current_locus
))
5284 if (gfc_match_eos () == MATCH_YES
)
5286 gfc_new_block
= NULL
;
5290 m
= gfc_match ("% %n%t", name
);
5294 if (gfc_get_symbol (name
, NULL
, &sym
))
5297 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
5300 gfc_new_block
= sym
;
5306 /* Free a namelist structure. */
5309 gfc_free_namelist (gfc_namelist
*name
)
5313 for (; name
; name
= n
)
5321 /* Free an OpenMP namelist structure. */
5324 gfc_free_omp_namelist (gfc_omp_namelist
*name
)
5326 gfc_omp_namelist
*n
;
5328 for (; name
; name
= n
)
5330 gfc_free_expr (name
->expr
);
5333 if (name
->udr
->combiner
)
5334 gfc_free_statement (name
->udr
->combiner
);
5335 if (name
->udr
->initializer
)
5336 gfc_free_statement (name
->udr
->initializer
);
5345 /* Match a NAMELIST statement. */
5348 gfc_match_namelist (void)
5350 gfc_symbol
*group_name
, *sym
;
5354 m
= gfc_match (" / %s /", &group_name
);
5357 if (m
== MATCH_ERROR
)
5362 if (group_name
->ts
.type
!= BT_UNKNOWN
)
5364 gfc_error ("Namelist group name %qs at %C already has a basic "
5365 "type of %s", group_name
->name
,
5366 gfc_typename (&group_name
->ts
));
5370 if (group_name
->attr
.flavor
== FL_NAMELIST
5371 && group_name
->attr
.use_assoc
5372 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name %qs "
5373 "at %C already is USE associated and can"
5374 "not be respecified.", group_name
->name
))
5377 if (group_name
->attr
.flavor
!= FL_NAMELIST
5378 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
5379 group_name
->name
, NULL
))
5384 m
= gfc_match_symbol (&sym
, 1);
5387 if (m
== MATCH_ERROR
)
5390 if (sym
->attr
.in_namelist
== 0
5391 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
5394 /* Use gfc_error_check here, rather than goto error, so that
5395 these are the only errors for the next two lines. */
5396 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
5398 gfc_error ("Assumed size array %qs in namelist %qs at "
5399 "%C is not allowed", sym
->name
, group_name
->name
);
5403 nl
= gfc_get_namelist ();
5407 if (group_name
->namelist
== NULL
)
5408 group_name
->namelist
= group_name
->namelist_tail
= nl
;
5411 group_name
->namelist_tail
->next
= nl
;
5412 group_name
->namelist_tail
= nl
;
5415 if (gfc_match_eos () == MATCH_YES
)
5418 m
= gfc_match_char (',');
5420 if (gfc_match_char ('/') == MATCH_YES
)
5422 m2
= gfc_match (" %s /", &group_name
);
5423 if (m2
== MATCH_YES
)
5425 if (m2
== MATCH_ERROR
)
5439 gfc_syntax_error (ST_NAMELIST
);
5446 /* Match a MODULE statement. */
5449 gfc_match_module (void)
5453 m
= gfc_match (" %s%t", &gfc_new_block
);
5457 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
5458 gfc_new_block
->name
, NULL
))
5465 /* Free equivalence sets and lists. Recursively is the easiest way to
5469 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
5474 gfc_free_equiv (eq
->eq
);
5475 gfc_free_equiv_until (eq
->next
, stop
);
5476 gfc_free_expr (eq
->expr
);
5482 gfc_free_equiv (gfc_equiv
*eq
)
5484 gfc_free_equiv_until (eq
, NULL
);
5488 /* Match an EQUIVALENCE statement. */
5491 gfc_match_equivalence (void)
5493 gfc_equiv
*eq
, *set
, *tail
;
5497 gfc_common_head
*common_head
= NULL
;
5505 eq
= gfc_get_equiv ();
5509 eq
->next
= gfc_current_ns
->equiv
;
5510 gfc_current_ns
->equiv
= eq
;
5512 if (gfc_match_char ('(') != MATCH_YES
)
5516 common_flag
= FALSE
;
5521 m
= gfc_match_equiv_variable (&set
->expr
);
5522 if (m
== MATCH_ERROR
)
5527 /* count the number of objects. */
5530 if (gfc_match_char ('%') == MATCH_YES
)
5532 gfc_error ("Derived type component %C is not a "
5533 "permitted EQUIVALENCE member");
5537 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
5538 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5540 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
5541 "be an array section");
5545 sym
= set
->expr
->symtree
->n
.sym
;
5547 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
5550 if (sym
->attr
.in_common
)
5553 common_head
= sym
->common_head
;
5556 if (gfc_match_char (')') == MATCH_YES
)
5559 if (gfc_match_char (',') != MATCH_YES
)
5562 set
->eq
= gfc_get_equiv ();
5568 gfc_error ("EQUIVALENCE at %C requires two or more objects");
5572 /* If one of the members of an equivalence is in common, then
5573 mark them all as being in common. Before doing this, check
5574 that members of the equivalence group are not in different
5577 for (set
= eq
; set
; set
= set
->eq
)
5579 sym
= set
->expr
->symtree
->n
.sym
;
5580 if (sym
->common_head
&& sym
->common_head
!= common_head
)
5582 gfc_error ("Attempt to indirectly overlap COMMON "
5583 "blocks %s and %s by EQUIVALENCE at %C",
5584 sym
->common_head
->name
, common_head
->name
);
5587 sym
->attr
.in_common
= 1;
5588 sym
->common_head
= common_head
;
5591 if (gfc_match_eos () == MATCH_YES
)
5593 if (gfc_match_char (',') != MATCH_YES
)
5595 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
5600 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "EQUIVALENCE statement at %C"))
5606 gfc_syntax_error (ST_EQUIVALENCE
);
5612 gfc_free_equiv (gfc_current_ns
->equiv
);
5613 gfc_current_ns
->equiv
= eq
;
5619 /* Check that a statement function is not recursive. This is done by looking
5620 for the statement function symbol(sym) by looking recursively through its
5621 expression(e). If a reference to sym is found, true is returned.
5622 12.5.4 requires that any variable of function that is implicitly typed
5623 shall have that type confirmed by any subsequent type declaration. The
5624 implicit typing is conveniently done here. */
5626 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
5629 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
5635 switch (e
->expr_type
)
5638 if (e
->symtree
== NULL
)
5641 /* Check the name before testing for nested recursion! */
5642 if (sym
->name
== e
->symtree
->n
.sym
->name
)
5645 /* Catch recursion via other statement functions. */
5646 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
5647 && e
->symtree
->n
.sym
->value
5648 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
5651 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5652 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5657 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
5660 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5661 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5673 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
5675 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
5679 /* Match a statement function declaration. It is so easy to match
5680 non-statement function statements with a MATCH_ERROR as opposed to
5681 MATCH_NO that we suppress error message in most cases. */
5684 gfc_match_st_function (void)
5686 gfc_error_buffer old_error
;
5691 m
= gfc_match_symbol (&sym
, 0);
5695 gfc_push_error (&old_error
);
5697 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
5700 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
5703 m
= gfc_match (" = %e%t", &expr
);
5707 gfc_free_error (&old_error
);
5709 if (m
== MATCH_ERROR
)
5712 if (recursive_stmt_fcn (expr
, sym
))
5714 gfc_error ("Statement function at %L is recursive", &expr
->where
);
5720 if ((gfc_current_state () == COMP_FUNCTION
5721 || gfc_current_state () == COMP_SUBROUTINE
)
5722 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
5724 gfc_error ("Statement function at %L cannot appear within an INTERFACE",
5729 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
5735 gfc_pop_error (&old_error
);
5740 /* Match an assignment to a pointer function (F2008). This could, in
5741 general be ambiguous with a statement function. In this implementation
5742 it remains so if it is the first statement after the specification
5746 gfc_match_ptr_fcn_assign (void)
5748 gfc_error_buffer old_error
;
5753 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5755 old_loc
= gfc_current_locus
;
5756 m
= gfc_match_name (name
);
5760 gfc_find_symbol (name
, NULL
, 1, &sym
);
5761 if (sym
&& sym
->attr
.flavor
!= FL_PROCEDURE
)
5764 gfc_push_error (&old_error
);
5766 if (sym
&& sym
->attr
.function
)
5767 goto match_actual_arglist
;
5769 gfc_current_locus
= old_loc
;
5770 m
= gfc_match_symbol (&sym
, 0);
5774 if (!gfc_add_procedure (&sym
->attr
, PROC_UNKNOWN
, sym
->name
, NULL
))
5777 match_actual_arglist
:
5778 gfc_current_locus
= old_loc
;
5779 m
= gfc_match (" %e", &expr
);
5783 new_st
.op
= EXEC_ASSIGN
;
5784 new_st
.expr1
= expr
;
5787 m
= gfc_match (" = %e%t", &expr
);
5791 new_st
.expr2
= expr
;
5795 gfc_pop_error (&old_error
);
5800 /***************** SELECT CASE subroutines ******************/
5802 /* Free a single case structure. */
5805 free_case (gfc_case
*p
)
5807 if (p
->low
== p
->high
)
5809 gfc_free_expr (p
->low
);
5810 gfc_free_expr (p
->high
);
5815 /* Free a list of case structures. */
5818 gfc_free_case_list (gfc_case
*p
)
5830 /* Match a single case selector. Combining the requirements of F08:C830
5831 and F08:C832 (R838) means that the case-value must have either CHARACTER,
5832 INTEGER, or LOGICAL type. */
5835 match_case_selector (gfc_case
**cp
)
5840 c
= gfc_get_case ();
5841 c
->where
= gfc_current_locus
;
5843 if (gfc_match_char (':') == MATCH_YES
)
5845 m
= gfc_match_init_expr (&c
->high
);
5848 if (m
== MATCH_ERROR
)
5851 if (c
->high
->ts
.type
!= BT_LOGICAL
&& c
->high
->ts
.type
!= BT_INTEGER
5852 && c
->high
->ts
.type
!= BT_CHARACTER
)
5854 gfc_error ("Expression in CASE selector at %L cannot be %s",
5855 &c
->high
->where
, gfc_typename (&c
->high
->ts
));
5861 m
= gfc_match_init_expr (&c
->low
);
5862 if (m
== MATCH_ERROR
)
5867 if (c
->low
->ts
.type
!= BT_LOGICAL
&& c
->low
->ts
.type
!= BT_INTEGER
5868 && c
->low
->ts
.type
!= BT_CHARACTER
)
5870 gfc_error ("Expression in CASE selector at %L cannot be %s",
5871 &c
->low
->where
, gfc_typename (&c
->low
->ts
));
5875 /* If we're not looking at a ':' now, make a range out of a single
5876 target. Else get the upper bound for the case range. */
5877 if (gfc_match_char (':') != MATCH_YES
)
5881 m
= gfc_match_init_expr (&c
->high
);
5882 if (m
== MATCH_ERROR
)
5884 /* MATCH_NO is fine. It's OK if nothing is there! */
5892 gfc_error ("Expected initialization expression in CASE at %C");
5900 /* Match the end of a case statement. */
5903 match_case_eos (void)
5905 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5908 if (gfc_match_eos () == MATCH_YES
)
5911 /* If the case construct doesn't have a case-construct-name, we
5912 should have matched the EOS. */
5913 if (!gfc_current_block ())
5916 gfc_gobble_whitespace ();
5918 m
= gfc_match_name (name
);
5922 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5924 gfc_error ("Expected block name %qs of SELECT construct at %C",
5925 gfc_current_block ()->name
);
5929 return gfc_match_eos ();
5933 /* Match a SELECT statement. */
5936 gfc_match_select (void)
5941 m
= gfc_match_label ();
5942 if (m
== MATCH_ERROR
)
5945 m
= gfc_match (" select case ( %e )%t", &expr
);
5949 new_st
.op
= EXEC_SELECT
;
5950 new_st
.expr1
= expr
;
5956 /* Transfer the selector typespec to the associate name. */
5959 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
)
5962 gfc_symbol
*assoc_sym
;
5965 assoc_sym
= associate
->symtree
->n
.sym
;
5967 /* At this stage the expression rank and arrayspec dimensions have
5968 not been completely sorted out. We must get the expr2->rank
5969 right here, so that the correct class container is obtained. */
5970 ref
= selector
->ref
;
5971 while (ref
&& ref
->next
)
5974 if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
5975 && ref
&& ref
->type
== REF_ARRAY
)
5977 /* Ensure that the array reference type is set. We cannot use
5978 gfc_resolve_expr at this point, so the usable parts of
5979 resolve.c(resolve_array_ref) are employed to do it. */
5980 if (ref
->u
.ar
.type
== AR_UNKNOWN
)
5982 ref
->u
.ar
.type
= AR_ELEMENT
;
5983 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
5984 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5985 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
5986 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
5987 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
5989 ref
->u
.ar
.type
= AR_SECTION
;
5994 if (ref
->u
.ar
.type
== AR_FULL
)
5995 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
5996 else if (ref
->u
.ar
.type
== AR_SECTION
)
5997 selector
->rank
= ref
->u
.ar
.dimen
;
6001 rank
= selector
->rank
;
6006 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
6007 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
6008 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
6009 && ref
->u
.ar
.end
[i
] == NULL
6010 && ref
->u
.ar
.stride
[i
] == NULL
))
6015 assoc_sym
->attr
.dimension
= 1;
6016 assoc_sym
->as
= gfc_get_array_spec ();
6017 assoc_sym
->as
->rank
= rank
;
6018 assoc_sym
->as
->type
= AS_DEFERRED
;
6021 assoc_sym
->as
= NULL
;
6024 assoc_sym
->as
= NULL
;
6026 if (selector
->ts
.type
== BT_CLASS
)
6028 /* The correct class container has to be available. */
6029 assoc_sym
->ts
.type
= BT_CLASS
;
6030 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
6031 assoc_sym
->attr
.pointer
= 1;
6032 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
6037 /* Push the current selector onto the SELECT TYPE stack. */
6040 select_type_push (gfc_symbol
*sel
)
6042 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
6043 top
->selector
= sel
;
6045 top
->prev
= select_type_stack
;
6047 select_type_stack
= top
;
6051 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
6053 static gfc_symtree
*
6054 select_intrinsic_set_tmp (gfc_typespec
*ts
)
6056 char name
[GFC_MAX_SYMBOL_LEN
];
6058 HOST_WIDE_INT charlen
= 0;
6060 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
6063 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
6064 && !select_type_stack
->selector
->attr
.class_ok
)
6067 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
6068 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6069 charlen
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
6071 if (ts
->type
!= BT_CHARACTER
)
6072 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
6075 snprintf (name
, sizeof (name
), "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
6076 gfc_basic_typename (ts
->type
), charlen
, ts
->kind
);
6078 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6079 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
6081 /* Copy across the array spec to the selector. */
6082 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
6083 && (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
6084 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
))
6086 tmp
->n
.sym
->attr
.pointer
= 1;
6087 tmp
->n
.sym
->attr
.dimension
6088 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
6089 tmp
->n
.sym
->attr
.codimension
6090 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
6092 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
6095 gfc_set_sym_referenced (tmp
->n
.sym
);
6096 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
6097 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
6103 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
6106 select_type_set_tmp (gfc_typespec
*ts
)
6108 char name
[GFC_MAX_SYMBOL_LEN
];
6109 gfc_symtree
*tmp
= NULL
;
6113 select_type_stack
->tmp
= NULL
;
6117 tmp
= select_intrinsic_set_tmp (ts
);
6124 if (ts
->type
== BT_CLASS
)
6125 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
6127 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
6128 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6129 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
6131 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
6132 && select_type_stack
->selector
->attr
.class_ok
)
6134 tmp
->n
.sym
->attr
.pointer
6135 = CLASS_DATA (select_type_stack
->selector
)->attr
.class_pointer
;
6137 /* Copy across the array spec to the selector. */
6138 if (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
6139 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
)
6141 tmp
->n
.sym
->attr
.dimension
6142 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
6143 tmp
->n
.sym
->attr
.codimension
6144 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
6146 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
6150 gfc_set_sym_referenced (tmp
->n
.sym
);
6151 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
6152 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
6154 if (ts
->type
== BT_CLASS
)
6155 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
6159 /* Add an association for it, so the rest of the parser knows it is
6160 an associate-name. The target will be set during resolution. */
6161 tmp
->n
.sym
->assoc
= gfc_get_association_list ();
6162 tmp
->n
.sym
->assoc
->dangling
= 1;
6163 tmp
->n
.sym
->assoc
->st
= tmp
;
6165 select_type_stack
->tmp
= tmp
;
6169 /* Match a SELECT TYPE statement. */
6172 gfc_match_select_type (void)
6174 gfc_expr
*expr1
, *expr2
= NULL
;
6176 char name
[GFC_MAX_SYMBOL_LEN
];
6179 gfc_namespace
*ns
= gfc_current_ns
;
6181 m
= gfc_match_label ();
6182 if (m
== MATCH_ERROR
)
6185 m
= gfc_match (" select type ( ");
6189 gfc_current_ns
= gfc_build_block_ns (ns
);
6190 m
= gfc_match (" %n => %e", name
, &expr2
);
6193 expr1
= gfc_get_expr ();
6194 expr1
->expr_type
= EXPR_VARIABLE
;
6195 expr1
->where
= expr2
->where
;
6196 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
6202 sym
= expr1
->symtree
->n
.sym
;
6203 if (expr2
->ts
.type
== BT_UNKNOWN
)
6204 sym
->attr
.untyped
= 1;
6206 copy_ts_from_selector_to_associate (expr1
, expr2
);
6208 sym
->attr
.flavor
= FL_VARIABLE
;
6209 sym
->attr
.referenced
= 1;
6210 sym
->attr
.class_ok
= 1;
6214 m
= gfc_match (" %e ", &expr1
);
6217 std::swap (ns
, gfc_current_ns
);
6218 gfc_free_namespace (ns
);
6223 m
= gfc_match (" )%t");
6226 gfc_error ("parse error in SELECT TYPE statement at %C");
6230 /* This ghastly expression seems to be needed to distinguish a CLASS
6231 array, which can have a reference, from other expressions that
6232 have references, such as derived type components, and are not
6233 allowed by the standard.
6234 TODO: see if it is sufficient to exclude component and substring
6236 class_array
= (expr1
->expr_type
== EXPR_VARIABLE
6237 && expr1
->ts
.type
== BT_CLASS
6238 && CLASS_DATA (expr1
)
6239 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
6240 && (CLASS_DATA (expr1
)->attr
.dimension
6241 || CLASS_DATA (expr1
)->attr
.codimension
)
6243 && expr1
->ref
->type
== REF_ARRAY
6244 && expr1
->ref
->u
.ar
.type
== AR_FULL
6245 && expr1
->ref
->next
== NULL
);
6247 /* Check for F03:C811 (F08:C835). */
6248 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
6249 || (!class_array
&& expr1
->ref
!= NULL
)))
6251 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
6252 "use associate-name=>");
6257 new_st
.op
= EXEC_SELECT_TYPE
;
6258 new_st
.expr1
= expr1
;
6259 new_st
.expr2
= expr2
;
6260 new_st
.ext
.block
.ns
= gfc_current_ns
;
6262 select_type_push (expr1
->symtree
->n
.sym
);
6263 gfc_current_ns
= ns
;
6268 gfc_free_expr (expr1
);
6269 gfc_free_expr (expr2
);
6270 gfc_undo_symbols ();
6271 std::swap (ns
, gfc_current_ns
);
6272 gfc_free_namespace (ns
);
6277 /* Match a CASE statement. */
6280 gfc_match_case (void)
6282 gfc_case
*c
, *head
, *tail
;
6287 if (gfc_current_state () != COMP_SELECT
)
6289 gfc_error ("Unexpected CASE statement at %C");
6293 if (gfc_match ("% default") == MATCH_YES
)
6295 m
= match_case_eos ();
6298 if (m
== MATCH_ERROR
)
6301 new_st
.op
= EXEC_SELECT
;
6302 c
= gfc_get_case ();
6303 c
->where
= gfc_current_locus
;
6304 new_st
.ext
.block
.case_list
= c
;
6308 if (gfc_match_char ('(') != MATCH_YES
)
6313 if (match_case_selector (&c
) == MATCH_ERROR
)
6323 if (gfc_match_char (')') == MATCH_YES
)
6325 if (gfc_match_char (',') != MATCH_YES
)
6329 m
= match_case_eos ();
6332 if (m
== MATCH_ERROR
)
6335 new_st
.op
= EXEC_SELECT
;
6336 new_st
.ext
.block
.case_list
= head
;
6341 gfc_error ("Syntax error in CASE specification at %C");
6344 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
6349 /* Match a TYPE IS statement. */
6352 gfc_match_type_is (void)
6357 if (gfc_current_state () != COMP_SELECT_TYPE
)
6359 gfc_error ("Unexpected TYPE IS statement at %C");
6363 if (gfc_match_char ('(') != MATCH_YES
)
6366 c
= gfc_get_case ();
6367 c
->where
= gfc_current_locus
;
6369 m
= gfc_match_type_spec (&c
->ts
);
6372 if (m
== MATCH_ERROR
)
6375 if (gfc_match_char (')') != MATCH_YES
)
6378 m
= match_case_eos ();
6381 if (m
== MATCH_ERROR
)
6384 new_st
.op
= EXEC_SELECT_TYPE
;
6385 new_st
.ext
.block
.case_list
= c
;
6387 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
6388 && (c
->ts
.u
.derived
->attr
.sequence
6389 || c
->ts
.u
.derived
->attr
.is_bind_c
))
6391 gfc_error ("The type-spec shall not specify a sequence derived "
6392 "type or a type with the BIND attribute in SELECT "
6393 "TYPE at %C [F2003:C815]");
6397 if (c
->ts
.type
== BT_DERIVED
6398 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
6399 && gfc_spec_list_type (type_param_spec_list
, c
->ts
.u
.derived
)
6402 gfc_error ("All the LEN type parameters in the TYPE IS statement "
6403 "at %C must be ASSUMED");
6407 /* Create temporary variable. */
6408 select_type_set_tmp (&c
->ts
);
6413 gfc_error ("Syntax error in TYPE IS specification at %C");
6417 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6422 /* Match a CLASS IS or CLASS DEFAULT statement. */
6425 gfc_match_class_is (void)
6430 if (gfc_current_state () != COMP_SELECT_TYPE
)
6433 if (gfc_match ("% default") == MATCH_YES
)
6435 m
= match_case_eos ();
6438 if (m
== MATCH_ERROR
)
6441 new_st
.op
= EXEC_SELECT_TYPE
;
6442 c
= gfc_get_case ();
6443 c
->where
= gfc_current_locus
;
6444 c
->ts
.type
= BT_UNKNOWN
;
6445 new_st
.ext
.block
.case_list
= c
;
6446 select_type_set_tmp (NULL
);
6450 m
= gfc_match ("% is");
6453 if (m
== MATCH_ERROR
)
6456 if (gfc_match_char ('(') != MATCH_YES
)
6459 c
= gfc_get_case ();
6460 c
->where
= gfc_current_locus
;
6462 m
= match_derived_type_spec (&c
->ts
);
6465 if (m
== MATCH_ERROR
)
6468 if (c
->ts
.type
== BT_DERIVED
)
6469 c
->ts
.type
= BT_CLASS
;
6471 if (gfc_match_char (')') != MATCH_YES
)
6474 m
= match_case_eos ();
6477 if (m
== MATCH_ERROR
)
6480 new_st
.op
= EXEC_SELECT_TYPE
;
6481 new_st
.ext
.block
.case_list
= c
;
6483 /* Create temporary variable. */
6484 select_type_set_tmp (&c
->ts
);
6489 gfc_error ("Syntax error in CLASS IS specification at %C");
6493 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6498 /********************* WHERE subroutines ********************/
6500 /* Match the rest of a simple WHERE statement that follows an IF statement.
6504 match_simple_where (void)
6510 m
= gfc_match (" ( %e )", &expr
);
6514 m
= gfc_match_assignment ();
6517 if (m
== MATCH_ERROR
)
6520 if (gfc_match_eos () != MATCH_YES
)
6523 c
= gfc_get_code (EXEC_WHERE
);
6526 c
->next
= XCNEW (gfc_code
);
6528 c
->next
->loc
= gfc_current_locus
;
6529 gfc_clear_new_st ();
6531 new_st
.op
= EXEC_WHERE
;
6537 gfc_syntax_error (ST_WHERE
);
6540 gfc_free_expr (expr
);
6545 /* Match a WHERE statement. */
6548 gfc_match_where (gfc_statement
*st
)
6554 m0
= gfc_match_label ();
6555 if (m0
== MATCH_ERROR
)
6558 m
= gfc_match (" where ( %e )", &expr
);
6562 if (gfc_match_eos () == MATCH_YES
)
6564 *st
= ST_WHERE_BLOCK
;
6565 new_st
.op
= EXEC_WHERE
;
6566 new_st
.expr1
= expr
;
6570 m
= gfc_match_assignment ();
6572 gfc_syntax_error (ST_WHERE
);
6576 gfc_free_expr (expr
);
6580 /* We've got a simple WHERE statement. */
6582 c
= gfc_get_code (EXEC_WHERE
);
6585 /* Put in the assignment. It will not be processed by add_statement, so we
6586 need to copy the location here. */
6588 c
->next
= XCNEW (gfc_code
);
6590 c
->next
->loc
= gfc_current_locus
;
6591 gfc_clear_new_st ();
6593 new_st
.op
= EXEC_WHERE
;
6600 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
6601 new_st if successful. */
6604 gfc_match_elsewhere (void)
6606 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6610 if (gfc_current_state () != COMP_WHERE
)
6612 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
6618 if (gfc_match_char ('(') == MATCH_YES
)
6620 m
= gfc_match_expr (&expr
);
6623 if (m
== MATCH_ERROR
)
6626 if (gfc_match_char (')') != MATCH_YES
)
6630 if (gfc_match_eos () != MATCH_YES
)
6632 /* Only makes sense if we have a where-construct-name. */
6633 if (!gfc_current_block ())
6638 /* Better be a name at this point. */
6639 m
= gfc_match_name (name
);
6642 if (m
== MATCH_ERROR
)
6645 if (gfc_match_eos () != MATCH_YES
)
6648 if (strcmp (name
, gfc_current_block ()->name
) != 0)
6650 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
6651 name
, gfc_current_block ()->name
);
6656 new_st
.op
= EXEC_WHERE
;
6657 new_st
.expr1
= expr
;
6661 gfc_syntax_error (ST_ELSEWHERE
);
6664 gfc_free_expr (expr
);