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
);
1354 if (lvalue
->expr_type
== EXPR_CONSTANT
)
1356 /* This clobbers %len and %kind. */
1358 gfc_error ("Assignment to a constant expression at %C");
1363 gfc_current_locus
= old_loc
;
1364 gfc_free_expr (lvalue
);
1365 gfc_free_expr (rvalue
);
1369 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1371 new_st
.op
= EXEC_ASSIGN
;
1372 new_st
.expr1
= lvalue
;
1373 new_st
.expr2
= rvalue
;
1375 gfc_check_do_variable (lvalue
->symtree
);
1377 if (lvalue
->ts
.type
== BT_CLASS
)
1378 gfc_find_vtab (&rvalue
->ts
);
1384 /* Match a pointer assignment statement. */
1387 gfc_match_pointer_assignment (void)
1389 gfc_expr
*lvalue
, *rvalue
;
1393 old_loc
= gfc_current_locus
;
1395 lvalue
= rvalue
= NULL
;
1396 gfc_matching_ptr_assignment
= 0;
1397 gfc_matching_procptr_assignment
= 0;
1399 m
= gfc_match (" %v =>", &lvalue
);
1406 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1407 || gfc_is_proc_ptr_comp (lvalue
))
1408 gfc_matching_procptr_assignment
= 1;
1410 gfc_matching_ptr_assignment
= 1;
1412 m
= gfc_match (" %e%t", &rvalue
);
1413 gfc_matching_ptr_assignment
= 0;
1414 gfc_matching_procptr_assignment
= 0;
1418 new_st
.op
= EXEC_POINTER_ASSIGN
;
1419 new_st
.expr1
= lvalue
;
1420 new_st
.expr2
= rvalue
;
1425 gfc_current_locus
= old_loc
;
1426 gfc_free_expr (lvalue
);
1427 gfc_free_expr (rvalue
);
1432 /* We try to match an easy arithmetic IF statement. This only happens
1433 when just after having encountered a simple IF statement. This code
1434 is really duplicate with parts of the gfc_match_if code, but this is
1438 match_arithmetic_if (void)
1440 gfc_st_label
*l1
, *l2
, *l3
;
1444 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1448 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1449 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1450 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1452 gfc_free_expr (expr
);
1456 if (!gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
1457 "Arithmetic IF statement at %C"))
1460 new_st
.op
= EXEC_ARITHMETIC_IF
;
1461 new_st
.expr1
= expr
;
1470 /* The IF statement is a bit of a pain. First of all, there are three
1471 forms of it, the simple IF, the IF that starts a block and the
1474 There is a problem with the simple IF and that is the fact that we
1475 only have a single level of undo information on symbols. What this
1476 means is for a simple IF, we must re-match the whole IF statement
1477 multiple times in order to guarantee that the symbol table ends up
1478 in the proper state. */
1480 static match
match_simple_forall (void);
1481 static match
match_simple_where (void);
1484 gfc_match_if (gfc_statement
*if_type
)
1487 gfc_st_label
*l1
, *l2
, *l3
;
1488 locus old_loc
, old_loc2
;
1492 n
= gfc_match_label ();
1493 if (n
== MATCH_ERROR
)
1496 old_loc
= gfc_current_locus
;
1498 m
= gfc_match (" if ( %e", &expr
);
1502 old_loc2
= gfc_current_locus
;
1503 gfc_current_locus
= old_loc
;
1505 if (gfc_match_parens () == MATCH_ERROR
)
1508 gfc_current_locus
= old_loc2
;
1510 if (gfc_match_char (')') != MATCH_YES
)
1512 gfc_error ("Syntax error in IF-expression at %C");
1513 gfc_free_expr (expr
);
1517 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1523 gfc_error ("Block label not appropriate for arithmetic IF "
1525 gfc_free_expr (expr
);
1529 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1530 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1531 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1533 gfc_free_expr (expr
);
1537 if (!gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
1538 "Arithmetic IF statement at %C"))
1541 new_st
.op
= EXEC_ARITHMETIC_IF
;
1542 new_st
.expr1
= expr
;
1547 *if_type
= ST_ARITHMETIC_IF
;
1551 if (gfc_match (" then%t") == MATCH_YES
)
1553 new_st
.op
= EXEC_IF
;
1554 new_st
.expr1
= expr
;
1555 *if_type
= ST_IF_BLOCK
;
1561 gfc_error ("Block label is not appropriate for IF statement at %C");
1562 gfc_free_expr (expr
);
1566 /* At this point the only thing left is a simple IF statement. At
1567 this point, n has to be MATCH_NO, so we don't have to worry about
1568 re-matching a block label. From what we've got so far, try
1569 matching an assignment. */
1571 *if_type
= ST_SIMPLE_IF
;
1573 m
= gfc_match_assignment ();
1577 gfc_free_expr (expr
);
1578 gfc_undo_symbols ();
1579 gfc_current_locus
= old_loc
;
1581 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1582 assignment was found. For MATCH_NO, continue to call the various
1584 if (m
== MATCH_ERROR
)
1587 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1589 m
= gfc_match_pointer_assignment ();
1593 gfc_free_expr (expr
);
1594 gfc_undo_symbols ();
1595 gfc_current_locus
= old_loc
;
1597 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1599 /* Look at the next keyword to see which matcher to call. Matching
1600 the keyword doesn't affect the symbol table, so we don't have to
1601 restore between tries. */
1603 #define match(string, subr, statement) \
1604 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1608 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1609 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1610 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1611 match ("call", gfc_match_call
, ST_CALL
)
1612 match ("change team", gfc_match_change_team
, ST_CHANGE_TEAM
)
1613 match ("close", gfc_match_close
, ST_CLOSE
)
1614 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1615 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1616 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1617 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1618 match ("end team", gfc_match_end_team
, ST_END_TEAM
)
1619 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
)
1620 match ("event post", gfc_match_event_post
, ST_EVENT_POST
)
1621 match ("event wait", gfc_match_event_wait
, ST_EVENT_WAIT
)
1622 match ("exit", gfc_match_exit
, ST_EXIT
)
1623 match ("fail image", gfc_match_fail_image
, ST_FAIL_IMAGE
)
1624 match ("flush", gfc_match_flush
, ST_FLUSH
)
1625 match ("forall", match_simple_forall
, ST_FORALL
)
1626 match ("form team", gfc_match_form_team
, ST_FORM_TEAM
)
1627 match ("go to", gfc_match_goto
, ST_GOTO
)
1628 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1629 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1630 match ("lock", gfc_match_lock
, ST_LOCK
)
1631 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1632 match ("open", gfc_match_open
, ST_OPEN
)
1633 match ("pause", gfc_match_pause
, ST_NONE
)
1634 match ("print", gfc_match_print
, ST_WRITE
)
1635 match ("read", gfc_match_read
, ST_READ
)
1636 match ("return", gfc_match_return
, ST_RETURN
)
1637 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1638 match ("stop", gfc_match_stop
, ST_STOP
)
1639 match ("wait", gfc_match_wait
, ST_WAIT
)
1640 match ("sync all", gfc_match_sync_all
, ST_SYNC_CALL
);
1641 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
1642 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
1643 match ("sync team", gfc_match_sync_team
, ST_SYNC_TEAM
)
1644 match ("unlock", gfc_match_unlock
, ST_UNLOCK
)
1645 match ("where", match_simple_where
, ST_WHERE
)
1646 match ("write", gfc_match_write
, ST_WRITE
)
1649 match ("type", gfc_match_print
, ST_WRITE
)
1651 /* The gfc_match_assignment() above may have returned a MATCH_NO
1652 where the assignment was to a named constant. Check that
1653 special case here. */
1654 m
= gfc_match_assignment ();
1657 gfc_error ("Cannot assign to a named constant at %C");
1658 gfc_free_expr (expr
);
1659 gfc_undo_symbols ();
1660 gfc_current_locus
= old_loc
;
1664 /* All else has failed, so give up. See if any of the matchers has
1665 stored an error message of some sort. */
1666 if (!gfc_error_check ())
1667 gfc_error ("Unclassifiable statement in IF-clause at %C");
1669 gfc_free_expr (expr
);
1674 gfc_error ("Syntax error in IF-clause at %C");
1677 gfc_free_expr (expr
);
1681 /* At this point, we've matched the single IF and the action clause
1682 is in new_st. Rearrange things so that the IF statement appears
1685 p
= gfc_get_code (EXEC_IF
);
1686 p
->next
= XCNEW (gfc_code
);
1688 p
->next
->loc
= gfc_current_locus
;
1692 gfc_clear_new_st ();
1694 new_st
.op
= EXEC_IF
;
1703 /* Match an ELSE statement. */
1706 gfc_match_else (void)
1708 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1710 if (gfc_match_eos () == MATCH_YES
)
1713 if (gfc_match_name (name
) != MATCH_YES
1714 || gfc_current_block () == NULL
1715 || gfc_match_eos () != MATCH_YES
)
1717 gfc_error ("Unexpected junk after ELSE statement at %C");
1721 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1723 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1724 name
, gfc_current_block ()->name
);
1732 /* Match an ELSE IF statement. */
1735 gfc_match_elseif (void)
1737 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1741 m
= gfc_match (" ( %e ) then", &expr
);
1745 if (gfc_match_eos () == MATCH_YES
)
1748 if (gfc_match_name (name
) != MATCH_YES
1749 || gfc_current_block () == NULL
1750 || gfc_match_eos () != MATCH_YES
)
1752 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1756 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1758 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1759 name
, gfc_current_block ()->name
);
1764 new_st
.op
= EXEC_IF
;
1765 new_st
.expr1
= expr
;
1769 gfc_free_expr (expr
);
1774 /* Free a gfc_iterator structure. */
1777 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1783 gfc_free_expr (iter
->var
);
1784 gfc_free_expr (iter
->start
);
1785 gfc_free_expr (iter
->end
);
1786 gfc_free_expr (iter
->step
);
1793 /* Match a CRITICAL statement. */
1795 gfc_match_critical (void)
1797 gfc_st_label
*label
= NULL
;
1799 if (gfc_match_label () == MATCH_ERROR
)
1802 if (gfc_match (" critical") != MATCH_YES
)
1805 if (gfc_match_st_label (&label
) == MATCH_ERROR
)
1808 if (gfc_match_eos () != MATCH_YES
)
1810 gfc_syntax_error (ST_CRITICAL
);
1814 if (gfc_pure (NULL
))
1816 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1820 if (gfc_find_state (COMP_DO_CONCURRENT
))
1822 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1827 gfc_unset_implicit_pure (NULL
);
1829 if (!gfc_notify_std (GFC_STD_F2008
, "CRITICAL statement at %C"))
1832 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1834 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1839 if (gfc_find_state (COMP_CRITICAL
))
1841 gfc_error ("Nested CRITICAL block at %C");
1845 new_st
.op
= EXEC_CRITICAL
;
1848 && !gfc_reference_st_label (label
, ST_LABEL_TARGET
))
1855 /* Match a BLOCK statement. */
1858 gfc_match_block (void)
1862 if (gfc_match_label () == MATCH_ERROR
)
1865 if (gfc_match (" block") != MATCH_YES
)
1868 /* For this to be a correct BLOCK statement, the line must end now. */
1869 m
= gfc_match_eos ();
1870 if (m
== MATCH_ERROR
)
1879 /* Match an ASSOCIATE statement. */
1882 gfc_match_associate (void)
1884 if (gfc_match_label () == MATCH_ERROR
)
1887 if (gfc_match (" associate") != MATCH_YES
)
1890 /* Match the association list. */
1891 if (gfc_match_char ('(') != MATCH_YES
)
1893 gfc_error ("Expected association list at %C");
1896 new_st
.ext
.block
.assoc
= NULL
;
1899 gfc_association_list
* newAssoc
= gfc_get_association_list ();
1900 gfc_association_list
* a
;
1902 /* Match the next association. */
1903 if (gfc_match (" %n =>", newAssoc
->name
) != MATCH_YES
)
1905 gfc_error ("Expected association at %C");
1906 goto assocListError
;
1909 if (gfc_match (" %e", &newAssoc
->target
) != MATCH_YES
)
1911 /* Have another go, allowing for procedure pointer selectors. */
1912 gfc_matching_procptr_assignment
= 1;
1913 if (gfc_match (" %e", &newAssoc
->target
) != MATCH_YES
)
1915 gfc_error ("Invalid association target at %C");
1916 goto assocListError
;
1918 gfc_matching_procptr_assignment
= 0;
1920 newAssoc
->where
= gfc_current_locus
;
1922 /* Check that the current name is not yet in the list. */
1923 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
1924 if (!strcmp (a
->name
, newAssoc
->name
))
1926 gfc_error ("Duplicate name %qs in association at %C",
1928 goto assocListError
;
1931 /* The target expression must not be coindexed. */
1932 if (gfc_is_coindexed (newAssoc
->target
))
1934 gfc_error ("Association target at %C must not be coindexed");
1935 goto assocListError
;
1938 /* The `variable' field is left blank for now; because the target is not
1939 yet resolved, we can't use gfc_has_vector_subscript to determine it
1940 for now. This is set during resolution. */
1942 /* Put it into the list. */
1943 newAssoc
->next
= new_st
.ext
.block
.assoc
;
1944 new_st
.ext
.block
.assoc
= newAssoc
;
1946 /* Try next one or end if closing parenthesis is found. */
1947 gfc_gobble_whitespace ();
1948 if (gfc_peek_char () == ')')
1950 if (gfc_match_char (',') != MATCH_YES
)
1952 gfc_error ("Expected %<)%> or %<,%> at %C");
1962 if (gfc_match_char (')') != MATCH_YES
)
1964 /* This should never happen as we peek above. */
1968 if (gfc_match_eos () != MATCH_YES
)
1970 gfc_error ("Junk after ASSOCIATE statement at %C");
1977 gfc_free_association_list (new_st
.ext
.block
.assoc
);
1982 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1983 an accessible derived type. */
1986 match_derived_type_spec (gfc_typespec
*ts
)
1988 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1990 gfc_symbol
*derived
, *der_type
;
1991 match m
= MATCH_YES
;
1992 gfc_actual_arglist
*decl_type_param_list
= NULL
;
1993 bool is_pdt_template
= false;
1995 old_locus
= gfc_current_locus
;
1997 if (gfc_match ("%n", name
) != MATCH_YES
)
1999 gfc_current_locus
= old_locus
;
2003 gfc_find_symbol (name
, NULL
, 1, &derived
);
2005 /* Match the PDT spec list, if there. */
2006 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
)
2008 gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &der_type
);
2009 is_pdt_template
= der_type
2010 && der_type
->attr
.flavor
== FL_DERIVED
2011 && der_type
->attr
.pdt_template
;
2014 if (is_pdt_template
)
2015 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
2017 if (m
== MATCH_ERROR
)
2019 gfc_free_actual_arglist (decl_type_param_list
);
2023 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
&& derived
->attr
.generic
)
2024 derived
= gfc_find_dt_in_generic (derived
);
2026 /* If this is a PDT, find the specific instance. */
2027 if (m
== MATCH_YES
&& is_pdt_template
)
2029 gfc_namespace
*old_ns
;
2031 old_ns
= gfc_current_ns
;
2032 while (gfc_current_ns
&& gfc_current_ns
->parent
)
2033 gfc_current_ns
= gfc_current_ns
->parent
;
2035 if (type_param_spec_list
)
2036 gfc_free_actual_arglist (type_param_spec_list
);
2037 m
= gfc_get_pdt_instance (decl_type_param_list
, &der_type
,
2038 &type_param_spec_list
);
2039 gfc_free_actual_arglist (decl_type_param_list
);
2044 gcc_assert (!derived
->attr
.pdt_template
&& derived
->attr
.pdt_type
);
2045 gfc_set_sym_referenced (derived
);
2047 gfc_current_ns
= old_ns
;
2050 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
2052 ts
->type
= BT_DERIVED
;
2053 ts
->u
.derived
= derived
;
2057 gfc_current_locus
= old_locus
;
2062 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2063 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2064 It only includes the intrinsic types from the Fortran 2003 standard
2065 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2066 the implicit_flag is not needed, so it was removed. Derived types are
2067 identified by their name alone. */
2070 gfc_match_type_spec (gfc_typespec
*ts
)
2074 char c
, name
[GFC_MAX_SYMBOL_LEN
+ 1];
2077 gfc_gobble_whitespace ();
2078 old_locus
= gfc_current_locus
;
2080 /* If c isn't [a-z], then return immediately. */
2081 c
= gfc_peek_ascii_char ();
2085 type_param_spec_list
= NULL
;
2087 if (match_derived_type_spec (ts
) == MATCH_YES
)
2089 /* Enforce F03:C401. */
2090 if (ts
->u
.derived
->attr
.abstract
)
2092 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
2093 ts
->u
.derived
->name
, &old_locus
);
2099 if (gfc_match ("integer") == MATCH_YES
)
2101 ts
->type
= BT_INTEGER
;
2102 ts
->kind
= gfc_default_integer_kind
;
2106 if (gfc_match ("double precision") == MATCH_YES
)
2109 ts
->kind
= gfc_default_double_kind
;
2113 if (gfc_match ("complex") == MATCH_YES
)
2115 ts
->type
= BT_COMPLEX
;
2116 ts
->kind
= gfc_default_complex_kind
;
2120 if (gfc_match ("character") == MATCH_YES
)
2122 ts
->type
= BT_CHARACTER
;
2124 m
= gfc_match_char_spec (ts
);
2125 if (ts
->u
.cl
&& ts
->u
.cl
->length
)
2126 gfc_resolve_expr (ts
->u
.cl
->length
);
2134 /* REAL is a real pain because it can be a type, intrinsic subprogram,
2135 or list item in a type-list of an OpenMP reduction clause. Need to
2136 differentiate REAL([KIND]=scalar-int-initialization-expr) from
2137 REAL(A,[KIND]) and REAL(KIND,A). Logically, when this code was
2138 written the use of LOGICAL as a type-spec or intrinsic subprogram
2141 m
= gfc_match (" %n", name
);
2143 && (strcmp (name
, "real") == 0 || strcmp (name
, "logical") == 0))
2152 ts
->kind
= gfc_default_real_kind
;
2156 ts
->type
= BT_LOGICAL
;
2157 ts
->kind
= gfc_default_logical_kind
;
2160 gfc_gobble_whitespace ();
2162 /* Prevent REAL*4, etc. */
2163 c
= gfc_peek_ascii_char ();
2166 gfc_error ("Invalid type-spec at %C");
2170 /* Found leading colon in REAL::, a trailing ')' in for example
2171 TYPE IS (REAL), or REAL, for an OpenMP list-item. */
2172 if (c
== ':' || c
== ')' || (flag_openmp
&& c
== ','))
2175 /* Found something other than the opening '(' in REAL(... */
2179 gfc_next_char (); /* Burn the '('. */
2181 /* Look for the optional KIND=. */
2182 where
= gfc_current_locus
;
2183 m
= gfc_match ("%n", name
);
2186 gfc_gobble_whitespace ();
2187 c
= gfc_next_char ();
2190 if (strcmp(name
, "a") == 0 || strcmp(name
, "l") == 0)
2192 else if (strcmp(name
, "kind") == 0)
2198 gfc_current_locus
= where
;
2201 gfc_current_locus
= where
;
2205 m
= gfc_match_init_expr (&e
);
2206 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
2209 /* If a comma appears, it is an intrinsic subprogram. */
2210 gfc_gobble_whitespace ();
2211 c
= gfc_peek_ascii_char ();
2218 /* If ')' appears, we have REAL(initialization-expr), here check for
2219 a scalar integer initialization-expr and valid kind parameter. */
2222 if (e
->ts
.type
!= BT_INTEGER
|| e
->rank
> 0)
2228 gfc_next_char (); /* Burn the ')'. */
2229 ts
->kind
= (int) mpz_get_si (e
->value
.integer
);
2230 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
2232 gfc_error ("Invalid type-spec at %C");
2242 /* If a type is not matched, simply return MATCH_NO. */
2243 gfc_current_locus
= old_locus
;
2248 gfc_gobble_whitespace ();
2250 /* This prevents INTEGER*4, etc. */
2251 if (gfc_peek_ascii_char () == '*')
2253 gfc_error ("Invalid type-spec at %C");
2257 m
= gfc_match_kind_spec (ts
, false);
2259 /* No kind specifier found. */
2267 /******************** FORALL subroutines ********************/
2269 /* Free a list of FORALL iterators. */
2272 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
2274 gfc_forall_iterator
*next
;
2279 gfc_free_expr (iter
->var
);
2280 gfc_free_expr (iter
->start
);
2281 gfc_free_expr (iter
->end
);
2282 gfc_free_expr (iter
->stride
);
2289 /* Match an iterator as part of a FORALL statement. The format is:
2291 <var> = <start>:<end>[:<stride>]
2293 On MATCH_NO, the caller tests for the possibility that there is a
2294 scalar mask expression. */
2297 match_forall_iterator (gfc_forall_iterator
**result
)
2299 gfc_forall_iterator
*iter
;
2303 where
= gfc_current_locus
;
2304 iter
= XCNEW (gfc_forall_iterator
);
2306 m
= gfc_match_expr (&iter
->var
);
2310 if (gfc_match_char ('=') != MATCH_YES
2311 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
2317 m
= gfc_match_expr (&iter
->start
);
2321 if (gfc_match_char (':') != MATCH_YES
)
2324 m
= gfc_match_expr (&iter
->end
);
2327 if (m
== MATCH_ERROR
)
2330 if (gfc_match_char (':') == MATCH_NO
)
2331 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2334 m
= gfc_match_expr (&iter
->stride
);
2337 if (m
== MATCH_ERROR
)
2341 /* Mark the iteration variable's symbol as used as a FORALL index. */
2342 iter
->var
->symtree
->n
.sym
->forall_index
= true;
2348 gfc_error ("Syntax error in FORALL iterator at %C");
2353 gfc_current_locus
= where
;
2354 gfc_free_forall_iterator (iter
);
2359 /* Match the header of a FORALL statement. */
2362 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
2364 gfc_forall_iterator
*head
, *tail
, *new_iter
;
2368 gfc_gobble_whitespace ();
2373 if (gfc_match_char ('(') != MATCH_YES
)
2376 m
= match_forall_iterator (&new_iter
);
2377 if (m
== MATCH_ERROR
)
2382 head
= tail
= new_iter
;
2386 if (gfc_match_char (',') != MATCH_YES
)
2389 m
= match_forall_iterator (&new_iter
);
2390 if (m
== MATCH_ERROR
)
2395 tail
->next
= new_iter
;
2400 /* Have to have a mask expression. */
2402 m
= gfc_match_expr (&msk
);
2405 if (m
== MATCH_ERROR
)
2411 if (gfc_match_char (')') == MATCH_NO
)
2419 gfc_syntax_error (ST_FORALL
);
2422 gfc_free_expr (msk
);
2423 gfc_free_forall_iterator (head
);
2428 /* Match the rest of a simple FORALL statement that follows an
2432 match_simple_forall (void)
2434 gfc_forall_iterator
*head
;
2443 m
= match_forall_header (&head
, &mask
);
2450 m
= gfc_match_assignment ();
2452 if (m
== MATCH_ERROR
)
2456 m
= gfc_match_pointer_assignment ();
2457 if (m
== MATCH_ERROR
)
2463 c
= XCNEW (gfc_code
);
2465 c
->loc
= gfc_current_locus
;
2467 if (gfc_match_eos () != MATCH_YES
)
2470 gfc_clear_new_st ();
2471 new_st
.op
= EXEC_FORALL
;
2472 new_st
.expr1
= mask
;
2473 new_st
.ext
.forall_iterator
= head
;
2474 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2475 new_st
.block
->next
= c
;
2480 gfc_syntax_error (ST_FORALL
);
2483 gfc_free_forall_iterator (head
);
2484 gfc_free_expr (mask
);
2490 /* Match a FORALL statement. */
2493 gfc_match_forall (gfc_statement
*st
)
2495 gfc_forall_iterator
*head
;
2504 m0
= gfc_match_label ();
2505 if (m0
== MATCH_ERROR
)
2508 m
= gfc_match (" forall");
2512 m
= match_forall_header (&head
, &mask
);
2513 if (m
== MATCH_ERROR
)
2518 if (gfc_match_eos () == MATCH_YES
)
2520 *st
= ST_FORALL_BLOCK
;
2521 new_st
.op
= EXEC_FORALL
;
2522 new_st
.expr1
= mask
;
2523 new_st
.ext
.forall_iterator
= head
;
2527 m
= gfc_match_assignment ();
2528 if (m
== MATCH_ERROR
)
2532 m
= gfc_match_pointer_assignment ();
2533 if (m
== MATCH_ERROR
)
2539 c
= XCNEW (gfc_code
);
2541 c
->loc
= gfc_current_locus
;
2543 gfc_clear_new_st ();
2544 new_st
.op
= EXEC_FORALL
;
2545 new_st
.expr1
= mask
;
2546 new_st
.ext
.forall_iterator
= head
;
2547 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2548 new_st
.block
->next
= c
;
2554 gfc_syntax_error (ST_FORALL
);
2557 gfc_free_forall_iterator (head
);
2558 gfc_free_expr (mask
);
2559 gfc_free_statements (c
);
2564 /* Match a DO statement. */
2569 gfc_iterator iter
, *ip
;
2571 gfc_st_label
*label
;
2574 old_loc
= gfc_current_locus
;
2576 memset (&iter
, '\0', sizeof (gfc_iterator
));
2579 m
= gfc_match_label ();
2580 if (m
== MATCH_ERROR
)
2583 if (gfc_match (" do") != MATCH_YES
)
2586 m
= gfc_match_st_label (&label
);
2587 if (m
== MATCH_ERROR
)
2590 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2592 if (gfc_match_eos () == MATCH_YES
)
2594 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
2595 new_st
.op
= EXEC_DO_WHILE
;
2599 /* Match an optional comma, if no comma is found, a space is obligatory. */
2600 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
2603 /* Check for balanced parens. */
2605 if (gfc_match_parens () == MATCH_ERROR
)
2608 if (gfc_match (" concurrent") == MATCH_YES
)
2610 gfc_forall_iterator
*head
;
2613 if (!gfc_notify_std (GFC_STD_F2008
, "DO CONCURRENT construct at %C"))
2619 m
= match_forall_header (&head
, &mask
);
2623 if (m
== MATCH_ERROR
)
2624 goto concurr_cleanup
;
2626 if (gfc_match_eos () != MATCH_YES
)
2627 goto concurr_cleanup
;
2630 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2631 goto concurr_cleanup
;
2633 new_st
.label1
= label
;
2634 new_st
.op
= EXEC_DO_CONCURRENT
;
2635 new_st
.expr1
= mask
;
2636 new_st
.ext
.forall_iterator
= head
;
2641 gfc_syntax_error (ST_DO
);
2642 gfc_free_expr (mask
);
2643 gfc_free_forall_iterator (head
);
2647 /* See if we have a DO WHILE. */
2648 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
2650 new_st
.op
= EXEC_DO_WHILE
;
2654 /* The abortive DO WHILE may have done something to the symbol
2655 table, so we start over. */
2656 gfc_undo_symbols ();
2657 gfc_current_locus
= old_loc
;
2659 gfc_match_label (); /* This won't error. */
2660 gfc_match (" do "); /* This will work. */
2662 gfc_match_st_label (&label
); /* Can't error out. */
2663 gfc_match_char (','); /* Optional comma. */
2665 m
= gfc_match_iterator (&iter
, 0);
2668 if (m
== MATCH_ERROR
)
2671 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
2672 gfc_check_do_variable (iter
.var
->symtree
);
2674 if (gfc_match_eos () != MATCH_YES
)
2676 gfc_syntax_error (ST_DO
);
2680 new_st
.op
= EXEC_DO
;
2684 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2687 new_st
.label1
= label
;
2689 if (new_st
.op
== EXEC_DO_WHILE
)
2690 new_st
.expr1
= iter
.end
;
2693 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
2700 gfc_free_iterator (&iter
, 0);
2706 /* Match an EXIT or CYCLE statement. */
2709 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2711 gfc_state_data
*p
, *o
;
2716 if (gfc_match_eos () == MATCH_YES
)
2720 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2723 m
= gfc_match ("% %n%t", name
);
2724 if (m
== MATCH_ERROR
)
2728 gfc_syntax_error (st
);
2732 /* Find the corresponding symbol. If there's a BLOCK statement
2733 between here and the label, it is not in gfc_current_ns but a parent
2735 stree
= gfc_find_symtree_in_proc (name
, gfc_current_ns
);
2738 gfc_error ("Name %qs in %s statement at %C is unknown",
2739 name
, gfc_ascii_statement (st
));
2744 if (sym
->attr
.flavor
!= FL_LABEL
)
2746 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2747 name
, gfc_ascii_statement (st
));
2752 /* Find the loop specified by the label (or lack of a label). */
2753 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2754 if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2756 else if (p
->state
== COMP_CRITICAL
)
2758 gfc_error("%s statement at %C leaves CRITICAL construct",
2759 gfc_ascii_statement (st
));
2762 else if (p
->state
== COMP_DO_CONCURRENT
2763 && (op
== EXEC_EXIT
|| (sym
&& sym
!= p
->sym
)))
2765 /* F2008, C821 & C845. */
2766 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2767 gfc_ascii_statement (st
));
2770 else if ((sym
&& sym
== p
->sym
)
2771 || (!sym
&& (p
->state
== COMP_DO
2772 || p
->state
== COMP_DO_CONCURRENT
)))
2778 gfc_error ("%s statement at %C is not within a construct",
2779 gfc_ascii_statement (st
));
2781 gfc_error ("%s statement at %C is not within construct %qs",
2782 gfc_ascii_statement (st
), sym
->name
);
2787 /* Special checks for EXIT from non-loop constructs. */
2791 case COMP_DO_CONCURRENT
:
2795 /* This is already handled above. */
2798 case COMP_ASSOCIATE
:
2802 case COMP_SELECT_TYPE
:
2804 if (op
== EXEC_CYCLE
)
2806 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2807 " construct %qs", sym
->name
);
2810 gcc_assert (op
== EXEC_EXIT
);
2811 if (!gfc_notify_std (GFC_STD_F2008
, "EXIT statement with no"
2812 " do-construct-name at %C"))
2817 gfc_error ("%s statement at %C is not applicable to construct %qs",
2818 gfc_ascii_statement (st
), sym
->name
);
2824 gfc_error (is_oacc (p
)
2825 ? G_("%s statement at %C leaving OpenACC structured block")
2826 : G_("%s statement at %C leaving OpenMP structured block"),
2827 gfc_ascii_statement (st
));
2831 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2835 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
2836 && (o
->head
->op
== EXEC_OACC_LOOP
2837 || o
->head
->op
== EXEC_OACC_PARALLEL_LOOP
))
2840 gcc_assert (o
->head
->next
!= NULL
2841 && (o
->head
->next
->op
== EXEC_DO
2842 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2843 && o
->previous
!= NULL
2844 && o
->previous
->tail
->op
== o
->head
->op
);
2845 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2846 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2847 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2848 if (st
== ST_EXIT
&& cnt
<= collapse
)
2850 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2853 if (st
== ST_CYCLE
&& cnt
< collapse
)
2855 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2856 " !$ACC LOOP loop");
2862 && (o
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2863 && (o
->head
->op
== EXEC_OMP_DO
2864 || o
->head
->op
== EXEC_OMP_PARALLEL_DO
2865 || o
->head
->op
== EXEC_OMP_SIMD
2866 || o
->head
->op
== EXEC_OMP_DO_SIMD
2867 || o
->head
->op
== EXEC_OMP_PARALLEL_DO_SIMD
))
2870 gcc_assert (o
->head
->next
!= NULL
2871 && (o
->head
->next
->op
== EXEC_DO
2872 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2873 && o
->previous
!= NULL
2874 && o
->previous
->tail
->op
== o
->head
->op
);
2875 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
)
2877 if (o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2878 count
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2879 if (o
->previous
->tail
->ext
.omp_clauses
->orderedc
)
2880 count
= o
->previous
->tail
->ext
.omp_clauses
->orderedc
;
2882 if (st
== ST_EXIT
&& cnt
<= count
)
2884 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2887 if (st
== ST_CYCLE
&& cnt
< count
)
2889 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2895 /* Save the first statement in the construct - needed by the backend. */
2896 new_st
.ext
.which_construct
= p
->construct
;
2904 /* Match the EXIT statement. */
2907 gfc_match_exit (void)
2909 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2913 /* Match the CYCLE statement. */
2916 gfc_match_cycle (void)
2918 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2922 /* Match a stop-code after an (ERROR) STOP or PAUSE statement. The
2923 requirements for a stop-code differ in the standards.
2927 R840 stop-stmt is STOP [ stop-code ]
2928 R841 stop-code is scalar-char-constant
2929 or digit [ digit [ digit [ digit [ digit ] ] ] ]
2931 Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
2934 R855 stop-stmt is STOP [ stop-code ]
2935 R856 allstop-stmt is ALL STOP [ stop-code ]
2936 R857 stop-code is scalar-default-char-constant-expr
2937 or scalar-int-constant-expr
2939 For free-form source code, all standards contain a statement of the form:
2941 A blank shall be used to separate names, constants, or labels from
2942 adjacent keywords, names, constants, or labels.
2944 A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003,
2948 is valid, but it is invalid Fortran 2008. */
2951 gfc_match_stopcode (gfc_statement st
)
2957 /* Set f95 for -std=f95. */
2958 f95
= (gfc_option
.allow_std
== GFC_STD_OPT_F95
);
2960 /* Set f03 for -std=f2003. */
2961 f03
= (gfc_option
.allow_std
== GFC_STD_OPT_F03
);
2963 /* Look for a blank between STOP and the stop-code for F2008 or later. */
2964 if (gfc_current_form
!= FORM_FIXED
&& !(f95
|| f03
))
2966 char c
= gfc_peek_ascii_char ();
2968 /* Look for end-of-statement. There is no stop-code. */
2969 if (c
== '\n' || c
== '!' || c
== ';')
2974 gfc_error ("Blank required in %s statement near %C",
2975 gfc_ascii_statement (st
));
2980 if (gfc_match_eos () != MATCH_YES
)
2985 /* First look for the F95 or F2003 digit [...] construct. */
2986 old_locus
= gfc_current_locus
;
2987 m
= gfc_match_small_int (&stopcode
);
2988 if (m
== MATCH_YES
&& (f95
|| f03
))
2992 gfc_error ("STOP code at %C cannot be negative");
2996 if (stopcode
> 99999)
2998 gfc_error ("STOP code at %C contains too many digits");
3003 /* Reset the locus and now load gfc_expr. */
3004 gfc_current_locus
= old_locus
;
3005 m
= gfc_match_expr (&e
);
3006 if (m
== MATCH_ERROR
)
3011 if (gfc_match_eos () != MATCH_YES
)
3015 if (gfc_pure (NULL
))
3017 if (st
== ST_ERROR_STOP
)
3019 if (!gfc_notify_std (GFC_STD_F2018
, "%s statement at %C in PURE "
3020 "procedure", gfc_ascii_statement (st
)))
3025 gfc_error ("%s statement not allowed in PURE procedure at %C",
3026 gfc_ascii_statement (st
));
3031 gfc_unset_implicit_pure (NULL
);
3033 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
))
3035 gfc_error ("Image control statement STOP at %C in CRITICAL block");
3038 if (st
== ST_STOP
&& gfc_find_state (COMP_DO_CONCURRENT
))
3040 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
3046 gfc_simplify_expr (e
, 0);
3048 /* Test for F95 and F2003 style STOP stop-code. */
3049 if (e
->expr_type
!= EXPR_CONSTANT
&& (f95
|| f03
))
3051 gfc_error ("STOP code at %L must be a scalar CHARACTER constant or "
3052 "digit[digit[digit[digit[digit]]]]", &e
->where
);
3056 /* Use the machinery for an initialization expression to reduce the
3057 stop-code to a constant. */
3058 gfc_init_expr_flag
= true;
3059 gfc_reduce_init_expr (e
);
3060 gfc_init_expr_flag
= false;
3062 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
3064 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
3071 gfc_error ("STOP code at %L must be scalar", &e
->where
);
3075 if (e
->ts
.type
== BT_CHARACTER
3076 && e
->ts
.kind
!= gfc_default_character_kind
)
3078 gfc_error ("STOP code at %L must be default character KIND=%d",
3079 &e
->where
, (int) gfc_default_character_kind
);
3083 if (e
->ts
.type
== BT_INTEGER
&& e
->ts
.kind
!= gfc_default_integer_kind
)
3085 gfc_error ("STOP code at %L must be default integer KIND=%d",
3086 &e
->where
, (int) gfc_default_integer_kind
);
3096 new_st
.op
= EXEC_STOP
;
3099 new_st
.op
= EXEC_ERROR_STOP
;
3102 new_st
.op
= EXEC_PAUSE
;
3109 new_st
.ext
.stop_code
= -1;
3114 gfc_syntax_error (st
);
3123 /* Match the (deprecated) PAUSE statement. */
3126 gfc_match_pause (void)
3130 m
= gfc_match_stopcode (ST_PAUSE
);
3133 if (!gfc_notify_std (GFC_STD_F95_DEL
, "PAUSE statement at %C"))
3140 /* Match the STOP statement. */
3143 gfc_match_stop (void)
3145 return gfc_match_stopcode (ST_STOP
);
3149 /* Match the ERROR STOP statement. */
3152 gfc_match_error_stop (void)
3154 if (!gfc_notify_std (GFC_STD_F2008
, "ERROR STOP statement at %C"))
3157 return gfc_match_stopcode (ST_ERROR_STOP
);
3160 /* Match EVENT POST/WAIT statement. Syntax:
3161 EVENT POST ( event-variable [, sync-stat-list] )
3162 EVENT WAIT ( event-variable [, wait-spec-list] )
3164 wait-spec-list is sync-stat-list or until-spec
3165 until-spec is UNTIL_COUNT = scalar-int-expr
3166 sync-stat is STAT= or ERRMSG=. */
3169 event_statement (gfc_statement st
)
3172 gfc_expr
*tmp
, *eventvar
, *until_count
, *stat
, *errmsg
;
3173 bool saw_until_count
, saw_stat
, saw_errmsg
;
3175 tmp
= eventvar
= until_count
= stat
= errmsg
= NULL
;
3176 saw_until_count
= saw_stat
= saw_errmsg
= false;
3178 if (gfc_pure (NULL
))
3180 gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
3181 st
== ST_EVENT_POST
? "POST" : "WAIT");
3185 gfc_unset_implicit_pure (NULL
);
3187 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3189 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3193 if (gfc_find_state (COMP_CRITICAL
))
3195 gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
3196 st
== ST_EVENT_POST
? "POST" : "WAIT");
3200 if (gfc_find_state (COMP_DO_CONCURRENT
))
3202 gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
3203 "block", st
== ST_EVENT_POST
? "POST" : "WAIT");
3207 if (gfc_match_char ('(') != MATCH_YES
)
3210 if (gfc_match ("%e", &eventvar
) != MATCH_YES
)
3212 m
= gfc_match_char (',');
3213 if (m
== MATCH_ERROR
)
3217 m
= gfc_match_char (')');
3225 m
= gfc_match (" stat = %v", &tmp
);
3226 if (m
== MATCH_ERROR
)
3232 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3238 m
= gfc_match_char (',');
3246 m
= gfc_match (" errmsg = %v", &tmp
);
3247 if (m
== MATCH_ERROR
)
3253 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3259 m
= gfc_match_char (',');
3267 m
= gfc_match (" until_count = %e", &tmp
);
3268 if (m
== MATCH_ERROR
|| st
== ST_EVENT_POST
)
3272 if (saw_until_count
)
3274 gfc_error ("Redundant UNTIL_COUNT tag found at %L",
3279 saw_until_count
= true;
3281 m
= gfc_match_char (',');
3292 if (m
== MATCH_ERROR
)
3295 if (gfc_match (" )%t") != MATCH_YES
)
3302 new_st
.op
= EXEC_EVENT_POST
;
3305 new_st
.op
= EXEC_EVENT_WAIT
;
3311 new_st
.expr1
= eventvar
;
3312 new_st
.expr2
= stat
;
3313 new_st
.expr3
= errmsg
;
3314 new_st
.expr4
= until_count
;
3319 gfc_syntax_error (st
);
3322 if (until_count
!= tmp
)
3323 gfc_free_expr (until_count
);
3325 gfc_free_expr (errmsg
);
3327 gfc_free_expr (stat
);
3329 gfc_free_expr (tmp
);
3330 gfc_free_expr (eventvar
);
3338 gfc_match_event_post (void)
3340 if (!gfc_notify_std (GFC_STD_F2018
, "EVENT POST statement at %C"))
3343 return event_statement (ST_EVENT_POST
);
3348 gfc_match_event_wait (void)
3350 if (!gfc_notify_std (GFC_STD_F2018
, "EVENT WAIT statement at %C"))
3353 return event_statement (ST_EVENT_WAIT
);
3357 /* Match a FAIL IMAGE statement. */
3360 gfc_match_fail_image (void)
3362 if (!gfc_notify_std (GFC_STD_F2018
, "FAIL IMAGE statement at %C"))
3365 if (gfc_match_char ('(') == MATCH_YES
)
3368 new_st
.op
= EXEC_FAIL_IMAGE
;
3373 gfc_syntax_error (ST_FAIL_IMAGE
);
3378 /* Match a FORM TEAM statement. */
3381 gfc_match_form_team (void)
3384 gfc_expr
*teamid
,*team
;
3386 if (!gfc_notify_std (GFC_STD_F2018
, "FORM TEAM statement at %C"))
3389 if (gfc_match_char ('(') == MATCH_NO
)
3392 new_st
.op
= EXEC_FORM_TEAM
;
3394 if (gfc_match ("%e", &teamid
) != MATCH_YES
)
3396 m
= gfc_match_char (',');
3397 if (m
== MATCH_ERROR
)
3399 if (gfc_match ("%e", &team
) != MATCH_YES
)
3402 m
= gfc_match_char (')');
3406 new_st
.expr1
= teamid
;
3407 new_st
.expr2
= team
;
3412 gfc_syntax_error (ST_FORM_TEAM
);
3417 /* Match a CHANGE TEAM statement. */
3420 gfc_match_change_team (void)
3425 if (!gfc_notify_std (GFC_STD_F2018
, "CHANGE TEAM statement at %C"))
3428 if (gfc_match_char ('(') == MATCH_NO
)
3431 new_st
.op
= EXEC_CHANGE_TEAM
;
3433 if (gfc_match ("%e", &team
) != MATCH_YES
)
3436 m
= gfc_match_char (')');
3440 new_st
.expr1
= team
;
3445 gfc_syntax_error (ST_CHANGE_TEAM
);
3450 /* Match a END TEAM statement. */
3453 gfc_match_end_team (void)
3455 if (!gfc_notify_std (GFC_STD_F2018
, "END TEAM statement at %C"))
3458 if (gfc_match_char ('(') == MATCH_YES
)
3461 new_st
.op
= EXEC_END_TEAM
;
3466 gfc_syntax_error (ST_END_TEAM
);
3471 /* Match a SYNC TEAM statement. */
3474 gfc_match_sync_team (void)
3479 if (!gfc_notify_std (GFC_STD_F2018
, "SYNC TEAM statement at %C"))
3482 if (gfc_match_char ('(') == MATCH_NO
)
3485 new_st
.op
= EXEC_SYNC_TEAM
;
3487 if (gfc_match ("%e", &team
) != MATCH_YES
)
3490 m
= gfc_match_char (')');
3494 new_st
.expr1
= team
;
3499 gfc_syntax_error (ST_SYNC_TEAM
);
3504 /* Match LOCK/UNLOCK statement. Syntax:
3505 LOCK ( lock-variable [ , lock-stat-list ] )
3506 UNLOCK ( lock-variable [ , sync-stat-list ] )
3507 where lock-stat is ACQUIRED_LOCK or sync-stat
3508 and sync-stat is STAT= or ERRMSG=. */
3511 lock_unlock_statement (gfc_statement st
)
3514 gfc_expr
*tmp
, *lockvar
, *acq_lock
, *stat
, *errmsg
;
3515 bool saw_acq_lock
, saw_stat
, saw_errmsg
;
3517 tmp
= lockvar
= acq_lock
= stat
= errmsg
= NULL
;
3518 saw_acq_lock
= saw_stat
= saw_errmsg
= false;
3520 if (gfc_pure (NULL
))
3522 gfc_error ("Image control statement %s at %C in PURE procedure",
3523 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3527 gfc_unset_implicit_pure (NULL
);
3529 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3531 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3535 if (gfc_find_state (COMP_CRITICAL
))
3537 gfc_error ("Image control statement %s at %C in CRITICAL block",
3538 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3542 if (gfc_find_state (COMP_DO_CONCURRENT
))
3544 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
3545 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3549 if (gfc_match_char ('(') != MATCH_YES
)
3552 if (gfc_match ("%e", &lockvar
) != MATCH_YES
)
3554 m
= gfc_match_char (',');
3555 if (m
== MATCH_ERROR
)
3559 m
= gfc_match_char (')');
3567 m
= gfc_match (" stat = %v", &tmp
);
3568 if (m
== MATCH_ERROR
)
3574 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3580 m
= gfc_match_char (',');
3588 m
= gfc_match (" errmsg = %v", &tmp
);
3589 if (m
== MATCH_ERROR
)
3595 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3601 m
= gfc_match_char (',');
3609 m
= gfc_match (" acquired_lock = %v", &tmp
);
3610 if (m
== MATCH_ERROR
|| st
== ST_UNLOCK
)
3616 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L",
3621 saw_acq_lock
= true;
3623 m
= gfc_match_char (',');
3634 if (m
== MATCH_ERROR
)
3637 if (gfc_match (" )%t") != MATCH_YES
)
3644 new_st
.op
= EXEC_LOCK
;
3647 new_st
.op
= EXEC_UNLOCK
;
3653 new_st
.expr1
= lockvar
;
3654 new_st
.expr2
= stat
;
3655 new_st
.expr3
= errmsg
;
3656 new_st
.expr4
= acq_lock
;
3661 gfc_syntax_error (st
);
3664 if (acq_lock
!= tmp
)
3665 gfc_free_expr (acq_lock
);
3667 gfc_free_expr (errmsg
);
3669 gfc_free_expr (stat
);
3671 gfc_free_expr (tmp
);
3672 gfc_free_expr (lockvar
);
3679 gfc_match_lock (void)
3681 if (!gfc_notify_std (GFC_STD_F2008
, "LOCK statement at %C"))
3684 return lock_unlock_statement (ST_LOCK
);
3689 gfc_match_unlock (void)
3691 if (!gfc_notify_std (GFC_STD_F2008
, "UNLOCK statement at %C"))
3694 return lock_unlock_statement (ST_UNLOCK
);
3698 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
3699 SYNC ALL [(sync-stat-list)]
3700 SYNC MEMORY [(sync-stat-list)]
3701 SYNC IMAGES (image-set [, sync-stat-list] )
3702 with sync-stat is int-expr or *. */
3705 sync_statement (gfc_statement st
)
3708 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
3709 bool saw_stat
, saw_errmsg
;
3711 tmp
= imageset
= stat
= errmsg
= NULL
;
3712 saw_stat
= saw_errmsg
= false;
3714 if (gfc_pure (NULL
))
3716 gfc_error ("Image control statement SYNC at %C in PURE procedure");
3720 gfc_unset_implicit_pure (NULL
);
3722 if (!gfc_notify_std (GFC_STD_F2008
, "SYNC statement at %C"))
3725 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3727 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
3732 if (gfc_find_state (COMP_CRITICAL
))
3734 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3738 if (gfc_find_state (COMP_DO_CONCURRENT
))
3740 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3744 if (gfc_match_eos () == MATCH_YES
)
3746 if (st
== ST_SYNC_IMAGES
)
3751 if (gfc_match_char ('(') != MATCH_YES
)
3754 if (st
== ST_SYNC_IMAGES
)
3756 /* Denote '*' as imageset == NULL. */
3757 m
= gfc_match_char ('*');
3758 if (m
== MATCH_ERROR
)
3762 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
3765 m
= gfc_match_char (',');
3766 if (m
== MATCH_ERROR
)
3770 m
= gfc_match_char (')');
3779 m
= gfc_match (" stat = %v", &tmp
);
3780 if (m
== MATCH_ERROR
)
3786 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3792 if (gfc_match_char (',') == MATCH_YES
)
3799 m
= gfc_match (" errmsg = %v", &tmp
);
3800 if (m
== MATCH_ERROR
)
3806 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3812 if (gfc_match_char (',') == MATCH_YES
)
3822 if (gfc_match (" )%t") != MATCH_YES
)
3829 new_st
.op
= EXEC_SYNC_ALL
;
3831 case ST_SYNC_IMAGES
:
3832 new_st
.op
= EXEC_SYNC_IMAGES
;
3834 case ST_SYNC_MEMORY
:
3835 new_st
.op
= EXEC_SYNC_MEMORY
;
3841 new_st
.expr1
= imageset
;
3842 new_st
.expr2
= stat
;
3843 new_st
.expr3
= errmsg
;
3848 gfc_syntax_error (st
);
3852 gfc_free_expr (stat
);
3854 gfc_free_expr (errmsg
);
3856 gfc_free_expr (tmp
);
3857 gfc_free_expr (imageset
);
3863 /* Match SYNC ALL statement. */
3866 gfc_match_sync_all (void)
3868 return sync_statement (ST_SYNC_ALL
);
3872 /* Match SYNC IMAGES statement. */
3875 gfc_match_sync_images (void)
3877 return sync_statement (ST_SYNC_IMAGES
);
3881 /* Match SYNC MEMORY statement. */
3884 gfc_match_sync_memory (void)
3886 return sync_statement (ST_SYNC_MEMORY
);
3890 /* Match a CONTINUE statement. */
3893 gfc_match_continue (void)
3895 if (gfc_match_eos () != MATCH_YES
)
3897 gfc_syntax_error (ST_CONTINUE
);
3901 new_st
.op
= EXEC_CONTINUE
;
3906 /* Match the (deprecated) ASSIGN statement. */
3909 gfc_match_assign (void)
3912 gfc_st_label
*label
;
3914 if (gfc_match (" %l", &label
) == MATCH_YES
)
3916 if (!gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
))
3918 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
3920 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGN statement at %C"))
3923 expr
->symtree
->n
.sym
->attr
.assign
= 1;
3925 new_st
.op
= EXEC_LABEL_ASSIGN
;
3926 new_st
.label1
= label
;
3927 new_st
.expr1
= expr
;
3935 /* Match the GO TO statement. As a computed GOTO statement is
3936 matched, it is transformed into an equivalent SELECT block. No
3937 tree is necessary, and the resulting jumps-to-jumps are
3938 specifically optimized away by the back end. */
3941 gfc_match_goto (void)
3943 gfc_code
*head
, *tail
;
3946 gfc_st_label
*label
;
3950 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
3952 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3955 new_st
.op
= EXEC_GOTO
;
3956 new_st
.label1
= label
;
3960 /* The assigned GO TO statement. */
3962 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
3964 if (!gfc_notify_std (GFC_STD_F95_DEL
, "Assigned GOTO statement at %C"))
3967 new_st
.op
= EXEC_GOTO
;
3968 new_st
.expr1
= expr
;
3970 if (gfc_match_eos () == MATCH_YES
)
3973 /* Match label list. */
3974 gfc_match_char (',');
3975 if (gfc_match_char ('(') != MATCH_YES
)
3977 gfc_syntax_error (ST_GOTO
);
3984 m
= gfc_match_st_label (&label
);
3988 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3992 head
= tail
= gfc_get_code (EXEC_GOTO
);
3995 tail
->block
= gfc_get_code (EXEC_GOTO
);
3999 tail
->label1
= label
;
4001 while (gfc_match_char (',') == MATCH_YES
);
4003 if (gfc_match (")%t") != MATCH_YES
)
4008 gfc_error ("Statement label list in GOTO at %C cannot be empty");
4011 new_st
.block
= head
;
4016 /* Last chance is a computed GO TO statement. */
4017 if (gfc_match_char ('(') != MATCH_YES
)
4019 gfc_syntax_error (ST_GOTO
);
4028 m
= gfc_match_st_label (&label
);
4032 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
4036 head
= tail
= gfc_get_code (EXEC_SELECT
);
4039 tail
->block
= gfc_get_code (EXEC_SELECT
);
4043 cp
= gfc_get_case ();
4044 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
4047 tail
->ext
.block
.case_list
= cp
;
4049 tail
->next
= gfc_get_code (EXEC_GOTO
);
4050 tail
->next
->label1
= label
;
4052 while (gfc_match_char (',') == MATCH_YES
);
4054 if (gfc_match_char (')') != MATCH_YES
)
4059 gfc_error ("Statement label list in GOTO at %C cannot be empty");
4063 /* Get the rest of the statement. */
4064 gfc_match_char (',');
4066 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
4069 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Computed GOTO at %C"))
4072 /* At this point, a computed GOTO has been fully matched and an
4073 equivalent SELECT statement constructed. */
4075 new_st
.op
= EXEC_SELECT
;
4076 new_st
.expr1
= NULL
;
4078 /* Hack: For a "real" SELECT, the expression is in expr. We put
4079 it in expr2 so we can distinguish then and produce the correct
4081 new_st
.expr2
= expr
;
4082 new_st
.block
= head
;
4086 gfc_syntax_error (ST_GOTO
);
4088 gfc_free_statements (head
);
4093 /* Frees a list of gfc_alloc structures. */
4096 gfc_free_alloc_list (gfc_alloc
*p
)
4103 gfc_free_expr (p
->expr
);
4109 /* Match an ALLOCATE statement. */
4112 gfc_match_allocate (void)
4114 gfc_alloc
*head
, *tail
;
4115 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
4119 locus old_locus
, deferred_locus
, assumed_locus
;
4120 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, saw_deferred
, b1
, b2
, b3
;
4121 bool saw_unlimited
= false, saw_assumed
= false;
4124 stat
= errmsg
= source
= mold
= tmp
= NULL
;
4125 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= saw_deferred
= false;
4127 if (gfc_match_char ('(') != MATCH_YES
)
4129 gfc_syntax_error (ST_ALLOCATE
);
4133 /* Match an optional type-spec. */
4134 old_locus
= gfc_current_locus
;
4135 m
= gfc_match_type_spec (&ts
);
4136 if (m
== MATCH_ERROR
)
4138 else if (m
== MATCH_NO
)
4140 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
4142 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
4144 gfc_error ("Error in type-spec at %L", &old_locus
);
4148 ts
.type
= BT_UNKNOWN
;
4152 /* Needed for the F2008:C631 check below. */
4153 assumed_locus
= gfc_current_locus
;
4155 if (gfc_match (" :: ") == MATCH_YES
)
4157 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
4163 gfc_error ("Type-spec at %L cannot contain a deferred "
4164 "type parameter", &old_locus
);
4168 if (ts
.type
== BT_CHARACTER
)
4170 if (!ts
.u
.cl
->length
)
4173 ts
.u
.cl
->length_from_typespec
= true;
4176 if (type_param_spec_list
4177 && gfc_spec_list_type (type_param_spec_list
, NULL
)
4180 gfc_error ("The type parameter spec list in the type-spec at "
4181 "%L cannot contain DEFERRED parameters", &old_locus
);
4187 ts
.type
= BT_UNKNOWN
;
4188 gfc_current_locus
= old_locus
;
4195 head
= tail
= gfc_get_alloc ();
4198 tail
->next
= gfc_get_alloc ();
4202 m
= gfc_match_variable (&tail
->expr
, 0);
4205 if (m
== MATCH_ERROR
)
4208 if (gfc_check_do_variable (tail
->expr
->symtree
))
4211 bool impure
= gfc_impure_variable (tail
->expr
->symtree
->n
.sym
);
4212 if (impure
&& gfc_pure (NULL
))
4214 gfc_error ("Bad allocate-object at %C for a PURE procedure");
4219 gfc_unset_implicit_pure (NULL
);
4221 /* F2008:C631 (R626) A type-param-value in a type-spec shall be an
4222 asterisk if and only if each allocate-object is a dummy argument
4223 for which the corresponding type parameter is assumed. */
4225 && (tail
->expr
->ts
.deferred
4226 || (tail
->expr
->ts
.u
.cl
&& tail
->expr
->ts
.u
.cl
->length
)
4227 || tail
->expr
->symtree
->n
.sym
->attr
.dummy
== 0))
4229 gfc_error ("Incompatible allocate-object at %C for CHARACTER "
4230 "type-spec at %L", &assumed_locus
);
4234 if (tail
->expr
->ts
.deferred
)
4236 saw_deferred
= true;
4237 deferred_locus
= tail
->expr
->where
;
4240 if (gfc_find_state (COMP_DO_CONCURRENT
)
4241 || gfc_find_state (COMP_CRITICAL
))
4244 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
4245 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
4246 if (ref
->type
== REF_COMPONENT
)
4247 coarray
= ref
->u
.c
.component
->attr
.codimension
;
4249 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
4251 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
4254 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
4256 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
4261 /* Check for F08:C628. */
4262 sym
= tail
->expr
->symtree
->n
.sym
;
4263 b1
= !(tail
->expr
->ref
4264 && (tail
->expr
->ref
->type
== REF_COMPONENT
4265 || tail
->expr
->ref
->type
== REF_ARRAY
));
4266 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4267 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
4268 || CLASS_DATA (sym
)->attr
.class_pointer
);
4270 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4271 || sym
->attr
.proc_pointer
);
4272 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
4273 && (sym
->ns
->proc_name
->attr
.allocatable
4274 || sym
->ns
->proc_name
->attr
.pointer
4275 || sym
->ns
->proc_name
->attr
.proc_pointer
);
4276 if (b1
&& b2
&& !b3
)
4278 gfc_error ("Allocate-object at %L is neither a data pointer "
4279 "nor an allocatable variable", &tail
->expr
->where
);
4283 /* The ALLOCATE statement had an optional typespec. Check the
4285 if (ts
.type
!= BT_UNKNOWN
)
4287 /* Enforce F03:C624. */
4288 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
4290 gfc_error ("Type of entity at %L is type incompatible with "
4291 "typespec", &tail
->expr
->where
);
4295 /* Enforce F03:C627. */
4296 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
4298 gfc_error ("Kind type parameter for entity at %L differs from "
4299 "the kind type parameter of the typespec",
4300 &tail
->expr
->where
);
4305 if (tail
->expr
->ts
.type
== BT_DERIVED
)
4306 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
4308 if (type_param_spec_list
)
4309 tail
->expr
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
4311 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
4313 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
4315 gfc_error ("Shape specification for allocatable scalar at %C");
4319 if (gfc_match_char (',') != MATCH_YES
)
4324 m
= gfc_match (" stat = %v", &tmp
);
4325 if (m
== MATCH_ERROR
)
4332 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4340 if (gfc_check_do_variable (stat
->symtree
))
4343 if (gfc_match_char (',') == MATCH_YES
)
4344 goto alloc_opt_list
;
4347 m
= gfc_match (" errmsg = %v", &tmp
);
4348 if (m
== MATCH_ERROR
)
4352 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
4358 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4366 if (gfc_match_char (',') == MATCH_YES
)
4367 goto alloc_opt_list
;
4370 m
= gfc_match (" source = %e", &tmp
);
4371 if (m
== MATCH_ERROR
)
4375 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
4381 gfc_error ("Redundant SOURCE tag found at %L", &tmp
->where
);
4385 /* The next 2 conditionals check C631. */
4386 if (ts
.type
!= BT_UNKNOWN
)
4388 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
4389 &tmp
->where
, &old_locus
);
4394 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
4395 " with more than a single allocate object",
4403 if (gfc_match_char (',') == MATCH_YES
)
4404 goto alloc_opt_list
;
4407 m
= gfc_match (" mold = %e", &tmp
);
4408 if (m
== MATCH_ERROR
)
4412 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
4415 /* Check F08:C636. */
4418 gfc_error ("Redundant MOLD tag found at %L", &tmp
->where
);
4422 /* Check F08:C637. */
4423 if (ts
.type
!= BT_UNKNOWN
)
4425 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
4426 &tmp
->where
, &old_locus
);
4435 if (gfc_match_char (',') == MATCH_YES
)
4436 goto alloc_opt_list
;
4439 gfc_gobble_whitespace ();
4441 if (gfc_peek_char () == ')')
4445 if (gfc_match (" )%t") != MATCH_YES
)
4448 /* Check F08:C637. */
4451 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
4452 &mold
->where
, &source
->where
);
4456 /* Check F03:C623, */
4457 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4459 gfc_error ("Allocate-object at %L with a deferred type parameter "
4460 "requires either a type-spec or SOURCE tag or a MOLD tag",
4465 /* Check F03:C625, */
4466 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4468 for (tail
= head
; tail
; tail
= tail
->next
)
4470 if (UNLIMITED_POLY (tail
->expr
))
4471 gfc_error ("Unlimited polymorphic allocate-object at %L "
4472 "requires either a type-spec or SOURCE tag "
4473 "or a MOLD tag", &tail
->expr
->where
);
4478 new_st
.op
= EXEC_ALLOCATE
;
4479 new_st
.expr1
= stat
;
4480 new_st
.expr2
= errmsg
;
4482 new_st
.expr3
= source
;
4484 new_st
.expr3
= mold
;
4485 new_st
.ext
.alloc
.list
= head
;
4486 new_st
.ext
.alloc
.ts
= ts
;
4488 if (type_param_spec_list
)
4489 gfc_free_actual_arglist (type_param_spec_list
);
4494 gfc_syntax_error (ST_ALLOCATE
);
4497 gfc_free_expr (errmsg
);
4498 gfc_free_expr (source
);
4499 gfc_free_expr (stat
);
4500 gfc_free_expr (mold
);
4501 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
4502 gfc_free_alloc_list (head
);
4503 if (type_param_spec_list
)
4504 gfc_free_actual_arglist (type_param_spec_list
);
4509 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
4510 a set of pointer assignments to intrinsic NULL(). */
4513 gfc_match_nullify (void)
4521 if (gfc_match_char ('(') != MATCH_YES
)
4526 m
= gfc_match_variable (&p
, 0);
4527 if (m
== MATCH_ERROR
)
4532 if (gfc_check_do_variable (p
->symtree
))
4536 if (gfc_is_coindexed (p
))
4538 gfc_error ("Pointer object at %C shall not be coindexed");
4542 /* build ' => NULL() '. */
4543 e
= gfc_get_null_expr (&gfc_current_locus
);
4545 /* Chain to list. */
4549 tail
->op
= EXEC_POINTER_ASSIGN
;
4553 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
4560 if (gfc_match (" )%t") == MATCH_YES
)
4562 if (gfc_match_char (',') != MATCH_YES
)
4569 gfc_syntax_error (ST_NULLIFY
);
4572 gfc_free_statements (new_st
.next
);
4574 gfc_free_expr (new_st
.expr1
);
4575 new_st
.expr1
= NULL
;
4576 gfc_free_expr (new_st
.expr2
);
4577 new_st
.expr2
= NULL
;
4582 /* Match a DEALLOCATE statement. */
4585 gfc_match_deallocate (void)
4587 gfc_alloc
*head
, *tail
;
4588 gfc_expr
*stat
, *errmsg
, *tmp
;
4591 bool saw_stat
, saw_errmsg
, b1
, b2
;
4594 stat
= errmsg
= tmp
= NULL
;
4595 saw_stat
= saw_errmsg
= false;
4597 if (gfc_match_char ('(') != MATCH_YES
)
4603 head
= tail
= gfc_get_alloc ();
4606 tail
->next
= gfc_get_alloc ();
4610 m
= gfc_match_variable (&tail
->expr
, 0);
4611 if (m
== MATCH_ERROR
)
4616 if (gfc_check_do_variable (tail
->expr
->symtree
))
4619 sym
= tail
->expr
->symtree
->n
.sym
;
4621 bool impure
= gfc_impure_variable (sym
);
4622 if (impure
&& gfc_pure (NULL
))
4624 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
4629 gfc_unset_implicit_pure (NULL
);
4631 if (gfc_is_coarray (tail
->expr
)
4632 && gfc_find_state (COMP_DO_CONCURRENT
))
4634 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
4638 if (gfc_is_coarray (tail
->expr
)
4639 && gfc_find_state (COMP_CRITICAL
))
4641 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
4645 /* FIXME: disable the checking on derived types. */
4646 b1
= !(tail
->expr
->ref
4647 && (tail
->expr
->ref
->type
== REF_COMPONENT
4648 || tail
->expr
->ref
->type
== REF_ARRAY
));
4649 if (sym
&& sym
->ts
.type
== BT_CLASS
)
4650 b2
= !(CLASS_DATA (sym
) && (CLASS_DATA (sym
)->attr
.allocatable
4651 || CLASS_DATA (sym
)->attr
.class_pointer
));
4653 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4654 || sym
->attr
.proc_pointer
);
4657 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
4658 "nor an allocatable variable");
4662 if (gfc_match_char (',') != MATCH_YES
)
4667 m
= gfc_match (" stat = %v", &tmp
);
4668 if (m
== MATCH_ERROR
)
4674 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4675 gfc_free_expr (tmp
);
4682 if (gfc_check_do_variable (stat
->symtree
))
4685 if (gfc_match_char (',') == MATCH_YES
)
4686 goto dealloc_opt_list
;
4689 m
= gfc_match (" errmsg = %v", &tmp
);
4690 if (m
== MATCH_ERROR
)
4694 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
4699 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4700 gfc_free_expr (tmp
);
4707 if (gfc_match_char (',') == MATCH_YES
)
4708 goto dealloc_opt_list
;
4711 gfc_gobble_whitespace ();
4713 if (gfc_peek_char () == ')')
4717 if (gfc_match (" )%t") != MATCH_YES
)
4720 new_st
.op
= EXEC_DEALLOCATE
;
4721 new_st
.expr1
= stat
;
4722 new_st
.expr2
= errmsg
;
4723 new_st
.ext
.alloc
.list
= head
;
4728 gfc_syntax_error (ST_DEALLOCATE
);
4731 gfc_free_expr (errmsg
);
4732 gfc_free_expr (stat
);
4733 gfc_free_alloc_list (head
);
4738 /* Match a RETURN statement. */
4741 gfc_match_return (void)
4745 gfc_compile_state s
;
4749 if (gfc_find_state (COMP_CRITICAL
))
4751 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4755 if (gfc_find_state (COMP_DO_CONCURRENT
))
4757 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4761 if (gfc_match_eos () == MATCH_YES
)
4764 if (!gfc_find_state (COMP_SUBROUTINE
))
4766 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4771 if (gfc_current_form
== FORM_FREE
)
4773 /* The following are valid, so we can't require a blank after the
4777 char c
= gfc_peek_ascii_char ();
4778 if (ISALPHA (c
) || ISDIGIT (c
))
4782 m
= gfc_match (" %e%t", &e
);
4785 if (m
== MATCH_ERROR
)
4788 gfc_syntax_error (ST_RETURN
);
4795 gfc_enclosing_unit (&s
);
4796 if (s
== COMP_PROGRAM
4797 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
4798 "main program at %C"))
4801 new_st
.op
= EXEC_RETURN
;
4808 /* Match the call of a type-bound procedure, if CALL%var has already been
4809 matched and var found to be a derived-type variable. */
4812 match_typebound_call (gfc_symtree
* varst
)
4817 base
= gfc_get_expr ();
4818 base
->expr_type
= EXPR_VARIABLE
;
4819 base
->symtree
= varst
;
4820 base
->where
= gfc_current_locus
;
4821 gfc_set_sym_referenced (varst
->n
.sym
);
4823 m
= gfc_match_varspec (base
, 0, true, true);
4825 gfc_error ("Expected component reference at %C");
4828 gfc_free_expr (base
);
4832 if (gfc_match_eos () != MATCH_YES
)
4834 gfc_error ("Junk after CALL at %C");
4835 gfc_free_expr (base
);
4839 if (base
->expr_type
== EXPR_COMPCALL
)
4840 new_st
.op
= EXEC_COMPCALL
;
4841 else if (base
->expr_type
== EXPR_PPC
)
4842 new_st
.op
= EXEC_CALL_PPC
;
4845 gfc_error ("Expected type-bound procedure or procedure pointer component "
4847 gfc_free_expr (base
);
4850 new_st
.expr1
= base
;
4856 /* Match a CALL statement. The tricky part here are possible
4857 alternate return specifiers. We handle these by having all
4858 "subroutines" actually return an integer via a register that gives
4859 the return number. If the call specifies alternate returns, we
4860 generate code for a SELECT statement whose case clauses contain
4861 GOTOs to the various labels. */
4864 gfc_match_call (void)
4866 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4867 gfc_actual_arglist
*a
, *arglist
;
4877 m
= gfc_match ("% %n", name
);
4883 if (gfc_get_ha_sym_tree (name
, &st
))
4888 /* If this is a variable of derived-type, it probably starts a type-bound
4890 if ((sym
->attr
.flavor
!= FL_PROCEDURE
4891 || gfc_is_function_return_value (sym
, gfc_current_ns
))
4892 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
4893 return match_typebound_call (st
);
4895 /* If it does not seem to be callable (include functions so that the
4896 right association is made. They are thrown out in resolution.)
4898 if (!sym
->attr
.generic
4899 && !sym
->attr
.subroutine
4900 && !sym
->attr
.function
)
4902 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
4904 /* ...create a symbol in this scope... */
4905 if (sym
->ns
!= gfc_current_ns
4906 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
4909 if (sym
!= st
->n
.sym
)
4913 /* ...and then to try to make the symbol into a subroutine. */
4914 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
4918 gfc_set_sym_referenced (sym
);
4920 if (gfc_match_eos () != MATCH_YES
)
4922 m
= gfc_match_actual_arglist (1, &arglist
);
4925 if (m
== MATCH_ERROR
)
4928 if (gfc_match_eos () != MATCH_YES
)
4932 /* If any alternate return labels were found, construct a SELECT
4933 statement that will jump to the right place. */
4936 for (a
= arglist
; a
; a
= a
->next
)
4937 if (a
->expr
== NULL
)
4945 gfc_symtree
*select_st
;
4946 gfc_symbol
*select_sym
;
4947 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4949 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
4950 sprintf (name
, "_result_%s", sym
->name
);
4951 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
4953 select_sym
= select_st
->n
.sym
;
4954 select_sym
->ts
.type
= BT_INTEGER
;
4955 select_sym
->ts
.kind
= gfc_default_integer_kind
;
4956 gfc_set_sym_referenced (select_sym
);
4957 c
->expr1
= gfc_get_expr ();
4958 c
->expr1
->expr_type
= EXPR_VARIABLE
;
4959 c
->expr1
->symtree
= select_st
;
4960 c
->expr1
->ts
= select_sym
->ts
;
4961 c
->expr1
->where
= gfc_current_locus
;
4964 for (a
= arglist
; a
; a
= a
->next
)
4966 if (a
->expr
!= NULL
)
4969 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
4974 c
->block
= gfc_get_code (EXEC_SELECT
);
4977 new_case
= gfc_get_case ();
4978 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
4979 new_case
->low
= new_case
->high
;
4980 c
->ext
.block
.case_list
= new_case
;
4982 c
->next
= gfc_get_code (EXEC_GOTO
);
4983 c
->next
->label1
= a
->label
;
4987 new_st
.op
= EXEC_CALL
;
4988 new_st
.symtree
= st
;
4989 new_st
.ext
.actual
= arglist
;
4994 gfc_syntax_error (ST_CALL
);
4997 gfc_free_actual_arglist (arglist
);
5002 /* Given a name, return a pointer to the common head structure,
5003 creating it if it does not exist. If FROM_MODULE is nonzero, we
5004 mangle the name so that it doesn't interfere with commons defined
5005 in the using namespace.
5006 TODO: Add to global symbol tree. */
5009 gfc_get_common (const char *name
, int from_module
)
5012 static int serial
= 0;
5013 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
5017 /* A use associated common block is only needed to correctly layout
5018 the variables it contains. */
5019 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
5020 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
5024 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
5027 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
5030 if (st
->n
.common
== NULL
)
5032 st
->n
.common
= gfc_get_common_head ();
5033 st
->n
.common
->where
= gfc_current_locus
;
5034 strcpy (st
->n
.common
->name
, name
);
5037 return st
->n
.common
;
5041 /* Match a common block name. */
5043 match
match_common_name (char *name
)
5047 if (gfc_match_char ('/') == MATCH_NO
)
5053 if (gfc_match_char ('/') == MATCH_YES
)
5059 m
= gfc_match_name (name
);
5061 if (m
== MATCH_ERROR
)
5063 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
5066 gfc_error ("Syntax error in common block name at %C");
5071 /* Match a COMMON statement. */
5074 gfc_match_common (void)
5076 gfc_symbol
*sym
, **head
, *tail
, *other
;
5077 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5087 m
= match_common_name (name
);
5088 if (m
== MATCH_ERROR
)
5091 if (name
[0] == '\0')
5093 t
= &gfc_current_ns
->blank_common
;
5094 if (t
->head
== NULL
)
5095 t
->where
= gfc_current_locus
;
5099 t
= gfc_get_common (name
, 0);
5108 while (tail
->common_next
)
5109 tail
= tail
->common_next
;
5112 /* Grab the list of symbols. */
5115 m
= gfc_match_symbol (&sym
, 0);
5116 if (m
== MATCH_ERROR
)
5121 /* See if we know the current common block is bind(c), and if
5122 so, then see if we can check if the symbol is (which it'll
5123 need to be). This can happen if the bind(c) attr stmt was
5124 applied to the common block, and the variable(s) already
5125 defined, before declaring the common block. */
5126 if (t
->is_bind_c
== 1)
5128 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
5130 /* If we find an error, just print it and continue,
5131 cause it's just semantic, and we can see if there
5133 gfc_error_now ("Variable %qs at %L in common block %qs "
5134 "at %C must be declared with a C "
5135 "interoperable kind since common block "
5137 sym
->name
, &(sym
->declared_at
), t
->name
,
5141 if (sym
->attr
.is_bind_c
== 1)
5142 gfc_error_now ("Variable %qs in common block %qs at %C can not "
5143 "be bind(c) since it is not global", sym
->name
,
5147 if (sym
->attr
.in_common
)
5149 gfc_error ("Symbol %qs at %C is already in a COMMON block",
5154 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
5155 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
5157 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol %qs at "
5158 "%C can only be COMMON in BLOCK DATA",
5163 /* Deal with an optional array specification after the
5165 m
= gfc_match_array_spec (&as
, true, true);
5166 if (m
== MATCH_ERROR
)
5171 if (as
->type
!= AS_EXPLICIT
)
5173 gfc_error ("Array specification for symbol %qs in COMMON "
5174 "at %C must be explicit", sym
->name
);
5178 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
5181 if (sym
->attr
.pointer
)
5183 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
5184 "POINTER array", sym
->name
);
5193 /* Add the in_common attribute, but ignore the reported errors
5194 if any, and continue matching. */
5195 gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
);
5197 sym
->common_block
= t
;
5198 sym
->common_block
->refs
++;
5201 tail
->common_next
= sym
;
5207 sym
->common_head
= t
;
5209 /* Check to see if the symbol is already in an equivalence group.
5210 If it is, set the other members as being in common. */
5211 if (sym
->attr
.in_equivalence
)
5213 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
5215 for (e2
= e1
; e2
; e2
= e2
->eq
)
5216 if (e2
->expr
->symtree
->n
.sym
== sym
)
5223 for (e2
= e1
; e2
; e2
= e2
->eq
)
5225 other
= e2
->expr
->symtree
->n
.sym
;
5226 if (other
->common_head
5227 && other
->common_head
!= sym
->common_head
)
5229 gfc_error ("Symbol %qs, in COMMON block %qs at "
5230 "%C is being indirectly equivalenced to "
5231 "another COMMON block %qs",
5232 sym
->name
, sym
->common_head
->name
,
5233 other
->common_head
->name
);
5236 other
->attr
.in_common
= 1;
5237 other
->common_head
= t
;
5243 gfc_gobble_whitespace ();
5244 if (gfc_match_eos () == MATCH_YES
)
5246 if (gfc_peek_ascii_char () == '/')
5248 if (gfc_match_char (',') != MATCH_YES
)
5250 gfc_gobble_whitespace ();
5251 if (gfc_peek_ascii_char () == '/')
5260 gfc_syntax_error (ST_COMMON
);
5263 gfc_free_array_spec (as
);
5268 /* Match a BLOCK DATA program unit. */
5271 gfc_match_block_data (void)
5273 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5277 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "BLOCK DATA construct at %L",
5278 &gfc_current_locus
))
5281 if (gfc_match_eos () == MATCH_YES
)
5283 gfc_new_block
= NULL
;
5287 m
= gfc_match ("% %n%t", name
);
5291 if (gfc_get_symbol (name
, NULL
, &sym
))
5294 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
5297 gfc_new_block
= sym
;
5303 /* Free a namelist structure. */
5306 gfc_free_namelist (gfc_namelist
*name
)
5310 for (; name
; name
= n
)
5318 /* Free an OpenMP namelist structure. */
5321 gfc_free_omp_namelist (gfc_omp_namelist
*name
)
5323 gfc_omp_namelist
*n
;
5325 for (; name
; name
= n
)
5327 gfc_free_expr (name
->expr
);
5330 if (name
->udr
->combiner
)
5331 gfc_free_statement (name
->udr
->combiner
);
5332 if (name
->udr
->initializer
)
5333 gfc_free_statement (name
->udr
->initializer
);
5342 /* Match a NAMELIST statement. */
5345 gfc_match_namelist (void)
5347 gfc_symbol
*group_name
, *sym
;
5351 m
= gfc_match (" / %s /", &group_name
);
5354 if (m
== MATCH_ERROR
)
5359 if (group_name
->ts
.type
!= BT_UNKNOWN
)
5361 gfc_error ("Namelist group name %qs at %C already has a basic "
5362 "type of %s", group_name
->name
,
5363 gfc_typename (&group_name
->ts
));
5367 if (group_name
->attr
.flavor
== FL_NAMELIST
5368 && group_name
->attr
.use_assoc
5369 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name %qs "
5370 "at %C already is USE associated and can"
5371 "not be respecified.", group_name
->name
))
5374 if (group_name
->attr
.flavor
!= FL_NAMELIST
5375 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
5376 group_name
->name
, NULL
))
5381 m
= gfc_match_symbol (&sym
, 1);
5384 if (m
== MATCH_ERROR
)
5387 if (sym
->attr
.in_namelist
== 0
5388 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
5391 /* Use gfc_error_check here, rather than goto error, so that
5392 these are the only errors for the next two lines. */
5393 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
5395 gfc_error ("Assumed size array %qs in namelist %qs at "
5396 "%C is not allowed", sym
->name
, group_name
->name
);
5400 nl
= gfc_get_namelist ();
5404 if (group_name
->namelist
== NULL
)
5405 group_name
->namelist
= group_name
->namelist_tail
= nl
;
5408 group_name
->namelist_tail
->next
= nl
;
5409 group_name
->namelist_tail
= nl
;
5412 if (gfc_match_eos () == MATCH_YES
)
5415 m
= gfc_match_char (',');
5417 if (gfc_match_char ('/') == MATCH_YES
)
5419 m2
= gfc_match (" %s /", &group_name
);
5420 if (m2
== MATCH_YES
)
5422 if (m2
== MATCH_ERROR
)
5436 gfc_syntax_error (ST_NAMELIST
);
5443 /* Match a MODULE statement. */
5446 gfc_match_module (void)
5450 m
= gfc_match (" %s%t", &gfc_new_block
);
5454 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
5455 gfc_new_block
->name
, NULL
))
5462 /* Free equivalence sets and lists. Recursively is the easiest way to
5466 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
5471 gfc_free_equiv (eq
->eq
);
5472 gfc_free_equiv_until (eq
->next
, stop
);
5473 gfc_free_expr (eq
->expr
);
5479 gfc_free_equiv (gfc_equiv
*eq
)
5481 gfc_free_equiv_until (eq
, NULL
);
5485 /* Match an EQUIVALENCE statement. */
5488 gfc_match_equivalence (void)
5490 gfc_equiv
*eq
, *set
, *tail
;
5494 gfc_common_head
*common_head
= NULL
;
5502 eq
= gfc_get_equiv ();
5506 eq
->next
= gfc_current_ns
->equiv
;
5507 gfc_current_ns
->equiv
= eq
;
5509 if (gfc_match_char ('(') != MATCH_YES
)
5513 common_flag
= FALSE
;
5518 m
= gfc_match_equiv_variable (&set
->expr
);
5519 if (m
== MATCH_ERROR
)
5524 /* count the number of objects. */
5527 if (gfc_match_char ('%') == MATCH_YES
)
5529 gfc_error ("Derived type component %C is not a "
5530 "permitted EQUIVALENCE member");
5534 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
5535 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5537 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
5538 "be an array section");
5542 sym
= set
->expr
->symtree
->n
.sym
;
5544 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
5547 if (sym
->attr
.in_common
)
5550 common_head
= sym
->common_head
;
5553 if (gfc_match_char (')') == MATCH_YES
)
5556 if (gfc_match_char (',') != MATCH_YES
)
5559 set
->eq
= gfc_get_equiv ();
5565 gfc_error ("EQUIVALENCE at %C requires two or more objects");
5569 /* If one of the members of an equivalence is in common, then
5570 mark them all as being in common. Before doing this, check
5571 that members of the equivalence group are not in different
5574 for (set
= eq
; set
; set
= set
->eq
)
5576 sym
= set
->expr
->symtree
->n
.sym
;
5577 if (sym
->common_head
&& sym
->common_head
!= common_head
)
5579 gfc_error ("Attempt to indirectly overlap COMMON "
5580 "blocks %s and %s by EQUIVALENCE at %C",
5581 sym
->common_head
->name
, common_head
->name
);
5584 sym
->attr
.in_common
= 1;
5585 sym
->common_head
= common_head
;
5588 if (gfc_match_eos () == MATCH_YES
)
5590 if (gfc_match_char (',') != MATCH_YES
)
5592 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
5597 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "EQUIVALENCE statement at %C"))
5603 gfc_syntax_error (ST_EQUIVALENCE
);
5609 gfc_free_equiv (gfc_current_ns
->equiv
);
5610 gfc_current_ns
->equiv
= eq
;
5616 /* Check that a statement function is not recursive. This is done by looking
5617 for the statement function symbol(sym) by looking recursively through its
5618 expression(e). If a reference to sym is found, true is returned.
5619 12.5.4 requires that any variable of function that is implicitly typed
5620 shall have that type confirmed by any subsequent type declaration. The
5621 implicit typing is conveniently done here. */
5623 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
5626 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
5632 switch (e
->expr_type
)
5635 if (e
->symtree
== NULL
)
5638 /* Check the name before testing for nested recursion! */
5639 if (sym
->name
== e
->symtree
->n
.sym
->name
)
5642 /* Catch recursion via other statement functions. */
5643 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
5644 && e
->symtree
->n
.sym
->value
5645 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
5648 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5649 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5654 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
5657 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5658 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5670 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
5672 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
5676 /* Match a statement function declaration. It is so easy to match
5677 non-statement function statements with a MATCH_ERROR as opposed to
5678 MATCH_NO that we suppress error message in most cases. */
5681 gfc_match_st_function (void)
5683 gfc_error_buffer old_error
;
5688 m
= gfc_match_symbol (&sym
, 0);
5692 gfc_push_error (&old_error
);
5694 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
5697 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
5700 m
= gfc_match (" = %e%t", &expr
);
5704 gfc_free_error (&old_error
);
5706 if (m
== MATCH_ERROR
)
5709 if (recursive_stmt_fcn (expr
, sym
))
5711 gfc_error ("Statement function at %L is recursive", &expr
->where
);
5717 if ((gfc_current_state () == COMP_FUNCTION
5718 || gfc_current_state () == COMP_SUBROUTINE
)
5719 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
5721 gfc_error ("Statement function at %L cannot appear within an INTERFACE",
5726 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
5732 gfc_pop_error (&old_error
);
5737 /* Match an assignment to a pointer function (F2008). This could, in
5738 general be ambiguous with a statement function. In this implementation
5739 it remains so if it is the first statement after the specification
5743 gfc_match_ptr_fcn_assign (void)
5745 gfc_error_buffer old_error
;
5750 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5752 old_loc
= gfc_current_locus
;
5753 m
= gfc_match_name (name
);
5757 gfc_find_symbol (name
, NULL
, 1, &sym
);
5758 if (sym
&& sym
->attr
.flavor
!= FL_PROCEDURE
)
5761 gfc_push_error (&old_error
);
5763 if (sym
&& sym
->attr
.function
)
5764 goto match_actual_arglist
;
5766 gfc_current_locus
= old_loc
;
5767 m
= gfc_match_symbol (&sym
, 0);
5771 if (!gfc_add_procedure (&sym
->attr
, PROC_UNKNOWN
, sym
->name
, NULL
))
5774 match_actual_arglist
:
5775 gfc_current_locus
= old_loc
;
5776 m
= gfc_match (" %e", &expr
);
5780 new_st
.op
= EXEC_ASSIGN
;
5781 new_st
.expr1
= expr
;
5784 m
= gfc_match (" = %e%t", &expr
);
5788 new_st
.expr2
= expr
;
5792 gfc_pop_error (&old_error
);
5797 /***************** SELECT CASE subroutines ******************/
5799 /* Free a single case structure. */
5802 free_case (gfc_case
*p
)
5804 if (p
->low
== p
->high
)
5806 gfc_free_expr (p
->low
);
5807 gfc_free_expr (p
->high
);
5812 /* Free a list of case structures. */
5815 gfc_free_case_list (gfc_case
*p
)
5827 /* Match a single case selector. Combining the requirements of F08:C830
5828 and F08:C832 (R838) means that the case-value must have either CHARACTER,
5829 INTEGER, or LOGICAL type. */
5832 match_case_selector (gfc_case
**cp
)
5837 c
= gfc_get_case ();
5838 c
->where
= gfc_current_locus
;
5840 if (gfc_match_char (':') == MATCH_YES
)
5842 m
= gfc_match_init_expr (&c
->high
);
5845 if (m
== MATCH_ERROR
)
5848 if (c
->high
->ts
.type
!= BT_LOGICAL
&& c
->high
->ts
.type
!= BT_INTEGER
5849 && c
->high
->ts
.type
!= BT_CHARACTER
)
5851 gfc_error ("Expression in CASE selector at %L cannot be %s",
5852 &c
->high
->where
, gfc_typename (&c
->high
->ts
));
5858 m
= gfc_match_init_expr (&c
->low
);
5859 if (m
== MATCH_ERROR
)
5864 if (c
->low
->ts
.type
!= BT_LOGICAL
&& c
->low
->ts
.type
!= BT_INTEGER
5865 && c
->low
->ts
.type
!= BT_CHARACTER
)
5867 gfc_error ("Expression in CASE selector at %L cannot be %s",
5868 &c
->low
->where
, gfc_typename (&c
->low
->ts
));
5872 /* If we're not looking at a ':' now, make a range out of a single
5873 target. Else get the upper bound for the case range. */
5874 if (gfc_match_char (':') != MATCH_YES
)
5878 m
= gfc_match_init_expr (&c
->high
);
5879 if (m
== MATCH_ERROR
)
5881 /* MATCH_NO is fine. It's OK if nothing is there! */
5889 gfc_error ("Expected initialization expression in CASE at %C");
5897 /* Match the end of a case statement. */
5900 match_case_eos (void)
5902 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5905 if (gfc_match_eos () == MATCH_YES
)
5908 /* If the case construct doesn't have a case-construct-name, we
5909 should have matched the EOS. */
5910 if (!gfc_current_block ())
5913 gfc_gobble_whitespace ();
5915 m
= gfc_match_name (name
);
5919 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5921 gfc_error ("Expected block name %qs of SELECT construct at %C",
5922 gfc_current_block ()->name
);
5926 return gfc_match_eos ();
5930 /* Match a SELECT statement. */
5933 gfc_match_select (void)
5938 m
= gfc_match_label ();
5939 if (m
== MATCH_ERROR
)
5942 m
= gfc_match (" select case ( %e )%t", &expr
);
5946 new_st
.op
= EXEC_SELECT
;
5947 new_st
.expr1
= expr
;
5953 /* Transfer the selector typespec to the associate name. */
5956 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
)
5959 gfc_symbol
*assoc_sym
;
5962 assoc_sym
= associate
->symtree
->n
.sym
;
5964 /* At this stage the expression rank and arrayspec dimensions have
5965 not been completely sorted out. We must get the expr2->rank
5966 right here, so that the correct class container is obtained. */
5967 ref
= selector
->ref
;
5968 while (ref
&& ref
->next
)
5971 if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
5972 && ref
&& ref
->type
== REF_ARRAY
)
5974 /* Ensure that the array reference type is set. We cannot use
5975 gfc_resolve_expr at this point, so the usable parts of
5976 resolve.c(resolve_array_ref) are employed to do it. */
5977 if (ref
->u
.ar
.type
== AR_UNKNOWN
)
5979 ref
->u
.ar
.type
= AR_ELEMENT
;
5980 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
5981 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5982 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
5983 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
5984 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
5986 ref
->u
.ar
.type
= AR_SECTION
;
5991 if (ref
->u
.ar
.type
== AR_FULL
)
5992 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
5993 else if (ref
->u
.ar
.type
== AR_SECTION
)
5994 selector
->rank
= ref
->u
.ar
.dimen
;
5998 rank
= selector
->rank
;
6003 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
6004 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
6005 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
6006 && ref
->u
.ar
.end
[i
] == NULL
6007 && ref
->u
.ar
.stride
[i
] == NULL
))
6012 assoc_sym
->attr
.dimension
= 1;
6013 assoc_sym
->as
= gfc_get_array_spec ();
6014 assoc_sym
->as
->rank
= rank
;
6015 assoc_sym
->as
->type
= AS_DEFERRED
;
6018 assoc_sym
->as
= NULL
;
6021 assoc_sym
->as
= NULL
;
6023 if (selector
->ts
.type
== BT_CLASS
)
6025 /* The correct class container has to be available. */
6026 assoc_sym
->ts
.type
= BT_CLASS
;
6027 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
6028 assoc_sym
->attr
.pointer
= 1;
6029 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
6034 /* Push the current selector onto the SELECT TYPE stack. */
6037 select_type_push (gfc_symbol
*sel
)
6039 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
6040 top
->selector
= sel
;
6042 top
->prev
= select_type_stack
;
6044 select_type_stack
= top
;
6048 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
6050 static gfc_symtree
*
6051 select_intrinsic_set_tmp (gfc_typespec
*ts
)
6053 char name
[GFC_MAX_SYMBOL_LEN
];
6055 HOST_WIDE_INT charlen
= 0;
6057 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
6060 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
6061 && !select_type_stack
->selector
->attr
.class_ok
)
6064 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
6065 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6066 charlen
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
6068 if (ts
->type
!= BT_CHARACTER
)
6069 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
6072 snprintf (name
, sizeof (name
), "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
6073 gfc_basic_typename (ts
->type
), charlen
, ts
->kind
);
6075 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6076 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
6078 /* Copy across the array spec to the selector. */
6079 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
6080 && (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
6081 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
))
6083 tmp
->n
.sym
->attr
.pointer
= 1;
6084 tmp
->n
.sym
->attr
.dimension
6085 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
6086 tmp
->n
.sym
->attr
.codimension
6087 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
6089 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
6092 gfc_set_sym_referenced (tmp
->n
.sym
);
6093 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
6094 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
6100 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
6103 select_type_set_tmp (gfc_typespec
*ts
)
6105 char name
[GFC_MAX_SYMBOL_LEN
];
6106 gfc_symtree
*tmp
= NULL
;
6110 select_type_stack
->tmp
= NULL
;
6114 tmp
= select_intrinsic_set_tmp (ts
);
6121 if (ts
->type
== BT_CLASS
)
6122 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
6124 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
6125 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6126 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
6128 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
6129 && select_type_stack
->selector
->attr
.class_ok
)
6131 tmp
->n
.sym
->attr
.pointer
6132 = CLASS_DATA (select_type_stack
->selector
)->attr
.class_pointer
;
6134 /* Copy across the array spec to the selector. */
6135 if (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
6136 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
)
6138 tmp
->n
.sym
->attr
.dimension
6139 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
6140 tmp
->n
.sym
->attr
.codimension
6141 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
6143 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
6147 gfc_set_sym_referenced (tmp
->n
.sym
);
6148 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
6149 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
6151 if (ts
->type
== BT_CLASS
)
6152 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
6156 /* Add an association for it, so the rest of the parser knows it is
6157 an associate-name. The target will be set during resolution. */
6158 tmp
->n
.sym
->assoc
= gfc_get_association_list ();
6159 tmp
->n
.sym
->assoc
->dangling
= 1;
6160 tmp
->n
.sym
->assoc
->st
= tmp
;
6162 select_type_stack
->tmp
= tmp
;
6166 /* Match a SELECT TYPE statement. */
6169 gfc_match_select_type (void)
6171 gfc_expr
*expr1
, *expr2
= NULL
;
6173 char name
[GFC_MAX_SYMBOL_LEN
];
6176 gfc_namespace
*ns
= gfc_current_ns
;
6178 m
= gfc_match_label ();
6179 if (m
== MATCH_ERROR
)
6182 m
= gfc_match (" select type ( ");
6186 gfc_current_ns
= gfc_build_block_ns (ns
);
6187 m
= gfc_match (" %n => %e", name
, &expr2
);
6190 expr1
= gfc_get_expr ();
6191 expr1
->expr_type
= EXPR_VARIABLE
;
6192 expr1
->where
= expr2
->where
;
6193 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
6199 sym
= expr1
->symtree
->n
.sym
;
6200 if (expr2
->ts
.type
== BT_UNKNOWN
)
6201 sym
->attr
.untyped
= 1;
6203 copy_ts_from_selector_to_associate (expr1
, expr2
);
6205 sym
->attr
.flavor
= FL_VARIABLE
;
6206 sym
->attr
.referenced
= 1;
6207 sym
->attr
.class_ok
= 1;
6211 m
= gfc_match (" %e ", &expr1
);
6214 std::swap (ns
, gfc_current_ns
);
6215 gfc_free_namespace (ns
);
6220 m
= gfc_match (" )%t");
6223 gfc_error ("parse error in SELECT TYPE statement at %C");
6227 /* This ghastly expression seems to be needed to distinguish a CLASS
6228 array, which can have a reference, from other expressions that
6229 have references, such as derived type components, and are not
6230 allowed by the standard.
6231 TODO: see if it is sufficient to exclude component and substring
6233 class_array
= (expr1
->expr_type
== EXPR_VARIABLE
6234 && expr1
->ts
.type
== BT_CLASS
6235 && CLASS_DATA (expr1
)
6236 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
6237 && (CLASS_DATA (expr1
)->attr
.dimension
6238 || CLASS_DATA (expr1
)->attr
.codimension
)
6240 && expr1
->ref
->type
== REF_ARRAY
6241 && expr1
->ref
->u
.ar
.type
== AR_FULL
6242 && expr1
->ref
->next
== NULL
);
6244 /* Check for F03:C811 (F08:C835). */
6245 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
6246 || (!class_array
&& expr1
->ref
!= NULL
)))
6248 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
6249 "use associate-name=>");
6254 new_st
.op
= EXEC_SELECT_TYPE
;
6255 new_st
.expr1
= expr1
;
6256 new_st
.expr2
= expr2
;
6257 new_st
.ext
.block
.ns
= gfc_current_ns
;
6259 select_type_push (expr1
->symtree
->n
.sym
);
6260 gfc_current_ns
= ns
;
6265 gfc_free_expr (expr1
);
6266 gfc_free_expr (expr2
);
6267 gfc_undo_symbols ();
6268 std::swap (ns
, gfc_current_ns
);
6269 gfc_free_namespace (ns
);
6274 /* Match a CASE statement. */
6277 gfc_match_case (void)
6279 gfc_case
*c
, *head
, *tail
;
6284 if (gfc_current_state () != COMP_SELECT
)
6286 gfc_error ("Unexpected CASE statement at %C");
6290 if (gfc_match ("% default") == MATCH_YES
)
6292 m
= match_case_eos ();
6295 if (m
== MATCH_ERROR
)
6298 new_st
.op
= EXEC_SELECT
;
6299 c
= gfc_get_case ();
6300 c
->where
= gfc_current_locus
;
6301 new_st
.ext
.block
.case_list
= c
;
6305 if (gfc_match_char ('(') != MATCH_YES
)
6310 if (match_case_selector (&c
) == MATCH_ERROR
)
6320 if (gfc_match_char (')') == MATCH_YES
)
6322 if (gfc_match_char (',') != MATCH_YES
)
6326 m
= match_case_eos ();
6329 if (m
== MATCH_ERROR
)
6332 new_st
.op
= EXEC_SELECT
;
6333 new_st
.ext
.block
.case_list
= head
;
6338 gfc_error ("Syntax error in CASE specification at %C");
6341 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
6346 /* Match a TYPE IS statement. */
6349 gfc_match_type_is (void)
6354 if (gfc_current_state () != COMP_SELECT_TYPE
)
6356 gfc_error ("Unexpected TYPE IS statement at %C");
6360 if (gfc_match_char ('(') != MATCH_YES
)
6363 c
= gfc_get_case ();
6364 c
->where
= gfc_current_locus
;
6366 m
= gfc_match_type_spec (&c
->ts
);
6369 if (m
== MATCH_ERROR
)
6372 if (gfc_match_char (')') != MATCH_YES
)
6375 m
= match_case_eos ();
6378 if (m
== MATCH_ERROR
)
6381 new_st
.op
= EXEC_SELECT_TYPE
;
6382 new_st
.ext
.block
.case_list
= c
;
6384 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
6385 && (c
->ts
.u
.derived
->attr
.sequence
6386 || c
->ts
.u
.derived
->attr
.is_bind_c
))
6388 gfc_error ("The type-spec shall not specify a sequence derived "
6389 "type or a type with the BIND attribute in SELECT "
6390 "TYPE at %C [F2003:C815]");
6394 if (c
->ts
.type
== BT_DERIVED
6395 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
6396 && gfc_spec_list_type (type_param_spec_list
, c
->ts
.u
.derived
)
6399 gfc_error ("All the LEN type parameters in the TYPE IS statement "
6400 "at %C must be ASSUMED");
6404 /* Create temporary variable. */
6405 select_type_set_tmp (&c
->ts
);
6410 gfc_error ("Syntax error in TYPE IS specification at %C");
6414 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6419 /* Match a CLASS IS or CLASS DEFAULT statement. */
6422 gfc_match_class_is (void)
6427 if (gfc_current_state () != COMP_SELECT_TYPE
)
6430 if (gfc_match ("% default") == MATCH_YES
)
6432 m
= match_case_eos ();
6435 if (m
== MATCH_ERROR
)
6438 new_st
.op
= EXEC_SELECT_TYPE
;
6439 c
= gfc_get_case ();
6440 c
->where
= gfc_current_locus
;
6441 c
->ts
.type
= BT_UNKNOWN
;
6442 new_st
.ext
.block
.case_list
= c
;
6443 select_type_set_tmp (NULL
);
6447 m
= gfc_match ("% is");
6450 if (m
== MATCH_ERROR
)
6453 if (gfc_match_char ('(') != MATCH_YES
)
6456 c
= gfc_get_case ();
6457 c
->where
= gfc_current_locus
;
6459 m
= match_derived_type_spec (&c
->ts
);
6462 if (m
== MATCH_ERROR
)
6465 if (c
->ts
.type
== BT_DERIVED
)
6466 c
->ts
.type
= BT_CLASS
;
6468 if (gfc_match_char (')') != MATCH_YES
)
6471 m
= match_case_eos ();
6474 if (m
== MATCH_ERROR
)
6477 new_st
.op
= EXEC_SELECT_TYPE
;
6478 new_st
.ext
.block
.case_list
= c
;
6480 /* Create temporary variable. */
6481 select_type_set_tmp (&c
->ts
);
6486 gfc_error ("Syntax error in CLASS IS specification at %C");
6490 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6495 /********************* WHERE subroutines ********************/
6497 /* Match the rest of a simple WHERE statement that follows an IF statement.
6501 match_simple_where (void)
6507 m
= gfc_match (" ( %e )", &expr
);
6511 m
= gfc_match_assignment ();
6514 if (m
== MATCH_ERROR
)
6517 if (gfc_match_eos () != MATCH_YES
)
6520 c
= gfc_get_code (EXEC_WHERE
);
6523 c
->next
= XCNEW (gfc_code
);
6525 c
->next
->loc
= gfc_current_locus
;
6526 gfc_clear_new_st ();
6528 new_st
.op
= EXEC_WHERE
;
6534 gfc_syntax_error (ST_WHERE
);
6537 gfc_free_expr (expr
);
6542 /* Match a WHERE statement. */
6545 gfc_match_where (gfc_statement
*st
)
6551 m0
= gfc_match_label ();
6552 if (m0
== MATCH_ERROR
)
6555 m
= gfc_match (" where ( %e )", &expr
);
6559 if (gfc_match_eos () == MATCH_YES
)
6561 *st
= ST_WHERE_BLOCK
;
6562 new_st
.op
= EXEC_WHERE
;
6563 new_st
.expr1
= expr
;
6567 m
= gfc_match_assignment ();
6569 gfc_syntax_error (ST_WHERE
);
6573 gfc_free_expr (expr
);
6577 /* We've got a simple WHERE statement. */
6579 c
= gfc_get_code (EXEC_WHERE
);
6582 /* Put in the assignment. It will not be processed by add_statement, so we
6583 need to copy the location here. */
6585 c
->next
= XCNEW (gfc_code
);
6587 c
->next
->loc
= gfc_current_locus
;
6588 gfc_clear_new_st ();
6590 new_st
.op
= EXEC_WHERE
;
6597 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
6598 new_st if successful. */
6601 gfc_match_elsewhere (void)
6603 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6607 if (gfc_current_state () != COMP_WHERE
)
6609 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
6615 if (gfc_match_char ('(') == MATCH_YES
)
6617 m
= gfc_match_expr (&expr
);
6620 if (m
== MATCH_ERROR
)
6623 if (gfc_match_char (')') != MATCH_YES
)
6627 if (gfc_match_eos () != MATCH_YES
)
6629 /* Only makes sense if we have a where-construct-name. */
6630 if (!gfc_current_block ())
6635 /* Better be a name at this point. */
6636 m
= gfc_match_name (name
);
6639 if (m
== MATCH_ERROR
)
6642 if (gfc_match_eos () != MATCH_YES
)
6645 if (strcmp (name
, gfc_current_block ()->name
) != 0)
6647 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
6648 name
, gfc_current_block ()->name
);
6653 new_st
.op
= EXEC_WHERE
;
6654 new_st
.expr1
= expr
;
6658 gfc_syntax_error (ST_ELSEWHERE
);
6661 gfc_free_expr (expr
);