1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000-2024 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 "
196 "after %<.%> at %C");
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
;
266 where
= gfc_current_locus
;
267 c
= gfc_next_char_literal (instring
);
270 if (quote
== ' ' && ((c
== '\'') || (c
== '"')))
273 instring
= INSTRING_WARN
;
276 if (quote
!= ' ' && c
== quote
)
279 instring
= NONSTRING
;
283 if (c
== '(' && quote
== ' ')
287 if (c
== ')' && quote
== ' ')
290 where
= gfc_current_locus
;
294 gfc_current_locus
= old_loc
;
298 gfc_error ("Missing %qs in statement at or before %L",
299 count
> 0? ")":"(", &where
);
307 /* See if the next character is a special character that has
308 escaped by a \ via the -fbackslash option. */
311 gfc_match_special_char (gfc_char_t
*res
)
319 switch ((c
= gfc_next_char_literal (INSTRING_WARN
)))
352 /* Hexadecimal form of wide characters. */
353 len
= (c
== 'x' ? 2 : (c
== 'u' ? 4 : 8));
355 for (i
= 0; i
< len
; i
++)
357 char buf
[2] = { '\0', '\0' };
359 c
= gfc_next_char_literal (INSTRING_WARN
);
360 if (!gfc_wide_fits_in_byte (c
)
361 || !gfc_check_digit ((unsigned char) c
, 16))
364 buf
[0] = (unsigned char) c
;
366 n
+= strtol (buf
, NULL
, 16);
372 /* Unknown backslash codes are simply not expanded. */
381 /* In free form, match at least one space. Always matches in fixed
385 gfc_match_space (void)
390 if (gfc_current_form
== FORM_FIXED
)
393 old_loc
= gfc_current_locus
;
395 c
= gfc_next_ascii_char ();
396 if (!gfc_is_whitespace (c
))
398 gfc_current_locus
= old_loc
;
402 gfc_gobble_whitespace ();
408 /* Match an end of statement. End of statement is optional
409 whitespace, followed by a ';' or '\n' or comment '!'. If a
410 semicolon is found, we continue to eat whitespace and semicolons. */
423 old_loc
= gfc_current_locus
;
424 gfc_gobble_whitespace ();
426 c
= gfc_next_ascii_char ();
432 c
= gfc_next_ascii_char ();
449 gfc_current_locus
= old_loc
;
450 return (flag
) ? MATCH_YES
: MATCH_NO
;
454 /* Match a literal integer on the input, setting the value on
455 MATCH_YES. Literal ints occur in kind-parameters as well as
456 old-style character length specifications. If cnt is non-NULL it
457 will be set to the number of digits.
458 When gobble_ws is false, do not skip over leading blanks. */
461 gfc_match_small_literal_int (int *value
, int *cnt
, bool gobble_ws
)
467 old_loc
= gfc_current_locus
;
471 gfc_gobble_whitespace ();
472 c
= gfc_next_ascii_char ();
478 gfc_current_locus
= old_loc
;
487 old_loc
= gfc_current_locus
;
488 c
= gfc_next_ascii_char ();
493 i
= 10 * i
+ c
- '0';
498 gfc_error ("Integer too large at %C");
503 gfc_current_locus
= old_loc
;
512 /* Match a small, constant integer expression, like in a kind
513 statement. On MATCH_YES, 'value' is set. */
516 gfc_match_small_int (int *value
)
522 m
= gfc_match_expr (&expr
);
526 if (gfc_extract_int (expr
, &i
, 1))
528 gfc_free_expr (expr
);
535 /* Matches a statement label. Uses gfc_match_small_literal_int() to
536 do most of the work. */
539 gfc_match_st_label (gfc_st_label
**label
)
545 old_loc
= gfc_current_locus
;
547 m
= gfc_match_small_literal_int (&i
, &cnt
);
553 gfc_error ("Too many digits in statement label at %C");
559 gfc_error ("Statement label at %C is zero");
563 *label
= gfc_get_st_label (i
);
568 gfc_current_locus
= old_loc
;
573 /* Match and validate a label associated with a named IF, DO or SELECT
574 statement. If the symbol does not have the label attribute, we add
575 it. We also make sure the symbol does not refer to another
576 (active) block. A matched label is pointed to by gfc_new_block. */
579 gfc_match_label (void)
581 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
584 gfc_new_block
= NULL
;
586 m
= gfc_match (" %n :", name
);
590 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
592 gfc_error ("Label name %qs at %C is ambiguous", name
);
596 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
598 gfc_error ("Duplicate construct label %qs at %C", name
);
602 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
603 gfc_new_block
->name
, NULL
))
610 /* See if the current input looks like a name of some sort. Modifies
611 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
612 Note that options.cc restricts max_identifier_length to not more
613 than GFC_MAX_SYMBOL_LEN.
614 When gobble_ws is false, do not skip over leading blanks. */
617 gfc_match_name (char *buffer
, bool gobble_ws
)
623 old_loc
= gfc_current_locus
;
625 gfc_gobble_whitespace ();
627 c
= gfc_next_ascii_char ();
628 if (!(ISALPHA (c
) || (c
== '_' && flag_allow_leading_underscore
)))
630 /* Special cases for unary minus and plus, which allows for a sensible
631 error message for code of the form 'c = exp(-a*b) )' where an
632 extra ')' appears at the end of statement. */
633 if (!gfc_error_flag_test () && c
!= '(' && c
!= '-' && c
!= '+')
634 gfc_error ("Invalid character in name at %C");
635 gfc_current_locus
= old_loc
;
645 if (i
> gfc_option
.max_identifier_length
)
647 gfc_error ("Name at %C is too long");
651 old_loc
= gfc_current_locus
;
652 c
= gfc_next_ascii_char ();
654 while (ISALNUM (c
) || c
== '_' || (flag_dollar_ok
&& c
== '$'));
656 if (c
== '$' && !flag_dollar_ok
)
658 gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to "
659 "allow it as an extension", &old_loc
);
664 gfc_current_locus
= old_loc
;
670 /* Match a symbol on the input. Modifies the pointer to the symbol
671 pointer if successful. */
674 gfc_match_sym_tree (gfc_symtree
**matched_symbol
, int host_assoc
)
676 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
679 m
= gfc_match_name (buffer
);
684 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
685 ? MATCH_ERROR
: MATCH_YES
;
687 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
, false))
695 gfc_match_symbol (gfc_symbol
**matched_symbol
, int host_assoc
)
700 m
= gfc_match_sym_tree (&st
, host_assoc
);
705 *matched_symbol
= st
->n
.sym
;
707 *matched_symbol
= NULL
;
710 *matched_symbol
= NULL
;
715 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
716 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
720 gfc_match_intrinsic_op (gfc_intrinsic_op
*result
)
722 locus orig_loc
= gfc_current_locus
;
725 gfc_gobble_whitespace ();
726 ch
= gfc_next_ascii_char ();
731 *result
= INTRINSIC_PLUS
;
736 *result
= INTRINSIC_MINUS
;
740 if (gfc_next_ascii_char () == '=')
743 *result
= INTRINSIC_EQ
;
749 if (gfc_peek_ascii_char () == '=')
752 gfc_next_ascii_char ();
753 *result
= INTRINSIC_LE
;
757 *result
= INTRINSIC_LT
;
761 if (gfc_peek_ascii_char () == '=')
764 gfc_next_ascii_char ();
765 *result
= INTRINSIC_GE
;
769 *result
= INTRINSIC_GT
;
773 if (gfc_peek_ascii_char () == '*')
776 gfc_next_ascii_char ();
777 *result
= INTRINSIC_POWER
;
781 *result
= INTRINSIC_TIMES
;
785 ch
= gfc_peek_ascii_char ();
789 gfc_next_ascii_char ();
790 *result
= INTRINSIC_NE
;
796 gfc_next_ascii_char ();
797 *result
= INTRINSIC_CONCAT
;
801 *result
= INTRINSIC_DIVIDE
;
805 ch
= gfc_next_ascii_char ();
809 if (gfc_next_ascii_char () == 'n'
810 && gfc_next_ascii_char () == 'd'
811 && gfc_next_ascii_char () == '.')
813 /* Matched ".and.". */
814 *result
= INTRINSIC_AND
;
820 if (gfc_next_ascii_char () == 'q')
822 ch
= gfc_next_ascii_char ();
825 /* Matched ".eq.". */
826 *result
= INTRINSIC_EQ_OS
;
831 if (gfc_next_ascii_char () == '.')
833 /* Matched ".eqv.". */
834 *result
= INTRINSIC_EQV
;
842 ch
= gfc_next_ascii_char ();
845 if (gfc_next_ascii_char () == '.')
847 /* Matched ".ge.". */
848 *result
= INTRINSIC_GE_OS
;
854 if (gfc_next_ascii_char () == '.')
856 /* Matched ".gt.". */
857 *result
= INTRINSIC_GT_OS
;
864 ch
= gfc_next_ascii_char ();
867 if (gfc_next_ascii_char () == '.')
869 /* Matched ".le.". */
870 *result
= INTRINSIC_LE_OS
;
876 if (gfc_next_ascii_char () == '.')
878 /* Matched ".lt.". */
879 *result
= INTRINSIC_LT_OS
;
886 ch
= gfc_next_ascii_char ();
889 ch
= gfc_next_ascii_char ();
892 /* Matched ".ne.". */
893 *result
= INTRINSIC_NE_OS
;
898 if (gfc_next_ascii_char () == 'v'
899 && gfc_next_ascii_char () == '.')
901 /* Matched ".neqv.". */
902 *result
= INTRINSIC_NEQV
;
909 if (gfc_next_ascii_char () == 't'
910 && gfc_next_ascii_char () == '.')
912 /* Matched ".not.". */
913 *result
= INTRINSIC_NOT
;
920 if (gfc_next_ascii_char () == 'r'
921 && gfc_next_ascii_char () == '.')
923 /* Matched ".or.". */
924 *result
= INTRINSIC_OR
;
930 if (gfc_next_ascii_char () == 'o'
931 && gfc_next_ascii_char () == 'r'
932 && gfc_next_ascii_char () == '.')
934 if (!gfc_notify_std (GFC_STD_LEGACY
, ".XOR. operator at %C"))
936 /* Matched ".xor." - equivalent to ".neqv.". */
937 *result
= INTRINSIC_NEQV
;
951 gfc_current_locus
= orig_loc
;
956 /* Match a loop control phrase:
958 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
960 If the final integer expression is not present, a constant unity
961 expression is returned. We don't return MATCH_ERROR until after
962 the equals sign is seen. */
965 gfc_match_iterator (gfc_iterator
*iter
, int init_flag
)
967 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
968 gfc_expr
*var
, *e1
, *e2
, *e3
;
974 /* Match the start of an iterator without affecting the symbol table. */
976 start
= gfc_current_locus
;
977 m
= gfc_match (" %n =", name
);
978 gfc_current_locus
= start
;
983 m
= gfc_match_variable (&var
, 0);
987 if (var
->symtree
->n
.sym
->attr
.dimension
)
989 gfc_error ("Loop variable at %C cannot be an array");
993 /* F2008, C617 & C565. */
994 if (var
->symtree
->n
.sym
->attr
.codimension
)
996 gfc_error ("Loop variable at %C cannot be a coarray");
1000 if (var
->ref
!= NULL
)
1002 gfc_error ("Loop variable at %C cannot be a sub-component");
1006 gfc_match_char ('=');
1008 var
->symtree
->n
.sym
->attr
.implied_index
= 1;
1010 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
1013 if (m
== MATCH_ERROR
)
1016 if (gfc_match_char (',') != MATCH_YES
)
1019 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
1022 if (m
== MATCH_ERROR
)
1025 if (gfc_match_char (',') != MATCH_YES
)
1027 e3
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1031 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
1032 if (m
== MATCH_ERROR
)
1036 gfc_error ("Expected a step value in iterator at %C");
1048 gfc_error ("Syntax error in iterator at %C");
1059 /* Tries to match the next non-whitespace character on the input.
1060 This subroutine does not return MATCH_ERROR.
1061 When gobble_ws is false, do not skip over leading blanks. */
1064 gfc_match_char (char c
, bool gobble_ws
)
1068 where
= gfc_current_locus
;
1070 gfc_gobble_whitespace ();
1072 if (gfc_next_ascii_char () == c
)
1075 gfc_current_locus
= where
;
1080 /* General purpose matching subroutine. The target string is a
1081 scanf-like format string in which spaces correspond to arbitrary
1082 whitespace (including no whitespace), characters correspond to
1083 themselves. The %-codes are:
1085 %% Literal percent sign
1086 %e Expression, pointer to a pointer is set
1087 %s Symbol, pointer to the symbol is set (host_assoc = 0)
1088 %S Symbol, pointer to the symbol is set (host_assoc = 1)
1089 %n Name, character buffer is set to name
1090 %t Matches end of statement.
1091 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1092 %l Matches a statement label
1093 %v Matches a variable expression (an lvalue, except function references
1094 having a data pointer result)
1095 % Matches a required space (in free form) and optional spaces. */
1098 gfc_match (const char *target
, ...)
1100 gfc_st_label
**label
;
1109 old_loc
= gfc_current_locus
;
1110 va_start (argp
, target
);
1120 gfc_gobble_whitespace ();
1131 vp
= va_arg (argp
, void **);
1132 n
= gfc_match_expr ((gfc_expr
**) vp
);
1143 vp
= va_arg (argp
, void **);
1144 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
1156 vp
= va_arg (argp
, void **);
1157 n
= gfc_match_symbol ((gfc_symbol
**) vp
, c
== 'S');
1168 np
= va_arg (argp
, char *);
1169 n
= gfc_match_name (np
);
1180 label
= va_arg (argp
, gfc_st_label
**);
1181 n
= gfc_match_st_label (label
);
1192 ip
= va_arg (argp
, int *);
1193 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
1204 if (gfc_match_eos () != MATCH_YES
)
1212 if (gfc_match_space () == MATCH_YES
)
1218 break; /* Fall through to character matcher. */
1221 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
1227 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1228 expect an upper case character here! */
1229 gcc_assert (TOLOWER (c
) == c
);
1231 if (c
== gfc_next_ascii_char ())
1241 /* Clean up after a failed match. */
1242 gfc_current_locus
= old_loc
;
1243 va_start (argp
, target
);
1246 for (; matches
> 0; matches
--)
1248 while (*p
++ != '%');
1256 /* Matches that don't have to be undone */
1261 (void) va_arg (argp
, void **);
1266 vp
= va_arg (argp
, void **);
1267 gfc_free_expr ((struct gfc_expr
*)*vp
);
1280 /*********************** Statement level matching **********************/
1282 /* Matches the start of a program unit, which is the program keyword
1283 followed by an obligatory symbol. */
1286 gfc_match_program (void)
1291 m
= gfc_match ("% %s%t", &sym
);
1295 gfc_error ("Invalid form of PROGRAM statement at %C");
1299 if (m
== MATCH_ERROR
)
1302 if (!gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
))
1305 gfc_new_block
= sym
;
1311 /* Match a simple assignment statement. */
1314 gfc_match_assignment (void)
1316 gfc_expr
*lvalue
, *rvalue
;
1320 old_loc
= gfc_current_locus
;
1323 m
= gfc_match (" %v =", &lvalue
);
1326 gfc_current_locus
= old_loc
;
1327 gfc_free_expr (lvalue
);
1332 m
= gfc_match (" %e%t", &rvalue
);
1335 && rvalue
->ts
.type
== BT_BOZ
1336 && lvalue
->ts
.type
== BT_CLASS
)
1339 gfc_error ("BOZ literal constant at %L is neither a DATA statement "
1340 "value nor an actual argument of INT/REAL/DBLE/CMPLX "
1341 "intrinsic subprogram", &rvalue
->where
);
1344 if (lvalue
->expr_type
== EXPR_CONSTANT
)
1346 /* This clobbers %len and %kind. */
1348 gfc_error ("Assignment to a constant expression at %C");
1353 gfc_current_locus
= old_loc
;
1354 gfc_free_expr (lvalue
);
1355 gfc_free_expr (rvalue
);
1359 if (!lvalue
->symtree
)
1361 gfc_free_expr (lvalue
);
1362 gfc_free_expr (rvalue
);
1367 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1369 new_st
.op
= EXEC_ASSIGN
;
1370 new_st
.expr1
= lvalue
;
1371 new_st
.expr2
= rvalue
;
1373 gfc_check_do_variable (lvalue
->symtree
);
1379 /* Match a pointer assignment statement. */
1382 gfc_match_pointer_assignment (void)
1384 gfc_expr
*lvalue
, *rvalue
;
1388 old_loc
= gfc_current_locus
;
1390 lvalue
= rvalue
= NULL
;
1391 gfc_matching_ptr_assignment
= 0;
1392 gfc_matching_procptr_assignment
= 0;
1394 m
= gfc_match (" %v =>", &lvalue
);
1395 if (m
!= MATCH_YES
|| !lvalue
->symtree
)
1401 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1402 || gfc_is_proc_ptr_comp (lvalue
))
1403 gfc_matching_procptr_assignment
= 1;
1405 gfc_matching_ptr_assignment
= 1;
1407 m
= gfc_match (" %e%t", &rvalue
);
1408 gfc_matching_ptr_assignment
= 0;
1409 gfc_matching_procptr_assignment
= 0;
1413 new_st
.op
= EXEC_POINTER_ASSIGN
;
1414 new_st
.expr1
= lvalue
;
1415 new_st
.expr2
= rvalue
;
1420 gfc_current_locus
= old_loc
;
1421 gfc_free_expr (lvalue
);
1422 gfc_free_expr (rvalue
);
1427 /* We try to match an easy arithmetic IF statement. This only happens
1428 when just after having encountered a simple IF statement. This code
1429 is really duplicate with parts of the gfc_match_if code, but this is
1433 match_arithmetic_if (void)
1435 gfc_st_label
*l1
, *l2
, *l3
;
1439 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1443 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1444 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1445 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1447 gfc_free_expr (expr
);
1451 if (!gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
1452 "Arithmetic IF statement at %C"))
1455 new_st
.op
= EXEC_ARITHMETIC_IF
;
1456 new_st
.expr1
= expr
;
1465 /* The IF statement is a bit of a pain. First of all, there are three
1466 forms of it, the simple IF, the IF that starts a block and the
1469 There is a problem with the simple IF and that is the fact that we
1470 only have a single level of undo information on symbols. What this
1471 means is for a simple IF, we must re-match the whole IF statement
1472 multiple times in order to guarantee that the symbol table ends up
1473 in the proper state. */
1475 static match
match_simple_forall (void);
1476 static match
match_simple_where (void);
1479 gfc_match_if (gfc_statement
*if_type
)
1482 gfc_st_label
*l1
, *l2
, *l3
;
1483 locus old_loc
, old_loc2
;
1487 n
= gfc_match_label ();
1488 if (n
== MATCH_ERROR
)
1491 old_loc
= gfc_current_locus
;
1493 m
= gfc_match (" if ", &expr
);
1497 if (gfc_match_char ('(') != MATCH_YES
)
1499 gfc_error ("Missing %<(%> in IF-expression at %C");
1503 m
= gfc_match ("%e", &expr
);
1507 old_loc2
= gfc_current_locus
;
1508 gfc_current_locus
= old_loc
;
1510 if (gfc_match_parens () == MATCH_ERROR
)
1513 gfc_current_locus
= old_loc2
;
1515 if (gfc_match_char (')') != MATCH_YES
)
1517 gfc_error ("Syntax error in IF-expression at %C");
1518 gfc_free_expr (expr
);
1522 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1528 gfc_error ("Block label not appropriate for arithmetic IF "
1530 gfc_free_expr (expr
);
1534 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1535 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1536 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1538 gfc_free_expr (expr
);
1542 if (!gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
1543 "Arithmetic IF statement at %C"))
1546 new_st
.op
= EXEC_ARITHMETIC_IF
;
1547 new_st
.expr1
= expr
;
1552 *if_type
= ST_ARITHMETIC_IF
;
1556 if (gfc_match (" then%t") == MATCH_YES
)
1558 new_st
.op
= EXEC_IF
;
1559 new_st
.expr1
= expr
;
1560 *if_type
= ST_IF_BLOCK
;
1566 gfc_error ("Block label is not appropriate for IF statement at %C");
1567 gfc_free_expr (expr
);
1571 /* At this point the only thing left is a simple IF statement. At
1572 this point, n has to be MATCH_NO, so we don't have to worry about
1573 re-matching a block label. From what we've got so far, try
1574 matching an assignment. */
1576 *if_type
= ST_SIMPLE_IF
;
1578 m
= gfc_match_assignment ();
1582 gfc_free_expr (expr
);
1583 gfc_undo_symbols ();
1584 gfc_current_locus
= old_loc
;
1586 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1587 assignment was found. For MATCH_NO, continue to call the various
1589 if (m
== MATCH_ERROR
)
1592 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1594 m
= gfc_match_pointer_assignment ();
1598 gfc_free_expr (expr
);
1599 gfc_undo_symbols ();
1600 gfc_current_locus
= old_loc
;
1602 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1604 /* Look at the next keyword to see which matcher to call. Matching
1605 the keyword doesn't affect the symbol table, so we don't have to
1606 restore between tries. */
1608 #define match(string, subr, statement) \
1609 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1613 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1614 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1615 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1616 match ("call", gfc_match_call
, ST_CALL
)
1617 match ("change% team", gfc_match_change_team
, ST_CHANGE_TEAM
)
1618 match ("close", gfc_match_close
, ST_CLOSE
)
1619 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1620 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1621 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1622 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1623 match ("end team", gfc_match_end_team
, ST_END_TEAM
)
1624 match ("error% stop", gfc_match_error_stop
, ST_ERROR_STOP
)
1625 match ("event% post", gfc_match_event_post
, ST_EVENT_POST
)
1626 match ("event% wait", gfc_match_event_wait
, ST_EVENT_WAIT
)
1627 match ("exit", gfc_match_exit
, ST_EXIT
)
1628 match ("fail% image", gfc_match_fail_image
, ST_FAIL_IMAGE
)
1629 match ("flush", gfc_match_flush
, ST_FLUSH
)
1630 match ("forall", match_simple_forall
, ST_FORALL
)
1631 match ("form% team", gfc_match_form_team
, ST_FORM_TEAM
)
1632 match ("go to", gfc_match_goto
, ST_GOTO
)
1633 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1634 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1635 match ("lock", gfc_match_lock
, ST_LOCK
)
1636 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1637 match ("open", gfc_match_open
, ST_OPEN
)
1638 match ("pause", gfc_match_pause
, ST_NONE
)
1639 match ("print", gfc_match_print
, ST_WRITE
)
1640 match ("read", gfc_match_read
, ST_READ
)
1641 match ("return", gfc_match_return
, ST_RETURN
)
1642 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1643 match ("stop", gfc_match_stop
, ST_STOP
)
1644 match ("wait", gfc_match_wait
, ST_WAIT
)
1645 match ("sync% all", gfc_match_sync_all
, ST_SYNC_CALL
);
1646 match ("sync% images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
1647 match ("sync% memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
1648 match ("sync% team", gfc_match_sync_team
, ST_SYNC_TEAM
)
1649 match ("unlock", gfc_match_unlock
, ST_UNLOCK
)
1650 match ("where", match_simple_where
, ST_WHERE
)
1651 match ("write", gfc_match_write
, ST_WRITE
)
1654 match ("type", gfc_match_print
, ST_WRITE
)
1656 /* All else has failed, so give up. See if any of the matchers has
1657 stored an error message of some sort. */
1658 if (!gfc_error_check ())
1659 gfc_error ("Syntax error in IF-clause after %C");
1661 gfc_free_expr (expr
);
1666 gfc_error ("Syntax error in IF-clause after %C");
1669 gfc_free_expr (expr
);
1673 /* At this point, we've matched the single IF and the action clause
1674 is in new_st. Rearrange things so that the IF statement appears
1677 p
= gfc_get_code (EXEC_IF
);
1678 p
->next
= XCNEW (gfc_code
);
1680 p
->next
->loc
= gfc_current_locus
;
1684 gfc_clear_new_st ();
1686 new_st
.op
= EXEC_IF
;
1695 /* Match an ELSE statement. */
1698 gfc_match_else (void)
1700 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1702 if (gfc_match_eos () == MATCH_YES
)
1705 if (gfc_match_name (name
) != MATCH_YES
1706 || gfc_current_block () == NULL
1707 || gfc_match_eos () != MATCH_YES
)
1709 gfc_error ("Invalid character(s) in ELSE statement after %C");
1713 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1715 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1716 name
, gfc_current_block ()->name
);
1724 /* Match an ELSE IF statement. */
1727 gfc_match_elseif (void)
1729 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1730 gfc_expr
*expr
, *then
;
1734 if (gfc_match_char ('(') != MATCH_YES
)
1736 gfc_error ("Missing %<(%> in ELSE IF expression at %C");
1740 m
= gfc_match (" %e ", &expr
);
1744 if (gfc_match_char (')') != MATCH_YES
)
1746 gfc_error ("Missing %<)%> in ELSE IF expression at %C");
1750 m
= gfc_match (" then ", &then
);
1752 where
= gfc_current_locus
;
1754 if (m
== MATCH_YES
&& (gfc_match_eos () == MATCH_YES
1755 || (gfc_current_block ()
1756 && gfc_match_name (name
) == MATCH_YES
)))
1759 if (gfc_match_eos () == MATCH_YES
)
1761 gfc_error ("Missing THEN in ELSE IF statement after %L", &where
);
1765 if (gfc_match_name (name
) != MATCH_YES
1766 || gfc_current_block () == NULL
1767 || gfc_match_eos () != MATCH_YES
)
1769 gfc_error ("Syntax error in ELSE IF statement after %L", &where
);
1773 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1775 gfc_error ("Label %qs after %L doesn't match IF label %qs",
1776 name
, &where
, gfc_current_block ()->name
);
1784 new_st
.op
= EXEC_IF
;
1785 new_st
.expr1
= expr
;
1789 gfc_free_expr (expr
);
1794 /* Free a gfc_iterator structure. */
1797 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1803 gfc_free_expr (iter
->var
);
1804 gfc_free_expr (iter
->start
);
1805 gfc_free_expr (iter
->end
);
1806 gfc_free_expr (iter
->step
);
1813 /* Match a CRITICAL statement. */
1815 gfc_match_critical (void)
1817 gfc_st_label
*label
= NULL
;
1819 if (gfc_match_label () == MATCH_ERROR
)
1822 if (gfc_match (" critical") != MATCH_YES
)
1825 if (gfc_match_st_label (&label
) == MATCH_ERROR
)
1828 if (gfc_match_eos () != MATCH_YES
)
1830 gfc_syntax_error (ST_CRITICAL
);
1834 if (gfc_pure (NULL
))
1836 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1840 if (gfc_find_state (COMP_DO_CONCURRENT
))
1842 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1847 gfc_unset_implicit_pure (NULL
);
1849 if (!gfc_notify_std (GFC_STD_F2008
, "CRITICAL statement at %C"))
1852 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1854 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1859 if (gfc_find_state (COMP_CRITICAL
))
1861 gfc_error ("Nested CRITICAL block at %C");
1865 new_st
.op
= EXEC_CRITICAL
;
1868 && !gfc_reference_st_label (label
, ST_LABEL_TARGET
))
1875 /* Match a BLOCK statement. */
1878 gfc_match_block (void)
1882 if (gfc_match_label () == MATCH_ERROR
)
1885 if (gfc_match (" block") != MATCH_YES
)
1888 /* For this to be a correct BLOCK statement, the line must end now. */
1889 m
= gfc_match_eos ();
1890 if (m
== MATCH_ERROR
)
1899 /* Match an ASSOCIATE statement. */
1902 gfc_match_associate (void)
1904 if (gfc_match_label () == MATCH_ERROR
)
1907 if (gfc_match (" associate") != MATCH_YES
)
1910 /* Match the association list. */
1911 if (gfc_match_char ('(') != MATCH_YES
)
1913 gfc_error ("Expected association list at %C");
1916 new_st
.ext
.block
.assoc
= NULL
;
1919 gfc_association_list
* newAssoc
= gfc_get_association_list ();
1920 gfc_association_list
* a
;
1922 /* Match the next association. */
1923 if (gfc_match (" %n =>", newAssoc
->name
) != MATCH_YES
)
1925 gfc_error ("Expected association at %C");
1926 goto assocListError
;
1929 if (gfc_match (" %e", &newAssoc
->target
) != MATCH_YES
)
1931 /* Have another go, allowing for procedure pointer selectors. */
1932 gfc_matching_procptr_assignment
= 1;
1933 if (gfc_match (" %e", &newAssoc
->target
) != MATCH_YES
)
1935 gfc_error ("Invalid association target at %C");
1936 goto assocListError
;
1938 gfc_matching_procptr_assignment
= 0;
1940 newAssoc
->where
= gfc_current_locus
;
1942 /* Check that the current name is not yet in the list. */
1943 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
1944 if (!strcmp (a
->name
, newAssoc
->name
))
1946 gfc_error ("Duplicate name %qs in association at %C",
1948 goto assocListError
;
1951 /* The target expression must not be coindexed. */
1952 if (gfc_is_coindexed (newAssoc
->target
))
1954 gfc_error ("Association target at %C must not be coindexed");
1955 goto assocListError
;
1958 /* The target expression cannot be a BOZ literal constant. */
1959 if (newAssoc
->target
->ts
.type
== BT_BOZ
)
1961 gfc_error ("Association target at %L cannot be a BOZ literal "
1962 "constant", &newAssoc
->target
->where
);
1963 goto assocListError
;
1966 /* The `variable' field is left blank for now; because the target is not
1967 yet resolved, we can't use gfc_has_vector_subscript to determine it
1968 for now. This is set during resolution. */
1970 /* Put it into the list. */
1971 newAssoc
->next
= new_st
.ext
.block
.assoc
;
1972 new_st
.ext
.block
.assoc
= newAssoc
;
1974 /* Try next one or end if closing parenthesis is found. */
1975 gfc_gobble_whitespace ();
1976 if (gfc_peek_char () == ')')
1978 if (gfc_match_char (',') != MATCH_YES
)
1980 gfc_error ("Expected %<)%> or %<,%> at %C");
1990 if (gfc_match_char (')') != MATCH_YES
)
1992 /* This should never happen as we peek above. */
1996 if (gfc_match_eos () != MATCH_YES
)
1998 gfc_error ("Junk after ASSOCIATE statement at %C");
2005 gfc_free_association_list (new_st
.ext
.block
.assoc
);
2010 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
2011 an accessible derived type. */
2014 match_derived_type_spec (gfc_typespec
*ts
)
2016 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2018 gfc_symbol
*derived
, *der_type
;
2019 match m
= MATCH_YES
;
2020 gfc_actual_arglist
*decl_type_param_list
= NULL
;
2021 bool is_pdt_template
= false;
2023 old_locus
= gfc_current_locus
;
2025 if (gfc_match ("%n", name
) != MATCH_YES
)
2027 gfc_current_locus
= old_locus
;
2031 gfc_find_symbol (name
, NULL
, 1, &derived
);
2033 /* Match the PDT spec list, if there. */
2034 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
)
2036 gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &der_type
);
2037 is_pdt_template
= der_type
2038 && der_type
->attr
.flavor
== FL_DERIVED
2039 && der_type
->attr
.pdt_template
;
2042 if (is_pdt_template
)
2043 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
2045 if (m
== MATCH_ERROR
)
2047 gfc_free_actual_arglist (decl_type_param_list
);
2051 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
&& derived
->attr
.generic
)
2052 derived
= gfc_find_dt_in_generic (derived
);
2054 /* If this is a PDT, find the specific instance. */
2055 if (m
== MATCH_YES
&& is_pdt_template
)
2057 gfc_namespace
*old_ns
;
2059 old_ns
= gfc_current_ns
;
2060 while (gfc_current_ns
&& gfc_current_ns
->parent
)
2061 gfc_current_ns
= gfc_current_ns
->parent
;
2063 if (type_param_spec_list
)
2064 gfc_free_actual_arglist (type_param_spec_list
);
2065 m
= gfc_get_pdt_instance (decl_type_param_list
, &der_type
,
2066 &type_param_spec_list
);
2067 gfc_free_actual_arglist (decl_type_param_list
);
2072 gcc_assert (!derived
->attr
.pdt_template
&& derived
->attr
.pdt_type
);
2073 gfc_set_sym_referenced (derived
);
2075 gfc_current_ns
= old_ns
;
2078 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
2080 ts
->type
= BT_DERIVED
;
2081 ts
->u
.derived
= derived
;
2085 gfc_current_locus
= old_locus
;
2090 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2091 gfc_match_decl_type_spec() from decl.cc, with the following exceptions:
2092 It only includes the intrinsic types from the Fortran 2003 standard
2093 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2094 the implicit_flag is not needed, so it was removed. Derived types are
2095 identified by their name alone. */
2098 gfc_match_type_spec (gfc_typespec
*ts
)
2102 char c
, name
[GFC_MAX_SYMBOL_LEN
+ 1];
2105 gfc_gobble_whitespace ();
2106 old_locus
= gfc_current_locus
;
2108 /* If c isn't [a-z], then return immediately. */
2109 c
= gfc_peek_ascii_char ();
2113 type_param_spec_list
= NULL
;
2115 if (match_derived_type_spec (ts
) == MATCH_YES
)
2117 /* Enforce F03:C401. */
2118 if (ts
->u
.derived
->attr
.abstract
)
2120 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
2121 ts
->u
.derived
->name
, &old_locus
);
2127 if (gfc_match ("integer") == MATCH_YES
)
2129 ts
->type
= BT_INTEGER
;
2130 ts
->kind
= gfc_default_integer_kind
;
2134 if (gfc_match ("double precision") == MATCH_YES
)
2137 ts
->kind
= gfc_default_double_kind
;
2141 if (gfc_match ("complex") == MATCH_YES
)
2143 ts
->type
= BT_COMPLEX
;
2144 ts
->kind
= gfc_default_complex_kind
;
2148 if (gfc_match ("character") == MATCH_YES
)
2150 ts
->type
= BT_CHARACTER
;
2152 m
= gfc_match_char_spec (ts
);
2160 /* REAL is a real pain because it can be a type, intrinsic subprogram,
2161 or list item in a type-list of an OpenMP reduction clause. Need to
2162 differentiate REAL([KIND]=scalar-int-initialization-expr) from
2163 REAL(A,[KIND]) and REAL(KIND,A). Logically, when this code was
2164 written the use of LOGICAL as a type-spec or intrinsic subprogram
2167 m
= gfc_match (" %n", name
);
2169 && (strcmp (name
, "real") == 0 || strcmp (name
, "logical") == 0))
2178 ts
->kind
= gfc_default_real_kind
;
2182 ts
->type
= BT_LOGICAL
;
2183 ts
->kind
= gfc_default_logical_kind
;
2186 gfc_gobble_whitespace ();
2188 /* Prevent REAL*4, etc. */
2189 c
= gfc_peek_ascii_char ();
2192 gfc_error ("Invalid type-spec at %C");
2196 /* Found leading colon in REAL::, a trailing ')' in for example
2197 TYPE IS (REAL), or REAL, for an OpenMP list-item. */
2198 if (c
== ':' || c
== ')' || (flag_openmp
&& c
== ','))
2201 /* Found something other than the opening '(' in REAL(... */
2205 gfc_next_char (); /* Burn the '('. */
2207 /* Look for the optional KIND=. */
2208 where
= gfc_current_locus
;
2209 m
= gfc_match ("%n", name
);
2212 gfc_gobble_whitespace ();
2213 c
= gfc_next_char ();
2216 if (strcmp(name
, "a") == 0 || strcmp(name
, "l") == 0)
2218 else if (strcmp(name
, "kind") == 0)
2224 gfc_current_locus
= where
;
2227 gfc_current_locus
= where
;
2231 m
= gfc_match_expr (&e
);
2232 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
2235 /* If a comma appears, it is an intrinsic subprogram. */
2236 gfc_gobble_whitespace ();
2237 c
= gfc_peek_ascii_char ();
2244 /* If ')' appears, we have REAL(initialization-expr), here check for
2245 a scalar integer initialization-expr and valid kind parameter. */
2249 if (e
->expr_type
!= EXPR_CONSTANT
&& e
->expr_type
!= EXPR_VARIABLE
)
2250 ok
= gfc_reduce_init_expr (e
);
2251 if (!ok
|| e
->ts
.type
!= BT_INTEGER
|| e
->rank
> 0)
2257 if (e
->expr_type
!= EXPR_CONSTANT
)
2260 gfc_next_char (); /* Burn the ')'. */
2261 ts
->kind
= (int) mpz_get_si (e
->value
.integer
);
2262 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
2264 gfc_error ("Invalid type-spec at %C");
2276 /* If a type is not matched, simply return MATCH_NO. */
2277 gfc_current_locus
= old_locus
;
2282 gfc_gobble_whitespace ();
2284 /* This prevents INTEGER*4, etc. */
2285 if (gfc_peek_ascii_char () == '*')
2287 gfc_error ("Invalid type-spec at %C");
2291 m
= gfc_match_kind_spec (ts
, false);
2293 /* No kind specifier found. */
2301 /******************** FORALL subroutines ********************/
2303 /* Free a list of FORALL iterators. */
2306 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
2308 gfc_forall_iterator
*next
;
2313 gfc_free_expr (iter
->var
);
2314 gfc_free_expr (iter
->start
);
2315 gfc_free_expr (iter
->end
);
2316 gfc_free_expr (iter
->stride
);
2323 /* Match an iterator as part of a FORALL statement. The format is:
2325 <var> = <start>:<end>[:<stride>]
2327 On MATCH_NO, the caller tests for the possibility that there is a
2328 scalar mask expression. */
2331 match_forall_iterator (gfc_forall_iterator
**result
)
2333 gfc_forall_iterator
*iter
;
2337 where
= gfc_current_locus
;
2338 iter
= XCNEW (gfc_forall_iterator
);
2340 m
= gfc_match_expr (&iter
->var
);
2344 if (gfc_match_char ('=') != MATCH_YES
2345 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
2351 m
= gfc_match_expr (&iter
->start
);
2355 if (gfc_match_char (':') != MATCH_YES
)
2358 m
= gfc_match_expr (&iter
->end
);
2361 if (m
== MATCH_ERROR
)
2364 if (gfc_match_char (':') == MATCH_NO
)
2365 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2368 m
= gfc_match_expr (&iter
->stride
);
2371 if (m
== MATCH_ERROR
)
2375 /* Mark the iteration variable's symbol as used as a FORALL index. */
2376 iter
->var
->symtree
->n
.sym
->forall_index
= true;
2382 gfc_error ("Syntax error in FORALL iterator at %C");
2387 gfc_current_locus
= where
;
2388 gfc_free_forall_iterator (iter
);
2393 /* Match the header of a FORALL statement. */
2396 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
2398 gfc_forall_iterator
*head
, *tail
, *new_iter
;
2402 gfc_gobble_whitespace ();
2407 if (gfc_match_char ('(') != MATCH_YES
)
2410 m
= match_forall_iterator (&new_iter
);
2411 if (m
== MATCH_ERROR
)
2416 head
= tail
= new_iter
;
2420 if (gfc_match_char (',') != MATCH_YES
)
2423 m
= match_forall_iterator (&new_iter
);
2424 if (m
== MATCH_ERROR
)
2429 tail
->next
= new_iter
;
2434 /* Have to have a mask expression. */
2436 m
= gfc_match_expr (&msk
);
2439 if (m
== MATCH_ERROR
)
2445 if (gfc_match_char (')') == MATCH_NO
)
2453 gfc_syntax_error (ST_FORALL
);
2456 gfc_free_expr (msk
);
2457 gfc_free_forall_iterator (head
);
2462 /* Match the rest of a simple FORALL statement that follows an
2466 match_simple_forall (void)
2468 gfc_forall_iterator
*head
;
2477 m
= match_forall_header (&head
, &mask
);
2484 m
= gfc_match_assignment ();
2486 if (m
== MATCH_ERROR
)
2490 m
= gfc_match_pointer_assignment ();
2491 if (m
== MATCH_ERROR
)
2497 c
= XCNEW (gfc_code
);
2499 c
->loc
= gfc_current_locus
;
2501 if (gfc_match_eos () != MATCH_YES
)
2504 gfc_clear_new_st ();
2505 new_st
.op
= EXEC_FORALL
;
2506 new_st
.expr1
= mask
;
2507 new_st
.ext
.forall_iterator
= head
;
2508 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2509 new_st
.block
->next
= c
;
2514 gfc_syntax_error (ST_FORALL
);
2517 gfc_free_forall_iterator (head
);
2518 gfc_free_expr (mask
);
2524 /* Match a FORALL statement. */
2527 gfc_match_forall (gfc_statement
*st
)
2529 gfc_forall_iterator
*head
;
2538 m0
= gfc_match_label ();
2539 if (m0
== MATCH_ERROR
)
2542 m
= gfc_match (" forall");
2546 m
= match_forall_header (&head
, &mask
);
2547 if (m
== MATCH_ERROR
)
2552 if (gfc_match_eos () == MATCH_YES
)
2554 *st
= ST_FORALL_BLOCK
;
2555 new_st
.op
= EXEC_FORALL
;
2556 new_st
.expr1
= mask
;
2557 new_st
.ext
.forall_iterator
= head
;
2561 m
= gfc_match_assignment ();
2562 if (m
== MATCH_ERROR
)
2566 m
= gfc_match_pointer_assignment ();
2567 if (m
== MATCH_ERROR
)
2573 c
= XCNEW (gfc_code
);
2575 c
->loc
= gfc_current_locus
;
2577 gfc_clear_new_st ();
2578 new_st
.op
= EXEC_FORALL
;
2579 new_st
.expr1
= mask
;
2580 new_st
.ext
.forall_iterator
= head
;
2581 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2582 new_st
.block
->next
= c
;
2588 gfc_syntax_error (ST_FORALL
);
2591 gfc_free_forall_iterator (head
);
2592 gfc_free_expr (mask
);
2593 gfc_free_statements (c
);
2598 /* Match a DO statement. */
2603 gfc_iterator iter
, *ip
;
2605 gfc_st_label
*label
;
2608 old_loc
= gfc_current_locus
;
2610 memset (&iter
, '\0', sizeof (gfc_iterator
));
2613 m
= gfc_match_label ();
2614 if (m
== MATCH_ERROR
)
2617 if (gfc_match (" do") != MATCH_YES
)
2620 m
= gfc_match_st_label (&label
);
2621 if (m
== MATCH_ERROR
)
2624 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2626 if (gfc_match_eos () == MATCH_YES
)
2628 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
2629 new_st
.op
= EXEC_DO_WHILE
;
2633 /* Match an optional comma, if no comma is found, a space is obligatory. */
2634 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
2637 /* Check for balanced parens. */
2639 if (gfc_match_parens () == MATCH_ERROR
)
2642 if (gfc_match (" concurrent") == MATCH_YES
)
2644 gfc_forall_iterator
*head
;
2647 if (!gfc_notify_std (GFC_STD_F2008
, "DO CONCURRENT construct at %C"))
2653 m
= match_forall_header (&head
, &mask
);
2657 if (m
== MATCH_ERROR
)
2658 goto concurr_cleanup
;
2660 if (gfc_match_eos () != MATCH_YES
)
2661 goto concurr_cleanup
;
2664 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2665 goto concurr_cleanup
;
2667 new_st
.label1
= label
;
2668 new_st
.op
= EXEC_DO_CONCURRENT
;
2669 new_st
.expr1
= mask
;
2670 new_st
.ext
.forall_iterator
= head
;
2675 gfc_syntax_error (ST_DO
);
2676 gfc_free_expr (mask
);
2677 gfc_free_forall_iterator (head
);
2681 /* See if we have a DO WHILE. */
2682 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
2684 new_st
.op
= EXEC_DO_WHILE
;
2688 /* The abortive DO WHILE may have done something to the symbol
2689 table, so we start over. */
2690 gfc_undo_symbols ();
2691 gfc_current_locus
= old_loc
;
2693 gfc_match_label (); /* This won't error. */
2694 gfc_match (" do "); /* This will work. */
2696 gfc_match_st_label (&label
); /* Can't error out. */
2697 gfc_match_char (','); /* Optional comma. */
2699 m
= gfc_match_iterator (&iter
, 0);
2702 if (m
== MATCH_ERROR
)
2705 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
2706 gfc_check_do_variable (iter
.var
->symtree
);
2708 if (gfc_match_eos () != MATCH_YES
)
2710 gfc_syntax_error (ST_DO
);
2714 new_st
.op
= EXEC_DO
;
2718 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2721 new_st
.label1
= label
;
2723 if (new_st
.op
== EXEC_DO_WHILE
)
2724 new_st
.expr1
= iter
.end
;
2727 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
2734 gfc_free_iterator (&iter
, 0);
2740 /* Match an EXIT or CYCLE statement. */
2743 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2745 gfc_state_data
*p
, *o
;
2750 if (gfc_match_eos () == MATCH_YES
)
2754 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2757 m
= gfc_match ("% %n%t", name
);
2758 if (m
== MATCH_ERROR
)
2762 gfc_syntax_error (st
);
2766 /* Find the corresponding symbol. If there's a BLOCK statement
2767 between here and the label, it is not in gfc_current_ns but a parent
2769 stree
= gfc_find_symtree_in_proc (name
, gfc_current_ns
);
2772 gfc_error ("Name %qs in %s statement at %C is unknown",
2773 name
, gfc_ascii_statement (st
));
2778 if (sym
->attr
.flavor
!= FL_LABEL
)
2780 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2781 name
, gfc_ascii_statement (st
));
2786 /* Find the loop specified by the label (or lack of a label). */
2787 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2788 if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2790 else if (p
->state
== COMP_CRITICAL
)
2792 gfc_error("%s statement at %C leaves CRITICAL construct",
2793 gfc_ascii_statement (st
));
2796 else if (p
->state
== COMP_DO_CONCURRENT
2797 && (op
== EXEC_EXIT
|| (sym
&& sym
!= p
->sym
)))
2799 /* F2008, C821 & C845. */
2800 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2801 gfc_ascii_statement (st
));
2804 else if ((sym
&& sym
== p
->sym
)
2805 || (!sym
&& (p
->state
== COMP_DO
2806 || p
->state
== COMP_DO_CONCURRENT
)))
2812 gfc_error ("%s statement at %C is not within a construct",
2813 gfc_ascii_statement (st
));
2815 gfc_error ("%s statement at %C is not within construct %qs",
2816 gfc_ascii_statement (st
), sym
->name
);
2821 /* Special checks for EXIT from non-loop constructs. */
2825 case COMP_DO_CONCURRENT
:
2829 /* This is already handled above. */
2832 case COMP_ASSOCIATE
:
2836 case COMP_SELECT_TYPE
:
2837 case COMP_SELECT_RANK
:
2839 if (op
== EXEC_CYCLE
)
2841 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2842 " construct %qs", sym
->name
);
2845 gcc_assert (op
== EXEC_EXIT
);
2846 if (!gfc_notify_std (GFC_STD_F2008
, "EXIT statement with no"
2847 " do-construct-name at %C"))
2852 gfc_error ("%s statement at %C is not applicable to construct %qs",
2853 gfc_ascii_statement (st
), sym
->name
);
2859 gfc_error (is_oacc (p
)
2860 ? G_("%s statement at %C leaving OpenACC structured block")
2861 : G_("%s statement at %C leaving OpenMP structured block"),
2862 gfc_ascii_statement (st
));
2866 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2872 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2873 switch (o
->head
->op
)
2875 case EXEC_OACC_LOOP
:
2876 case EXEC_OACC_KERNELS_LOOP
:
2877 case EXEC_OACC_PARALLEL_LOOP
:
2878 case EXEC_OACC_SERIAL_LOOP
:
2879 gcc_assert (o
->head
->next
!= NULL
2880 && (o
->head
->next
->op
== EXEC_DO
2881 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2882 && o
->previous
!= NULL
2883 && o
->previous
->tail
->op
== o
->head
->op
);
2884 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
)
2886 /* Both collapsed and tiled loops are lowered the same way, but are
2887 not compatible. In gfc_trans_omp_do, the tile is prioritized. */
2888 if (o
->previous
->tail
->ext
.omp_clauses
->tile_list
)
2892 = o
->previous
->tail
->ext
.omp_clauses
->tile_list
;
2893 for ( ; el
; el
= el
->next
)
2896 else if (o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2897 count
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2899 if (st
== ST_EXIT
&& cnt
<= count
)
2901 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2904 if (st
== ST_CYCLE
&& cnt
< count
)
2906 gfc_error (o
->previous
->tail
->ext
.omp_clauses
->tile_list
2907 ? G_("CYCLE statement at %C to non-innermost tiled "
2909 : G_("CYCLE statement at %C to non-innermost collapsed "
2910 "!$ACC LOOP loop"));
2914 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2915 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
2916 case EXEC_OMP_TARGET_SIMD
:
2917 case EXEC_OMP_TASKLOOP_SIMD
:
2918 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
2919 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
2920 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
2921 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
2922 case EXEC_OMP_PARALLEL_DO_SIMD
:
2923 case EXEC_OMP_DISTRIBUTE_SIMD
:
2924 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2925 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
2926 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2928 case EXEC_OMP_PARALLEL_LOOP
:
2929 case EXEC_OMP_TEAMS_LOOP
:
2930 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
2931 case EXEC_OMP_TARGET_TEAMS_LOOP
:
2933 case EXEC_OMP_PARALLEL_DO
:
2935 case EXEC_OMP_DO_SIMD
:
2936 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
2937 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2938 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2939 case EXEC_OMP_TARGET_PARALLEL_DO
:
2940 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2942 gcc_assert (o
->head
->next
!= NULL
2943 && (o
->head
->next
->op
== EXEC_DO
2944 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2945 && o
->previous
!= NULL
2946 && o
->previous
->tail
->op
== o
->head
->op
);
2947 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
)
2949 if (o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2950 count
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2951 if (o
->previous
->tail
->ext
.omp_clauses
->orderedc
)
2952 count
= o
->previous
->tail
->ext
.omp_clauses
->orderedc
;
2954 if (st
== ST_EXIT
&& cnt
<= count
)
2956 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2959 if (st
== ST_CYCLE
&& cnt
< count
)
2961 gfc_error ("CYCLE statement at %C to non-innermost collapsed "
2970 /* Save the first statement in the construct - needed by the backend. */
2971 new_st
.ext
.which_construct
= p
->construct
;
2979 /* Match the EXIT statement. */
2982 gfc_match_exit (void)
2984 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2988 /* Match the CYCLE statement. */
2991 gfc_match_cycle (void)
2993 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2997 /* Match a stop-code after an (ERROR) STOP or PAUSE statement. The
2998 requirements for a stop-code differ in the standards.
3002 R840 stop-stmt is STOP [ stop-code ]
3003 R841 stop-code is scalar-char-constant
3004 or digit [ digit [ digit [ digit [ digit ] ] ] ]
3006 Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
3009 R855 stop-stmt is STOP [ stop-code ]
3010 R856 allstop-stmt is ALL STOP [ stop-code ]
3011 R857 stop-code is scalar-default-char-constant-expr
3012 or scalar-int-constant-expr
3015 R1160 stop-stmt is STOP [ stop-code ] [ , QUIET = scalar-logical-expr]
3016 R1161 error-stop-stmt is
3017 ERROR STOP [ stop-code ] [ , QUIET = scalar-logical-expr]
3018 R1162 stop-code is scalar-default-char-expr
3021 For free-form source code, all standards contain a statement of the form:
3023 A blank shall be used to separate names, constants, or labels from
3024 adjacent keywords, names, constants, or labels.
3026 A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003,
3030 is valid, but it is invalid Fortran 2008. */
3033 gfc_match_stopcode (gfc_statement st
)
3036 gfc_expr
*quiet
= NULL
;
3041 /* Set f95 for -std=f95. */
3042 f95
= (gfc_option
.allow_std
== GFC_STD_OPT_F95
);
3044 /* Set f03 for -std=f2003. */
3045 f03
= (gfc_option
.allow_std
== GFC_STD_OPT_F03
);
3047 /* Set f08 for -std=f2008. */
3048 f08
= (gfc_option
.allow_std
== GFC_STD_OPT_F08
);
3050 /* Plain STOP statement? */
3051 if (gfc_match_eos () == MATCH_YES
)
3054 /* Look for a blank between STOP and the stop-code for F2008 or later.
3055 But allow for F2018's ,QUIET= specifier. */
3056 c
= gfc_peek_ascii_char ();
3058 if (gfc_current_form
!= FORM_FIXED
&& !(f95
|| f03
) && c
!= ',')
3060 /* Look for end-of-statement. There is no stop-code. */
3061 if (c
== '\n' || c
== '!' || c
== ';')
3066 gfc_error ("Blank required in %s statement near %C",
3067 gfc_ascii_statement (st
));
3074 gfc_gobble_whitespace ();
3075 c
= gfc_peek_ascii_char ();
3082 /* First look for the F95 or F2003 digit [...] construct. */
3083 old_locus
= gfc_current_locus
;
3084 m
= gfc_match_small_int (&stopcode
);
3085 if (m
== MATCH_YES
&& (f95
|| f03
))
3089 gfc_error ("STOP code at %C cannot be negative");
3093 if (stopcode
> 99999)
3095 gfc_error ("STOP code at %C contains too many digits");
3100 /* Reset the locus and now load gfc_expr. */
3101 gfc_current_locus
= old_locus
;
3102 m
= gfc_match_expr (&e
);
3103 if (m
== MATCH_ERROR
)
3109 if (gfc_match (" , quiet = %e", &quiet
) == MATCH_YES
)
3111 if (!gfc_notify_std (GFC_STD_F2018
, "QUIET= specifier for %s at %L",
3112 gfc_ascii_statement (st
), &quiet
->where
))
3116 if (gfc_match_eos () != MATCH_YES
)
3121 if (gfc_pure (NULL
))
3123 if (st
== ST_ERROR_STOP
)
3125 if (!gfc_notify_std (GFC_STD_F2018
, "%s statement at %C in PURE "
3126 "procedure", gfc_ascii_statement (st
)))
3131 gfc_error ("%s statement not allowed in PURE procedure at %C",
3132 gfc_ascii_statement (st
));
3137 gfc_unset_implicit_pure (NULL
);
3139 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
))
3141 gfc_error ("Image control statement STOP at %C in CRITICAL block");
3144 if (st
== ST_STOP
&& gfc_find_state (COMP_DO_CONCURRENT
))
3146 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
3152 if (!gfc_simplify_expr (e
, 0))
3155 /* Test for F95 and F2003 style STOP stop-code. */
3156 if (e
->expr_type
!= EXPR_CONSTANT
&& (f95
|| f03
))
3158 gfc_error ("STOP code at %L must be a scalar CHARACTER constant "
3159 "or digit[digit[digit[digit[digit]]]]", &e
->where
);
3163 /* Use the machinery for an initialization expression to reduce the
3164 stop-code to a constant. */
3165 gfc_reduce_init_expr (e
);
3167 /* Test for F2008 style STOP stop-code. */
3168 if (e
->expr_type
!= EXPR_CONSTANT
&& f08
)
3170 gfc_error ("STOP code at %L must be a scalar default CHARACTER or "
3171 "INTEGER constant expression", &e
->where
);
3175 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
3177 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
3184 gfc_error ("STOP code at %L must be scalar", &e
->where
);
3188 if (e
->ts
.type
== BT_CHARACTER
3189 && e
->ts
.kind
!= gfc_default_character_kind
)
3191 gfc_error ("STOP code at %L must be default character KIND=%d",
3192 &e
->where
, (int) gfc_default_character_kind
);
3196 if (e
->ts
.type
== BT_INTEGER
&& e
->ts
.kind
!= gfc_default_integer_kind
3197 && !gfc_notify_std (GFC_STD_F2018
,
3198 "STOP code at %L must be default integer KIND=%d",
3199 &e
->where
, (int) gfc_default_integer_kind
))
3205 if (!gfc_simplify_expr (quiet
, 0))
3208 if (quiet
->rank
!= 0)
3210 gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
3221 new_st
.op
= EXEC_STOP
;
3224 new_st
.op
= EXEC_ERROR_STOP
;
3227 new_st
.op
= EXEC_PAUSE
;
3234 new_st
.expr2
= quiet
;
3235 new_st
.ext
.stop_code
= -1;
3240 gfc_syntax_error (st
);
3245 gfc_free_expr (quiet
);
3250 /* Match the (deprecated) PAUSE statement. */
3253 gfc_match_pause (void)
3257 m
= gfc_match_stopcode (ST_PAUSE
);
3260 if (!gfc_notify_std (GFC_STD_F95_DEL
, "PAUSE statement at %C"))
3267 /* Match the STOP statement. */
3270 gfc_match_stop (void)
3272 return gfc_match_stopcode (ST_STOP
);
3276 /* Match the ERROR STOP statement. */
3279 gfc_match_error_stop (void)
3281 if (!gfc_notify_std (GFC_STD_F2008
, "ERROR STOP statement at %C"))
3284 return gfc_match_stopcode (ST_ERROR_STOP
);
3287 /* Match EVENT POST/WAIT statement. Syntax:
3288 EVENT POST ( event-variable [, sync-stat-list] )
3289 EVENT WAIT ( event-variable [, wait-spec-list] )
3291 wait-spec-list is sync-stat-list or until-spec
3292 until-spec is UNTIL_COUNT = scalar-int-expr
3293 sync-stat is STAT= or ERRMSG=. */
3296 event_statement (gfc_statement st
)
3299 gfc_expr
*tmp
, *eventvar
, *until_count
, *stat
, *errmsg
;
3300 bool saw_until_count
, saw_stat
, saw_errmsg
;
3302 tmp
= eventvar
= until_count
= stat
= errmsg
= NULL
;
3303 saw_until_count
= saw_stat
= saw_errmsg
= false;
3305 if (gfc_pure (NULL
))
3307 gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
3308 st
== ST_EVENT_POST
? "POST" : "WAIT");
3312 gfc_unset_implicit_pure (NULL
);
3314 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3316 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3320 if (gfc_find_state (COMP_CRITICAL
))
3322 gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
3323 st
== ST_EVENT_POST
? "POST" : "WAIT");
3327 if (gfc_find_state (COMP_DO_CONCURRENT
))
3329 gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
3330 "block", st
== ST_EVENT_POST
? "POST" : "WAIT");
3334 if (gfc_match_char ('(') != MATCH_YES
)
3337 if (gfc_match ("%e", &eventvar
) != MATCH_YES
)
3339 m
= gfc_match_char (',');
3340 if (m
== MATCH_ERROR
)
3344 m
= gfc_match_char (')');
3352 m
= gfc_match (" stat = %v", &tmp
);
3353 if (m
== MATCH_ERROR
)
3359 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3365 m
= gfc_match_char (',');
3373 m
= gfc_match (" errmsg = %v", &tmp
);
3374 if (m
== MATCH_ERROR
)
3380 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3386 m
= gfc_match_char (',');
3394 m
= gfc_match (" until_count = %e", &tmp
);
3395 if (m
== MATCH_ERROR
|| st
== ST_EVENT_POST
)
3399 if (saw_until_count
)
3401 gfc_error ("Redundant UNTIL_COUNT tag found at %L",
3406 saw_until_count
= true;
3408 m
= gfc_match_char (',');
3419 if (m
== MATCH_ERROR
)
3422 if (gfc_match (" )%t") != MATCH_YES
)
3429 new_st
.op
= EXEC_EVENT_POST
;
3432 new_st
.op
= EXEC_EVENT_WAIT
;
3438 new_st
.expr1
= eventvar
;
3439 new_st
.expr2
= stat
;
3440 new_st
.expr3
= errmsg
;
3441 new_st
.expr4
= until_count
;
3446 gfc_syntax_error (st
);
3449 if (until_count
!= tmp
)
3450 gfc_free_expr (until_count
);
3452 gfc_free_expr (errmsg
);
3454 gfc_free_expr (stat
);
3456 gfc_free_expr (tmp
);
3457 gfc_free_expr (eventvar
);
3465 gfc_match_event_post (void)
3467 if (!gfc_notify_std (GFC_STD_F2018
, "EVENT POST statement at %C"))
3470 return event_statement (ST_EVENT_POST
);
3475 gfc_match_event_wait (void)
3477 if (!gfc_notify_std (GFC_STD_F2018
, "EVENT WAIT statement at %C"))
3480 return event_statement (ST_EVENT_WAIT
);
3484 /* Match a FAIL IMAGE statement. */
3487 gfc_match_fail_image (void)
3489 if (!gfc_notify_std (GFC_STD_F2018
, "FAIL IMAGE statement at %C"))
3492 if (gfc_match_char ('(') == MATCH_YES
)
3495 new_st
.op
= EXEC_FAIL_IMAGE
;
3500 gfc_syntax_error (ST_FAIL_IMAGE
);
3505 /* Match a FORM TEAM statement. */
3508 gfc_match_form_team (void)
3511 gfc_expr
*teamid
,*team
;
3513 if (!gfc_notify_std (GFC_STD_F2018
, "FORM TEAM statement at %C"))
3516 if (gfc_match_char ('(') == MATCH_NO
)
3519 new_st
.op
= EXEC_FORM_TEAM
;
3521 if (gfc_match ("%e", &teamid
) != MATCH_YES
)
3523 m
= gfc_match_char (',');
3524 if (m
== MATCH_ERROR
)
3526 if (gfc_match ("%e", &team
) != MATCH_YES
)
3529 m
= gfc_match_char (')');
3533 new_st
.expr1
= teamid
;
3534 new_st
.expr2
= team
;
3539 gfc_syntax_error (ST_FORM_TEAM
);
3544 /* Match a CHANGE TEAM statement. */
3547 gfc_match_change_team (void)
3552 if (!gfc_notify_std (GFC_STD_F2018
, "CHANGE TEAM statement at %C"))
3555 if (gfc_match_char ('(') == MATCH_NO
)
3558 new_st
.op
= EXEC_CHANGE_TEAM
;
3560 if (gfc_match ("%e", &team
) != MATCH_YES
)
3563 m
= gfc_match_char (')');
3567 new_st
.expr1
= team
;
3572 gfc_syntax_error (ST_CHANGE_TEAM
);
3577 /* Match a END TEAM statement. */
3580 gfc_match_end_team (void)
3582 if (!gfc_notify_std (GFC_STD_F2018
, "END TEAM statement at %C"))
3585 if (gfc_match_char ('(') == MATCH_YES
)
3588 new_st
.op
= EXEC_END_TEAM
;
3593 gfc_syntax_error (ST_END_TEAM
);
3598 /* Match a SYNC TEAM statement. */
3601 gfc_match_sync_team (void)
3606 if (!gfc_notify_std (GFC_STD_F2018
, "SYNC TEAM statement at %C"))
3609 if (gfc_match_char ('(') == MATCH_NO
)
3612 new_st
.op
= EXEC_SYNC_TEAM
;
3614 if (gfc_match ("%e", &team
) != MATCH_YES
)
3617 m
= gfc_match_char (')');
3621 new_st
.expr1
= team
;
3626 gfc_syntax_error (ST_SYNC_TEAM
);
3631 /* Match LOCK/UNLOCK statement. Syntax:
3632 LOCK ( lock-variable [ , lock-stat-list ] )
3633 UNLOCK ( lock-variable [ , sync-stat-list ] )
3634 where lock-stat is ACQUIRED_LOCK or sync-stat
3635 and sync-stat is STAT= or ERRMSG=. */
3638 lock_unlock_statement (gfc_statement st
)
3641 gfc_expr
*tmp
, *lockvar
, *acq_lock
, *stat
, *errmsg
;
3642 bool saw_acq_lock
, saw_stat
, saw_errmsg
;
3644 tmp
= lockvar
= acq_lock
= stat
= errmsg
= NULL
;
3645 saw_acq_lock
= saw_stat
= saw_errmsg
= false;
3647 if (gfc_pure (NULL
))
3649 gfc_error ("Image control statement %s at %C in PURE procedure",
3650 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3654 gfc_unset_implicit_pure (NULL
);
3656 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3658 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3662 if (gfc_find_state (COMP_CRITICAL
))
3664 gfc_error ("Image control statement %s at %C in CRITICAL block",
3665 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3669 if (gfc_find_state (COMP_DO_CONCURRENT
))
3671 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
3672 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3676 if (gfc_match_char ('(') != MATCH_YES
)
3679 if (gfc_match ("%e", &lockvar
) != MATCH_YES
)
3681 m
= gfc_match_char (',');
3682 if (m
== MATCH_ERROR
)
3686 m
= gfc_match_char (')');
3694 m
= gfc_match (" stat = %v", &tmp
);
3695 if (m
== MATCH_ERROR
)
3701 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3707 m
= gfc_match_char (',');
3715 m
= gfc_match (" errmsg = %v", &tmp
);
3716 if (m
== MATCH_ERROR
)
3722 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3728 m
= gfc_match_char (',');
3736 m
= gfc_match (" acquired_lock = %v", &tmp
);
3737 if (m
== MATCH_ERROR
|| st
== ST_UNLOCK
)
3743 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L",
3748 saw_acq_lock
= true;
3750 m
= gfc_match_char (',');
3761 if (m
== MATCH_ERROR
)
3764 if (gfc_match (" )%t") != MATCH_YES
)
3771 new_st
.op
= EXEC_LOCK
;
3774 new_st
.op
= EXEC_UNLOCK
;
3780 new_st
.expr1
= lockvar
;
3781 new_st
.expr2
= stat
;
3782 new_st
.expr3
= errmsg
;
3783 new_st
.expr4
= acq_lock
;
3788 gfc_syntax_error (st
);
3791 if (acq_lock
!= tmp
)
3792 gfc_free_expr (acq_lock
);
3794 gfc_free_expr (errmsg
);
3796 gfc_free_expr (stat
);
3798 gfc_free_expr (tmp
);
3799 gfc_free_expr (lockvar
);
3806 gfc_match_lock (void)
3808 if (!gfc_notify_std (GFC_STD_F2008
, "LOCK statement at %C"))
3811 return lock_unlock_statement (ST_LOCK
);
3816 gfc_match_unlock (void)
3818 if (!gfc_notify_std (GFC_STD_F2008
, "UNLOCK statement at %C"))
3821 return lock_unlock_statement (ST_UNLOCK
);
3825 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
3826 SYNC ALL [(sync-stat-list)]
3827 SYNC MEMORY [(sync-stat-list)]
3828 SYNC IMAGES (image-set [, sync-stat-list] )
3829 with sync-stat is int-expr or *. */
3832 sync_statement (gfc_statement st
)
3835 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
3836 bool saw_stat
, saw_errmsg
;
3838 tmp
= imageset
= stat
= errmsg
= NULL
;
3839 saw_stat
= saw_errmsg
= false;
3841 if (gfc_pure (NULL
))
3843 gfc_error ("Image control statement SYNC at %C in PURE procedure");
3847 gfc_unset_implicit_pure (NULL
);
3849 if (!gfc_notify_std (GFC_STD_F2008
, "SYNC statement at %C"))
3852 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3854 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
3859 if (gfc_find_state (COMP_CRITICAL
))
3861 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3865 if (gfc_find_state (COMP_DO_CONCURRENT
))
3867 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3871 if (gfc_match_eos () == MATCH_YES
)
3873 if (st
== ST_SYNC_IMAGES
)
3878 if (gfc_match_char ('(') != MATCH_YES
)
3881 if (st
== ST_SYNC_IMAGES
)
3883 /* Denote '*' as imageset == NULL. */
3884 m
= gfc_match_char ('*');
3885 if (m
== MATCH_ERROR
)
3889 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
3892 m
= gfc_match_char (',');
3893 if (m
== MATCH_ERROR
)
3897 m
= gfc_match_char (')');
3906 m
= gfc_match (" stat = %e", &tmp
);
3907 if (m
== MATCH_ERROR
)
3913 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3919 if (gfc_match_char (',') == MATCH_YES
)
3926 m
= gfc_match (" errmsg = %e", &tmp
);
3927 if (m
== MATCH_ERROR
)
3933 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3939 if (gfc_match_char (',') == MATCH_YES
)
3949 if (gfc_match (" )%t") != MATCH_YES
)
3956 new_st
.op
= EXEC_SYNC_ALL
;
3958 case ST_SYNC_IMAGES
:
3959 new_st
.op
= EXEC_SYNC_IMAGES
;
3961 case ST_SYNC_MEMORY
:
3962 new_st
.op
= EXEC_SYNC_MEMORY
;
3968 new_st
.expr1
= imageset
;
3969 new_st
.expr2
= stat
;
3970 new_st
.expr3
= errmsg
;
3975 gfc_syntax_error (st
);
3979 gfc_free_expr (stat
);
3981 gfc_free_expr (errmsg
);
3983 gfc_free_expr (tmp
);
3984 gfc_free_expr (imageset
);
3990 /* Match SYNC ALL statement. */
3993 gfc_match_sync_all (void)
3995 return sync_statement (ST_SYNC_ALL
);
3999 /* Match SYNC IMAGES statement. */
4002 gfc_match_sync_images (void)
4004 return sync_statement (ST_SYNC_IMAGES
);
4008 /* Match SYNC MEMORY statement. */
4011 gfc_match_sync_memory (void)
4013 return sync_statement (ST_SYNC_MEMORY
);
4017 /* Match a CONTINUE statement. */
4020 gfc_match_continue (void)
4022 if (gfc_match_eos () != MATCH_YES
)
4024 gfc_syntax_error (ST_CONTINUE
);
4028 new_st
.op
= EXEC_CONTINUE
;
4033 /* Match the (deprecated) ASSIGN statement. */
4036 gfc_match_assign (void)
4039 gfc_st_label
*label
;
4041 if (gfc_match (" %l", &label
) == MATCH_YES
)
4043 if (!gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
))
4045 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
4047 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGN statement at %C"))
4050 expr
->symtree
->n
.sym
->attr
.assign
= 1;
4052 new_st
.op
= EXEC_LABEL_ASSIGN
;
4053 new_st
.label1
= label
;
4054 new_st
.expr1
= expr
;
4062 /* Match the GO TO statement. As a computed GOTO statement is
4063 matched, it is transformed into an equivalent SELECT block. No
4064 tree is necessary, and the resulting jumps-to-jumps are
4065 specifically optimized away by the back end. */
4068 gfc_match_goto (void)
4070 gfc_code
*head
, *tail
;
4073 gfc_st_label
*label
;
4077 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
4079 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
4082 new_st
.op
= EXEC_GOTO
;
4083 new_st
.label1
= label
;
4087 /* The assigned GO TO statement. */
4089 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
4091 if (!gfc_notify_std (GFC_STD_F95_DEL
, "Assigned GOTO statement at %C"))
4094 new_st
.op
= EXEC_GOTO
;
4095 new_st
.expr1
= expr
;
4097 if (gfc_match_eos () == MATCH_YES
)
4100 /* Match label list. */
4101 gfc_match_char (',');
4102 if (gfc_match_char ('(') != MATCH_YES
)
4104 gfc_syntax_error (ST_GOTO
);
4111 m
= gfc_match_st_label (&label
);
4115 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
4119 head
= tail
= gfc_get_code (EXEC_GOTO
);
4122 tail
->block
= gfc_get_code (EXEC_GOTO
);
4126 tail
->label1
= label
;
4128 while (gfc_match_char (',') == MATCH_YES
);
4130 if (gfc_match (" )%t") != MATCH_YES
)
4135 gfc_error ("Statement label list in GOTO at %C cannot be empty");
4138 new_st
.block
= head
;
4143 /* Last chance is a computed GO TO statement. */
4144 if (gfc_match_char ('(') != MATCH_YES
)
4146 gfc_syntax_error (ST_GOTO
);
4155 m
= gfc_match_st_label (&label
);
4159 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
4163 head
= tail
= gfc_get_code (EXEC_SELECT
);
4166 tail
->block
= gfc_get_code (EXEC_SELECT
);
4170 cp
= gfc_get_case ();
4171 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
4174 tail
->ext
.block
.case_list
= cp
;
4176 tail
->next
= gfc_get_code (EXEC_GOTO
);
4177 tail
->next
->label1
= label
;
4179 while (gfc_match_char (',') == MATCH_YES
);
4181 if (gfc_match_char (')') != MATCH_YES
)
4186 gfc_error ("Statement label list in GOTO at %C cannot be empty");
4190 /* Get the rest of the statement. */
4191 gfc_match_char (',');
4193 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
4196 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Computed GOTO at %C"))
4199 /* At this point, a computed GOTO has been fully matched and an
4200 equivalent SELECT statement constructed. */
4202 new_st
.op
= EXEC_SELECT
;
4203 new_st
.expr1
= NULL
;
4205 /* Hack: For a "real" SELECT, the expression is in expr. We put
4206 it in expr2 so we can distinguish then and produce the correct
4208 new_st
.expr2
= expr
;
4209 new_st
.block
= head
;
4213 gfc_syntax_error (ST_GOTO
);
4215 gfc_free_statements (head
);
4220 /* Frees a list of gfc_alloc structures. */
4223 gfc_free_alloc_list (gfc_alloc
*p
)
4230 gfc_free_expr (p
->expr
);
4236 /* Match an ALLOCATE statement. */
4239 gfc_match_allocate (void)
4241 gfc_alloc
*head
, *tail
;
4242 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
4246 locus old_locus
, deferred_locus
, assumed_locus
;
4247 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, saw_deferred
, b1
, b2
, b3
;
4248 bool saw_unlimited
= false, saw_assumed
= false;
4251 stat
= errmsg
= source
= mold
= tmp
= NULL
;
4252 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= saw_deferred
= false;
4254 if (gfc_match_char ('(') != MATCH_YES
)
4256 gfc_syntax_error (ST_ALLOCATE
);
4260 /* Match an optional type-spec. */
4261 old_locus
= gfc_current_locus
;
4262 m
= gfc_match_type_spec (&ts
);
4263 if (m
== MATCH_ERROR
)
4265 else if (m
== MATCH_NO
)
4267 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
4269 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
4271 gfc_error ("Error in type-spec at %L", &old_locus
);
4275 ts
.type
= BT_UNKNOWN
;
4279 /* Needed for the F2008:C631 check below. */
4280 assumed_locus
= gfc_current_locus
;
4282 if (gfc_match (" :: ") == MATCH_YES
)
4284 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
4290 gfc_error ("Type-spec at %L cannot contain a deferred "
4291 "type parameter", &old_locus
);
4295 if (ts
.type
== BT_CHARACTER
)
4297 if (!ts
.u
.cl
->length
)
4300 ts
.u
.cl
->length_from_typespec
= true;
4303 if (type_param_spec_list
4304 && gfc_spec_list_type (type_param_spec_list
, NULL
)
4307 gfc_error ("The type parameter spec list in the type-spec at "
4308 "%L cannot contain DEFERRED parameters", &old_locus
);
4314 ts
.type
= BT_UNKNOWN
;
4315 gfc_current_locus
= old_locus
;
4322 head
= tail
= gfc_get_alloc ();
4325 tail
->next
= gfc_get_alloc ();
4329 m
= gfc_match_variable (&tail
->expr
, 0);
4332 if (m
== MATCH_ERROR
)
4335 if (tail
->expr
->expr_type
== EXPR_CONSTANT
)
4337 gfc_error ("Unexpected constant at %C");
4341 if (gfc_check_do_variable (tail
->expr
->symtree
))
4344 bool impure
= gfc_impure_variable (tail
->expr
->symtree
->n
.sym
);
4345 if (impure
&& gfc_pure (NULL
))
4347 gfc_error ("Bad allocate-object at %C for a PURE procedure");
4352 gfc_unset_implicit_pure (NULL
);
4354 /* F2008:C631 (R626) A type-param-value in a type-spec shall be an
4355 asterisk if and only if each allocate-object is a dummy argument
4356 for which the corresponding type parameter is assumed. */
4358 && (tail
->expr
->ts
.deferred
4359 || (tail
->expr
->ts
.u
.cl
&& tail
->expr
->ts
.u
.cl
->length
)
4360 || tail
->expr
->symtree
->n
.sym
->attr
.dummy
== 0))
4362 gfc_error ("Incompatible allocate-object at %C for CHARACTER "
4363 "type-spec at %L", &assumed_locus
);
4367 if (tail
->expr
->ts
.deferred
)
4369 saw_deferred
= true;
4370 deferred_locus
= tail
->expr
->where
;
4373 if (gfc_find_state (COMP_DO_CONCURRENT
)
4374 || gfc_find_state (COMP_CRITICAL
))
4377 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
4378 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
4379 if (ref
->type
== REF_COMPONENT
)
4380 coarray
= ref
->u
.c
.component
->attr
.codimension
;
4382 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
4384 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
4387 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
4389 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
4394 /* Check for F08:C628. */
4395 sym
= tail
->expr
->symtree
->n
.sym
;
4396 b1
= !(tail
->expr
->ref
4397 && (tail
->expr
->ref
->type
== REF_COMPONENT
4398 || tail
->expr
->ref
->type
== REF_ARRAY
));
4399 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4400 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
4401 || CLASS_DATA (sym
)->attr
.class_pointer
);
4403 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4404 || sym
->attr
.proc_pointer
);
4405 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
4406 && (sym
->ns
->proc_name
->attr
.allocatable
4407 || sym
->ns
->proc_name
->attr
.pointer
4408 || sym
->ns
->proc_name
->attr
.proc_pointer
);
4409 if (b1
&& b2
&& !b3
)
4411 gfc_error ("Allocate-object at %L is neither a data pointer "
4412 "nor an allocatable variable", &tail
->expr
->where
);
4416 /* The ALLOCATE statement had an optional typespec. Check the
4418 if (ts
.type
!= BT_UNKNOWN
)
4420 /* Enforce F03:C624. */
4421 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
4423 gfc_error ("Type of entity at %L is type incompatible with "
4424 "typespec", &tail
->expr
->where
);
4428 /* Enforce F03:C627. */
4429 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
4431 gfc_error ("Kind type parameter for entity at %L differs from "
4432 "the kind type parameter of the typespec",
4433 &tail
->expr
->where
);
4438 if (tail
->expr
->ts
.type
== BT_DERIVED
)
4439 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
4441 if (type_param_spec_list
)
4442 tail
->expr
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
4444 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
4446 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
4448 gfc_error ("Shape specification for allocatable scalar at %C");
4452 if (gfc_match_char (',') != MATCH_YES
)
4457 m
= gfc_match (" stat = %e", &tmp
);
4458 if (m
== MATCH_ERROR
)
4465 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4473 if (stat
->expr_type
== EXPR_CONSTANT
)
4475 gfc_error ("STAT tag at %L cannot be a constant", &stat
->where
);
4479 if (gfc_check_do_variable (stat
->symtree
))
4482 if (gfc_match_char (',') == MATCH_YES
)
4483 goto alloc_opt_list
;
4486 m
= gfc_match (" errmsg = %e", &tmp
);
4487 if (m
== MATCH_ERROR
)
4491 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
4497 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4505 if (gfc_match_char (',') == MATCH_YES
)
4506 goto alloc_opt_list
;
4509 m
= gfc_match (" source = %e", &tmp
);
4510 if (m
== MATCH_ERROR
)
4514 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
4520 gfc_error ("Redundant SOURCE tag found at %L", &tmp
->where
);
4524 /* The next 2 conditionals check C631. */
4525 if (ts
.type
!= BT_UNKNOWN
)
4527 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
4528 &tmp
->where
, &old_locus
);
4533 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
4534 " with more than a single allocate object",
4542 if (gfc_match_char (',') == MATCH_YES
)
4543 goto alloc_opt_list
;
4546 m
= gfc_match (" mold = %e", &tmp
);
4547 if (m
== MATCH_ERROR
)
4551 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
4554 /* Check F08:C636. */
4557 gfc_error ("Redundant MOLD tag found at %L", &tmp
->where
);
4561 /* Check F08:C637. */
4562 if (ts
.type
!= BT_UNKNOWN
)
4564 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
4565 &tmp
->where
, &old_locus
);
4574 if (gfc_match_char (',') == MATCH_YES
)
4575 goto alloc_opt_list
;
4578 gfc_gobble_whitespace ();
4580 if (gfc_peek_char () == ')')
4584 if (gfc_match (" )%t") != MATCH_YES
)
4587 /* Check F08:C637. */
4590 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
4591 &mold
->where
, &source
->where
);
4595 /* Check F03:C623, */
4596 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4598 gfc_error ("Allocate-object at %L with a deferred type parameter "
4599 "requires either a type-spec or SOURCE tag or a MOLD tag",
4604 /* Check F03:C625, */
4605 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4607 for (tail
= head
; tail
; tail
= tail
->next
)
4609 if (UNLIMITED_POLY (tail
->expr
))
4610 gfc_error ("Unlimited polymorphic allocate-object at %L "
4611 "requires either a type-spec or SOURCE tag "
4612 "or a MOLD tag", &tail
->expr
->where
);
4617 new_st
.op
= EXEC_ALLOCATE
;
4618 new_st
.expr1
= stat
;
4619 new_st
.expr2
= errmsg
;
4621 new_st
.expr3
= source
;
4623 new_st
.expr3
= mold
;
4624 new_st
.ext
.alloc
.list
= head
;
4625 new_st
.ext
.alloc
.ts
= ts
;
4627 if (type_param_spec_list
)
4628 gfc_free_actual_arglist (type_param_spec_list
);
4633 gfc_syntax_error (ST_ALLOCATE
);
4636 gfc_free_expr (errmsg
);
4637 gfc_free_expr (source
);
4638 gfc_free_expr (stat
);
4639 gfc_free_expr (mold
);
4640 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
4641 gfc_free_alloc_list (head
);
4642 if (type_param_spec_list
)
4643 gfc_free_actual_arglist (type_param_spec_list
);
4648 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
4649 a set of pointer assignments to intrinsic NULL(). */
4652 gfc_match_nullify (void)
4660 if (gfc_match_char ('(') != MATCH_YES
)
4665 m
= gfc_match_variable (&p
, 0);
4666 if (m
== MATCH_ERROR
)
4671 if (gfc_check_do_variable (p
->symtree
))
4675 if (gfc_is_coindexed (p
))
4677 gfc_error ("Pointer object at %C shall not be coindexed");
4681 /* Check for valid array pointer object. Bounds remapping is not
4682 allowed with NULLIFY. */
4685 gfc_ref
*remap
= p
->ref
;
4686 for (; remap
; remap
= remap
->next
)
4687 if (!remap
->next
&& remap
->type
== REF_ARRAY
4688 && remap
->u
.ar
.type
!= AR_FULL
)
4692 gfc_error ("NULLIFY does not allow bounds remapping for "
4693 "pointer object at %C");
4698 /* build ' => NULL() '. */
4699 e
= gfc_get_null_expr (&gfc_current_locus
);
4701 /* Chain to list. */
4705 tail
->op
= EXEC_POINTER_ASSIGN
;
4709 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
4716 if (gfc_match (" )%t") == MATCH_YES
)
4718 if (gfc_match_char (',') != MATCH_YES
)
4725 gfc_syntax_error (ST_NULLIFY
);
4728 gfc_free_statements (new_st
.next
);
4730 gfc_free_expr (new_st
.expr1
);
4731 new_st
.expr1
= NULL
;
4732 gfc_free_expr (new_st
.expr2
);
4733 new_st
.expr2
= NULL
;
4738 /* Match a DEALLOCATE statement. */
4741 gfc_match_deallocate (void)
4743 gfc_alloc
*head
, *tail
;
4744 gfc_expr
*stat
, *errmsg
, *tmp
;
4747 bool saw_stat
, saw_errmsg
, b1
, b2
;
4750 stat
= errmsg
= tmp
= NULL
;
4751 saw_stat
= saw_errmsg
= false;
4753 if (gfc_match_char ('(') != MATCH_YES
)
4759 head
= tail
= gfc_get_alloc ();
4762 tail
->next
= gfc_get_alloc ();
4766 m
= gfc_match_variable (&tail
->expr
, 0);
4767 if (m
== MATCH_ERROR
)
4772 if (tail
->expr
->expr_type
== EXPR_CONSTANT
)
4774 gfc_error ("Unexpected constant at %C");
4778 if (gfc_check_do_variable (tail
->expr
->symtree
))
4781 sym
= tail
->expr
->symtree
->n
.sym
;
4783 bool impure
= gfc_impure_variable (sym
);
4784 if (impure
&& gfc_pure (NULL
))
4786 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
4791 gfc_unset_implicit_pure (NULL
);
4793 if (gfc_is_coarray (tail
->expr
)
4794 && gfc_find_state (COMP_DO_CONCURRENT
))
4796 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
4800 if (gfc_is_coarray (tail
->expr
)
4801 && gfc_find_state (COMP_CRITICAL
))
4803 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
4807 /* FIXME: disable the checking on derived types. */
4808 b1
= !(tail
->expr
->ref
4809 && (tail
->expr
->ref
->type
== REF_COMPONENT
4810 || tail
->expr
->ref
->type
== REF_ARRAY
));
4811 if (sym
&& sym
->ts
.type
== BT_CLASS
)
4812 b2
= !(CLASS_DATA (sym
) && (CLASS_DATA (sym
)->attr
.allocatable
4813 || CLASS_DATA (sym
)->attr
.class_pointer
));
4815 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4816 || sym
->attr
.proc_pointer
);
4819 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
4820 "nor an allocatable variable");
4824 if (gfc_match_char (',') != MATCH_YES
)
4829 m
= gfc_match (" stat = %e", &tmp
);
4830 if (m
== MATCH_ERROR
)
4836 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4837 gfc_free_expr (tmp
);
4844 if (gfc_check_do_variable (stat
->symtree
))
4847 if (gfc_match_char (',') == MATCH_YES
)
4848 goto dealloc_opt_list
;
4851 m
= gfc_match (" errmsg = %e", &tmp
);
4852 if (m
== MATCH_ERROR
)
4856 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
4861 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4862 gfc_free_expr (tmp
);
4869 if (gfc_match_char (',') == MATCH_YES
)
4870 goto dealloc_opt_list
;
4873 gfc_gobble_whitespace ();
4875 if (gfc_peek_char () == ')')
4879 if (gfc_match (" )%t") != MATCH_YES
)
4882 new_st
.op
= EXEC_DEALLOCATE
;
4883 new_st
.expr1
= stat
;
4884 new_st
.expr2
= errmsg
;
4885 new_st
.ext
.alloc
.list
= head
;
4890 gfc_syntax_error (ST_DEALLOCATE
);
4893 gfc_free_expr (errmsg
);
4894 gfc_free_expr (stat
);
4895 gfc_free_alloc_list (head
);
4900 /* Match a RETURN statement. */
4903 gfc_match_return (void)
4907 gfc_compile_state s
;
4911 if (gfc_find_state (COMP_CRITICAL
))
4913 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4917 if (gfc_find_state (COMP_DO_CONCURRENT
))
4919 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4923 if (gfc_match_eos () == MATCH_YES
)
4926 if (!gfc_find_state (COMP_SUBROUTINE
))
4928 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4933 if (gfc_current_form
== FORM_FREE
)
4935 /* The following are valid, so we can't require a blank after the
4939 char c
= gfc_peek_ascii_char ();
4940 if (ISALPHA (c
) || ISDIGIT (c
))
4944 m
= gfc_match (" %e%t", &e
);
4947 if (m
== MATCH_ERROR
)
4950 gfc_syntax_error (ST_RETURN
);
4957 gfc_enclosing_unit (&s
);
4958 if (s
== COMP_PROGRAM
4959 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
4960 "main program at %C"))
4963 new_st
.op
= EXEC_RETURN
;
4970 /* Match the call of a type-bound procedure, if CALL%var has already been
4971 matched and var found to be a derived-type variable. */
4974 match_typebound_call (gfc_symtree
* varst
)
4979 base
= gfc_get_expr ();
4980 base
->expr_type
= EXPR_VARIABLE
;
4981 base
->symtree
= varst
;
4982 base
->where
= gfc_current_locus
;
4983 gfc_set_sym_referenced (varst
->n
.sym
);
4985 m
= gfc_match_varspec (base
, 0, true, true);
4987 gfc_error ("Expected component reference at %C");
4990 gfc_free_expr (base
);
4994 if (gfc_match_eos () != MATCH_YES
)
4996 gfc_error ("Junk after CALL at %C");
4997 gfc_free_expr (base
);
5001 if (base
->expr_type
== EXPR_COMPCALL
)
5002 new_st
.op
= EXEC_COMPCALL
;
5003 else if (base
->expr_type
== EXPR_PPC
)
5004 new_st
.op
= EXEC_CALL_PPC
;
5007 gfc_error ("Expected type-bound procedure or procedure pointer component "
5009 gfc_free_expr (base
);
5012 new_st
.expr1
= base
;
5018 /* Match a CALL statement. The tricky part here are possible
5019 alternate return specifiers. We handle these by having all
5020 "subroutines" actually return an integer via a register that gives
5021 the return number. If the call specifies alternate returns, we
5022 generate code for a SELECT statement whose case clauses contain
5023 GOTOs to the various labels. */
5026 gfc_match_call (void)
5028 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5029 gfc_actual_arglist
*a
, *arglist
;
5039 m
= gfc_match ("% %n", name
);
5045 if (gfc_get_ha_sym_tree (name
, &st
))
5050 /* If this is a variable of derived-type, it probably starts a type-bound
5051 procedure call. Associate variable targets have to be resolved for the
5053 if (((sym
->attr
.flavor
!= FL_PROCEDURE
5054 || gfc_is_function_return_value (sym
, gfc_current_ns
))
5055 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
5057 (sym
->assoc
&& sym
->assoc
->target
5058 && gfc_resolve_expr (sym
->assoc
->target
)
5059 && (sym
->assoc
->target
->ts
.type
== BT_DERIVED
5060 || sym
->assoc
->target
->ts
.type
== BT_CLASS
)))
5061 return match_typebound_call (st
);
5063 /* If it does not seem to be callable (include functions so that the
5064 right association is made. They are thrown out in resolution.)
5066 if (!sym
->attr
.generic
5067 && !sym
->attr
.proc_pointer
5068 && !sym
->attr
.subroutine
5069 && !sym
->attr
.function
)
5071 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
5073 /* ...create a symbol in this scope... */
5074 if (sym
->ns
!= gfc_current_ns
5075 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
5078 if (sym
!= st
->n
.sym
)
5082 /* ...and then to try to make the symbol into a subroutine. */
5083 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
5087 gfc_set_sym_referenced (sym
);
5089 if (gfc_match_eos () != MATCH_YES
)
5091 m
= gfc_match_actual_arglist (1, &arglist
);
5094 if (m
== MATCH_ERROR
)
5097 if (gfc_match_eos () != MATCH_YES
)
5101 /* Walk the argument list looking for invalid BOZ. */
5102 for (a
= arglist
; a
; a
= a
->next
)
5103 if (a
->expr
&& a
->expr
->ts
.type
== BT_BOZ
)
5105 gfc_error ("A BOZ literal constant at %L cannot appear as an actual "
5106 "argument in a subroutine reference", &a
->expr
->where
);
5111 /* If any alternate return labels were found, construct a SELECT
5112 statement that will jump to the right place. */
5115 for (a
= arglist
; a
; a
= a
->next
)
5116 if (a
->expr
== NULL
)
5124 gfc_symtree
*select_st
;
5125 gfc_symbol
*select_sym
;
5126 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5128 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
5129 sprintf (name
, "_result_%s", sym
->name
);
5130 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
5132 select_sym
= select_st
->n
.sym
;
5133 select_sym
->ts
.type
= BT_INTEGER
;
5134 select_sym
->ts
.kind
= gfc_default_integer_kind
;
5135 gfc_set_sym_referenced (select_sym
);
5136 c
->expr1
= gfc_get_expr ();
5137 c
->expr1
->expr_type
= EXPR_VARIABLE
;
5138 c
->expr1
->symtree
= select_st
;
5139 c
->expr1
->ts
= select_sym
->ts
;
5140 c
->expr1
->where
= gfc_current_locus
;
5143 for (a
= arglist
; a
; a
= a
->next
)
5145 if (a
->expr
!= NULL
)
5148 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
5153 c
->block
= gfc_get_code (EXEC_SELECT
);
5156 new_case
= gfc_get_case ();
5157 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
5158 new_case
->low
= new_case
->high
;
5159 c
->ext
.block
.case_list
= new_case
;
5161 c
->next
= gfc_get_code (EXEC_GOTO
);
5162 c
->next
->label1
= a
->label
;
5166 new_st
.op
= EXEC_CALL
;
5167 new_st
.symtree
= st
;
5168 new_st
.ext
.actual
= arglist
;
5173 gfc_syntax_error (ST_CALL
);
5176 gfc_free_actual_arglist (arglist
);
5181 /* Given a name, return a pointer to the common head structure,
5182 creating it if it does not exist. If FROM_MODULE is nonzero, we
5183 mangle the name so that it doesn't interfere with commons defined
5184 in the using namespace.
5185 TODO: Add to global symbol tree. */
5188 gfc_get_common (const char *name
, int from_module
)
5191 static int serial
= 0;
5192 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
5196 /* A use associated common block is only needed to correctly layout
5197 the variables it contains. */
5198 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
5199 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
5203 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
5206 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
5209 if (st
->n
.common
== NULL
)
5211 st
->n
.common
= gfc_get_common_head ();
5212 st
->n
.common
->where
= gfc_current_locus
;
5213 strcpy (st
->n
.common
->name
, name
);
5216 return st
->n
.common
;
5220 /* Match a common block name. */
5223 gfc_match_common_name (char *name
)
5227 if (gfc_match_char ('/') == MATCH_NO
)
5233 if (gfc_match_char ('/') == MATCH_YES
)
5239 m
= gfc_match_name (name
);
5241 if (m
== MATCH_ERROR
)
5243 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
5246 gfc_error ("Syntax error in common block name at %C");
5251 /* Match a COMMON statement. */
5254 gfc_match_common (void)
5256 gfc_symbol
*sym
, **head
, *tail
, *other
;
5257 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5264 /* COMMON has been matched. In free form source code, the next character
5265 needs to be whitespace or '/'. Check that here. Fixed form source
5266 code needs to be checked below. */
5267 c
= gfc_peek_ascii_char ();
5268 if (gfc_current_form
== FORM_FREE
&& !gfc_is_whitespace (c
) && c
!= '/')
5275 m
= gfc_match_common_name (name
);
5276 if (m
== MATCH_ERROR
)
5279 if (name
[0] == '\0')
5281 t
= &gfc_current_ns
->blank_common
;
5282 if (t
->head
== NULL
)
5283 t
->where
= gfc_current_locus
;
5287 t
= gfc_get_common (name
, 0);
5296 while (tail
->common_next
)
5297 tail
= tail
->common_next
;
5300 /* Grab the list of symbols. */
5303 m
= gfc_match_symbol (&sym
, 0);
5304 if (m
== MATCH_ERROR
)
5309 /* See if we know the current common block is bind(c), and if
5310 so, then see if we can check if the symbol is (which it'll
5311 need to be). This can happen if the bind(c) attr stmt was
5312 applied to the common block, and the variable(s) already
5313 defined, before declaring the common block. */
5314 if (t
->is_bind_c
== 1)
5316 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
5318 /* If we find an error, just print it and continue,
5319 cause it's just semantic, and we can see if there
5321 gfc_error_now ("Variable %qs at %L in common block %qs "
5322 "at %C must be declared with a C "
5323 "interoperable kind since common block "
5325 sym
->name
, &(sym
->declared_at
), t
->name
,
5329 if (sym
->attr
.is_bind_c
== 1)
5330 gfc_error_now ("Variable %qs in common block %qs at %C cannot "
5331 "be bind(c) since it is not global", sym
->name
,
5335 if (sym
->attr
.in_common
)
5337 gfc_error ("Symbol %qs at %C is already in a COMMON block",
5342 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
5343 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
5345 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol %qs at "
5346 "%C can only be COMMON in BLOCK DATA",
5351 /* F2018:R874: common-block-object is variable-name [ (array-spec) ]
5352 F2018:C8121: A variable-name shall not be a name made accessible
5353 by use association. */
5354 if (sym
->attr
.use_assoc
)
5356 gfc_error ("Symbol %qs at %C is USE associated from module %qs "
5357 "and cannot occur in COMMON", sym
->name
, sym
->module
);
5361 /* Deal with an optional array specification after the
5363 m
= gfc_match_array_spec (&as
, true, true);
5364 if (m
== MATCH_ERROR
)
5369 if (as
->type
!= AS_EXPLICIT
)
5371 gfc_error ("Array specification for symbol %qs in COMMON "
5372 "at %C must be explicit", sym
->name
);
5378 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
5379 "coarray", sym
->name
);
5383 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
5386 if (sym
->attr
.pointer
)
5388 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
5389 "POINTER array", sym
->name
);
5398 /* Add the in_common attribute, but ignore the reported errors
5399 if any, and continue matching. */
5400 gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
);
5402 sym
->common_block
= t
;
5403 sym
->common_block
->refs
++;
5406 tail
->common_next
= sym
;
5412 sym
->common_head
= t
;
5414 /* Check to see if the symbol is already in an equivalence group.
5415 If it is, set the other members as being in common. */
5416 if (sym
->attr
.in_equivalence
)
5418 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
5420 for (e2
= e1
; e2
; e2
= e2
->eq
)
5421 if (e2
->expr
->symtree
->n
.sym
== sym
)
5428 for (e2
= e1
; e2
; e2
= e2
->eq
)
5430 other
= e2
->expr
->symtree
->n
.sym
;
5431 if (other
->common_head
5432 && other
->common_head
!= sym
->common_head
)
5434 gfc_error ("Symbol %qs, in COMMON block %qs at "
5435 "%C is being indirectly equivalenced to "
5436 "another COMMON block %qs",
5437 sym
->name
, sym
->common_head
->name
,
5438 other
->common_head
->name
);
5441 other
->attr
.in_common
= 1;
5442 other
->common_head
= t
;
5448 gfc_gobble_whitespace ();
5449 if (gfc_match_eos () == MATCH_YES
)
5451 c
= gfc_peek_ascii_char ();
5456 /* In Fixed form source code, gfortran can end up here for an
5457 expression of the form COMMONI = RHS. This may not be an
5458 error, so return MATCH_NO. */
5459 if (gfc_current_form
== FORM_FIXED
&& c
== '=')
5461 gfc_free_array_spec (as
);
5467 gfc_match_char (',');
5469 gfc_gobble_whitespace ();
5470 if (gfc_peek_ascii_char () == '/')
5479 gfc_syntax_error (ST_COMMON
);
5482 gfc_free_array_spec (as
);
5487 /* Match a BLOCK DATA program unit. */
5490 gfc_match_block_data (void)
5492 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5496 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "BLOCK DATA construct at %L",
5497 &gfc_current_locus
))
5500 if (gfc_match_eos () == MATCH_YES
)
5502 gfc_new_block
= NULL
;
5506 m
= gfc_match ("% %n%t", name
);
5510 if (gfc_get_symbol (name
, NULL
, &sym
))
5513 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
5516 gfc_new_block
= sym
;
5522 /* Free a namelist structure. */
5525 gfc_free_namelist (gfc_namelist
*name
)
5529 for (; name
; name
= n
)
5537 /* Free an OpenMP namelist structure. */
5540 gfc_free_omp_namelist (gfc_omp_namelist
*name
, bool free_ns
,
5541 bool free_align_allocator
,
5542 bool free_mem_traits_space
)
5544 gfc_omp_namelist
*n
;
5545 gfc_expr
*last_allocator
= NULL
;
5547 for (; name
; name
= n
)
5549 gfc_free_expr (name
->expr
);
5550 if (free_align_allocator
)
5551 gfc_free_expr (name
->u
.align
);
5552 else if (free_mem_traits_space
)
5553 { } /* name->u.memspace_sym: shall not call gfc_free_symbol here. */
5555 gfc_free_namespace (name
->u2
.ns
);
5556 else if (free_align_allocator
)
5558 if (last_allocator
!= name
->u2
.allocator
)
5560 last_allocator
= name
->u2
.allocator
;
5561 gfc_free_expr (name
->u2
.allocator
);
5564 else if (free_mem_traits_space
)
5565 { } /* name->u2.traits_sym: shall not call gfc_free_symbol here. */
5566 else if (name
->u2
.udr
)
5568 if (name
->u2
.udr
->combiner
)
5569 gfc_free_statement (name
->u2
.udr
->combiner
);
5570 if (name
->u2
.udr
->initializer
)
5571 gfc_free_statement (name
->u2
.udr
->initializer
);
5572 free (name
->u2
.udr
);
5580 /* Match a NAMELIST statement. */
5583 gfc_match_namelist (void)
5585 gfc_symbol
*group_name
, *sym
;
5589 m
= gfc_match (" / %s /", &group_name
);
5592 if (m
== MATCH_ERROR
)
5597 if (group_name
->ts
.type
!= BT_UNKNOWN
)
5599 gfc_error ("Namelist group name %qs at %C already has a basic "
5600 "type of %s", group_name
->name
,
5601 gfc_typename (&group_name
->ts
));
5605 if (group_name
->attr
.flavor
== FL_NAMELIST
5606 && group_name
->attr
.use_assoc
5607 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name %qs "
5608 "at %C already is USE associated and can"
5609 "not be respecified.", group_name
->name
))
5612 if (group_name
->attr
.flavor
!= FL_NAMELIST
5613 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
5614 group_name
->name
, NULL
))
5619 m
= gfc_match_symbol (&sym
, 1);
5622 if (m
== MATCH_ERROR
)
5625 if (sym
->ts
.type
== BT_UNKNOWN
)
5627 if (gfc_current_ns
->seen_implicit_none
)
5629 /* It is required that members of a namelist be declared
5630 before the namelist. We check this by checking if the
5631 symbol has a defined type for IMPLICIT NONE. */
5632 gfc_error ("Symbol %qs in namelist %qs at %C must be "
5633 "declared before the namelist is declared.",
5634 sym
->name
, group_name
->name
);
5639 /* Before the symbol is given an implicit type, check to
5640 see if the symbol is already available in the namespace,
5641 possibly through host association. Importantly, the
5642 symbol may be a user defined type. */
5646 gfc_find_symbol (sym
->name
, NULL
, 1, &tmp
);
5647 if (tmp
&& tmp
->attr
.generic
5648 && (tmp
= gfc_find_dt_in_generic (tmp
)))
5650 if (tmp
->attr
.flavor
== FL_DERIVED
)
5652 gfc_error ("Derived type %qs at %L conflicts with "
5653 "namelist object %qs at %C",
5654 tmp
->name
, &tmp
->declared_at
, sym
->name
);
5659 /* Set type of the symbol to its implicit default type. It is
5660 not allowed to set it later to any other type. */
5661 gfc_set_default_type (sym
, 0, gfc_current_ns
);
5664 if (sym
->attr
.in_namelist
== 0
5665 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
5668 /* Use gfc_error_check here, rather than goto error, so that
5669 these are the only errors for the next two lines. */
5670 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
5672 gfc_error ("Assumed size array %qs in namelist %qs at "
5673 "%C is not allowed", sym
->name
, group_name
->name
);
5677 nl
= gfc_get_namelist ();
5681 if (group_name
->namelist
== NULL
)
5682 group_name
->namelist
= group_name
->namelist_tail
= nl
;
5685 group_name
->namelist_tail
->next
= nl
;
5686 group_name
->namelist_tail
= nl
;
5689 if (gfc_match_eos () == MATCH_YES
)
5692 m
= gfc_match_char (',');
5694 if (gfc_match_char ('/') == MATCH_YES
)
5696 m2
= gfc_match (" %s /", &group_name
);
5697 if (m2
== MATCH_YES
)
5699 if (m2
== MATCH_ERROR
)
5713 gfc_syntax_error (ST_NAMELIST
);
5720 /* Match a MODULE statement. */
5723 gfc_match_module (void)
5727 m
= gfc_match (" %s%t", &gfc_new_block
);
5731 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
5732 gfc_new_block
->name
, NULL
))
5739 /* Free equivalence sets and lists. Recursively is the easiest way to
5743 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
5748 gfc_free_equiv (eq
->eq
);
5749 gfc_free_equiv_until (eq
->next
, stop
);
5750 gfc_free_expr (eq
->expr
);
5756 gfc_free_equiv (gfc_equiv
*eq
)
5758 gfc_free_equiv_until (eq
, NULL
);
5762 /* Match an EQUIVALENCE statement. */
5765 gfc_match_equivalence (void)
5767 gfc_equiv
*eq
, *set
, *tail
;
5771 gfc_common_head
*common_head
= NULL
;
5776 /* EQUIVALENCE has been matched. After gobbling any possible whitespace,
5777 the next character needs to be '('. Check that here, and return
5778 MATCH_NO for a variable of the form equivalence. */
5779 gfc_gobble_whitespace ();
5780 c
= gfc_peek_ascii_char ();
5788 eq
= gfc_get_equiv ();
5792 eq
->next
= gfc_current_ns
->equiv
;
5793 gfc_current_ns
->equiv
= eq
;
5795 if (gfc_match_char ('(') != MATCH_YES
)
5799 common_flag
= false;
5804 m
= gfc_match_equiv_variable (&set
->expr
);
5805 if (m
== MATCH_ERROR
)
5810 /* count the number of objects. */
5813 if (gfc_match_char ('%') == MATCH_YES
)
5815 gfc_error ("Derived type component %C is not a "
5816 "permitted EQUIVALENCE member");
5820 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
5821 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5823 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
5824 "be an array section");
5828 sym
= set
->expr
->symtree
->n
.sym
;
5830 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
5832 if (sym
->ts
.type
== BT_CLASS
5834 && !gfc_add_in_equivalence (&CLASS_DATA (sym
)->attr
,
5838 if (sym
->attr
.in_common
)
5841 common_head
= sym
->common_head
;
5844 if (gfc_match_char (')') == MATCH_YES
)
5847 if (gfc_match_char (',') != MATCH_YES
)
5850 set
->eq
= gfc_get_equiv ();
5856 gfc_error ("EQUIVALENCE at %C requires two or more objects");
5860 /* If one of the members of an equivalence is in common, then
5861 mark them all as being in common. Before doing this, check
5862 that members of the equivalence group are not in different
5865 for (set
= eq
; set
; set
= set
->eq
)
5867 sym
= set
->expr
->symtree
->n
.sym
;
5868 if (sym
->common_head
&& sym
->common_head
!= common_head
)
5870 gfc_error ("Attempt to indirectly overlap COMMON "
5871 "blocks %s and %s by EQUIVALENCE at %C",
5872 sym
->common_head
->name
, common_head
->name
);
5875 sym
->attr
.in_common
= 1;
5876 sym
->common_head
= common_head
;
5879 if (gfc_match_eos () == MATCH_YES
)
5881 if (gfc_match_char (',') != MATCH_YES
)
5883 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
5888 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "EQUIVALENCE statement at %C"))
5894 gfc_syntax_error (ST_EQUIVALENCE
);
5900 gfc_free_equiv (gfc_current_ns
->equiv
);
5901 gfc_current_ns
->equiv
= eq
;
5907 /* Check that a statement function is not recursive. This is done by looking
5908 for the statement function symbol(sym) by looking recursively through its
5909 expression(e). If a reference to sym is found, true is returned.
5910 12.5.4 requires that any variable of function that is implicitly typed
5911 shall have that type confirmed by any subsequent type declaration. The
5912 implicit typing is conveniently done here. */
5914 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
5917 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
5923 switch (e
->expr_type
)
5926 if (e
->symtree
== NULL
)
5929 /* Check the name before testing for nested recursion! */
5930 if (sym
->name
== e
->symtree
->n
.sym
->name
)
5933 /* Catch recursion via other statement functions. */
5934 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
5935 && e
->symtree
->n
.sym
->value
5936 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
5939 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5940 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5945 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
5948 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5949 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5961 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
5963 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
5967 /* Check for invalid uses of statement function dummy arguments in body. */
5970 chk_stmt_fcn_body (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
5972 gfc_formal_arglist
*formal
;
5974 if (e
== NULL
|| e
->symtree
== NULL
|| e
->expr_type
!= EXPR_FUNCTION
)
5977 for (formal
= sym
->formal
; formal
; formal
= formal
->next
)
5979 if (formal
->sym
== e
->symtree
->n
.sym
)
5981 gfc_error ("Invalid use of statement function argument at %L",
5991 /* Match a statement function declaration. It is so easy to match
5992 non-statement function statements with a MATCH_ERROR as opposed to
5993 MATCH_NO that we suppress error message in most cases. */
5996 gfc_match_st_function (void)
5998 gfc_error_buffer old_error
;
6002 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6005 gfc_formal_arglist
*ptr
;
6007 /* Read the possible statement function name, and then check to see if
6008 a symbol is already present in the namespace. Record if it is a
6009 function and whether it has been referenced. */
6012 old_locus
= gfc_current_locus
;
6013 m
= gfc_match_name (name
);
6016 gfc_find_symbol (name
, NULL
, 1, &sym
);
6017 if (sym
&& sym
->attr
.function
&& !sym
->attr
.referenced
)
6024 gfc_current_locus
= old_locus
;
6025 m
= gfc_match_symbol (&sym
, 0);
6029 gfc_push_error (&old_error
);
6031 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
6034 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
6037 m
= gfc_match (" = %e%t", &expr
);
6041 gfc_free_error (&old_error
);
6043 if (m
== MATCH_ERROR
)
6046 if (recursive_stmt_fcn (expr
, sym
))
6048 gfc_error ("Statement function at %L is recursive", &expr
->where
);
6052 if (fcn
&& ptr
!= sym
->formal
)
6054 gfc_error ("Statement function %qs at %L conflicts with function name",
6055 sym
->name
, &expr
->where
);
6059 if (gfc_traverse_expr (expr
, sym
, chk_stmt_fcn_body
, 0))
6064 if ((gfc_current_state () == COMP_FUNCTION
6065 || gfc_current_state () == COMP_SUBROUTINE
)
6066 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
6068 gfc_error ("Statement function at %L cannot appear within an INTERFACE",
6073 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
6079 gfc_pop_error (&old_error
);
6084 /* Match an assignment to a pointer function (F2008). This could, in
6085 general be ambiguous with a statement function. In this implementation
6086 it remains so if it is the first statement after the specification
6090 gfc_match_ptr_fcn_assign (void)
6092 gfc_error_buffer old_error
;
6097 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6099 old_loc
= gfc_current_locus
;
6100 m
= gfc_match_name (name
);
6104 gfc_find_symbol (name
, NULL
, 1, &sym
);
6105 if (sym
&& sym
->attr
.flavor
!= FL_PROCEDURE
)
6108 gfc_push_error (&old_error
);
6110 if (sym
&& sym
->attr
.function
)
6111 goto match_actual_arglist
;
6113 gfc_current_locus
= old_loc
;
6114 m
= gfc_match_symbol (&sym
, 0);
6118 if (!gfc_add_procedure (&sym
->attr
, PROC_UNKNOWN
, sym
->name
, NULL
))
6121 match_actual_arglist
:
6122 gfc_current_locus
= old_loc
;
6123 m
= gfc_match (" %e", &expr
);
6127 new_st
.op
= EXEC_ASSIGN
;
6128 new_st
.expr1
= expr
;
6131 m
= gfc_match (" = %e%t", &expr
);
6135 new_st
.expr2
= expr
;
6139 gfc_pop_error (&old_error
);
6144 /***************** SELECT CASE subroutines ******************/
6146 /* Free a single case structure. */
6149 free_case (gfc_case
*p
)
6151 if (p
->low
== p
->high
)
6153 gfc_free_expr (p
->low
);
6154 gfc_free_expr (p
->high
);
6159 /* Free a list of case structures. */
6162 gfc_free_case_list (gfc_case
*p
)
6174 /* Match a single case selector. Combining the requirements of F08:C830
6175 and F08:C832 (R838) means that the case-value must have either CHARACTER,
6176 INTEGER, or LOGICAL type. */
6179 match_case_selector (gfc_case
**cp
)
6184 c
= gfc_get_case ();
6185 c
->where
= gfc_current_locus
;
6187 if (gfc_match_char (':') == MATCH_YES
)
6189 m
= gfc_match_init_expr (&c
->high
);
6192 if (m
== MATCH_ERROR
)
6195 if (c
->high
->ts
.type
!= BT_LOGICAL
&& c
->high
->ts
.type
!= BT_INTEGER
6196 && c
->high
->ts
.type
!= BT_CHARACTER
)
6198 gfc_error ("Expression in CASE selector at %L cannot be %s",
6199 &c
->high
->where
, gfc_typename (&c
->high
->ts
));
6205 m
= gfc_match_init_expr (&c
->low
);
6206 if (m
== MATCH_ERROR
)
6211 if (c
->low
->ts
.type
!= BT_LOGICAL
&& c
->low
->ts
.type
!= BT_INTEGER
6212 && c
->low
->ts
.type
!= BT_CHARACTER
)
6214 gfc_error ("Expression in CASE selector at %L cannot be %s",
6215 &c
->low
->where
, gfc_typename (&c
->low
->ts
));
6219 /* If we're not looking at a ':' now, make a range out of a single
6220 target. Else get the upper bound for the case range. */
6221 if (gfc_match_char (':') != MATCH_YES
)
6225 m
= gfc_match_init_expr (&c
->high
);
6226 if (m
== MATCH_ERROR
)
6229 && c
->high
->ts
.type
!= BT_LOGICAL
6230 && c
->high
->ts
.type
!= BT_INTEGER
6231 && c
->high
->ts
.type
!= BT_CHARACTER
)
6233 gfc_error ("Expression in CASE selector at %L cannot be %s",
6234 &c
->high
->where
, gfc_typename (c
->high
));
6237 /* MATCH_NO is fine. It's OK if nothing is there! */
6241 if (c
->low
&& c
->low
->rank
!= 0)
6243 gfc_error ("Expression in CASE selector at %L must be scalar",
6247 if (c
->high
&& c
->high
->rank
!= 0)
6249 gfc_error ("Expression in CASE selector at %L must be scalar",
6258 gfc_error ("Expected initialization expression in CASE at %C");
6266 /* Match the end of a case statement. */
6269 match_case_eos (void)
6271 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6274 if (gfc_match_eos () == MATCH_YES
)
6277 /* If the case construct doesn't have a case-construct-name, we
6278 should have matched the EOS. */
6279 if (!gfc_current_block ())
6282 gfc_gobble_whitespace ();
6284 m
= gfc_match_name (name
);
6288 if (strcmp (name
, gfc_current_block ()->name
) != 0)
6290 gfc_error ("Expected block name %qs of SELECT construct at %C",
6291 gfc_current_block ()->name
);
6295 return gfc_match_eos ();
6299 /* Match a SELECT statement. */
6302 gfc_match_select (void)
6307 m
= gfc_match_label ();
6308 if (m
== MATCH_ERROR
)
6311 m
= gfc_match (" select case ( %e )%t", &expr
);
6315 new_st
.op
= EXEC_SELECT
;
6316 new_st
.expr1
= expr
;
6322 /* Transfer the selector typespec to the associate name. */
6325 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
,
6326 bool select_type
= false)
6329 gfc_symbol
*assoc_sym
;
6332 assoc_sym
= associate
->symtree
->n
.sym
;
6334 /* At this stage the expression rank and arrayspec dimensions have
6335 not been completely sorted out. We must get the expr2->rank
6336 right here, so that the correct class container is obtained. */
6337 ref
= selector
->ref
;
6338 while (ref
&& ref
->next
)
6341 if (selector
->ts
.type
== BT_CLASS
6342 && CLASS_DATA (selector
)
6343 && CLASS_DATA (selector
)->as
6344 && CLASS_DATA (selector
)->as
->type
== AS_ASSUMED_RANK
)
6346 assoc_sym
->attr
.dimension
= 1;
6347 assoc_sym
->as
= gfc_copy_array_spec (CLASS_DATA (selector
)->as
);
6348 goto build_class_sym
;
6350 else if (selector
->ts
.type
== BT_CLASS
6351 && CLASS_DATA (selector
)
6352 && CLASS_DATA (selector
)->as
6353 && ((ref
&& ref
->type
== REF_ARRAY
)
6354 || selector
->expr_type
== EXPR_OP
))
6356 /* Ensure that the array reference type is set. We cannot use
6357 gfc_resolve_expr at this point, so the usable parts of
6358 resolve.cc(resolve_array_ref) are employed to do it. */
6359 if (ref
&& ref
->u
.ar
.type
== AR_UNKNOWN
)
6361 ref
->u
.ar
.type
= AR_ELEMENT
;
6362 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
6363 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
6364 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
6365 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
6366 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
6368 ref
->u
.ar
.type
= AR_SECTION
;
6373 if (!ref
|| ref
->u
.ar
.type
== AR_FULL
)
6374 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
6375 else if (ref
->u
.ar
.type
== AR_SECTION
)
6376 selector
->rank
= ref
->u
.ar
.dimen
;
6380 rank
= selector
->rank
;
6387 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
6388 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
6389 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
6390 && ref
->u
.ar
.end
[i
] == NULL
6391 && ref
->u
.ar
.stride
[i
] == NULL
))
6397 assoc_sym
->attr
.dimension
= 1;
6398 assoc_sym
->as
= gfc_get_array_spec ();
6399 assoc_sym
->as
->rank
= rank
;
6400 assoc_sym
->as
->type
= AS_DEFERRED
;
6403 assoc_sym
->as
= NULL
;
6406 assoc_sym
->as
= NULL
;
6409 /* Deal with the very specific case of a SELECT_TYPE selector being an
6410 associate_name whose type has been identified by component references.
6411 It must be assumed that it will be identified as a CLASS expression,
6412 so convert it now. */
6414 && IS_INFERRED_TYPE (selector
)
6415 && selector
->ts
.type
== BT_DERIVED
)
6417 gfc_find_derived_vtab (selector
->ts
.u
.derived
);
6418 /* The correct class container has to be available. */
6419 assoc_sym
->ts
.u
.derived
= selector
->ts
.u
.derived
;
6420 assoc_sym
->ts
.type
= BT_CLASS
;
6421 assoc_sym
->attr
.pointer
= 1;
6422 if (!selector
->ts
.u
.derived
->attr
.is_class
)
6423 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
6424 associate
->ts
= assoc_sym
->ts
;
6426 else if (selector
->ts
.type
== BT_CLASS
)
6428 /* The correct class container has to be available. */
6429 assoc_sym
->ts
.type
= BT_CLASS
;
6430 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)
6431 ? CLASS_DATA (selector
)->ts
.u
.derived
6432 : selector
->ts
.u
.derived
;
6433 assoc_sym
->attr
.pointer
= 1;
6434 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
6439 /* Build the associate name */
6441 build_associate_name (const char *name
, gfc_expr
**e1
, gfc_expr
**e2
)
6443 gfc_expr
*expr1
= *e1
;
6444 gfc_expr
*expr2
= *e2
;
6447 /* For the case where the associate name is already an associate name. */
6450 expr1
= gfc_get_expr ();
6451 expr1
->expr_type
= EXPR_VARIABLE
;
6452 expr1
->where
= expr2
->where
;
6453 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
6456 sym
= expr1
->symtree
->n
.sym
;
6457 if (expr2
->ts
.type
== BT_UNKNOWN
)
6458 sym
->attr
.untyped
= 1;
6460 copy_ts_from_selector_to_associate (expr1
, expr2
, true);
6462 sym
->attr
.flavor
= FL_VARIABLE
;
6463 sym
->attr
.referenced
= 1;
6464 sym
->attr
.class_ok
= 1;
6472 /* Push the current selector onto the SELECT TYPE stack. */
6475 select_type_push (gfc_symbol
*sel
)
6477 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
6478 top
->selector
= sel
;
6480 top
->prev
= select_type_stack
;
6482 select_type_stack
= top
;
6486 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
6488 static gfc_symtree
*
6489 select_intrinsic_set_tmp (gfc_typespec
*ts
)
6491 char name
[GFC_MAX_SYMBOL_LEN
];
6493 HOST_WIDE_INT charlen
= 0;
6494 gfc_symbol
*selector
= select_type_stack
->selector
;
6497 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
6500 if (selector
->ts
.type
== BT_CLASS
&& !selector
->attr
.class_ok
)
6503 /* Case value == NULL corresponds to SELECT TYPE cases otherwise
6504 the values correspond to SELECT rank cases. */
6505 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
6506 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6507 charlen
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
6509 if (ts
->type
!= BT_CHARACTER
)
6510 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
6513 snprintf (name
, sizeof (name
),
6514 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
6515 gfc_basic_typename (ts
->type
), charlen
, ts
->kind
);
6517 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6519 gfc_add_type (sym
, ts
, NULL
);
6521 /* Copy across the array spec to the selector. */
6522 if (selector
->ts
.type
== BT_CLASS
6523 && (CLASS_DATA (selector
)->attr
.dimension
6524 || CLASS_DATA (selector
)->attr
.codimension
))
6526 sym
->attr
.pointer
= 1;
6527 sym
->attr
.dimension
= CLASS_DATA (selector
)->attr
.dimension
;
6528 sym
->attr
.codimension
= CLASS_DATA (selector
)->attr
.codimension
;
6529 sym
->as
= gfc_copy_array_spec (CLASS_DATA (selector
)->as
);
6532 gfc_set_sym_referenced (sym
);
6533 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, name
, NULL
);
6534 sym
->attr
.select_type_temporary
= 1;
6540 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
6543 select_type_set_tmp (gfc_typespec
*ts
)
6545 char name
[GFC_MAX_SYMBOL_LEN
+ 12 + 1];
6546 gfc_symtree
*tmp
= NULL
;
6547 gfc_symbol
*selector
= select_type_stack
->selector
;
6553 select_type_stack
->tmp
= NULL
;
6557 tmp
= select_intrinsic_set_tmp (ts
);
6564 if (ts
->type
== BT_CLASS
)
6565 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
6567 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
6569 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6571 gfc_add_type (sym
, ts
, NULL
);
6573 /* If the SELECT TYPE selector is a function we might be able to obtain
6574 a typespec from the result. Since the function might not have been
6575 parsed yet we have to check that there is indeed a result symbol. */
6576 if (selector
->ts
.type
== BT_UNKNOWN
6577 && gfc_state_stack
->construct
6579 && (expr2
= gfc_state_stack
->construct
->expr2
)
6580 && expr2
->expr_type
== EXPR_FUNCTION
6582 && expr2
->symtree
->n
.sym
&& expr2
->symtree
->n
.sym
->result
)
6583 selector
->ts
= expr2
->symtree
->n
.sym
->result
->ts
;
6585 if (selector
->ts
.type
== BT_CLASS
6586 && selector
->attr
.class_ok
6587 && selector
->ts
.u
.derived
&& CLASS_DATA (selector
))
6590 = CLASS_DATA (selector
)->attr
.class_pointer
;
6592 /* Copy across the array spec to the selector. */
6593 if (CLASS_DATA (selector
)->attr
.dimension
6594 || CLASS_DATA (selector
)->attr
.codimension
)
6597 = CLASS_DATA (selector
)->attr
.dimension
;
6598 sym
->attr
.codimension
6599 = CLASS_DATA (selector
)->attr
.codimension
;
6600 if (CLASS_DATA (selector
)->as
->type
!= AS_EXPLICIT
)
6601 sym
->as
= gfc_copy_array_spec (CLASS_DATA (selector
)->as
);
6604 sym
->as
= gfc_get_array_spec();
6605 sym
->as
->rank
= CLASS_DATA (selector
)->as
->rank
;
6606 sym
->as
->type
= AS_DEFERRED
;
6611 gfc_set_sym_referenced (sym
);
6612 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, name
, NULL
);
6613 sym
->attr
.select_type_temporary
= 1;
6615 if (ts
->type
== BT_CLASS
)
6616 gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
6622 /* Add an association for it, so the rest of the parser knows it is
6623 an associate-name. The target will be set during resolution. */
6624 sym
->assoc
= gfc_get_association_list ();
6625 sym
->assoc
->dangling
= 1;
6626 sym
->assoc
->st
= tmp
;
6628 select_type_stack
->tmp
= tmp
;
6632 /* Match a SELECT TYPE statement. */
6635 gfc_match_select_type (void)
6637 gfc_expr
*expr1
, *expr2
= NULL
;
6639 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6641 gfc_namespace
*ns
= gfc_current_ns
;
6643 m
= gfc_match_label ();
6644 if (m
== MATCH_ERROR
)
6647 m
= gfc_match (" select type ( ");
6651 if (gfc_current_state() == COMP_MODULE
6652 || gfc_current_state() == COMP_SUBMODULE
)
6654 gfc_error ("SELECT TYPE at %C cannot appear in this scope");
6658 gfc_current_ns
= gfc_build_block_ns (ns
);
6659 m
= gfc_match (" %n => %e", name
, &expr2
);
6662 if (build_associate_name (name
, &expr1
, &expr2
))
6670 m
= gfc_match (" %e ", &expr1
);
6673 std::swap (ns
, gfc_current_ns
);
6674 gfc_free_namespace (ns
);
6679 m
= gfc_match (" )%t");
6682 gfc_error ("parse error in SELECT TYPE statement at %C");
6686 /* This ghastly expression seems to be needed to distinguish a CLASS
6687 array, which can have a reference, from other expressions that
6688 have references, such as derived type components, and are not
6689 allowed by the standard.
6690 TODO: see if it is sufficient to exclude component and substring
6692 class_array
= (expr1
->expr_type
== EXPR_VARIABLE
6693 && expr1
->ts
.type
== BT_CLASS
6694 && CLASS_DATA (expr1
)
6695 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
6696 && (CLASS_DATA (expr1
)->attr
.dimension
6697 || CLASS_DATA (expr1
)->attr
.codimension
)
6699 && expr1
->ref
->type
== REF_ARRAY
6700 && expr1
->ref
->u
.ar
.type
== AR_FULL
6701 && expr1
->ref
->next
== NULL
);
6703 /* Check for F03:C811 (F08:C835). */
6704 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
6705 || (!class_array
&& expr1
->ref
!= NULL
)))
6707 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
6708 "use associate-name=>");
6713 /* Prevent an existing associate name from reuse here by pushing expr1 to
6714 expr2 and building a new associate name. */
6715 if (!expr2
&& expr1
->symtree
->n
.sym
->assoc
6716 && !expr1
->symtree
->n
.sym
->attr
.select_type_temporary
6717 && !expr1
->symtree
->n
.sym
->attr
.select_rank_temporary
6718 && build_associate_name (expr1
->symtree
->n
.sym
->name
, &expr1
, &expr2
))
6724 new_st
.op
= EXEC_SELECT_TYPE
;
6725 new_st
.expr1
= expr1
;
6726 new_st
.expr2
= expr2
;
6727 new_st
.ext
.block
.ns
= gfc_current_ns
;
6729 select_type_push (expr1
->symtree
->n
.sym
);
6730 gfc_current_ns
= ns
;
6735 gfc_free_expr (expr1
);
6736 gfc_free_expr (expr2
);
6737 gfc_undo_symbols ();
6738 std::swap (ns
, gfc_current_ns
);
6739 gfc_free_namespace (ns
);
6744 /* Set the temporary for the current intrinsic SELECT RANK selector. */
6747 select_rank_set_tmp (gfc_typespec
*ts
, int *case_value
)
6749 char name
[2 * GFC_MAX_SYMBOL_LEN
];
6750 char tname
[GFC_MAX_SYMBOL_LEN
+ 7];
6752 gfc_symbol
*selector
= select_type_stack
->selector
;
6755 HOST_WIDE_INT charlen
= 0;
6757 if (case_value
== NULL
)
6760 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
6761 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6762 charlen
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
6764 if (ts
->type
== BT_CLASS
)
6765 sprintf (tname
, "class_%s", ts
->u
.derived
->name
);
6766 else if (ts
->type
== BT_DERIVED
)
6767 sprintf (tname
, "type_%s", ts
->u
.derived
->name
);
6768 else if (ts
->type
!= BT_CHARACTER
)
6769 sprintf (tname
, "%s_%d", gfc_basic_typename (ts
->type
), ts
->kind
);
6771 sprintf (tname
, "%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
6772 gfc_basic_typename (ts
->type
), charlen
, ts
->kind
);
6774 /* Case value == NULL corresponds to SELECT TYPE cases otherwise
6775 the values correspond to SELECT rank cases. */
6776 if (*case_value
>=0)
6777 sprintf (name
, "__tmp_%s_rank_%d", tname
, *case_value
);
6779 sprintf (name
, "__tmp_%s_rank_m%d", tname
, -*case_value
);
6781 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
6785 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6787 gfc_add_type (sym
, ts
, NULL
);
6789 /* Copy across the array spec to the selector. */
6790 if (selector
->ts
.type
== BT_CLASS
)
6792 sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
6793 sym
->attr
.pointer
= CLASS_DATA (selector
)->attr
.pointer
;
6794 sym
->attr
.allocatable
= CLASS_DATA (selector
)->attr
.allocatable
;
6795 sym
->attr
.target
= CLASS_DATA (selector
)->attr
.target
;
6796 sym
->attr
.class_ok
= 0;
6797 if (case_value
&& *case_value
!= 0)
6799 sym
->attr
.dimension
= 1;
6800 sym
->as
= gfc_copy_array_spec (CLASS_DATA (selector
)->as
);
6801 if (*case_value
> 0)
6803 sym
->as
->type
= AS_DEFERRED
;
6804 sym
->as
->rank
= *case_value
;
6806 else if (*case_value
== -1)
6808 sym
->as
->type
= AS_ASSUMED_SIZE
;
6815 sym
->attr
.pointer
= selector
->attr
.pointer
;
6816 sym
->attr
.allocatable
= selector
->attr
.allocatable
;
6817 sym
->attr
.target
= selector
->attr
.target
;
6818 if (case_value
&& *case_value
!= 0)
6820 sym
->attr
.dimension
= 1;
6821 sym
->as
= gfc_copy_array_spec (selector
->as
);
6822 if (*case_value
> 0)
6824 sym
->as
->type
= AS_DEFERRED
;
6825 sym
->as
->rank
= *case_value
;
6827 else if (*case_value
== -1)
6829 sym
->as
->type
= AS_ASSUMED_SIZE
;
6835 gfc_set_sym_referenced (sym
);
6836 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, name
, NULL
);
6837 sym
->attr
.select_type_temporary
= 1;
6839 sym
->attr
.select_rank_temporary
= 1;
6841 if (ts
->type
== BT_CLASS
)
6842 gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
6844 /* Add an association for it, so the rest of the parser knows it is
6845 an associate-name. The target will be set during resolution. */
6846 sym
->assoc
= gfc_get_association_list ();
6847 sym
->assoc
->dangling
= 1;
6848 sym
->assoc
->st
= tmp
;
6850 select_type_stack
->tmp
= tmp
;
6854 /* Match a SELECT RANK statement. */
6857 gfc_match_select_rank (void)
6859 gfc_expr
*expr1
, *expr2
= NULL
;
6861 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6862 gfc_symbol
*sym
, *sym2
;
6863 gfc_namespace
*ns
= gfc_current_ns
;
6864 gfc_array_spec
*as
= NULL
;
6866 m
= gfc_match_label ();
6867 if (m
== MATCH_ERROR
)
6870 m
= gfc_match (" select% rank ( ");
6874 if (!gfc_notify_std (GFC_STD_F2018
, "SELECT RANK statement at %C"))
6877 gfc_current_ns
= gfc_build_block_ns (ns
);
6878 m
= gfc_match (" %n => %e", name
, &expr2
);
6882 /* If expr2 corresponds to an implicitly typed variable, then the
6883 actual type of the variable may not have been set. Set it here. */
6884 if (!gfc_current_ns
->seen_implicit_none
6885 && expr2
->expr_type
== EXPR_VARIABLE
6886 && expr2
->ts
.type
== BT_UNKNOWN
6887 && expr2
->symtree
&& expr2
->symtree
->n
.sym
)
6889 gfc_set_default_type (expr2
->symtree
->n
.sym
, 0, gfc_current_ns
);
6890 expr2
->ts
.type
= expr2
->symtree
->n
.sym
->ts
.type
;
6893 expr1
= gfc_get_expr ();
6894 expr1
->expr_type
= EXPR_VARIABLE
;
6895 expr1
->where
= expr2
->where
;
6896 expr1
->ref
= gfc_copy_ref (expr2
->ref
);
6897 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
6903 sym
= expr1
->symtree
->n
.sym
;
6907 sym2
= expr2
->symtree
->n
.sym
;
6908 as
= (sym2
->ts
.type
== BT_CLASS
6909 && CLASS_DATA (sym2
)) ? CLASS_DATA (sym2
)->as
: sym2
->as
;
6912 if (expr2
->expr_type
!= EXPR_VARIABLE
6913 || !(as
&& as
->type
== AS_ASSUMED_RANK
))
6915 gfc_error ("The SELECT RANK selector at %C must be an assumed "
6921 if (expr2
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym2
))
6923 copy_ts_from_selector_to_associate (expr1
, expr2
);
6925 sym
->attr
.flavor
= FL_VARIABLE
;
6926 sym
->attr
.referenced
= 1;
6927 sym
->attr
.class_ok
= 1;
6928 CLASS_DATA (sym
)->attr
.allocatable
= CLASS_DATA (sym2
)->attr
.allocatable
;
6929 CLASS_DATA (sym
)->attr
.pointer
= CLASS_DATA (sym2
)->attr
.pointer
;
6930 CLASS_DATA (sym
)->attr
.target
= CLASS_DATA (sym2
)->attr
.target
;
6931 sym
->attr
.pointer
= 1;
6936 sym
->as
= gfc_copy_array_spec (sym2
->as
);
6937 sym
->attr
.dimension
= 1;
6939 sym
->attr
.flavor
= FL_VARIABLE
;
6940 sym
->attr
.referenced
= 1;
6941 sym
->attr
.class_ok
= sym2
->attr
.class_ok
;
6942 sym
->attr
.allocatable
= sym2
->attr
.allocatable
;
6943 sym
->attr
.pointer
= sym2
->attr
.pointer
;
6944 sym
->attr
.target
= sym2
->attr
.target
;
6949 m
= gfc_match (" %e ", &expr1
);
6953 gfc_undo_symbols ();
6954 std::swap (ns
, gfc_current_ns
);
6955 gfc_free_namespace (ns
);
6961 sym
= expr1
->symtree
->n
.sym
;
6962 as
= (sym
->ts
.type
== BT_CLASS
6963 && CLASS_DATA (sym
)) ? CLASS_DATA (sym
)->as
: sym
->as
;
6966 if (expr1
->expr_type
!= EXPR_VARIABLE
6967 || !(as
&& as
->type
== AS_ASSUMED_RANK
))
6969 gfc_error("The SELECT RANK selector at %C must be an assumed "
6976 m
= gfc_match (" )%t");
6979 gfc_error ("parse error in SELECT RANK statement at %C");
6983 new_st
.op
= EXEC_SELECT_RANK
;
6984 new_st
.expr1
= expr1
;
6985 new_st
.expr2
= expr2
;
6986 new_st
.ext
.block
.ns
= gfc_current_ns
;
6988 select_type_push (expr1
->symtree
->n
.sym
);
6989 gfc_current_ns
= ns
;
6994 gfc_free_expr (expr1
);
6995 gfc_free_expr (expr2
);
6996 gfc_undo_symbols ();
6997 std::swap (ns
, gfc_current_ns
);
6998 gfc_free_namespace (ns
);
7003 /* Match a CASE statement. */
7006 gfc_match_case (void)
7008 gfc_case
*c
, *head
, *tail
;
7013 if (gfc_current_state () != COMP_SELECT
)
7015 gfc_error ("Unexpected CASE statement at %C");
7019 if (gfc_match ("% default") == MATCH_YES
)
7021 m
= match_case_eos ();
7024 if (m
== MATCH_ERROR
)
7027 new_st
.op
= EXEC_SELECT
;
7028 c
= gfc_get_case ();
7029 c
->where
= gfc_current_locus
;
7030 new_st
.ext
.block
.case_list
= c
;
7034 if (gfc_match_char ('(') != MATCH_YES
)
7039 if (match_case_selector (&c
) == MATCH_ERROR
)
7049 if (gfc_match_char (')') == MATCH_YES
)
7051 if (gfc_match_char (',') != MATCH_YES
)
7055 m
= match_case_eos ();
7058 if (m
== MATCH_ERROR
)
7061 new_st
.op
= EXEC_SELECT
;
7062 new_st
.ext
.block
.case_list
= head
;
7067 gfc_error ("Syntax error in CASE specification at %C");
7070 gfc_free_case_list (head
); /* new_st is cleaned up in parse.cc. */
7075 /* Match a TYPE IS statement. */
7078 gfc_match_type_is (void)
7083 if (gfc_current_state () != COMP_SELECT_TYPE
)
7085 gfc_error ("Unexpected TYPE IS statement at %C");
7089 if (gfc_match_char ('(') != MATCH_YES
)
7092 c
= gfc_get_case ();
7093 c
->where
= gfc_current_locus
;
7095 m
= gfc_match_type_spec (&c
->ts
);
7098 if (m
== MATCH_ERROR
)
7101 if (gfc_match_char (')') != MATCH_YES
)
7104 m
= match_case_eos ();
7107 if (m
== MATCH_ERROR
)
7110 new_st
.op
= EXEC_SELECT_TYPE
;
7111 new_st
.ext
.block
.case_list
= c
;
7113 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
7114 && (c
->ts
.u
.derived
->attr
.sequence
7115 || c
->ts
.u
.derived
->attr
.is_bind_c
))
7117 gfc_error ("The type-spec shall not specify a sequence derived "
7118 "type or a type with the BIND attribute in SELECT "
7119 "TYPE at %C [F2003:C815]");
7123 if (c
->ts
.type
== BT_DERIVED
7124 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
7125 && gfc_spec_list_type (type_param_spec_list
, c
->ts
.u
.derived
)
7128 gfc_error ("All the LEN type parameters in the TYPE IS statement "
7129 "at %C must be ASSUMED");
7133 /* Create temporary variable. */
7134 select_type_set_tmp (&c
->ts
);
7139 gfc_error ("Syntax error in TYPE IS specification at %C");
7143 gfc_free_case_list (c
); /* new_st is cleaned up in parse.cc. */
7148 /* Match a CLASS IS or CLASS DEFAULT statement. */
7151 gfc_match_class_is (void)
7156 if (gfc_current_state () != COMP_SELECT_TYPE
)
7159 if (gfc_match ("% default") == MATCH_YES
)
7161 m
= match_case_eos ();
7164 if (m
== MATCH_ERROR
)
7167 new_st
.op
= EXEC_SELECT_TYPE
;
7168 c
= gfc_get_case ();
7169 c
->where
= gfc_current_locus
;
7170 c
->ts
.type
= BT_UNKNOWN
;
7171 new_st
.ext
.block
.case_list
= c
;
7172 select_type_set_tmp (NULL
);
7176 m
= gfc_match ("% is");
7179 if (m
== MATCH_ERROR
)
7182 if (gfc_match_char ('(') != MATCH_YES
)
7185 c
= gfc_get_case ();
7186 c
->where
= gfc_current_locus
;
7188 m
= match_derived_type_spec (&c
->ts
);
7191 if (m
== MATCH_ERROR
)
7194 if (c
->ts
.type
== BT_DERIVED
)
7195 c
->ts
.type
= BT_CLASS
;
7197 if (gfc_match_char (')') != MATCH_YES
)
7200 m
= match_case_eos ();
7203 if (m
== MATCH_ERROR
)
7206 new_st
.op
= EXEC_SELECT_TYPE
;
7207 new_st
.ext
.block
.case_list
= c
;
7209 /* Create temporary variable. */
7210 select_type_set_tmp (&c
->ts
);
7215 gfc_error ("Syntax error in CLASS IS specification at %C");
7219 gfc_free_case_list (c
); /* new_st is cleaned up in parse.cc. */
7224 /* Match a RANK statement. */
7227 gfc_match_rank_is (void)
7233 if (gfc_current_state () != COMP_SELECT_RANK
)
7235 gfc_error ("Unexpected RANK statement at %C");
7239 if (gfc_match ("% default") == MATCH_YES
)
7241 m
= match_case_eos ();
7244 if (m
== MATCH_ERROR
)
7247 new_st
.op
= EXEC_SELECT_RANK
;
7248 c
= gfc_get_case ();
7249 c
->ts
.type
= BT_UNKNOWN
;
7250 c
->where
= gfc_current_locus
;
7251 new_st
.ext
.block
.case_list
= c
;
7252 select_type_stack
->tmp
= NULL
;
7256 if (gfc_match_char ('(') != MATCH_YES
)
7259 c
= gfc_get_case ();
7260 c
->where
= gfc_current_locus
;
7261 c
->ts
= select_type_stack
->selector
->ts
;
7263 m
= gfc_match_expr (&c
->low
);
7266 if (gfc_match_char ('*') == MATCH_YES
)
7267 c
->low
= gfc_get_int_expr (gfc_default_integer_kind
,
7274 else if (m
== MATCH_YES
)
7277 if (c
->low
->expr_type
!= EXPR_CONSTANT
7278 || c
->low
->ts
.type
!= BT_INTEGER
7281 gfc_error ("The SELECT RANK CASE expression at %C must be a "
7282 "scalar, integer constant");
7286 case_value
= (int) mpz_get_si (c
->low
->value
.integer
);
7288 if ((case_value
< 0) || (case_value
> GFC_MAX_DIMENSIONS
))
7290 gfc_error ("The value of the SELECT RANK CASE expression at "
7291 "%C must not be less than zero or greater than %d",
7292 GFC_MAX_DIMENSIONS
);
7299 if (gfc_match_char (')') != MATCH_YES
)
7302 m
= match_case_eos ();
7305 if (m
== MATCH_ERROR
)
7308 new_st
.op
= EXEC_SELECT_RANK
;
7309 new_st
.ext
.block
.case_list
= c
;
7311 /* Create temporary variable. Recycle the select type code. */
7312 select_rank_set_tmp (&c
->ts
, &case_value
);
7317 gfc_error ("Syntax error in RANK specification at %C");
7321 gfc_free_case_list (c
); /* new_st is cleaned up in parse.cc. */
7325 /********************* WHERE subroutines ********************/
7327 /* Match the rest of a simple WHERE statement that follows an IF statement.
7331 match_simple_where (void)
7337 m
= gfc_match (" ( %e )", &expr
);
7341 m
= gfc_match_assignment ();
7344 if (m
== MATCH_ERROR
)
7347 if (gfc_match_eos () != MATCH_YES
)
7350 c
= gfc_get_code (EXEC_WHERE
);
7353 c
->next
= XCNEW (gfc_code
);
7355 c
->next
->loc
= gfc_current_locus
;
7356 gfc_clear_new_st ();
7358 new_st
.op
= EXEC_WHERE
;
7364 gfc_syntax_error (ST_WHERE
);
7367 gfc_free_expr (expr
);
7372 /* Match a WHERE statement. */
7375 gfc_match_where (gfc_statement
*st
)
7381 m0
= gfc_match_label ();
7382 if (m0
== MATCH_ERROR
)
7385 m
= gfc_match (" where ( %e )", &expr
);
7389 if (gfc_match_eos () == MATCH_YES
)
7391 *st
= ST_WHERE_BLOCK
;
7392 new_st
.op
= EXEC_WHERE
;
7393 new_st
.expr1
= expr
;
7397 m
= gfc_match_assignment ();
7399 gfc_syntax_error (ST_WHERE
);
7403 gfc_free_expr (expr
);
7407 /* We've got a simple WHERE statement. */
7409 c
= gfc_get_code (EXEC_WHERE
);
7412 /* Put in the assignment. It will not be processed by add_statement, so we
7413 need to copy the location here. */
7415 c
->next
= XCNEW (gfc_code
);
7417 c
->next
->loc
= gfc_current_locus
;
7418 gfc_clear_new_st ();
7420 new_st
.op
= EXEC_WHERE
;
7427 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
7428 new_st if successful. */
7431 gfc_match_elsewhere (void)
7433 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7437 if (gfc_current_state () != COMP_WHERE
)
7439 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
7445 if (gfc_match_char ('(') == MATCH_YES
)
7447 m
= gfc_match_expr (&expr
);
7450 if (m
== MATCH_ERROR
)
7453 if (gfc_match_char (')') != MATCH_YES
)
7457 if (gfc_match_eos () != MATCH_YES
)
7459 /* Only makes sense if we have a where-construct-name. */
7460 if (!gfc_current_block ())
7465 /* Better be a name at this point. */
7466 m
= gfc_match_name (name
);
7469 if (m
== MATCH_ERROR
)
7472 if (gfc_match_eos () != MATCH_YES
)
7475 if (strcmp (name
, gfc_current_block ()->name
) != 0)
7477 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
7478 name
, gfc_current_block ()->name
);
7483 new_st
.op
= EXEC_WHERE
;
7484 new_st
.expr1
= expr
;
7488 gfc_syntax_error (ST_ELSEWHERE
);
7491 gfc_free_expr (expr
);