1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000-2018 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
29 int gfc_matching_ptr_assignment
= 0;
30 int gfc_matching_procptr_assignment
= 0;
31 bool gfc_matching_prefix
= false;
33 /* Stack of SELECT TYPE statements. */
34 gfc_select_type_stack
*select_type_stack
= NULL
;
36 /* List of type parameter expressions. */
37 gfc_actual_arglist
*type_param_spec_list
;
39 /* For debugging and diagnostic purposes. Return the textual representation
40 of the intrinsic operator OP. */
42 gfc_op2string (gfc_intrinsic_op op
)
50 case INTRINSIC_UMINUS
:
56 case INTRINSIC_CONCAT
:
60 case INTRINSIC_DIVIDE
:
99 case INTRINSIC_ASSIGN
:
102 case INTRINSIC_PARENTHESES
:
109 case INTRINSIC_FORMATTED
:
111 case INTRINSIC_UNFORMATTED
:
112 return "unformatted";
118 gfc_internal_error ("gfc_op2string(): Bad code");
123 /******************** Generic matching subroutines ************************/
125 /* Matches a member separator. With standard FORTRAN this is '%', but with
126 DEC structures we must carefully match dot ('.').
127 Because operators are spelled ".op.", a dotted string such as "x.y.z..."
128 can be either a component reference chain or a combination of binary
130 There is no real way to win because the string may be grammatically
131 ambiguous. The following rules help avoid ambiguities - they match
132 some behavior of other (older) compilers. If the rules here are changed
133 the test cases should be updated. If the user has problems with these rules
134 they probably deserve the consequences. Consider "x.y.z":
135 (1) If any user defined operator ".y." exists, this is always y(x,z)
136 (even if ".y." is the wrong type and/or x has a member y).
137 (2) Otherwise if x has a member y, and y is itself a derived type,
138 this is (x->y)->z, even if an intrinsic operator exists which
140 (3) If x has no member y or (x->y) is not a derived type but ".y."
141 is an intrinsic operator (such as ".eq."), this is y(x,z).
142 (4) Lastly if there is no operator ".y." and x has no member "y", it is an
144 It is worth noting that the logic here does not support mixed use of member
145 accessors within a single string. That is, even if x has component y and y
146 has component z, the following are all syntax errors:
147 "x%y.z" "x.y%z" "(x.y).z" "(x%y)%z"
151 gfc_match_member_sep(gfc_symbol
*sym
)
153 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
154 locus dot_loc
, start_loc
;
155 gfc_intrinsic_op iop
;
158 gfc_component
*c
= NULL
;
160 /* What a relief: '%' is an unambiguous member separator. */
161 if (gfc_match_char ('%') == MATCH_YES
)
164 /* Beware ye who enter here. */
165 if (!flag_dec_structure
|| !sym
)
170 /* We may be given either a derived type variable or the derived type
171 declaration itself (which actually contains the components);
172 we need the latter to search for components. */
173 if (gfc_fl_struct (sym
->attr
.flavor
))
175 else if (gfc_bt_struct (sym
->ts
.type
))
176 tsym
= sym
->ts
.u
.derived
;
178 iop
= INTRINSIC_NONE
;
182 /* If we have to reject come back here later. */
183 start_loc
= gfc_current_locus
;
185 /* Look for a component access next. */
186 if (gfc_match_char ('.') != MATCH_YES
)
189 /* If we accept, come back here. */
190 dot_loc
= gfc_current_locus
;
192 /* Try to match a symbol name following the dot. */
193 if (gfc_match_name (name
) != MATCH_YES
)
195 gfc_error ("Expected structure component or operator name "
200 /* If no dot follows we have "x.y" which should be a component access. */
201 if (gfc_match_char ('.') != MATCH_YES
)
204 /* Now we have a string "x.y.z" which could be a nested member access
205 (x->y)->z or a binary operation y on x and z. */
207 /* First use any user-defined operators ".y." */
208 if (gfc_find_uop (name
, sym
->ns
) != NULL
)
211 /* Match accesses to existing derived-type components for
212 derived-type vars: "x.y.z" = (x->y)->z */
213 c
= gfc_find_component(tsym
, name
, false, true, NULL
);
214 if (c
&& (gfc_bt_struct (c
->ts
.type
) || c
->ts
.type
== BT_CLASS
))
217 /* If y is not a component or has no members, try intrinsic operators. */
218 gfc_current_locus
= start_loc
;
219 if (gfc_match_intrinsic_op (&iop
) != MATCH_YES
)
221 /* If ".y." is not an intrinsic operator but y was a valid non-
222 structure component, match and leave the trailing dot to be
227 gfc_error ("%qs is neither a defined operator nor a "
228 "structure component in dotted string at %C", name
);
232 /* .y. is an intrinsic operator, overriding any possible member access. */
235 /* Return keeping the current locus consistent with the match result. */
239 gfc_current_locus
= start_loc
;
242 gfc_current_locus
= dot_loc
;
247 /* This function scans the current statement counting the opened and closed
248 parenthesis to make sure they are balanced. */
251 gfc_match_parens (void)
253 locus old_loc
, where
;
255 gfc_instring instring
;
258 old_loc
= gfc_current_locus
;
260 instring
= NONSTRING
;
265 c
= gfc_next_char_literal (instring
);
268 if (quote
== ' ' && ((c
== '\'') || (c
== '"')))
271 instring
= INSTRING_WARN
;
274 if (quote
!= ' ' && c
== quote
)
277 instring
= NONSTRING
;
281 if (c
== '(' && quote
== ' ')
284 where
= gfc_current_locus
;
286 if (c
== ')' && quote
== ' ')
289 where
= gfc_current_locus
;
293 gfc_current_locus
= old_loc
;
297 gfc_error ("Missing %<)%> in statement at or before %L", &where
);
302 gfc_error ("Missing %<(%> in statement at or before %L", &where
);
310 /* See if the next character is a special character that has
311 escaped by a \ via the -fbackslash option. */
314 gfc_match_special_char (gfc_char_t
*res
)
322 switch ((c
= gfc_next_char_literal (INSTRING_WARN
)))
355 /* Hexadecimal form of wide characters. */
356 len
= (c
== 'x' ? 2 : (c
== 'u' ? 4 : 8));
358 for (i
= 0; i
< len
; i
++)
360 char buf
[2] = { '\0', '\0' };
362 c
= gfc_next_char_literal (INSTRING_WARN
);
363 if (!gfc_wide_fits_in_byte (c
)
364 || !gfc_check_digit ((unsigned char) c
, 16))
367 buf
[0] = (unsigned char) c
;
369 n
+= strtol (buf
, NULL
, 16);
375 /* Unknown backslash codes are simply not expanded. */
384 /* In free form, match at least one space. Always matches in fixed
388 gfc_match_space (void)
393 if (gfc_current_form
== FORM_FIXED
)
396 old_loc
= gfc_current_locus
;
398 c
= gfc_next_ascii_char ();
399 if (!gfc_is_whitespace (c
))
401 gfc_current_locus
= old_loc
;
405 gfc_gobble_whitespace ();
411 /* Match an end of statement. End of statement is optional
412 whitespace, followed by a ';' or '\n' or comment '!'. If a
413 semicolon is found, we continue to eat whitespace and semicolons. */
426 old_loc
= gfc_current_locus
;
427 gfc_gobble_whitespace ();
429 c
= gfc_next_ascii_char ();
435 c
= gfc_next_ascii_char ();
452 gfc_current_locus
= old_loc
;
453 return (flag
) ? MATCH_YES
: MATCH_NO
;
457 /* Match a literal integer on the input, setting the value on
458 MATCH_YES. Literal ints occur in kind-parameters as well as
459 old-style character length specifications. If cnt is non-NULL it
460 will be set to the number of digits. */
463 gfc_match_small_literal_int (int *value
, int *cnt
)
469 old_loc
= gfc_current_locus
;
472 gfc_gobble_whitespace ();
473 c
= gfc_next_ascii_char ();
479 gfc_current_locus
= old_loc
;
488 old_loc
= gfc_current_locus
;
489 c
= gfc_next_ascii_char ();
494 i
= 10 * i
+ c
- '0';
499 gfc_error ("Integer too large at %C");
504 gfc_current_locus
= old_loc
;
513 /* Match a small, constant integer expression, like in a kind
514 statement. On MATCH_YES, 'value' is set. */
517 gfc_match_small_int (int *value
)
523 m
= gfc_match_expr (&expr
);
527 if (gfc_extract_int (expr
, &i
, 1))
529 gfc_free_expr (expr
);
536 /* This function is the same as the gfc_match_small_int, except that
537 we're keeping the pointer to the expr. This function could just be
538 removed and the previously mentioned one modified, though all calls
539 to it would have to be modified then (and there were a number of
540 them). Return MATCH_ERROR if fail to extract the int; otherwise,
541 return the result of gfc_match_expr(). The expr (if any) that was
542 matched is returned in the parameter expr. */
545 gfc_match_small_int_expr (int *value
, gfc_expr
**expr
)
550 m
= gfc_match_expr (expr
);
554 if (gfc_extract_int (*expr
, &i
, 1))
562 /* Matches a statement label. Uses gfc_match_small_literal_int() to
563 do most of the work. */
566 gfc_match_st_label (gfc_st_label
**label
)
572 old_loc
= gfc_current_locus
;
574 m
= gfc_match_small_literal_int (&i
, &cnt
);
580 gfc_error ("Too many digits in statement label at %C");
586 gfc_error ("Statement label at %C is zero");
590 *label
= gfc_get_st_label (i
);
595 gfc_current_locus
= old_loc
;
600 /* Match and validate a label associated with a named IF, DO or SELECT
601 statement. If the symbol does not have the label attribute, we add
602 it. We also make sure the symbol does not refer to another
603 (active) block. A matched label is pointed to by gfc_new_block. */
606 gfc_match_label (void)
608 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
611 gfc_new_block
= NULL
;
613 m
= gfc_match (" %n :", name
);
617 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
619 gfc_error ("Label name %qs at %C is ambiguous", name
);
623 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
625 gfc_error ("Duplicate construct label %qs at %C", name
);
629 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
630 gfc_new_block
->name
, NULL
))
637 /* See if the current input looks like a name of some sort. Modifies
638 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
639 Note that options.c restricts max_identifier_length to not more
640 than GFC_MAX_SYMBOL_LEN. */
643 gfc_match_name (char *buffer
)
649 old_loc
= gfc_current_locus
;
650 gfc_gobble_whitespace ();
652 c
= gfc_next_ascii_char ();
653 if (!(ISALPHA (c
) || (c
== '_' && flag_allow_leading_underscore
)))
655 /* Special cases for unary minus and plus, which allows for a sensible
656 error message for code of the form 'c = exp(-a*b) )' where an
657 extra ')' appears at the end of statement. */
658 if (!gfc_error_flag_test () && c
!= '(' && c
!= '-' && c
!= '+')
659 gfc_error ("Invalid character in name at %C");
660 gfc_current_locus
= old_loc
;
670 if (i
> gfc_option
.max_identifier_length
)
672 gfc_error ("Name at %C is too long");
676 old_loc
= gfc_current_locus
;
677 c
= gfc_next_ascii_char ();
679 while (ISALNUM (c
) || c
== '_' || (flag_dollar_ok
&& c
== '$'));
681 if (c
== '$' && !flag_dollar_ok
)
683 gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to "
684 "allow it as an extension", &old_loc
);
689 gfc_current_locus
= old_loc
;
695 /* Match a symbol on the input. Modifies the pointer to the symbol
696 pointer if successful. */
699 gfc_match_sym_tree (gfc_symtree
**matched_symbol
, int host_assoc
)
701 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
704 m
= gfc_match_name (buffer
);
709 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
710 ? MATCH_ERROR
: MATCH_YES
;
712 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
, false))
720 gfc_match_symbol (gfc_symbol
**matched_symbol
, int host_assoc
)
725 m
= gfc_match_sym_tree (&st
, host_assoc
);
730 *matched_symbol
= st
->n
.sym
;
732 *matched_symbol
= NULL
;
735 *matched_symbol
= NULL
;
740 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
741 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
745 gfc_match_intrinsic_op (gfc_intrinsic_op
*result
)
747 locus orig_loc
= gfc_current_locus
;
750 gfc_gobble_whitespace ();
751 ch
= gfc_next_ascii_char ();
756 *result
= INTRINSIC_PLUS
;
761 *result
= INTRINSIC_MINUS
;
765 if (gfc_next_ascii_char () == '=')
768 *result
= INTRINSIC_EQ
;
774 if (gfc_peek_ascii_char () == '=')
777 gfc_next_ascii_char ();
778 *result
= INTRINSIC_LE
;
782 *result
= INTRINSIC_LT
;
786 if (gfc_peek_ascii_char () == '=')
789 gfc_next_ascii_char ();
790 *result
= INTRINSIC_GE
;
794 *result
= INTRINSIC_GT
;
798 if (gfc_peek_ascii_char () == '*')
801 gfc_next_ascii_char ();
802 *result
= INTRINSIC_POWER
;
806 *result
= INTRINSIC_TIMES
;
810 ch
= gfc_peek_ascii_char ();
814 gfc_next_ascii_char ();
815 *result
= INTRINSIC_NE
;
821 gfc_next_ascii_char ();
822 *result
= INTRINSIC_CONCAT
;
826 *result
= INTRINSIC_DIVIDE
;
830 ch
= gfc_next_ascii_char ();
834 if (gfc_next_ascii_char () == 'n'
835 && gfc_next_ascii_char () == 'd'
836 && gfc_next_ascii_char () == '.')
838 /* Matched ".and.". */
839 *result
= INTRINSIC_AND
;
845 if (gfc_next_ascii_char () == 'q')
847 ch
= gfc_next_ascii_char ();
850 /* Matched ".eq.". */
851 *result
= INTRINSIC_EQ_OS
;
856 if (gfc_next_ascii_char () == '.')
858 /* Matched ".eqv.". */
859 *result
= INTRINSIC_EQV
;
867 ch
= gfc_next_ascii_char ();
870 if (gfc_next_ascii_char () == '.')
872 /* Matched ".ge.". */
873 *result
= INTRINSIC_GE_OS
;
879 if (gfc_next_ascii_char () == '.')
881 /* Matched ".gt.". */
882 *result
= INTRINSIC_GT_OS
;
889 ch
= gfc_next_ascii_char ();
892 if (gfc_next_ascii_char () == '.')
894 /* Matched ".le.". */
895 *result
= INTRINSIC_LE_OS
;
901 if (gfc_next_ascii_char () == '.')
903 /* Matched ".lt.". */
904 *result
= INTRINSIC_LT_OS
;
911 ch
= gfc_next_ascii_char ();
914 ch
= gfc_next_ascii_char ();
917 /* Matched ".ne.". */
918 *result
= INTRINSIC_NE_OS
;
923 if (gfc_next_ascii_char () == 'v'
924 && gfc_next_ascii_char () == '.')
926 /* Matched ".neqv.". */
927 *result
= INTRINSIC_NEQV
;
934 if (gfc_next_ascii_char () == 't'
935 && gfc_next_ascii_char () == '.')
937 /* Matched ".not.". */
938 *result
= INTRINSIC_NOT
;
945 if (gfc_next_ascii_char () == 'r'
946 && gfc_next_ascii_char () == '.')
948 /* Matched ".or.". */
949 *result
= INTRINSIC_OR
;
955 if (gfc_next_ascii_char () == 'o'
956 && gfc_next_ascii_char () == 'r'
957 && gfc_next_ascii_char () == '.')
959 if (!gfc_notify_std (GFC_STD_LEGACY
, ".XOR. operator at %C"))
961 /* Matched ".xor." - equivalent to ".neqv.". */
962 *result
= INTRINSIC_NEQV
;
976 gfc_current_locus
= orig_loc
;
981 /* Match a loop control phrase:
983 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
985 If the final integer expression is not present, a constant unity
986 expression is returned. We don't return MATCH_ERROR until after
987 the equals sign is seen. */
990 gfc_match_iterator (gfc_iterator
*iter
, int init_flag
)
992 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
993 gfc_expr
*var
, *e1
, *e2
, *e3
;
999 /* Match the start of an iterator without affecting the symbol table. */
1001 start
= gfc_current_locus
;
1002 m
= gfc_match (" %n =", name
);
1003 gfc_current_locus
= start
;
1008 m
= gfc_match_variable (&var
, 0);
1012 if (var
->symtree
->n
.sym
->attr
.dimension
)
1014 gfc_error ("Loop variable at %C cannot be an array");
1018 /* F2008, C617 & C565. */
1019 if (var
->symtree
->n
.sym
->attr
.codimension
)
1021 gfc_error ("Loop variable at %C cannot be a coarray");
1025 if (var
->ref
!= NULL
)
1027 gfc_error ("Loop variable at %C cannot be a sub-component");
1031 gfc_match_char ('=');
1033 var
->symtree
->n
.sym
->attr
.implied_index
= 1;
1035 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
1038 if (m
== MATCH_ERROR
)
1041 if (gfc_match_char (',') != MATCH_YES
)
1044 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
1047 if (m
== MATCH_ERROR
)
1050 if (gfc_match_char (',') != MATCH_YES
)
1052 e3
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1056 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
1057 if (m
== MATCH_ERROR
)
1061 gfc_error ("Expected a step value in iterator at %C");
1073 gfc_error ("Syntax error in iterator at %C");
1084 /* Tries to match the next non-whitespace character on the input.
1085 This subroutine does not return MATCH_ERROR. */
1088 gfc_match_char (char c
)
1092 where
= gfc_current_locus
;
1093 gfc_gobble_whitespace ();
1095 if (gfc_next_ascii_char () == c
)
1098 gfc_current_locus
= where
;
1103 /* General purpose matching subroutine. The target string is a
1104 scanf-like format string in which spaces correspond to arbitrary
1105 whitespace (including no whitespace), characters correspond to
1106 themselves. The %-codes are:
1108 %% Literal percent sign
1109 %e Expression, pointer to a pointer is set
1110 %s Symbol, pointer to the symbol is set
1111 %n Name, character buffer is set to name
1112 %t Matches end of statement.
1113 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1114 %l Matches a statement label
1115 %v Matches a variable expression (an lvalue)
1116 % Matches a required space (in free form) and optional spaces. */
1119 gfc_match (const char *target
, ...)
1121 gfc_st_label
**label
;
1130 old_loc
= gfc_current_locus
;
1131 va_start (argp
, target
);
1141 gfc_gobble_whitespace ();
1152 vp
= va_arg (argp
, void **);
1153 n
= gfc_match_expr ((gfc_expr
**) vp
);
1164 vp
= va_arg (argp
, void **);
1165 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
1176 vp
= va_arg (argp
, void **);
1177 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
1188 np
= va_arg (argp
, char *);
1189 n
= gfc_match_name (np
);
1200 label
= va_arg (argp
, gfc_st_label
**);
1201 n
= gfc_match_st_label (label
);
1212 ip
= va_arg (argp
, int *);
1213 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
1224 if (gfc_match_eos () != MATCH_YES
)
1232 if (gfc_match_space () == MATCH_YES
)
1238 break; /* Fall through to character matcher. */
1241 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
1247 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1248 expect an upper case character here! */
1249 gcc_assert (TOLOWER (c
) == c
);
1251 if (c
== gfc_next_ascii_char ())
1261 /* Clean up after a failed match. */
1262 gfc_current_locus
= old_loc
;
1263 va_start (argp
, target
);
1266 for (; matches
> 0; matches
--)
1268 while (*p
++ != '%');
1276 /* Matches that don't have to be undone */
1281 (void) va_arg (argp
, void **);
1286 vp
= va_arg (argp
, void **);
1287 gfc_free_expr ((struct gfc_expr
*)*vp
);
1300 /*********************** Statement level matching **********************/
1302 /* Matches the start of a program unit, which is the program keyword
1303 followed by an obligatory symbol. */
1306 gfc_match_program (void)
1311 m
= gfc_match ("% %s%t", &sym
);
1315 gfc_error ("Invalid form of PROGRAM statement at %C");
1319 if (m
== MATCH_ERROR
)
1322 if (!gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
))
1325 gfc_new_block
= sym
;
1331 /* Match a simple assignment statement. */
1334 gfc_match_assignment (void)
1336 gfc_expr
*lvalue
, *rvalue
;
1340 old_loc
= gfc_current_locus
;
1343 m
= gfc_match (" %v =", &lvalue
);
1346 gfc_current_locus
= old_loc
;
1347 gfc_free_expr (lvalue
);
1352 m
= gfc_match (" %e%t", &rvalue
);
1355 gfc_current_locus
= old_loc
;
1356 gfc_free_expr (lvalue
);
1357 gfc_free_expr (rvalue
);
1361 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1363 new_st
.op
= EXEC_ASSIGN
;
1364 new_st
.expr1
= lvalue
;
1365 new_st
.expr2
= rvalue
;
1367 gfc_check_do_variable (lvalue
->symtree
);
1369 if (lvalue
->ts
.type
== BT_CLASS
)
1370 gfc_find_vtab (&rvalue
->ts
);
1376 /* Match a pointer assignment statement. */
1379 gfc_match_pointer_assignment (void)
1381 gfc_expr
*lvalue
, *rvalue
;
1385 old_loc
= gfc_current_locus
;
1387 lvalue
= rvalue
= NULL
;
1388 gfc_matching_ptr_assignment
= 0;
1389 gfc_matching_procptr_assignment
= 0;
1391 m
= gfc_match (" %v =>", &lvalue
);
1398 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1399 || gfc_is_proc_ptr_comp (lvalue
))
1400 gfc_matching_procptr_assignment
= 1;
1402 gfc_matching_ptr_assignment
= 1;
1404 m
= gfc_match (" %e%t", &rvalue
);
1405 gfc_matching_ptr_assignment
= 0;
1406 gfc_matching_procptr_assignment
= 0;
1410 new_st
.op
= EXEC_POINTER_ASSIGN
;
1411 new_st
.expr1
= lvalue
;
1412 new_st
.expr2
= rvalue
;
1417 gfc_current_locus
= old_loc
;
1418 gfc_free_expr (lvalue
);
1419 gfc_free_expr (rvalue
);
1424 /* We try to match an easy arithmetic IF statement. This only happens
1425 when just after having encountered a simple IF statement. This code
1426 is really duplicate with parts of the gfc_match_if code, but this is
1430 match_arithmetic_if (void)
1432 gfc_st_label
*l1
, *l2
, *l3
;
1436 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1440 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1441 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1442 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1444 gfc_free_expr (expr
);
1448 if (!gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
1449 "Arithmetic IF statement at %C"))
1452 new_st
.op
= EXEC_ARITHMETIC_IF
;
1453 new_st
.expr1
= expr
;
1462 /* The IF statement is a bit of a pain. First of all, there are three
1463 forms of it, the simple IF, the IF that starts a block and the
1466 There is a problem with the simple IF and that is the fact that we
1467 only have a single level of undo information on symbols. What this
1468 means is for a simple IF, we must re-match the whole IF statement
1469 multiple times in order to guarantee that the symbol table ends up
1470 in the proper state. */
1472 static match
match_simple_forall (void);
1473 static match
match_simple_where (void);
1476 gfc_match_if (gfc_statement
*if_type
)
1479 gfc_st_label
*l1
, *l2
, *l3
;
1480 locus old_loc
, old_loc2
;
1484 n
= gfc_match_label ();
1485 if (n
== MATCH_ERROR
)
1488 old_loc
= gfc_current_locus
;
1490 m
= gfc_match (" if ( %e", &expr
);
1494 old_loc2
= gfc_current_locus
;
1495 gfc_current_locus
= old_loc
;
1497 if (gfc_match_parens () == MATCH_ERROR
)
1500 gfc_current_locus
= old_loc2
;
1502 if (gfc_match_char (')') != MATCH_YES
)
1504 gfc_error ("Syntax error in IF-expression at %C");
1505 gfc_free_expr (expr
);
1509 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1515 gfc_error ("Block label not appropriate for arithmetic IF "
1517 gfc_free_expr (expr
);
1521 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1522 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1523 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1525 gfc_free_expr (expr
);
1529 if (!gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
1530 "Arithmetic IF statement at %C"))
1533 new_st
.op
= EXEC_ARITHMETIC_IF
;
1534 new_st
.expr1
= expr
;
1539 *if_type
= ST_ARITHMETIC_IF
;
1543 if (gfc_match (" then%t") == MATCH_YES
)
1545 new_st
.op
= EXEC_IF
;
1546 new_st
.expr1
= expr
;
1547 *if_type
= ST_IF_BLOCK
;
1553 gfc_error ("Block label is not appropriate for IF statement at %C");
1554 gfc_free_expr (expr
);
1558 /* At this point the only thing left is a simple IF statement. At
1559 this point, n has to be MATCH_NO, so we don't have to worry about
1560 re-matching a block label. From what we've got so far, try
1561 matching an assignment. */
1563 *if_type
= ST_SIMPLE_IF
;
1565 m
= gfc_match_assignment ();
1569 gfc_free_expr (expr
);
1570 gfc_undo_symbols ();
1571 gfc_current_locus
= old_loc
;
1573 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1574 assignment was found. For MATCH_NO, continue to call the various
1576 if (m
== MATCH_ERROR
)
1579 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1581 m
= gfc_match_pointer_assignment ();
1585 gfc_free_expr (expr
);
1586 gfc_undo_symbols ();
1587 gfc_current_locus
= old_loc
;
1589 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1591 /* Look at the next keyword to see which matcher to call. Matching
1592 the keyword doesn't affect the symbol table, so we don't have to
1593 restore between tries. */
1595 #define match(string, subr, statement) \
1596 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1600 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1601 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1602 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1603 match ("call", gfc_match_call
, ST_CALL
)
1604 match ("change team", gfc_match_change_team
, ST_CHANGE_TEAM
)
1605 match ("close", gfc_match_close
, ST_CLOSE
)
1606 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1607 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1608 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1609 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1610 match ("end team", gfc_match_end_team
, ST_END_TEAM
)
1611 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
)
1612 match ("event post", gfc_match_event_post
, ST_EVENT_POST
)
1613 match ("event wait", gfc_match_event_wait
, ST_EVENT_WAIT
)
1614 match ("exit", gfc_match_exit
, ST_EXIT
)
1615 match ("fail image", gfc_match_fail_image
, ST_FAIL_IMAGE
)
1616 match ("flush", gfc_match_flush
, ST_FLUSH
)
1617 match ("forall", match_simple_forall
, ST_FORALL
)
1618 match ("form team", gfc_match_form_team
, ST_FORM_TEAM
)
1619 match ("go to", gfc_match_goto
, ST_GOTO
)
1620 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1621 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1622 match ("lock", gfc_match_lock
, ST_LOCK
)
1623 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1624 match ("open", gfc_match_open
, ST_OPEN
)
1625 match ("pause", gfc_match_pause
, ST_NONE
)
1626 match ("print", gfc_match_print
, ST_WRITE
)
1627 match ("read", gfc_match_read
, ST_READ
)
1628 match ("return", gfc_match_return
, ST_RETURN
)
1629 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1630 match ("stop", gfc_match_stop
, ST_STOP
)
1631 match ("wait", gfc_match_wait
, ST_WAIT
)
1632 match ("sync all", gfc_match_sync_all
, ST_SYNC_CALL
);
1633 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
1634 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
1635 match ("sync team", gfc_match_sync_team
, ST_SYNC_TEAM
)
1636 match ("unlock", gfc_match_unlock
, ST_UNLOCK
)
1637 match ("where", match_simple_where
, ST_WHERE
)
1638 match ("write", gfc_match_write
, ST_WRITE
)
1641 match ("type", gfc_match_print
, ST_WRITE
)
1643 /* The gfc_match_assignment() above may have returned a MATCH_NO
1644 where the assignment was to a named constant. Check that
1645 special case here. */
1646 m
= gfc_match_assignment ();
1649 gfc_error ("Cannot assign to a named constant at %C");
1650 gfc_free_expr (expr
);
1651 gfc_undo_symbols ();
1652 gfc_current_locus
= old_loc
;
1656 /* All else has failed, so give up. See if any of the matchers has
1657 stored an error message of some sort. */
1658 if (!gfc_error_check ())
1659 gfc_error ("Unclassifiable statement in IF-clause at %C");
1661 gfc_free_expr (expr
);
1666 gfc_error ("Syntax error in IF-clause at %C");
1669 gfc_free_expr (expr
);
1673 /* At this point, we've matched the single IF and the action clause
1674 is in new_st. Rearrange things so that the IF statement appears
1677 p
= gfc_get_code (EXEC_IF
);
1678 p
->next
= XCNEW (gfc_code
);
1680 p
->next
->loc
= gfc_current_locus
;
1684 gfc_clear_new_st ();
1686 new_st
.op
= EXEC_IF
;
1695 /* Match an ELSE statement. */
1698 gfc_match_else (void)
1700 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1702 if (gfc_match_eos () == MATCH_YES
)
1705 if (gfc_match_name (name
) != MATCH_YES
1706 || gfc_current_block () == NULL
1707 || gfc_match_eos () != MATCH_YES
)
1709 gfc_error ("Unexpected junk after ELSE statement at %C");
1713 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1715 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1716 name
, gfc_current_block ()->name
);
1724 /* Match an ELSE IF statement. */
1727 gfc_match_elseif (void)
1729 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1733 m
= gfc_match (" ( %e ) then", &expr
);
1737 if (gfc_match_eos () == MATCH_YES
)
1740 if (gfc_match_name (name
) != MATCH_YES
1741 || gfc_current_block () == NULL
1742 || gfc_match_eos () != MATCH_YES
)
1744 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1748 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1750 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1751 name
, gfc_current_block ()->name
);
1756 new_st
.op
= EXEC_IF
;
1757 new_st
.expr1
= expr
;
1761 gfc_free_expr (expr
);
1766 /* Free a gfc_iterator structure. */
1769 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1775 gfc_free_expr (iter
->var
);
1776 gfc_free_expr (iter
->start
);
1777 gfc_free_expr (iter
->end
);
1778 gfc_free_expr (iter
->step
);
1785 /* Match a CRITICAL statement. */
1787 gfc_match_critical (void)
1789 gfc_st_label
*label
= NULL
;
1791 if (gfc_match_label () == MATCH_ERROR
)
1794 if (gfc_match (" critical") != MATCH_YES
)
1797 if (gfc_match_st_label (&label
) == MATCH_ERROR
)
1800 if (gfc_match_eos () != MATCH_YES
)
1802 gfc_syntax_error (ST_CRITICAL
);
1806 if (gfc_pure (NULL
))
1808 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1812 if (gfc_find_state (COMP_DO_CONCURRENT
))
1814 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1819 gfc_unset_implicit_pure (NULL
);
1821 if (!gfc_notify_std (GFC_STD_F2008
, "CRITICAL statement at %C"))
1824 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1826 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1831 if (gfc_find_state (COMP_CRITICAL
))
1833 gfc_error ("Nested CRITICAL block at %C");
1837 new_st
.op
= EXEC_CRITICAL
;
1840 && !gfc_reference_st_label (label
, ST_LABEL_TARGET
))
1847 /* Match a BLOCK statement. */
1850 gfc_match_block (void)
1854 if (gfc_match_label () == MATCH_ERROR
)
1857 if (gfc_match (" block") != MATCH_YES
)
1860 /* For this to be a correct BLOCK statement, the line must end now. */
1861 m
= gfc_match_eos ();
1862 if (m
== MATCH_ERROR
)
1871 /* Match an ASSOCIATE statement. */
1874 gfc_match_associate (void)
1876 if (gfc_match_label () == MATCH_ERROR
)
1879 if (gfc_match (" associate") != MATCH_YES
)
1882 /* Match the association list. */
1883 if (gfc_match_char ('(') != MATCH_YES
)
1885 gfc_error ("Expected association list at %C");
1888 new_st
.ext
.block
.assoc
= NULL
;
1891 gfc_association_list
* newAssoc
= gfc_get_association_list ();
1892 gfc_association_list
* a
;
1894 /* Match the next association. */
1895 if (gfc_match (" %n =>", newAssoc
->name
) != MATCH_YES
)
1897 gfc_error ("Expected association at %C");
1898 goto assocListError
;
1901 if (gfc_match (" %e", &newAssoc
->target
) != MATCH_YES
)
1903 /* Have another go, allowing for procedure pointer selectors. */
1904 gfc_matching_procptr_assignment
= 1;
1905 if (gfc_match (" %e", &newAssoc
->target
) != MATCH_YES
)
1907 gfc_error ("Invalid association target at %C");
1908 goto assocListError
;
1910 gfc_matching_procptr_assignment
= 0;
1912 newAssoc
->where
= gfc_current_locus
;
1914 /* Check that the current name is not yet in the list. */
1915 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
1916 if (!strcmp (a
->name
, newAssoc
->name
))
1918 gfc_error ("Duplicate name %qs in association at %C",
1920 goto assocListError
;
1923 /* The target expression must not be coindexed. */
1924 if (gfc_is_coindexed (newAssoc
->target
))
1926 gfc_error ("Association target at %C must not be coindexed");
1927 goto assocListError
;
1930 /* The `variable' field is left blank for now; because the target is not
1931 yet resolved, we can't use gfc_has_vector_subscript to determine it
1932 for now. This is set during resolution. */
1934 /* Put it into the list. */
1935 newAssoc
->next
= new_st
.ext
.block
.assoc
;
1936 new_st
.ext
.block
.assoc
= newAssoc
;
1938 /* Try next one or end if closing parenthesis is found. */
1939 gfc_gobble_whitespace ();
1940 if (gfc_peek_char () == ')')
1942 if (gfc_match_char (',') != MATCH_YES
)
1944 gfc_error ("Expected %<)%> or %<,%> at %C");
1954 if (gfc_match_char (')') != MATCH_YES
)
1956 /* This should never happen as we peek above. */
1960 if (gfc_match_eos () != MATCH_YES
)
1962 gfc_error ("Junk after ASSOCIATE statement at %C");
1969 gfc_free_association_list (new_st
.ext
.block
.assoc
);
1974 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1975 an accessible derived type. */
1978 match_derived_type_spec (gfc_typespec
*ts
)
1980 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1982 gfc_symbol
*derived
, *der_type
;
1983 match m
= MATCH_YES
;
1984 gfc_actual_arglist
*decl_type_param_list
= NULL
;
1985 bool is_pdt_template
= false;
1987 old_locus
= gfc_current_locus
;
1989 if (gfc_match ("%n", name
) != MATCH_YES
)
1991 gfc_current_locus
= old_locus
;
1995 gfc_find_symbol (name
, NULL
, 1, &derived
);
1997 /* Match the PDT spec list, if there. */
1998 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
)
2000 gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &der_type
);
2001 is_pdt_template
= der_type
2002 && der_type
->attr
.flavor
== FL_DERIVED
2003 && der_type
->attr
.pdt_template
;
2006 if (is_pdt_template
)
2007 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
2009 if (m
== MATCH_ERROR
)
2011 gfc_free_actual_arglist (decl_type_param_list
);
2015 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
&& derived
->attr
.generic
)
2016 derived
= gfc_find_dt_in_generic (derived
);
2018 /* If this is a PDT, find the specific instance. */
2019 if (m
== MATCH_YES
&& is_pdt_template
)
2021 gfc_namespace
*old_ns
;
2023 old_ns
= gfc_current_ns
;
2024 while (gfc_current_ns
&& gfc_current_ns
->parent
)
2025 gfc_current_ns
= gfc_current_ns
->parent
;
2027 if (type_param_spec_list
)
2028 gfc_free_actual_arglist (type_param_spec_list
);
2029 m
= gfc_get_pdt_instance (decl_type_param_list
, &der_type
,
2030 &type_param_spec_list
);
2031 gfc_free_actual_arglist (decl_type_param_list
);
2036 gcc_assert (!derived
->attr
.pdt_template
&& derived
->attr
.pdt_type
);
2037 gfc_set_sym_referenced (derived
);
2039 gfc_current_ns
= old_ns
;
2042 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
2044 ts
->type
= BT_DERIVED
;
2045 ts
->u
.derived
= derived
;
2049 gfc_current_locus
= old_locus
;
2054 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2055 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2056 It only includes the intrinsic types from the Fortran 2003 standard
2057 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2058 the implicit_flag is not needed, so it was removed. Derived types are
2059 identified by their name alone. */
2062 gfc_match_type_spec (gfc_typespec
*ts
)
2066 char c
, name
[GFC_MAX_SYMBOL_LEN
+ 1];
2069 gfc_gobble_whitespace ();
2070 old_locus
= gfc_current_locus
;
2072 /* If c isn't [a-z], then return immediately. */
2073 c
= gfc_peek_ascii_char ();
2077 type_param_spec_list
= NULL
;
2079 if (match_derived_type_spec (ts
) == MATCH_YES
)
2081 /* Enforce F03:C401. */
2082 if (ts
->u
.derived
->attr
.abstract
)
2084 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
2085 ts
->u
.derived
->name
, &old_locus
);
2091 if (gfc_match ("integer") == MATCH_YES
)
2093 ts
->type
= BT_INTEGER
;
2094 ts
->kind
= gfc_default_integer_kind
;
2098 if (gfc_match ("double precision") == MATCH_YES
)
2101 ts
->kind
= gfc_default_double_kind
;
2105 if (gfc_match ("complex") == MATCH_YES
)
2107 ts
->type
= BT_COMPLEX
;
2108 ts
->kind
= gfc_default_complex_kind
;
2112 if (gfc_match ("character") == MATCH_YES
)
2114 ts
->type
= BT_CHARACTER
;
2116 m
= gfc_match_char_spec (ts
);
2117 if (ts
->u
.cl
&& ts
->u
.cl
->length
)
2118 gfc_resolve_expr (ts
->u
.cl
->length
);
2126 /* REAL is a real pain because it can be a type, intrinsic subprogram,
2127 or list item in a type-list of an OpenMP reduction clause. Need to
2128 differentiate REAL([KIND]=scalar-int-initialization-expr) from
2129 REAL(A,[KIND]) and REAL(KIND,A). Logically, when this code was
2130 written the use of LOGICAL as a type-spec or intrinsic subprogram
2133 m
= gfc_match (" %n", name
);
2135 && (strcmp (name
, "real") == 0 || strcmp (name
, "logical") == 0))
2144 ts
->kind
= gfc_default_real_kind
;
2148 ts
->type
= BT_LOGICAL
;
2149 ts
->kind
= gfc_default_logical_kind
;
2152 gfc_gobble_whitespace ();
2154 /* Prevent REAL*4, etc. */
2155 c
= gfc_peek_ascii_char ();
2158 gfc_error ("Invalid type-spec at %C");
2162 /* Found leading colon in REAL::, a trailing ')' in for example
2163 TYPE IS (REAL), or REAL, for an OpenMP list-item. */
2164 if (c
== ':' || c
== ')' || (flag_openmp
&& c
== ','))
2167 /* Found something other than the opening '(' in REAL(... */
2171 gfc_next_char (); /* Burn the '('. */
2173 /* Look for the optional KIND=. */
2174 where
= gfc_current_locus
;
2175 m
= gfc_match ("%n", name
);
2178 gfc_gobble_whitespace ();
2179 c
= gfc_next_char ();
2182 if (strcmp(name
, "a") == 0 || strcmp(name
, "l") == 0)
2184 else if (strcmp(name
, "kind") == 0)
2190 gfc_current_locus
= where
;
2193 gfc_current_locus
= where
;
2197 m
= gfc_match_init_expr (&e
);
2198 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
2201 /* If a comma appears, it is an intrinsic subprogram. */
2202 gfc_gobble_whitespace ();
2203 c
= gfc_peek_ascii_char ();
2210 /* If ')' appears, we have REAL(initialization-expr), here check for
2211 a scalar integer initialization-expr and valid kind parameter. */
2214 if (e
->ts
.type
!= BT_INTEGER
|| e
->rank
> 0)
2220 gfc_next_char (); /* Burn the ')'. */
2221 ts
->kind
= (int) mpz_get_si (e
->value
.integer
);
2222 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
2224 gfc_error ("Invalid type-spec at %C");
2234 /* If a type is not matched, simply return MATCH_NO. */
2235 gfc_current_locus
= old_locus
;
2240 gfc_gobble_whitespace ();
2242 /* This prevents INTEGER*4, etc. */
2243 if (gfc_peek_ascii_char () == '*')
2245 gfc_error ("Invalid type-spec at %C");
2249 m
= gfc_match_kind_spec (ts
, false);
2251 /* No kind specifier found. */
2259 /******************** FORALL subroutines ********************/
2261 /* Free a list of FORALL iterators. */
2264 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
2266 gfc_forall_iterator
*next
;
2271 gfc_free_expr (iter
->var
);
2272 gfc_free_expr (iter
->start
);
2273 gfc_free_expr (iter
->end
);
2274 gfc_free_expr (iter
->stride
);
2281 /* Match an iterator as part of a FORALL statement. The format is:
2283 <var> = <start>:<end>[:<stride>]
2285 On MATCH_NO, the caller tests for the possibility that there is a
2286 scalar mask expression. */
2289 match_forall_iterator (gfc_forall_iterator
**result
)
2291 gfc_forall_iterator
*iter
;
2295 where
= gfc_current_locus
;
2296 iter
= XCNEW (gfc_forall_iterator
);
2298 m
= gfc_match_expr (&iter
->var
);
2302 if (gfc_match_char ('=') != MATCH_YES
2303 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
2309 m
= gfc_match_expr (&iter
->start
);
2313 if (gfc_match_char (':') != MATCH_YES
)
2316 m
= gfc_match_expr (&iter
->end
);
2319 if (m
== MATCH_ERROR
)
2322 if (gfc_match_char (':') == MATCH_NO
)
2323 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2326 m
= gfc_match_expr (&iter
->stride
);
2329 if (m
== MATCH_ERROR
)
2333 /* Mark the iteration variable's symbol as used as a FORALL index. */
2334 iter
->var
->symtree
->n
.sym
->forall_index
= true;
2340 gfc_error ("Syntax error in FORALL iterator at %C");
2345 gfc_current_locus
= where
;
2346 gfc_free_forall_iterator (iter
);
2351 /* Match the header of a FORALL statement. */
2354 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
2356 gfc_forall_iterator
*head
, *tail
, *new_iter
;
2360 gfc_gobble_whitespace ();
2365 if (gfc_match_char ('(') != MATCH_YES
)
2368 m
= match_forall_iterator (&new_iter
);
2369 if (m
== MATCH_ERROR
)
2374 head
= tail
= new_iter
;
2378 if (gfc_match_char (',') != MATCH_YES
)
2381 m
= match_forall_iterator (&new_iter
);
2382 if (m
== MATCH_ERROR
)
2387 tail
->next
= new_iter
;
2392 /* Have to have a mask expression. */
2394 m
= gfc_match_expr (&msk
);
2397 if (m
== MATCH_ERROR
)
2403 if (gfc_match_char (')') == MATCH_NO
)
2411 gfc_syntax_error (ST_FORALL
);
2414 gfc_free_expr (msk
);
2415 gfc_free_forall_iterator (head
);
2420 /* Match the rest of a simple FORALL statement that follows an
2424 match_simple_forall (void)
2426 gfc_forall_iterator
*head
;
2435 m
= match_forall_header (&head
, &mask
);
2442 m
= gfc_match_assignment ();
2444 if (m
== MATCH_ERROR
)
2448 m
= gfc_match_pointer_assignment ();
2449 if (m
== MATCH_ERROR
)
2455 c
= XCNEW (gfc_code
);
2457 c
->loc
= gfc_current_locus
;
2459 if (gfc_match_eos () != MATCH_YES
)
2462 gfc_clear_new_st ();
2463 new_st
.op
= EXEC_FORALL
;
2464 new_st
.expr1
= mask
;
2465 new_st
.ext
.forall_iterator
= head
;
2466 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2467 new_st
.block
->next
= c
;
2472 gfc_syntax_error (ST_FORALL
);
2475 gfc_free_forall_iterator (head
);
2476 gfc_free_expr (mask
);
2482 /* Match a FORALL statement. */
2485 gfc_match_forall (gfc_statement
*st
)
2487 gfc_forall_iterator
*head
;
2496 m0
= gfc_match_label ();
2497 if (m0
== MATCH_ERROR
)
2500 m
= gfc_match (" forall");
2504 m
= match_forall_header (&head
, &mask
);
2505 if (m
== MATCH_ERROR
)
2510 if (gfc_match_eos () == MATCH_YES
)
2512 *st
= ST_FORALL_BLOCK
;
2513 new_st
.op
= EXEC_FORALL
;
2514 new_st
.expr1
= mask
;
2515 new_st
.ext
.forall_iterator
= head
;
2519 m
= gfc_match_assignment ();
2520 if (m
== MATCH_ERROR
)
2524 m
= gfc_match_pointer_assignment ();
2525 if (m
== MATCH_ERROR
)
2531 c
= XCNEW (gfc_code
);
2533 c
->loc
= gfc_current_locus
;
2535 gfc_clear_new_st ();
2536 new_st
.op
= EXEC_FORALL
;
2537 new_st
.expr1
= mask
;
2538 new_st
.ext
.forall_iterator
= head
;
2539 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2540 new_st
.block
->next
= c
;
2546 gfc_syntax_error (ST_FORALL
);
2549 gfc_free_forall_iterator (head
);
2550 gfc_free_expr (mask
);
2551 gfc_free_statements (c
);
2556 /* Match a DO statement. */
2561 gfc_iterator iter
, *ip
;
2563 gfc_st_label
*label
;
2566 old_loc
= gfc_current_locus
;
2568 memset (&iter
, '\0', sizeof (gfc_iterator
));
2571 m
= gfc_match_label ();
2572 if (m
== MATCH_ERROR
)
2575 if (gfc_match (" do") != MATCH_YES
)
2578 m
= gfc_match_st_label (&label
);
2579 if (m
== MATCH_ERROR
)
2582 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2584 if (gfc_match_eos () == MATCH_YES
)
2586 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
2587 new_st
.op
= EXEC_DO_WHILE
;
2591 /* Match an optional comma, if no comma is found, a space is obligatory. */
2592 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
2595 /* Check for balanced parens. */
2597 if (gfc_match_parens () == MATCH_ERROR
)
2600 if (gfc_match (" concurrent") == MATCH_YES
)
2602 gfc_forall_iterator
*head
;
2605 if (!gfc_notify_std (GFC_STD_F2008
, "DO CONCURRENT construct at %C"))
2611 m
= match_forall_header (&head
, &mask
);
2615 if (m
== MATCH_ERROR
)
2616 goto concurr_cleanup
;
2618 if (gfc_match_eos () != MATCH_YES
)
2619 goto concurr_cleanup
;
2622 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2623 goto concurr_cleanup
;
2625 new_st
.label1
= label
;
2626 new_st
.op
= EXEC_DO_CONCURRENT
;
2627 new_st
.expr1
= mask
;
2628 new_st
.ext
.forall_iterator
= head
;
2633 gfc_syntax_error (ST_DO
);
2634 gfc_free_expr (mask
);
2635 gfc_free_forall_iterator (head
);
2639 /* See if we have a DO WHILE. */
2640 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
2642 new_st
.op
= EXEC_DO_WHILE
;
2646 /* The abortive DO WHILE may have done something to the symbol
2647 table, so we start over. */
2648 gfc_undo_symbols ();
2649 gfc_current_locus
= old_loc
;
2651 gfc_match_label (); /* This won't error. */
2652 gfc_match (" do "); /* This will work. */
2654 gfc_match_st_label (&label
); /* Can't error out. */
2655 gfc_match_char (','); /* Optional comma. */
2657 m
= gfc_match_iterator (&iter
, 0);
2660 if (m
== MATCH_ERROR
)
2663 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
2664 gfc_check_do_variable (iter
.var
->symtree
);
2666 if (gfc_match_eos () != MATCH_YES
)
2668 gfc_syntax_error (ST_DO
);
2672 new_st
.op
= EXEC_DO
;
2676 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2679 new_st
.label1
= label
;
2681 if (new_st
.op
== EXEC_DO_WHILE
)
2682 new_st
.expr1
= iter
.end
;
2685 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
2692 gfc_free_iterator (&iter
, 0);
2698 /* Match an EXIT or CYCLE statement. */
2701 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2703 gfc_state_data
*p
, *o
;
2708 if (gfc_match_eos () == MATCH_YES
)
2712 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2715 m
= gfc_match ("% %n%t", name
);
2716 if (m
== MATCH_ERROR
)
2720 gfc_syntax_error (st
);
2724 /* Find the corresponding symbol. If there's a BLOCK statement
2725 between here and the label, it is not in gfc_current_ns but a parent
2727 stree
= gfc_find_symtree_in_proc (name
, gfc_current_ns
);
2730 gfc_error ("Name %qs in %s statement at %C is unknown",
2731 name
, gfc_ascii_statement (st
));
2736 if (sym
->attr
.flavor
!= FL_LABEL
)
2738 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2739 name
, gfc_ascii_statement (st
));
2744 /* Find the loop specified by the label (or lack of a label). */
2745 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2746 if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2748 else if (p
->state
== COMP_CRITICAL
)
2750 gfc_error("%s statement at %C leaves CRITICAL construct",
2751 gfc_ascii_statement (st
));
2754 else if (p
->state
== COMP_DO_CONCURRENT
2755 && (op
== EXEC_EXIT
|| (sym
&& sym
!= p
->sym
)))
2757 /* F2008, C821 & C845. */
2758 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2759 gfc_ascii_statement (st
));
2762 else if ((sym
&& sym
== p
->sym
)
2763 || (!sym
&& (p
->state
== COMP_DO
2764 || p
->state
== COMP_DO_CONCURRENT
)))
2770 gfc_error ("%s statement at %C is not within a construct",
2771 gfc_ascii_statement (st
));
2773 gfc_error ("%s statement at %C is not within construct %qs",
2774 gfc_ascii_statement (st
), sym
->name
);
2779 /* Special checks for EXIT from non-loop constructs. */
2783 case COMP_DO_CONCURRENT
:
2787 /* This is already handled above. */
2790 case COMP_ASSOCIATE
:
2794 case COMP_SELECT_TYPE
:
2796 if (op
== EXEC_CYCLE
)
2798 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2799 " construct %qs", sym
->name
);
2802 gcc_assert (op
== EXEC_EXIT
);
2803 if (!gfc_notify_std (GFC_STD_F2008
, "EXIT statement with no"
2804 " do-construct-name at %C"))
2809 gfc_error ("%s statement at %C is not applicable to construct %qs",
2810 gfc_ascii_statement (st
), sym
->name
);
2816 gfc_error (is_oacc (p
)
2817 ? G_("%s statement at %C leaving OpenACC structured block")
2818 : G_("%s statement at %C leaving OpenMP structured block"),
2819 gfc_ascii_statement (st
));
2823 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2827 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
2828 && (o
->head
->op
== EXEC_OACC_LOOP
2829 || o
->head
->op
== EXEC_OACC_PARALLEL_LOOP
))
2832 gcc_assert (o
->head
->next
!= NULL
2833 && (o
->head
->next
->op
== EXEC_DO
2834 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2835 && o
->previous
!= NULL
2836 && o
->previous
->tail
->op
== o
->head
->op
);
2837 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2838 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2839 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2840 if (st
== ST_EXIT
&& cnt
<= collapse
)
2842 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2845 if (st
== ST_CYCLE
&& cnt
< collapse
)
2847 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2848 " !$ACC LOOP loop");
2854 && (o
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2855 && (o
->head
->op
== EXEC_OMP_DO
2856 || o
->head
->op
== EXEC_OMP_PARALLEL_DO
2857 || o
->head
->op
== EXEC_OMP_SIMD
2858 || o
->head
->op
== EXEC_OMP_DO_SIMD
2859 || o
->head
->op
== EXEC_OMP_PARALLEL_DO_SIMD
))
2862 gcc_assert (o
->head
->next
!= NULL
2863 && (o
->head
->next
->op
== EXEC_DO
2864 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2865 && o
->previous
!= NULL
2866 && o
->previous
->tail
->op
== o
->head
->op
);
2867 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
)
2869 if (o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2870 count
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2871 if (o
->previous
->tail
->ext
.omp_clauses
->orderedc
)
2872 count
= o
->previous
->tail
->ext
.omp_clauses
->orderedc
;
2874 if (st
== ST_EXIT
&& cnt
<= count
)
2876 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2879 if (st
== ST_CYCLE
&& cnt
< count
)
2881 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2887 /* Save the first statement in the construct - needed by the backend. */
2888 new_st
.ext
.which_construct
= p
->construct
;
2896 /* Match the EXIT statement. */
2899 gfc_match_exit (void)
2901 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2905 /* Match the CYCLE statement. */
2908 gfc_match_cycle (void)
2910 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2914 /* Match a stop-code after an (ERROR) STOP or PAUSE statement. The
2915 requirements for a stop-code differ in the standards.
2919 R840 stop-stmt is STOP [ stop-code ]
2920 R841 stop-code is scalar-char-constant
2921 or digit [ digit [ digit [ digit [ digit ] ] ] ]
2923 Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
2926 R855 stop-stmt is STOP [ stop-code ]
2927 R856 allstop-stmt is ALL STOP [ stop-code ]
2928 R857 stop-code is scalar-default-char-constant-expr
2929 or scalar-int-constant-expr
2931 For free-form source code, all standards contain a statement of the form:
2933 A blank shall be used to separate names, constants, or labels from
2934 adjacent keywords, names, constants, or labels.
2936 A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003,
2940 is valid, but it is invalid Fortran 2008. */
2943 gfc_match_stopcode (gfc_statement st
)
2949 /* Set f95 for -std=f95. */
2950 f95
= (gfc_option
.allow_std
== GFC_STD_OPT_F95
);
2952 /* Set f03 for -std=f2003. */
2953 f03
= (gfc_option
.allow_std
== GFC_STD_OPT_F03
);
2955 /* Look for a blank between STOP and the stop-code for F2008 or later. */
2956 if (gfc_current_form
!= FORM_FIXED
&& !(f95
|| f03
))
2958 char c
= gfc_peek_ascii_char ();
2960 /* Look for end-of-statement. There is no stop-code. */
2961 if (c
== '\n' || c
== '!' || c
== ';')
2966 gfc_error ("Blank required in %s statement near %C",
2967 gfc_ascii_statement (st
));
2972 if (gfc_match_eos () != MATCH_YES
)
2977 /* First look for the F95 or F2003 digit [...] construct. */
2978 old_locus
= gfc_current_locus
;
2979 m
= gfc_match_small_int (&stopcode
);
2980 if (m
== MATCH_YES
&& (f95
|| f03
))
2984 gfc_error ("STOP code at %C cannot be negative");
2988 if (stopcode
> 99999)
2990 gfc_error ("STOP code at %C contains too many digits");
2995 /* Reset the locus and now load gfc_expr. */
2996 gfc_current_locus
= old_locus
;
2997 m
= gfc_match_expr (&e
);
2998 if (m
== MATCH_ERROR
)
3003 if (gfc_match_eos () != MATCH_YES
)
3007 if (gfc_pure (NULL
))
3009 if (st
== ST_ERROR_STOP
)
3011 if (!gfc_notify_std (GFC_STD_F2018
, "%s statement at %C in PURE "
3012 "procedure", gfc_ascii_statement (st
)))
3017 gfc_error ("%s statement not allowed in PURE procedure at %C",
3018 gfc_ascii_statement (st
));
3023 gfc_unset_implicit_pure (NULL
);
3025 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
))
3027 gfc_error ("Image control statement STOP at %C in CRITICAL block");
3030 if (st
== ST_STOP
&& gfc_find_state (COMP_DO_CONCURRENT
))
3032 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
3038 gfc_simplify_expr (e
, 0);
3040 /* Test for F95 and F2003 style STOP stop-code. */
3041 if (e
->expr_type
!= EXPR_CONSTANT
&& (f95
|| f03
))
3043 gfc_error ("STOP code at %L must be a scalar CHARACTER constant or "
3044 "digit[digit[digit[digit[digit]]]]", &e
->where
);
3048 /* Use the machinery for an initialization expression to reduce the
3049 stop-code to a constant. */
3050 gfc_init_expr_flag
= true;
3051 gfc_reduce_init_expr (e
);
3052 gfc_init_expr_flag
= false;
3054 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
3056 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
3063 gfc_error ("STOP code at %L must be scalar", &e
->where
);
3067 if (e
->ts
.type
== BT_CHARACTER
3068 && e
->ts
.kind
!= gfc_default_character_kind
)
3070 gfc_error ("STOP code at %L must be default character KIND=%d",
3071 &e
->where
, (int) gfc_default_character_kind
);
3075 if (e
->ts
.type
== BT_INTEGER
&& e
->ts
.kind
!= gfc_default_integer_kind
)
3077 gfc_error ("STOP code at %L must be default integer KIND=%d",
3078 &e
->where
, (int) gfc_default_integer_kind
);
3088 new_st
.op
= EXEC_STOP
;
3091 new_st
.op
= EXEC_ERROR_STOP
;
3094 new_st
.op
= EXEC_PAUSE
;
3101 new_st
.ext
.stop_code
= -1;
3106 gfc_syntax_error (st
);
3115 /* Match the (deprecated) PAUSE statement. */
3118 gfc_match_pause (void)
3122 m
= gfc_match_stopcode (ST_PAUSE
);
3125 if (!gfc_notify_std (GFC_STD_F95_DEL
, "PAUSE statement at %C"))
3132 /* Match the STOP statement. */
3135 gfc_match_stop (void)
3137 return gfc_match_stopcode (ST_STOP
);
3141 /* Match the ERROR STOP statement. */
3144 gfc_match_error_stop (void)
3146 if (!gfc_notify_std (GFC_STD_F2008
, "ERROR STOP statement at %C"))
3149 return gfc_match_stopcode (ST_ERROR_STOP
);
3152 /* Match EVENT POST/WAIT statement. Syntax:
3153 EVENT POST ( event-variable [, sync-stat-list] )
3154 EVENT WAIT ( event-variable [, wait-spec-list] )
3156 wait-spec-list is sync-stat-list or until-spec
3157 until-spec is UNTIL_COUNT = scalar-int-expr
3158 sync-stat is STAT= or ERRMSG=. */
3161 event_statement (gfc_statement st
)
3164 gfc_expr
*tmp
, *eventvar
, *until_count
, *stat
, *errmsg
;
3165 bool saw_until_count
, saw_stat
, saw_errmsg
;
3167 tmp
= eventvar
= until_count
= stat
= errmsg
= NULL
;
3168 saw_until_count
= saw_stat
= saw_errmsg
= false;
3170 if (gfc_pure (NULL
))
3172 gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
3173 st
== ST_EVENT_POST
? "POST" : "WAIT");
3177 gfc_unset_implicit_pure (NULL
);
3179 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3181 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3185 if (gfc_find_state (COMP_CRITICAL
))
3187 gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
3188 st
== ST_EVENT_POST
? "POST" : "WAIT");
3192 if (gfc_find_state (COMP_DO_CONCURRENT
))
3194 gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
3195 "block", st
== ST_EVENT_POST
? "POST" : "WAIT");
3199 if (gfc_match_char ('(') != MATCH_YES
)
3202 if (gfc_match ("%e", &eventvar
) != MATCH_YES
)
3204 m
= gfc_match_char (',');
3205 if (m
== MATCH_ERROR
)
3209 m
= gfc_match_char (')');
3217 m
= gfc_match (" stat = %v", &tmp
);
3218 if (m
== MATCH_ERROR
)
3224 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3230 m
= gfc_match_char (',');
3238 m
= gfc_match (" errmsg = %v", &tmp
);
3239 if (m
== MATCH_ERROR
)
3245 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3251 m
= gfc_match_char (',');
3259 m
= gfc_match (" until_count = %e", &tmp
);
3260 if (m
== MATCH_ERROR
|| st
== ST_EVENT_POST
)
3264 if (saw_until_count
)
3266 gfc_error ("Redundant UNTIL_COUNT tag found at %L",
3271 saw_until_count
= true;
3273 m
= gfc_match_char (',');
3284 if (m
== MATCH_ERROR
)
3287 if (gfc_match (" )%t") != MATCH_YES
)
3294 new_st
.op
= EXEC_EVENT_POST
;
3297 new_st
.op
= EXEC_EVENT_WAIT
;
3303 new_st
.expr1
= eventvar
;
3304 new_st
.expr2
= stat
;
3305 new_st
.expr3
= errmsg
;
3306 new_st
.expr4
= until_count
;
3311 gfc_syntax_error (st
);
3314 if (until_count
!= tmp
)
3315 gfc_free_expr (until_count
);
3317 gfc_free_expr (errmsg
);
3319 gfc_free_expr (stat
);
3321 gfc_free_expr (tmp
);
3322 gfc_free_expr (eventvar
);
3330 gfc_match_event_post (void)
3332 if (!gfc_notify_std (GFC_STD_F2018
, "EVENT POST statement at %C"))
3335 return event_statement (ST_EVENT_POST
);
3340 gfc_match_event_wait (void)
3342 if (!gfc_notify_std (GFC_STD_F2018
, "EVENT WAIT statement at %C"))
3345 return event_statement (ST_EVENT_WAIT
);
3349 /* Match a FAIL IMAGE statement. */
3352 gfc_match_fail_image (void)
3354 if (!gfc_notify_std (GFC_STD_F2018
, "FAIL IMAGE statement at %C"))
3357 if (gfc_match_char ('(') == MATCH_YES
)
3360 new_st
.op
= EXEC_FAIL_IMAGE
;
3365 gfc_syntax_error (ST_FAIL_IMAGE
);
3370 /* Match a FORM TEAM statement. */
3373 gfc_match_form_team (void)
3376 gfc_expr
*teamid
,*team
;
3378 if (!gfc_notify_std (GFC_STD_F2018
, "FORM TEAM statement at %C"))
3381 if (gfc_match_char ('(') == MATCH_NO
)
3384 new_st
.op
= EXEC_FORM_TEAM
;
3386 if (gfc_match ("%e", &teamid
) != MATCH_YES
)
3388 m
= gfc_match_char (',');
3389 if (m
== MATCH_ERROR
)
3391 if (gfc_match ("%e", &team
) != MATCH_YES
)
3394 m
= gfc_match_char (')');
3398 new_st
.expr1
= teamid
;
3399 new_st
.expr2
= team
;
3404 gfc_syntax_error (ST_FORM_TEAM
);
3409 /* Match a CHANGE TEAM statement. */
3412 gfc_match_change_team (void)
3417 if (!gfc_notify_std (GFC_STD_F2018
, "CHANGE TEAM statement at %C"))
3420 if (gfc_match_char ('(') == MATCH_NO
)
3423 new_st
.op
= EXEC_CHANGE_TEAM
;
3425 if (gfc_match ("%e", &team
) != MATCH_YES
)
3428 m
= gfc_match_char (')');
3432 new_st
.expr1
= team
;
3437 gfc_syntax_error (ST_CHANGE_TEAM
);
3442 /* Match a END TEAM statement. */
3445 gfc_match_end_team (void)
3447 if (!gfc_notify_std (GFC_STD_F2018
, "END TEAM statement at %C"))
3450 if (gfc_match_char ('(') == MATCH_YES
)
3453 new_st
.op
= EXEC_END_TEAM
;
3458 gfc_syntax_error (ST_END_TEAM
);
3463 /* Match a SYNC TEAM statement. */
3466 gfc_match_sync_team (void)
3471 if (!gfc_notify_std (GFC_STD_F2018
, "SYNC TEAM statement at %C"))
3474 if (gfc_match_char ('(') == MATCH_NO
)
3477 new_st
.op
= EXEC_SYNC_TEAM
;
3479 if (gfc_match ("%e", &team
) != MATCH_YES
)
3482 m
= gfc_match_char (')');
3486 new_st
.expr1
= team
;
3491 gfc_syntax_error (ST_SYNC_TEAM
);
3496 /* Match LOCK/UNLOCK statement. Syntax:
3497 LOCK ( lock-variable [ , lock-stat-list ] )
3498 UNLOCK ( lock-variable [ , sync-stat-list ] )
3499 where lock-stat is ACQUIRED_LOCK or sync-stat
3500 and sync-stat is STAT= or ERRMSG=. */
3503 lock_unlock_statement (gfc_statement st
)
3506 gfc_expr
*tmp
, *lockvar
, *acq_lock
, *stat
, *errmsg
;
3507 bool saw_acq_lock
, saw_stat
, saw_errmsg
;
3509 tmp
= lockvar
= acq_lock
= stat
= errmsg
= NULL
;
3510 saw_acq_lock
= saw_stat
= saw_errmsg
= false;
3512 if (gfc_pure (NULL
))
3514 gfc_error ("Image control statement %s at %C in PURE procedure",
3515 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3519 gfc_unset_implicit_pure (NULL
);
3521 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3523 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3527 if (gfc_find_state (COMP_CRITICAL
))
3529 gfc_error ("Image control statement %s at %C in CRITICAL block",
3530 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3534 if (gfc_find_state (COMP_DO_CONCURRENT
))
3536 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
3537 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3541 if (gfc_match_char ('(') != MATCH_YES
)
3544 if (gfc_match ("%e", &lockvar
) != MATCH_YES
)
3546 m
= gfc_match_char (',');
3547 if (m
== MATCH_ERROR
)
3551 m
= gfc_match_char (')');
3559 m
= gfc_match (" stat = %v", &tmp
);
3560 if (m
== MATCH_ERROR
)
3566 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3572 m
= gfc_match_char (',');
3580 m
= gfc_match (" errmsg = %v", &tmp
);
3581 if (m
== MATCH_ERROR
)
3587 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3593 m
= gfc_match_char (',');
3601 m
= gfc_match (" acquired_lock = %v", &tmp
);
3602 if (m
== MATCH_ERROR
|| st
== ST_UNLOCK
)
3608 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L",
3613 saw_acq_lock
= true;
3615 m
= gfc_match_char (',');
3626 if (m
== MATCH_ERROR
)
3629 if (gfc_match (" )%t") != MATCH_YES
)
3636 new_st
.op
= EXEC_LOCK
;
3639 new_st
.op
= EXEC_UNLOCK
;
3645 new_st
.expr1
= lockvar
;
3646 new_st
.expr2
= stat
;
3647 new_st
.expr3
= errmsg
;
3648 new_st
.expr4
= acq_lock
;
3653 gfc_syntax_error (st
);
3656 if (acq_lock
!= tmp
)
3657 gfc_free_expr (acq_lock
);
3659 gfc_free_expr (errmsg
);
3661 gfc_free_expr (stat
);
3663 gfc_free_expr (tmp
);
3664 gfc_free_expr (lockvar
);
3671 gfc_match_lock (void)
3673 if (!gfc_notify_std (GFC_STD_F2008
, "LOCK statement at %C"))
3676 return lock_unlock_statement (ST_LOCK
);
3681 gfc_match_unlock (void)
3683 if (!gfc_notify_std (GFC_STD_F2008
, "UNLOCK statement at %C"))
3686 return lock_unlock_statement (ST_UNLOCK
);
3690 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
3691 SYNC ALL [(sync-stat-list)]
3692 SYNC MEMORY [(sync-stat-list)]
3693 SYNC IMAGES (image-set [, sync-stat-list] )
3694 with sync-stat is int-expr or *. */
3697 sync_statement (gfc_statement st
)
3700 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
3701 bool saw_stat
, saw_errmsg
;
3703 tmp
= imageset
= stat
= errmsg
= NULL
;
3704 saw_stat
= saw_errmsg
= false;
3706 if (gfc_pure (NULL
))
3708 gfc_error ("Image control statement SYNC at %C in PURE procedure");
3712 gfc_unset_implicit_pure (NULL
);
3714 if (!gfc_notify_std (GFC_STD_F2008
, "SYNC statement at %C"))
3717 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3719 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
3724 if (gfc_find_state (COMP_CRITICAL
))
3726 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3730 if (gfc_find_state (COMP_DO_CONCURRENT
))
3732 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3736 if (gfc_match_eos () == MATCH_YES
)
3738 if (st
== ST_SYNC_IMAGES
)
3743 if (gfc_match_char ('(') != MATCH_YES
)
3746 if (st
== ST_SYNC_IMAGES
)
3748 /* Denote '*' as imageset == NULL. */
3749 m
= gfc_match_char ('*');
3750 if (m
== MATCH_ERROR
)
3754 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
3757 m
= gfc_match_char (',');
3758 if (m
== MATCH_ERROR
)
3762 m
= gfc_match_char (')');
3771 m
= gfc_match (" stat = %v", &tmp
);
3772 if (m
== MATCH_ERROR
)
3778 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3784 if (gfc_match_char (',') == MATCH_YES
)
3791 m
= gfc_match (" errmsg = %v", &tmp
);
3792 if (m
== MATCH_ERROR
)
3798 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3804 if (gfc_match_char (',') == MATCH_YES
)
3814 if (gfc_match (" )%t") != MATCH_YES
)
3821 new_st
.op
= EXEC_SYNC_ALL
;
3823 case ST_SYNC_IMAGES
:
3824 new_st
.op
= EXEC_SYNC_IMAGES
;
3826 case ST_SYNC_MEMORY
:
3827 new_st
.op
= EXEC_SYNC_MEMORY
;
3833 new_st
.expr1
= imageset
;
3834 new_st
.expr2
= stat
;
3835 new_st
.expr3
= errmsg
;
3840 gfc_syntax_error (st
);
3844 gfc_free_expr (stat
);
3846 gfc_free_expr (errmsg
);
3848 gfc_free_expr (tmp
);
3849 gfc_free_expr (imageset
);
3855 /* Match SYNC ALL statement. */
3858 gfc_match_sync_all (void)
3860 return sync_statement (ST_SYNC_ALL
);
3864 /* Match SYNC IMAGES statement. */
3867 gfc_match_sync_images (void)
3869 return sync_statement (ST_SYNC_IMAGES
);
3873 /* Match SYNC MEMORY statement. */
3876 gfc_match_sync_memory (void)
3878 return sync_statement (ST_SYNC_MEMORY
);
3882 /* Match a CONTINUE statement. */
3885 gfc_match_continue (void)
3887 if (gfc_match_eos () != MATCH_YES
)
3889 gfc_syntax_error (ST_CONTINUE
);
3893 new_st
.op
= EXEC_CONTINUE
;
3898 /* Match the (deprecated) ASSIGN statement. */
3901 gfc_match_assign (void)
3904 gfc_st_label
*label
;
3906 if (gfc_match (" %l", &label
) == MATCH_YES
)
3908 if (!gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
))
3910 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
3912 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGN statement at %C"))
3915 expr
->symtree
->n
.sym
->attr
.assign
= 1;
3917 new_st
.op
= EXEC_LABEL_ASSIGN
;
3918 new_st
.label1
= label
;
3919 new_st
.expr1
= expr
;
3927 /* Match the GO TO statement. As a computed GOTO statement is
3928 matched, it is transformed into an equivalent SELECT block. No
3929 tree is necessary, and the resulting jumps-to-jumps are
3930 specifically optimized away by the back end. */
3933 gfc_match_goto (void)
3935 gfc_code
*head
, *tail
;
3938 gfc_st_label
*label
;
3942 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
3944 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3947 new_st
.op
= EXEC_GOTO
;
3948 new_st
.label1
= label
;
3952 /* The assigned GO TO statement. */
3954 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
3956 if (!gfc_notify_std (GFC_STD_F95_DEL
, "Assigned GOTO statement at %C"))
3959 new_st
.op
= EXEC_GOTO
;
3960 new_st
.expr1
= expr
;
3962 if (gfc_match_eos () == MATCH_YES
)
3965 /* Match label list. */
3966 gfc_match_char (',');
3967 if (gfc_match_char ('(') != MATCH_YES
)
3969 gfc_syntax_error (ST_GOTO
);
3976 m
= gfc_match_st_label (&label
);
3980 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3984 head
= tail
= gfc_get_code (EXEC_GOTO
);
3987 tail
->block
= gfc_get_code (EXEC_GOTO
);
3991 tail
->label1
= label
;
3993 while (gfc_match_char (',') == MATCH_YES
);
3995 if (gfc_match (")%t") != MATCH_YES
)
4000 gfc_error ("Statement label list in GOTO at %C cannot be empty");
4003 new_st
.block
= head
;
4008 /* Last chance is a computed GO TO statement. */
4009 if (gfc_match_char ('(') != MATCH_YES
)
4011 gfc_syntax_error (ST_GOTO
);
4020 m
= gfc_match_st_label (&label
);
4024 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
4028 head
= tail
= gfc_get_code (EXEC_SELECT
);
4031 tail
->block
= gfc_get_code (EXEC_SELECT
);
4035 cp
= gfc_get_case ();
4036 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
4039 tail
->ext
.block
.case_list
= cp
;
4041 tail
->next
= gfc_get_code (EXEC_GOTO
);
4042 tail
->next
->label1
= label
;
4044 while (gfc_match_char (',') == MATCH_YES
);
4046 if (gfc_match_char (')') != MATCH_YES
)
4051 gfc_error ("Statement label list in GOTO at %C cannot be empty");
4055 /* Get the rest of the statement. */
4056 gfc_match_char (',');
4058 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
4061 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Computed GOTO at %C"))
4064 /* At this point, a computed GOTO has been fully matched and an
4065 equivalent SELECT statement constructed. */
4067 new_st
.op
= EXEC_SELECT
;
4068 new_st
.expr1
= NULL
;
4070 /* Hack: For a "real" SELECT, the expression is in expr. We put
4071 it in expr2 so we can distinguish then and produce the correct
4073 new_st
.expr2
= expr
;
4074 new_st
.block
= head
;
4078 gfc_syntax_error (ST_GOTO
);
4080 gfc_free_statements (head
);
4085 /* Frees a list of gfc_alloc structures. */
4088 gfc_free_alloc_list (gfc_alloc
*p
)
4095 gfc_free_expr (p
->expr
);
4101 /* Match an ALLOCATE statement. */
4104 gfc_match_allocate (void)
4106 gfc_alloc
*head
, *tail
;
4107 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
4111 locus old_locus
, deferred_locus
, assumed_locus
;
4112 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, saw_deferred
, b1
, b2
, b3
;
4113 bool saw_unlimited
= false, saw_assumed
= false;
4116 stat
= errmsg
= source
= mold
= tmp
= NULL
;
4117 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= saw_deferred
= false;
4119 if (gfc_match_char ('(') != MATCH_YES
)
4121 gfc_syntax_error (ST_ALLOCATE
);
4125 /* Match an optional type-spec. */
4126 old_locus
= gfc_current_locus
;
4127 m
= gfc_match_type_spec (&ts
);
4128 if (m
== MATCH_ERROR
)
4130 else if (m
== MATCH_NO
)
4132 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
4134 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
4136 gfc_error ("Error in type-spec at %L", &old_locus
);
4140 ts
.type
= BT_UNKNOWN
;
4144 /* Needed for the F2008:C631 check below. */
4145 assumed_locus
= gfc_current_locus
;
4147 if (gfc_match (" :: ") == MATCH_YES
)
4149 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
4155 gfc_error ("Type-spec at %L cannot contain a deferred "
4156 "type parameter", &old_locus
);
4160 if (ts
.type
== BT_CHARACTER
)
4162 if (!ts
.u
.cl
->length
)
4165 ts
.u
.cl
->length_from_typespec
= true;
4168 if (type_param_spec_list
4169 && gfc_spec_list_type (type_param_spec_list
, NULL
)
4172 gfc_error ("The type parameter spec list in the type-spec at "
4173 "%L cannot contain DEFERRED parameters", &old_locus
);
4179 ts
.type
= BT_UNKNOWN
;
4180 gfc_current_locus
= old_locus
;
4187 head
= tail
= gfc_get_alloc ();
4190 tail
->next
= gfc_get_alloc ();
4194 m
= gfc_match_variable (&tail
->expr
, 0);
4197 if (m
== MATCH_ERROR
)
4200 if (gfc_check_do_variable (tail
->expr
->symtree
))
4203 bool impure
= gfc_impure_variable (tail
->expr
->symtree
->n
.sym
);
4204 if (impure
&& gfc_pure (NULL
))
4206 gfc_error ("Bad allocate-object at %C for a PURE procedure");
4211 gfc_unset_implicit_pure (NULL
);
4213 /* F2008:C631 (R626) A type-param-value in a type-spec shall be an
4214 asterisk if and only if each allocate-object is a dummy argument
4215 for which the corresponding type parameter is assumed. */
4217 && (tail
->expr
->ts
.deferred
4218 || (tail
->expr
->ts
.u
.cl
&& tail
->expr
->ts
.u
.cl
->length
)
4219 || tail
->expr
->symtree
->n
.sym
->attr
.dummy
== 0))
4221 gfc_error ("Incompatible allocate-object at %C for CHARACTER "
4222 "type-spec at %L", &assumed_locus
);
4226 if (tail
->expr
->ts
.deferred
)
4228 saw_deferred
= true;
4229 deferred_locus
= tail
->expr
->where
;
4232 if (gfc_find_state (COMP_DO_CONCURRENT
)
4233 || gfc_find_state (COMP_CRITICAL
))
4236 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
4237 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
4238 if (ref
->type
== REF_COMPONENT
)
4239 coarray
= ref
->u
.c
.component
->attr
.codimension
;
4241 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
4243 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
4246 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
4248 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
4253 /* Check for F08:C628. */
4254 sym
= tail
->expr
->symtree
->n
.sym
;
4255 b1
= !(tail
->expr
->ref
4256 && (tail
->expr
->ref
->type
== REF_COMPONENT
4257 || tail
->expr
->ref
->type
== REF_ARRAY
));
4258 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4259 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
4260 || CLASS_DATA (sym
)->attr
.class_pointer
);
4262 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4263 || sym
->attr
.proc_pointer
);
4264 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
4265 && (sym
->ns
->proc_name
->attr
.allocatable
4266 || sym
->ns
->proc_name
->attr
.pointer
4267 || sym
->ns
->proc_name
->attr
.proc_pointer
);
4268 if (b1
&& b2
&& !b3
)
4270 gfc_error ("Allocate-object at %L is neither a data pointer "
4271 "nor an allocatable variable", &tail
->expr
->where
);
4275 /* The ALLOCATE statement had an optional typespec. Check the
4277 if (ts
.type
!= BT_UNKNOWN
)
4279 /* Enforce F03:C624. */
4280 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
4282 gfc_error ("Type of entity at %L is type incompatible with "
4283 "typespec", &tail
->expr
->where
);
4287 /* Enforce F03:C627. */
4288 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
4290 gfc_error ("Kind type parameter for entity at %L differs from "
4291 "the kind type parameter of the typespec",
4292 &tail
->expr
->where
);
4297 if (tail
->expr
->ts
.type
== BT_DERIVED
)
4298 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
4300 if (type_param_spec_list
)
4301 tail
->expr
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
4303 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
4305 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
4307 gfc_error ("Shape specification for allocatable scalar at %C");
4311 if (gfc_match_char (',') != MATCH_YES
)
4316 m
= gfc_match (" stat = %v", &tmp
);
4317 if (m
== MATCH_ERROR
)
4324 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4332 if (gfc_check_do_variable (stat
->symtree
))
4335 if (gfc_match_char (',') == MATCH_YES
)
4336 goto alloc_opt_list
;
4339 m
= gfc_match (" errmsg = %v", &tmp
);
4340 if (m
== MATCH_ERROR
)
4344 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
4350 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4358 if (gfc_match_char (',') == MATCH_YES
)
4359 goto alloc_opt_list
;
4362 m
= gfc_match (" source = %e", &tmp
);
4363 if (m
== MATCH_ERROR
)
4367 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
4373 gfc_error ("Redundant SOURCE tag found at %L", &tmp
->where
);
4377 /* The next 2 conditionals check C631. */
4378 if (ts
.type
!= BT_UNKNOWN
)
4380 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
4381 &tmp
->where
, &old_locus
);
4386 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
4387 " with more than a single allocate object",
4395 if (gfc_match_char (',') == MATCH_YES
)
4396 goto alloc_opt_list
;
4399 m
= gfc_match (" mold = %e", &tmp
);
4400 if (m
== MATCH_ERROR
)
4404 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
4407 /* Check F08:C636. */
4410 gfc_error ("Redundant MOLD tag found at %L", &tmp
->where
);
4414 /* Check F08:C637. */
4415 if (ts
.type
!= BT_UNKNOWN
)
4417 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
4418 &tmp
->where
, &old_locus
);
4427 if (gfc_match_char (',') == MATCH_YES
)
4428 goto alloc_opt_list
;
4431 gfc_gobble_whitespace ();
4433 if (gfc_peek_char () == ')')
4437 if (gfc_match (" )%t") != MATCH_YES
)
4440 /* Check F08:C637. */
4443 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
4444 &mold
->where
, &source
->where
);
4448 /* Check F03:C623, */
4449 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4451 gfc_error ("Allocate-object at %L with a deferred type parameter "
4452 "requires either a type-spec or SOURCE tag or a MOLD tag",
4457 /* Check F03:C625, */
4458 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4460 for (tail
= head
; tail
; tail
= tail
->next
)
4462 if (UNLIMITED_POLY (tail
->expr
))
4463 gfc_error ("Unlimited polymorphic allocate-object at %L "
4464 "requires either a type-spec or SOURCE tag "
4465 "or a MOLD tag", &tail
->expr
->where
);
4470 new_st
.op
= EXEC_ALLOCATE
;
4471 new_st
.expr1
= stat
;
4472 new_st
.expr2
= errmsg
;
4474 new_st
.expr3
= source
;
4476 new_st
.expr3
= mold
;
4477 new_st
.ext
.alloc
.list
= head
;
4478 new_st
.ext
.alloc
.ts
= ts
;
4480 if (type_param_spec_list
)
4481 gfc_free_actual_arglist (type_param_spec_list
);
4486 gfc_syntax_error (ST_ALLOCATE
);
4489 gfc_free_expr (errmsg
);
4490 gfc_free_expr (source
);
4491 gfc_free_expr (stat
);
4492 gfc_free_expr (mold
);
4493 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
4494 gfc_free_alloc_list (head
);
4495 if (type_param_spec_list
)
4496 gfc_free_actual_arglist (type_param_spec_list
);
4501 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
4502 a set of pointer assignments to intrinsic NULL(). */
4505 gfc_match_nullify (void)
4513 if (gfc_match_char ('(') != MATCH_YES
)
4518 m
= gfc_match_variable (&p
, 0);
4519 if (m
== MATCH_ERROR
)
4524 if (gfc_check_do_variable (p
->symtree
))
4528 if (gfc_is_coindexed (p
))
4530 gfc_error ("Pointer object at %C shall not be coindexed");
4534 /* build ' => NULL() '. */
4535 e
= gfc_get_null_expr (&gfc_current_locus
);
4537 /* Chain to list. */
4541 tail
->op
= EXEC_POINTER_ASSIGN
;
4545 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
4552 if (gfc_match (" )%t") == MATCH_YES
)
4554 if (gfc_match_char (',') != MATCH_YES
)
4561 gfc_syntax_error (ST_NULLIFY
);
4564 gfc_free_statements (new_st
.next
);
4566 gfc_free_expr (new_st
.expr1
);
4567 new_st
.expr1
= NULL
;
4568 gfc_free_expr (new_st
.expr2
);
4569 new_st
.expr2
= NULL
;
4574 /* Match a DEALLOCATE statement. */
4577 gfc_match_deallocate (void)
4579 gfc_alloc
*head
, *tail
;
4580 gfc_expr
*stat
, *errmsg
, *tmp
;
4583 bool saw_stat
, saw_errmsg
, b1
, b2
;
4586 stat
= errmsg
= tmp
= NULL
;
4587 saw_stat
= saw_errmsg
= false;
4589 if (gfc_match_char ('(') != MATCH_YES
)
4595 head
= tail
= gfc_get_alloc ();
4598 tail
->next
= gfc_get_alloc ();
4602 m
= gfc_match_variable (&tail
->expr
, 0);
4603 if (m
== MATCH_ERROR
)
4608 if (gfc_check_do_variable (tail
->expr
->symtree
))
4611 sym
= tail
->expr
->symtree
->n
.sym
;
4613 bool impure
= gfc_impure_variable (sym
);
4614 if (impure
&& gfc_pure (NULL
))
4616 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
4621 gfc_unset_implicit_pure (NULL
);
4623 if (gfc_is_coarray (tail
->expr
)
4624 && gfc_find_state (COMP_DO_CONCURRENT
))
4626 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
4630 if (gfc_is_coarray (tail
->expr
)
4631 && gfc_find_state (COMP_CRITICAL
))
4633 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
4637 /* FIXME: disable the checking on derived types. */
4638 b1
= !(tail
->expr
->ref
4639 && (tail
->expr
->ref
->type
== REF_COMPONENT
4640 || tail
->expr
->ref
->type
== REF_ARRAY
));
4641 if (sym
&& sym
->ts
.type
== BT_CLASS
)
4642 b2
= !(CLASS_DATA (sym
) && (CLASS_DATA (sym
)->attr
.allocatable
4643 || CLASS_DATA (sym
)->attr
.class_pointer
));
4645 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4646 || sym
->attr
.proc_pointer
);
4649 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
4650 "nor an allocatable variable");
4654 if (gfc_match_char (',') != MATCH_YES
)
4659 m
= gfc_match (" stat = %v", &tmp
);
4660 if (m
== MATCH_ERROR
)
4666 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4667 gfc_free_expr (tmp
);
4674 if (gfc_check_do_variable (stat
->symtree
))
4677 if (gfc_match_char (',') == MATCH_YES
)
4678 goto dealloc_opt_list
;
4681 m
= gfc_match (" errmsg = %v", &tmp
);
4682 if (m
== MATCH_ERROR
)
4686 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
4691 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4692 gfc_free_expr (tmp
);
4699 if (gfc_match_char (',') == MATCH_YES
)
4700 goto dealloc_opt_list
;
4703 gfc_gobble_whitespace ();
4705 if (gfc_peek_char () == ')')
4709 if (gfc_match (" )%t") != MATCH_YES
)
4712 new_st
.op
= EXEC_DEALLOCATE
;
4713 new_st
.expr1
= stat
;
4714 new_st
.expr2
= errmsg
;
4715 new_st
.ext
.alloc
.list
= head
;
4720 gfc_syntax_error (ST_DEALLOCATE
);
4723 gfc_free_expr (errmsg
);
4724 gfc_free_expr (stat
);
4725 gfc_free_alloc_list (head
);
4730 /* Match a RETURN statement. */
4733 gfc_match_return (void)
4737 gfc_compile_state s
;
4741 if (gfc_find_state (COMP_CRITICAL
))
4743 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4747 if (gfc_find_state (COMP_DO_CONCURRENT
))
4749 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4753 if (gfc_match_eos () == MATCH_YES
)
4756 if (!gfc_find_state (COMP_SUBROUTINE
))
4758 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4763 if (gfc_current_form
== FORM_FREE
)
4765 /* The following are valid, so we can't require a blank after the
4769 char c
= gfc_peek_ascii_char ();
4770 if (ISALPHA (c
) || ISDIGIT (c
))
4774 m
= gfc_match (" %e%t", &e
);
4777 if (m
== MATCH_ERROR
)
4780 gfc_syntax_error (ST_RETURN
);
4787 gfc_enclosing_unit (&s
);
4788 if (s
== COMP_PROGRAM
4789 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
4790 "main program at %C"))
4793 new_st
.op
= EXEC_RETURN
;
4800 /* Match the call of a type-bound procedure, if CALL%var has already been
4801 matched and var found to be a derived-type variable. */
4804 match_typebound_call (gfc_symtree
* varst
)
4809 base
= gfc_get_expr ();
4810 base
->expr_type
= EXPR_VARIABLE
;
4811 base
->symtree
= varst
;
4812 base
->where
= gfc_current_locus
;
4813 gfc_set_sym_referenced (varst
->n
.sym
);
4815 m
= gfc_match_varspec (base
, 0, true, true);
4817 gfc_error ("Expected component reference at %C");
4820 gfc_free_expr (base
);
4824 if (gfc_match_eos () != MATCH_YES
)
4826 gfc_error ("Junk after CALL at %C");
4827 gfc_free_expr (base
);
4831 if (base
->expr_type
== EXPR_COMPCALL
)
4832 new_st
.op
= EXEC_COMPCALL
;
4833 else if (base
->expr_type
== EXPR_PPC
)
4834 new_st
.op
= EXEC_CALL_PPC
;
4837 gfc_error ("Expected type-bound procedure or procedure pointer component "
4839 gfc_free_expr (base
);
4842 new_st
.expr1
= base
;
4848 /* Match a CALL statement. The tricky part here are possible
4849 alternate return specifiers. We handle these by having all
4850 "subroutines" actually return an integer via a register that gives
4851 the return number. If the call specifies alternate returns, we
4852 generate code for a SELECT statement whose case clauses contain
4853 GOTOs to the various labels. */
4856 gfc_match_call (void)
4858 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4859 gfc_actual_arglist
*a
, *arglist
;
4869 m
= gfc_match ("% %n", name
);
4875 if (gfc_get_ha_sym_tree (name
, &st
))
4880 /* If this is a variable of derived-type, it probably starts a type-bound
4882 if ((sym
->attr
.flavor
!= FL_PROCEDURE
4883 || gfc_is_function_return_value (sym
, gfc_current_ns
))
4884 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
4885 return match_typebound_call (st
);
4887 /* If it does not seem to be callable (include functions so that the
4888 right association is made. They are thrown out in resolution.)
4890 if (!sym
->attr
.generic
4891 && !sym
->attr
.subroutine
4892 && !sym
->attr
.function
)
4894 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
4896 /* ...create a symbol in this scope... */
4897 if (sym
->ns
!= gfc_current_ns
4898 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
4901 if (sym
!= st
->n
.sym
)
4905 /* ...and then to try to make the symbol into a subroutine. */
4906 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
4910 gfc_set_sym_referenced (sym
);
4912 if (gfc_match_eos () != MATCH_YES
)
4914 m
= gfc_match_actual_arglist (1, &arglist
);
4917 if (m
== MATCH_ERROR
)
4920 if (gfc_match_eos () != MATCH_YES
)
4924 /* If any alternate return labels were found, construct a SELECT
4925 statement that will jump to the right place. */
4928 for (a
= arglist
; a
; a
= a
->next
)
4929 if (a
->expr
== NULL
)
4937 gfc_symtree
*select_st
;
4938 gfc_symbol
*select_sym
;
4939 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4941 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
4942 sprintf (name
, "_result_%s", sym
->name
);
4943 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
4945 select_sym
= select_st
->n
.sym
;
4946 select_sym
->ts
.type
= BT_INTEGER
;
4947 select_sym
->ts
.kind
= gfc_default_integer_kind
;
4948 gfc_set_sym_referenced (select_sym
);
4949 c
->expr1
= gfc_get_expr ();
4950 c
->expr1
->expr_type
= EXPR_VARIABLE
;
4951 c
->expr1
->symtree
= select_st
;
4952 c
->expr1
->ts
= select_sym
->ts
;
4953 c
->expr1
->where
= gfc_current_locus
;
4956 for (a
= arglist
; a
; a
= a
->next
)
4958 if (a
->expr
!= NULL
)
4961 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
4966 c
->block
= gfc_get_code (EXEC_SELECT
);
4969 new_case
= gfc_get_case ();
4970 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
4971 new_case
->low
= new_case
->high
;
4972 c
->ext
.block
.case_list
= new_case
;
4974 c
->next
= gfc_get_code (EXEC_GOTO
);
4975 c
->next
->label1
= a
->label
;
4979 new_st
.op
= EXEC_CALL
;
4980 new_st
.symtree
= st
;
4981 new_st
.ext
.actual
= arglist
;
4986 gfc_syntax_error (ST_CALL
);
4989 gfc_free_actual_arglist (arglist
);
4994 /* Given a name, return a pointer to the common head structure,
4995 creating it if it does not exist. If FROM_MODULE is nonzero, we
4996 mangle the name so that it doesn't interfere with commons defined
4997 in the using namespace.
4998 TODO: Add to global symbol tree. */
5001 gfc_get_common (const char *name
, int from_module
)
5004 static int serial
= 0;
5005 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
5009 /* A use associated common block is only needed to correctly layout
5010 the variables it contains. */
5011 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
5012 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
5016 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
5019 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
5022 if (st
->n
.common
== NULL
)
5024 st
->n
.common
= gfc_get_common_head ();
5025 st
->n
.common
->where
= gfc_current_locus
;
5026 strcpy (st
->n
.common
->name
, name
);
5029 return st
->n
.common
;
5033 /* Match a common block name. */
5035 match
match_common_name (char *name
)
5039 if (gfc_match_char ('/') == MATCH_NO
)
5045 if (gfc_match_char ('/') == MATCH_YES
)
5051 m
= gfc_match_name (name
);
5053 if (m
== MATCH_ERROR
)
5055 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
5058 gfc_error ("Syntax error in common block name at %C");
5063 /* Match a COMMON statement. */
5066 gfc_match_common (void)
5068 gfc_symbol
*sym
, **head
, *tail
, *other
;
5069 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5079 m
= match_common_name (name
);
5080 if (m
== MATCH_ERROR
)
5083 if (name
[0] == '\0')
5085 t
= &gfc_current_ns
->blank_common
;
5086 if (t
->head
== NULL
)
5087 t
->where
= gfc_current_locus
;
5091 t
= gfc_get_common (name
, 0);
5100 while (tail
->common_next
)
5101 tail
= tail
->common_next
;
5104 /* Grab the list of symbols. */
5107 m
= gfc_match_symbol (&sym
, 0);
5108 if (m
== MATCH_ERROR
)
5113 /* See if we know the current common block is bind(c), and if
5114 so, then see if we can check if the symbol is (which it'll
5115 need to be). This can happen if the bind(c) attr stmt was
5116 applied to the common block, and the variable(s) already
5117 defined, before declaring the common block. */
5118 if (t
->is_bind_c
== 1)
5120 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
5122 /* If we find an error, just print it and continue,
5123 cause it's just semantic, and we can see if there
5125 gfc_error_now ("Variable %qs at %L in common block %qs "
5126 "at %C must be declared with a C "
5127 "interoperable kind since common block "
5129 sym
->name
, &(sym
->declared_at
), t
->name
,
5133 if (sym
->attr
.is_bind_c
== 1)
5134 gfc_error_now ("Variable %qs in common block %qs at %C can not "
5135 "be bind(c) since it is not global", sym
->name
,
5139 if (sym
->attr
.in_common
)
5141 gfc_error ("Symbol %qs at %C is already in a COMMON block",
5146 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
5147 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
5149 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol %qs at "
5150 "%C can only be COMMON in BLOCK DATA",
5155 /* Deal with an optional array specification after the
5157 m
= gfc_match_array_spec (&as
, true, true);
5158 if (m
== MATCH_ERROR
)
5163 if (as
->type
!= AS_EXPLICIT
)
5165 gfc_error ("Array specification for symbol %qs in COMMON "
5166 "at %C must be explicit", sym
->name
);
5170 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
5173 if (sym
->attr
.pointer
)
5175 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
5176 "POINTER array", sym
->name
);
5185 /* Add the in_common attribute, but ignore the reported errors
5186 if any, and continue matching. */
5187 gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
);
5189 sym
->common_block
= t
;
5190 sym
->common_block
->refs
++;
5193 tail
->common_next
= sym
;
5199 sym
->common_head
= t
;
5201 /* Check to see if the symbol is already in an equivalence group.
5202 If it is, set the other members as being in common. */
5203 if (sym
->attr
.in_equivalence
)
5205 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
5207 for (e2
= e1
; e2
; e2
= e2
->eq
)
5208 if (e2
->expr
->symtree
->n
.sym
== sym
)
5215 for (e2
= e1
; e2
; e2
= e2
->eq
)
5217 other
= e2
->expr
->symtree
->n
.sym
;
5218 if (other
->common_head
5219 && other
->common_head
!= sym
->common_head
)
5221 gfc_error ("Symbol %qs, in COMMON block %qs at "
5222 "%C is being indirectly equivalenced to "
5223 "another COMMON block %qs",
5224 sym
->name
, sym
->common_head
->name
,
5225 other
->common_head
->name
);
5228 other
->attr
.in_common
= 1;
5229 other
->common_head
= t
;
5235 gfc_gobble_whitespace ();
5236 if (gfc_match_eos () == MATCH_YES
)
5238 if (gfc_peek_ascii_char () == '/')
5240 if (gfc_match_char (',') != MATCH_YES
)
5242 gfc_gobble_whitespace ();
5243 if (gfc_peek_ascii_char () == '/')
5252 gfc_syntax_error (ST_COMMON
);
5255 gfc_free_array_spec (as
);
5260 /* Match a BLOCK DATA program unit. */
5263 gfc_match_block_data (void)
5265 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5269 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "BLOCK DATA construct at %L",
5270 &gfc_current_locus
))
5273 if (gfc_match_eos () == MATCH_YES
)
5275 gfc_new_block
= NULL
;
5279 m
= gfc_match ("% %n%t", name
);
5283 if (gfc_get_symbol (name
, NULL
, &sym
))
5286 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
5289 gfc_new_block
= sym
;
5295 /* Free a namelist structure. */
5298 gfc_free_namelist (gfc_namelist
*name
)
5302 for (; name
; name
= n
)
5310 /* Free an OpenMP namelist structure. */
5313 gfc_free_omp_namelist (gfc_omp_namelist
*name
)
5315 gfc_omp_namelist
*n
;
5317 for (; name
; name
= n
)
5319 gfc_free_expr (name
->expr
);
5322 if (name
->udr
->combiner
)
5323 gfc_free_statement (name
->udr
->combiner
);
5324 if (name
->udr
->initializer
)
5325 gfc_free_statement (name
->udr
->initializer
);
5334 /* Match a NAMELIST statement. */
5337 gfc_match_namelist (void)
5339 gfc_symbol
*group_name
, *sym
;
5343 m
= gfc_match (" / %s /", &group_name
);
5346 if (m
== MATCH_ERROR
)
5351 if (group_name
->ts
.type
!= BT_UNKNOWN
)
5353 gfc_error ("Namelist group name %qs at %C already has a basic "
5354 "type of %s", group_name
->name
,
5355 gfc_typename (&group_name
->ts
));
5359 if (group_name
->attr
.flavor
== FL_NAMELIST
5360 && group_name
->attr
.use_assoc
5361 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name %qs "
5362 "at %C already is USE associated and can"
5363 "not be respecified.", group_name
->name
))
5366 if (group_name
->attr
.flavor
!= FL_NAMELIST
5367 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
5368 group_name
->name
, NULL
))
5373 m
= gfc_match_symbol (&sym
, 1);
5376 if (m
== MATCH_ERROR
)
5379 if (sym
->attr
.in_namelist
== 0
5380 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
5383 /* Use gfc_error_check here, rather than goto error, so that
5384 these are the only errors for the next two lines. */
5385 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
5387 gfc_error ("Assumed size array %qs in namelist %qs at "
5388 "%C is not allowed", sym
->name
, group_name
->name
);
5392 nl
= gfc_get_namelist ();
5396 if (group_name
->namelist
== NULL
)
5397 group_name
->namelist
= group_name
->namelist_tail
= nl
;
5400 group_name
->namelist_tail
->next
= nl
;
5401 group_name
->namelist_tail
= nl
;
5404 if (gfc_match_eos () == MATCH_YES
)
5407 m
= gfc_match_char (',');
5409 if (gfc_match_char ('/') == MATCH_YES
)
5411 m2
= gfc_match (" %s /", &group_name
);
5412 if (m2
== MATCH_YES
)
5414 if (m2
== MATCH_ERROR
)
5428 gfc_syntax_error (ST_NAMELIST
);
5435 /* Match a MODULE statement. */
5438 gfc_match_module (void)
5442 m
= gfc_match (" %s%t", &gfc_new_block
);
5446 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
5447 gfc_new_block
->name
, NULL
))
5454 /* Free equivalence sets and lists. Recursively is the easiest way to
5458 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
5463 gfc_free_equiv (eq
->eq
);
5464 gfc_free_equiv_until (eq
->next
, stop
);
5465 gfc_free_expr (eq
->expr
);
5471 gfc_free_equiv (gfc_equiv
*eq
)
5473 gfc_free_equiv_until (eq
, NULL
);
5477 /* Match an EQUIVALENCE statement. */
5480 gfc_match_equivalence (void)
5482 gfc_equiv
*eq
, *set
, *tail
;
5486 gfc_common_head
*common_head
= NULL
;
5494 eq
= gfc_get_equiv ();
5498 eq
->next
= gfc_current_ns
->equiv
;
5499 gfc_current_ns
->equiv
= eq
;
5501 if (gfc_match_char ('(') != MATCH_YES
)
5505 common_flag
= FALSE
;
5510 m
= gfc_match_equiv_variable (&set
->expr
);
5511 if (m
== MATCH_ERROR
)
5516 /* count the number of objects. */
5519 if (gfc_match_char ('%') == MATCH_YES
)
5521 gfc_error ("Derived type component %C is not a "
5522 "permitted EQUIVALENCE member");
5526 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
5527 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5529 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
5530 "be an array section");
5534 sym
= set
->expr
->symtree
->n
.sym
;
5536 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
5539 if (sym
->attr
.in_common
)
5542 common_head
= sym
->common_head
;
5545 if (gfc_match_char (')') == MATCH_YES
)
5548 if (gfc_match_char (',') != MATCH_YES
)
5551 set
->eq
= gfc_get_equiv ();
5557 gfc_error ("EQUIVALENCE at %C requires two or more objects");
5561 /* If one of the members of an equivalence is in common, then
5562 mark them all as being in common. Before doing this, check
5563 that members of the equivalence group are not in different
5566 for (set
= eq
; set
; set
= set
->eq
)
5568 sym
= set
->expr
->symtree
->n
.sym
;
5569 if (sym
->common_head
&& sym
->common_head
!= common_head
)
5571 gfc_error ("Attempt to indirectly overlap COMMON "
5572 "blocks %s and %s by EQUIVALENCE at %C",
5573 sym
->common_head
->name
, common_head
->name
);
5576 sym
->attr
.in_common
= 1;
5577 sym
->common_head
= common_head
;
5580 if (gfc_match_eos () == MATCH_YES
)
5582 if (gfc_match_char (',') != MATCH_YES
)
5584 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
5589 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "EQUIVALENCE statement at %C"))
5595 gfc_syntax_error (ST_EQUIVALENCE
);
5601 gfc_free_equiv (gfc_current_ns
->equiv
);
5602 gfc_current_ns
->equiv
= eq
;
5608 /* Check that a statement function is not recursive. This is done by looking
5609 for the statement function symbol(sym) by looking recursively through its
5610 expression(e). If a reference to sym is found, true is returned.
5611 12.5.4 requires that any variable of function that is implicitly typed
5612 shall have that type confirmed by any subsequent type declaration. The
5613 implicit typing is conveniently done here. */
5615 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
5618 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
5624 switch (e
->expr_type
)
5627 if (e
->symtree
== NULL
)
5630 /* Check the name before testing for nested recursion! */
5631 if (sym
->name
== e
->symtree
->n
.sym
->name
)
5634 /* Catch recursion via other statement functions. */
5635 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
5636 && e
->symtree
->n
.sym
->value
5637 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
5640 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5641 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5646 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
5649 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5650 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5662 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
5664 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
5668 /* Match a statement function declaration. It is so easy to match
5669 non-statement function statements with a MATCH_ERROR as opposed to
5670 MATCH_NO that we suppress error message in most cases. */
5673 gfc_match_st_function (void)
5675 gfc_error_buffer old_error
;
5680 m
= gfc_match_symbol (&sym
, 0);
5684 gfc_push_error (&old_error
);
5686 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
5689 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
5692 m
= gfc_match (" = %e%t", &expr
);
5696 gfc_free_error (&old_error
);
5698 if (m
== MATCH_ERROR
)
5701 if (recursive_stmt_fcn (expr
, sym
))
5703 gfc_error ("Statement function at %L is recursive", &expr
->where
);
5709 if ((gfc_current_state () == COMP_FUNCTION
5710 || gfc_current_state () == COMP_SUBROUTINE
)
5711 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
5713 gfc_error ("Statement function at %L cannot appear within an INTERFACE",
5718 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
5724 gfc_pop_error (&old_error
);
5729 /* Match an assignment to a pointer function (F2008). This could, in
5730 general be ambiguous with a statement function. In this implementation
5731 it remains so if it is the first statement after the specification
5735 gfc_match_ptr_fcn_assign (void)
5737 gfc_error_buffer old_error
;
5742 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5744 old_loc
= gfc_current_locus
;
5745 m
= gfc_match_name (name
);
5749 gfc_find_symbol (name
, NULL
, 1, &sym
);
5750 if (sym
&& sym
->attr
.flavor
!= FL_PROCEDURE
)
5753 gfc_push_error (&old_error
);
5755 if (sym
&& sym
->attr
.function
)
5756 goto match_actual_arglist
;
5758 gfc_current_locus
= old_loc
;
5759 m
= gfc_match_symbol (&sym
, 0);
5763 if (!gfc_add_procedure (&sym
->attr
, PROC_UNKNOWN
, sym
->name
, NULL
))
5766 match_actual_arglist
:
5767 gfc_current_locus
= old_loc
;
5768 m
= gfc_match (" %e", &expr
);
5772 new_st
.op
= EXEC_ASSIGN
;
5773 new_st
.expr1
= expr
;
5776 m
= gfc_match (" = %e%t", &expr
);
5780 new_st
.expr2
= expr
;
5784 gfc_pop_error (&old_error
);
5789 /***************** SELECT CASE subroutines ******************/
5791 /* Free a single case structure. */
5794 free_case (gfc_case
*p
)
5796 if (p
->low
== p
->high
)
5798 gfc_free_expr (p
->low
);
5799 gfc_free_expr (p
->high
);
5804 /* Free a list of case structures. */
5807 gfc_free_case_list (gfc_case
*p
)
5819 /* Match a single case selector. Combining the requirements of F08:C830
5820 and F08:C832 (R838) means that the case-value must have either CHARACTER,
5821 INTEGER, or LOGICAL type. */
5824 match_case_selector (gfc_case
**cp
)
5829 c
= gfc_get_case ();
5830 c
->where
= gfc_current_locus
;
5832 if (gfc_match_char (':') == MATCH_YES
)
5834 m
= gfc_match_init_expr (&c
->high
);
5837 if (m
== MATCH_ERROR
)
5840 if (c
->high
->ts
.type
!= BT_LOGICAL
&& c
->high
->ts
.type
!= BT_INTEGER
5841 && c
->high
->ts
.type
!= BT_CHARACTER
)
5843 gfc_error ("Expression in CASE selector at %L cannot be %s",
5844 &c
->high
->where
, gfc_typename (&c
->high
->ts
));
5850 m
= gfc_match_init_expr (&c
->low
);
5851 if (m
== MATCH_ERROR
)
5856 if (c
->low
->ts
.type
!= BT_LOGICAL
&& c
->low
->ts
.type
!= BT_INTEGER
5857 && c
->low
->ts
.type
!= BT_CHARACTER
)
5859 gfc_error ("Expression in CASE selector at %L cannot be %s",
5860 &c
->low
->where
, gfc_typename (&c
->low
->ts
));
5864 /* If we're not looking at a ':' now, make a range out of a single
5865 target. Else get the upper bound for the case range. */
5866 if (gfc_match_char (':') != MATCH_YES
)
5870 m
= gfc_match_init_expr (&c
->high
);
5871 if (m
== MATCH_ERROR
)
5873 /* MATCH_NO is fine. It's OK if nothing is there! */
5881 gfc_error ("Expected initialization expression in CASE at %C");
5889 /* Match the end of a case statement. */
5892 match_case_eos (void)
5894 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5897 if (gfc_match_eos () == MATCH_YES
)
5900 /* If the case construct doesn't have a case-construct-name, we
5901 should have matched the EOS. */
5902 if (!gfc_current_block ())
5905 gfc_gobble_whitespace ();
5907 m
= gfc_match_name (name
);
5911 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5913 gfc_error ("Expected block name %qs of SELECT construct at %C",
5914 gfc_current_block ()->name
);
5918 return gfc_match_eos ();
5922 /* Match a SELECT statement. */
5925 gfc_match_select (void)
5930 m
= gfc_match_label ();
5931 if (m
== MATCH_ERROR
)
5934 m
= gfc_match (" select case ( %e )%t", &expr
);
5938 new_st
.op
= EXEC_SELECT
;
5939 new_st
.expr1
= expr
;
5945 /* Transfer the selector typespec to the associate name. */
5948 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
)
5951 gfc_symbol
*assoc_sym
;
5954 assoc_sym
= associate
->symtree
->n
.sym
;
5956 /* At this stage the expression rank and arrayspec dimensions have
5957 not been completely sorted out. We must get the expr2->rank
5958 right here, so that the correct class container is obtained. */
5959 ref
= selector
->ref
;
5960 while (ref
&& ref
->next
)
5963 if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
5964 && ref
&& ref
->type
== REF_ARRAY
)
5966 /* Ensure that the array reference type is set. We cannot use
5967 gfc_resolve_expr at this point, so the usable parts of
5968 resolve.c(resolve_array_ref) are employed to do it. */
5969 if (ref
->u
.ar
.type
== AR_UNKNOWN
)
5971 ref
->u
.ar
.type
= AR_ELEMENT
;
5972 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
5973 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5974 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
5975 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
5976 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
5978 ref
->u
.ar
.type
= AR_SECTION
;
5983 if (ref
->u
.ar
.type
== AR_FULL
)
5984 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
5985 else if (ref
->u
.ar
.type
== AR_SECTION
)
5986 selector
->rank
= ref
->u
.ar
.dimen
;
5990 rank
= selector
->rank
;
5995 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
5996 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
5997 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
5998 && ref
->u
.ar
.end
[i
] == NULL
5999 && ref
->u
.ar
.stride
[i
] == NULL
))
6004 assoc_sym
->attr
.dimension
= 1;
6005 assoc_sym
->as
= gfc_get_array_spec ();
6006 assoc_sym
->as
->rank
= rank
;
6007 assoc_sym
->as
->type
= AS_DEFERRED
;
6010 assoc_sym
->as
= NULL
;
6013 assoc_sym
->as
= NULL
;
6015 if (selector
->ts
.type
== BT_CLASS
)
6017 /* The correct class container has to be available. */
6018 assoc_sym
->ts
.type
= BT_CLASS
;
6019 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
6020 assoc_sym
->attr
.pointer
= 1;
6021 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
6026 /* Push the current selector onto the SELECT TYPE stack. */
6029 select_type_push (gfc_symbol
*sel
)
6031 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
6032 top
->selector
= sel
;
6034 top
->prev
= select_type_stack
;
6036 select_type_stack
= top
;
6040 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
6042 static gfc_symtree
*
6043 select_intrinsic_set_tmp (gfc_typespec
*ts
)
6045 char name
[GFC_MAX_SYMBOL_LEN
];
6047 HOST_WIDE_INT charlen
= 0;
6049 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
6052 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
6053 && !select_type_stack
->selector
->attr
.class_ok
)
6056 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
6057 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6058 charlen
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
6060 if (ts
->type
!= BT_CHARACTER
)
6061 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
6064 snprintf (name
, sizeof (name
), "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
6065 gfc_basic_typename (ts
->type
), charlen
, ts
->kind
);
6067 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6068 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
6070 /* Copy across the array spec to the selector. */
6071 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
6072 && (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
6073 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
))
6075 tmp
->n
.sym
->attr
.pointer
= 1;
6076 tmp
->n
.sym
->attr
.dimension
6077 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
6078 tmp
->n
.sym
->attr
.codimension
6079 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
6081 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
6084 gfc_set_sym_referenced (tmp
->n
.sym
);
6085 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
6086 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
6092 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
6095 select_type_set_tmp (gfc_typespec
*ts
)
6097 char name
[GFC_MAX_SYMBOL_LEN
];
6098 gfc_symtree
*tmp
= NULL
;
6102 select_type_stack
->tmp
= NULL
;
6106 tmp
= select_intrinsic_set_tmp (ts
);
6113 if (ts
->type
== BT_CLASS
)
6114 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
6116 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
6117 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6118 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
6120 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
6121 && select_type_stack
->selector
->attr
.class_ok
)
6123 tmp
->n
.sym
->attr
.pointer
6124 = CLASS_DATA (select_type_stack
->selector
)->attr
.class_pointer
;
6126 /* Copy across the array spec to the selector. */
6127 if (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
6128 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
)
6130 tmp
->n
.sym
->attr
.dimension
6131 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
6132 tmp
->n
.sym
->attr
.codimension
6133 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
6135 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
6139 gfc_set_sym_referenced (tmp
->n
.sym
);
6140 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
6141 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
6143 if (ts
->type
== BT_CLASS
)
6144 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
6148 /* Add an association for it, so the rest of the parser knows it is
6149 an associate-name. The target will be set during resolution. */
6150 tmp
->n
.sym
->assoc
= gfc_get_association_list ();
6151 tmp
->n
.sym
->assoc
->dangling
= 1;
6152 tmp
->n
.sym
->assoc
->st
= tmp
;
6154 select_type_stack
->tmp
= tmp
;
6158 /* Match a SELECT TYPE statement. */
6161 gfc_match_select_type (void)
6163 gfc_expr
*expr1
, *expr2
= NULL
;
6165 char name
[GFC_MAX_SYMBOL_LEN
];
6168 gfc_namespace
*ns
= gfc_current_ns
;
6170 m
= gfc_match_label ();
6171 if (m
== MATCH_ERROR
)
6174 m
= gfc_match (" select type ( ");
6178 gfc_current_ns
= gfc_build_block_ns (ns
);
6179 m
= gfc_match (" %n => %e", name
, &expr2
);
6182 expr1
= gfc_get_expr ();
6183 expr1
->expr_type
= EXPR_VARIABLE
;
6184 expr1
->where
= expr2
->where
;
6185 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
6191 sym
= expr1
->symtree
->n
.sym
;
6192 if (expr2
->ts
.type
== BT_UNKNOWN
)
6193 sym
->attr
.untyped
= 1;
6195 copy_ts_from_selector_to_associate (expr1
, expr2
);
6197 sym
->attr
.flavor
= FL_VARIABLE
;
6198 sym
->attr
.referenced
= 1;
6199 sym
->attr
.class_ok
= 1;
6203 m
= gfc_match (" %e ", &expr1
);
6206 std::swap (ns
, gfc_current_ns
);
6207 gfc_free_namespace (ns
);
6212 m
= gfc_match (" )%t");
6215 gfc_error ("parse error in SELECT TYPE statement at %C");
6219 /* This ghastly expression seems to be needed to distinguish a CLASS
6220 array, which can have a reference, from other expressions that
6221 have references, such as derived type components, and are not
6222 allowed by the standard.
6223 TODO: see if it is sufficient to exclude component and substring
6225 class_array
= (expr1
->expr_type
== EXPR_VARIABLE
6226 && expr1
->ts
.type
== BT_CLASS
6227 && CLASS_DATA (expr1
)
6228 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
6229 && (CLASS_DATA (expr1
)->attr
.dimension
6230 || CLASS_DATA (expr1
)->attr
.codimension
)
6232 && expr1
->ref
->type
== REF_ARRAY
6233 && expr1
->ref
->u
.ar
.type
== AR_FULL
6234 && expr1
->ref
->next
== NULL
);
6236 /* Check for F03:C811 (F08:C835). */
6237 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
6238 || (!class_array
&& expr1
->ref
!= NULL
)))
6240 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
6241 "use associate-name=>");
6246 new_st
.op
= EXEC_SELECT_TYPE
;
6247 new_st
.expr1
= expr1
;
6248 new_st
.expr2
= expr2
;
6249 new_st
.ext
.block
.ns
= gfc_current_ns
;
6251 select_type_push (expr1
->symtree
->n
.sym
);
6252 gfc_current_ns
= ns
;
6257 gfc_free_expr (expr1
);
6258 gfc_free_expr (expr2
);
6259 gfc_undo_symbols ();
6260 std::swap (ns
, gfc_current_ns
);
6261 gfc_free_namespace (ns
);
6266 /* Match a CASE statement. */
6269 gfc_match_case (void)
6271 gfc_case
*c
, *head
, *tail
;
6276 if (gfc_current_state () != COMP_SELECT
)
6278 gfc_error ("Unexpected CASE statement at %C");
6282 if (gfc_match ("% default") == MATCH_YES
)
6284 m
= match_case_eos ();
6287 if (m
== MATCH_ERROR
)
6290 new_st
.op
= EXEC_SELECT
;
6291 c
= gfc_get_case ();
6292 c
->where
= gfc_current_locus
;
6293 new_st
.ext
.block
.case_list
= c
;
6297 if (gfc_match_char ('(') != MATCH_YES
)
6302 if (match_case_selector (&c
) == MATCH_ERROR
)
6312 if (gfc_match_char (')') == MATCH_YES
)
6314 if (gfc_match_char (',') != MATCH_YES
)
6318 m
= match_case_eos ();
6321 if (m
== MATCH_ERROR
)
6324 new_st
.op
= EXEC_SELECT
;
6325 new_st
.ext
.block
.case_list
= head
;
6330 gfc_error ("Syntax error in CASE specification at %C");
6333 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
6338 /* Match a TYPE IS statement. */
6341 gfc_match_type_is (void)
6346 if (gfc_current_state () != COMP_SELECT_TYPE
)
6348 gfc_error ("Unexpected TYPE IS statement at %C");
6352 if (gfc_match_char ('(') != MATCH_YES
)
6355 c
= gfc_get_case ();
6356 c
->where
= gfc_current_locus
;
6358 m
= gfc_match_type_spec (&c
->ts
);
6361 if (m
== MATCH_ERROR
)
6364 if (gfc_match_char (')') != MATCH_YES
)
6367 m
= match_case_eos ();
6370 if (m
== MATCH_ERROR
)
6373 new_st
.op
= EXEC_SELECT_TYPE
;
6374 new_st
.ext
.block
.case_list
= c
;
6376 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
6377 && (c
->ts
.u
.derived
->attr
.sequence
6378 || c
->ts
.u
.derived
->attr
.is_bind_c
))
6380 gfc_error ("The type-spec shall not specify a sequence derived "
6381 "type or a type with the BIND attribute in SELECT "
6382 "TYPE at %C [F2003:C815]");
6386 if (c
->ts
.type
== BT_DERIVED
6387 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
6388 && gfc_spec_list_type (type_param_spec_list
, c
->ts
.u
.derived
)
6391 gfc_error ("All the LEN type parameters in the TYPE IS statement "
6392 "at %C must be ASSUMED");
6396 /* Create temporary variable. */
6397 select_type_set_tmp (&c
->ts
);
6402 gfc_error ("Syntax error in TYPE IS specification at %C");
6406 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6411 /* Match a CLASS IS or CLASS DEFAULT statement. */
6414 gfc_match_class_is (void)
6419 if (gfc_current_state () != COMP_SELECT_TYPE
)
6422 if (gfc_match ("% default") == MATCH_YES
)
6424 m
= match_case_eos ();
6427 if (m
== MATCH_ERROR
)
6430 new_st
.op
= EXEC_SELECT_TYPE
;
6431 c
= gfc_get_case ();
6432 c
->where
= gfc_current_locus
;
6433 c
->ts
.type
= BT_UNKNOWN
;
6434 new_st
.ext
.block
.case_list
= c
;
6435 select_type_set_tmp (NULL
);
6439 m
= gfc_match ("% is");
6442 if (m
== MATCH_ERROR
)
6445 if (gfc_match_char ('(') != MATCH_YES
)
6448 c
= gfc_get_case ();
6449 c
->where
= gfc_current_locus
;
6451 m
= match_derived_type_spec (&c
->ts
);
6454 if (m
== MATCH_ERROR
)
6457 if (c
->ts
.type
== BT_DERIVED
)
6458 c
->ts
.type
= BT_CLASS
;
6460 if (gfc_match_char (')') != MATCH_YES
)
6463 m
= match_case_eos ();
6466 if (m
== MATCH_ERROR
)
6469 new_st
.op
= EXEC_SELECT_TYPE
;
6470 new_st
.ext
.block
.case_list
= c
;
6472 /* Create temporary variable. */
6473 select_type_set_tmp (&c
->ts
);
6478 gfc_error ("Syntax error in CLASS IS specification at %C");
6482 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6487 /********************* WHERE subroutines ********************/
6489 /* Match the rest of a simple WHERE statement that follows an IF statement.
6493 match_simple_where (void)
6499 m
= gfc_match (" ( %e )", &expr
);
6503 m
= gfc_match_assignment ();
6506 if (m
== MATCH_ERROR
)
6509 if (gfc_match_eos () != MATCH_YES
)
6512 c
= gfc_get_code (EXEC_WHERE
);
6515 c
->next
= XCNEW (gfc_code
);
6517 c
->next
->loc
= gfc_current_locus
;
6518 gfc_clear_new_st ();
6520 new_st
.op
= EXEC_WHERE
;
6526 gfc_syntax_error (ST_WHERE
);
6529 gfc_free_expr (expr
);
6534 /* Match a WHERE statement. */
6537 gfc_match_where (gfc_statement
*st
)
6543 m0
= gfc_match_label ();
6544 if (m0
== MATCH_ERROR
)
6547 m
= gfc_match (" where ( %e )", &expr
);
6551 if (gfc_match_eos () == MATCH_YES
)
6553 *st
= ST_WHERE_BLOCK
;
6554 new_st
.op
= EXEC_WHERE
;
6555 new_st
.expr1
= expr
;
6559 m
= gfc_match_assignment ();
6561 gfc_syntax_error (ST_WHERE
);
6565 gfc_free_expr (expr
);
6569 /* We've got a simple WHERE statement. */
6571 c
= gfc_get_code (EXEC_WHERE
);
6574 /* Put in the assignment. It will not be processed by add_statement, so we
6575 need to copy the location here. */
6577 c
->next
= XCNEW (gfc_code
);
6579 c
->next
->loc
= gfc_current_locus
;
6580 gfc_clear_new_st ();
6582 new_st
.op
= EXEC_WHERE
;
6589 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
6590 new_st if successful. */
6593 gfc_match_elsewhere (void)
6595 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6599 if (gfc_current_state () != COMP_WHERE
)
6601 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
6607 if (gfc_match_char ('(') == MATCH_YES
)
6609 m
= gfc_match_expr (&expr
);
6612 if (m
== MATCH_ERROR
)
6615 if (gfc_match_char (')') != MATCH_YES
)
6619 if (gfc_match_eos () != MATCH_YES
)
6621 /* Only makes sense if we have a where-construct-name. */
6622 if (!gfc_current_block ())
6627 /* Better be a name at this point. */
6628 m
= gfc_match_name (name
);
6631 if (m
== MATCH_ERROR
)
6634 if (gfc_match_eos () != MATCH_YES
)
6637 if (strcmp (name
, gfc_current_block ()->name
) != 0)
6639 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
6640 name
, gfc_current_block ()->name
);
6645 new_st
.op
= EXEC_WHERE
;
6646 new_st
.expr1
= expr
;
6650 gfc_syntax_error (ST_ELSEWHERE
);
6653 gfc_free_expr (expr
);