1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000-2020 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
29 int gfc_matching_ptr_assignment
= 0;
30 int gfc_matching_procptr_assignment
= 0;
31 bool gfc_matching_prefix
= false;
33 /* Stack of SELECT TYPE statements. */
34 gfc_select_type_stack
*select_type_stack
= NULL
;
36 /* List of type parameter expressions. */
37 gfc_actual_arglist
*type_param_spec_list
;
39 /* For debugging and diagnostic purposes. Return the textual representation
40 of the intrinsic operator OP. */
42 gfc_op2string (gfc_intrinsic_op op
)
50 case INTRINSIC_UMINUS
:
56 case INTRINSIC_CONCAT
:
60 case INTRINSIC_DIVIDE
:
99 case INTRINSIC_ASSIGN
:
102 case INTRINSIC_PARENTHESES
:
109 case INTRINSIC_FORMATTED
:
111 case INTRINSIC_UNFORMATTED
:
112 return "unformatted";
118 gfc_internal_error ("gfc_op2string(): Bad code");
123 /******************** Generic matching subroutines ************************/
125 /* Matches a member separator. With standard FORTRAN this is '%', but with
126 DEC structures we must carefully match dot ('.').
127 Because operators are spelled ".op.", a dotted string such as "x.y.z..."
128 can be either a component reference chain or a combination of binary
130 There is no real way to win because the string may be grammatically
131 ambiguous. The following rules help avoid ambiguities - they match
132 some behavior of other (older) compilers. If the rules here are changed
133 the test cases should be updated. If the user has problems with these rules
134 they probably deserve the consequences. Consider "x.y.z":
135 (1) If any user defined operator ".y." exists, this is always y(x,z)
136 (even if ".y." is the wrong type and/or x has a member y).
137 (2) Otherwise if x has a member y, and y is itself a derived type,
138 this is (x->y)->z, even if an intrinsic operator exists which
140 (3) If x has no member y or (x->y) is not a derived type but ".y."
141 is an intrinsic operator (such as ".eq."), this is y(x,z).
142 (4) Lastly if there is no operator ".y." and x has no member "y", it is an
144 It is worth noting that the logic here does not support mixed use of member
145 accessors within a single string. That is, even if x has component y and y
146 has component z, the following are all syntax errors:
147 "x%y.z" "x.y%z" "(x.y).z" "(x%y)%z"
151 gfc_match_member_sep(gfc_symbol
*sym
)
153 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
154 locus dot_loc
, start_loc
;
155 gfc_intrinsic_op iop
;
158 gfc_component
*c
= NULL
;
160 /* What a relief: '%' is an unambiguous member separator. */
161 if (gfc_match_char ('%') == MATCH_YES
)
164 /* Beware ye who enter here. */
165 if (!flag_dec_structure
|| !sym
)
170 /* We may be given either a derived type variable or the derived type
171 declaration itself (which actually contains the components);
172 we need the latter to search for components. */
173 if (gfc_fl_struct (sym
->attr
.flavor
))
175 else if (gfc_bt_struct (sym
->ts
.type
))
176 tsym
= sym
->ts
.u
.derived
;
178 iop
= INTRINSIC_NONE
;
182 /* If we have to reject come back here later. */
183 start_loc
= gfc_current_locus
;
185 /* Look for a component access next. */
186 if (gfc_match_char ('.') != MATCH_YES
)
189 /* If we accept, come back here. */
190 dot_loc
= gfc_current_locus
;
192 /* Try to match a symbol name following the dot. */
193 if (gfc_match_name (name
) != MATCH_YES
)
195 gfc_error ("Expected structure component or operator name "
200 /* If no dot follows we have "x.y" which should be a component access. */
201 if (gfc_match_char ('.') != MATCH_YES
)
204 /* Now we have a string "x.y.z" which could be a nested member access
205 (x->y)->z or a binary operation y on x and z. */
207 /* First use any user-defined operators ".y." */
208 if (gfc_find_uop (name
, sym
->ns
) != NULL
)
211 /* Match accesses to existing derived-type components for
212 derived-type vars: "x.y.z" = (x->y)->z */
213 c
= gfc_find_component(tsym
, name
, false, true, NULL
);
214 if (c
&& (gfc_bt_struct (c
->ts
.type
) || c
->ts
.type
== BT_CLASS
))
217 /* If y is not a component or has no members, try intrinsic operators. */
218 gfc_current_locus
= start_loc
;
219 if (gfc_match_intrinsic_op (&iop
) != MATCH_YES
)
221 /* If ".y." is not an intrinsic operator but y was a valid non-
222 structure component, match and leave the trailing dot to be
227 gfc_error ("%qs is neither a defined operator nor a "
228 "structure component in dotted string at %C", name
);
232 /* .y. is an intrinsic operator, overriding any possible member access. */
235 /* Return keeping the current locus consistent with the match result. */
239 gfc_current_locus
= start_loc
;
242 gfc_current_locus
= dot_loc
;
247 /* This function scans the current statement counting the opened and closed
248 parenthesis to make sure they are balanced. */
251 gfc_match_parens (void)
253 locus old_loc
, where
;
255 gfc_instring instring
;
258 old_loc
= gfc_current_locus
;
260 instring
= NONSTRING
;
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. */
460 gfc_match_small_literal_int (int *value
, int *cnt
)
466 old_loc
= gfc_current_locus
;
469 gfc_gobble_whitespace ();
470 c
= gfc_next_ascii_char ();
476 gfc_current_locus
= old_loc
;
485 old_loc
= gfc_current_locus
;
486 c
= gfc_next_ascii_char ();
491 i
= 10 * i
+ c
- '0';
496 gfc_error ("Integer too large at %C");
501 gfc_current_locus
= old_loc
;
510 /* Match a small, constant integer expression, like in a kind
511 statement. On MATCH_YES, 'value' is set. */
514 gfc_match_small_int (int *value
)
520 m
= gfc_match_expr (&expr
);
524 if (gfc_extract_int (expr
, &i
, 1))
526 gfc_free_expr (expr
);
533 /* This function is the same as the gfc_match_small_int, except that
534 we're keeping the pointer to the expr. This function could just be
535 removed and the previously mentioned one modified, though all calls
536 to it would have to be modified then (and there were a number of
537 them). Return MATCH_ERROR if fail to extract the int; otherwise,
538 return the result of gfc_match_expr(). The expr (if any) that was
539 matched is returned in the parameter expr. */
542 gfc_match_small_int_expr (int *value
, gfc_expr
**expr
)
547 m
= gfc_match_expr (expr
);
551 if (gfc_extract_int (*expr
, &i
, 1))
559 /* Matches a statement label. Uses gfc_match_small_literal_int() to
560 do most of the work. */
563 gfc_match_st_label (gfc_st_label
**label
)
569 old_loc
= gfc_current_locus
;
571 m
= gfc_match_small_literal_int (&i
, &cnt
);
577 gfc_error ("Too many digits in statement label at %C");
583 gfc_error ("Statement label at %C is zero");
587 *label
= gfc_get_st_label (i
);
592 gfc_current_locus
= old_loc
;
597 /* Match and validate a label associated with a named IF, DO or SELECT
598 statement. If the symbol does not have the label attribute, we add
599 it. We also make sure the symbol does not refer to another
600 (active) block. A matched label is pointed to by gfc_new_block. */
603 gfc_match_label (void)
605 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
608 gfc_new_block
= NULL
;
610 m
= gfc_match (" %n :", name
);
614 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
616 gfc_error ("Label name %qs at %C is ambiguous", name
);
620 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
622 gfc_error ("Duplicate construct label %qs at %C", name
);
626 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
627 gfc_new_block
->name
, NULL
))
634 /* See if the current input looks like a name of some sort. Modifies
635 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
636 Note that options.c restricts max_identifier_length to not more
637 than GFC_MAX_SYMBOL_LEN. */
640 gfc_match_name (char *buffer
)
646 old_loc
= gfc_current_locus
;
647 gfc_gobble_whitespace ();
649 c
= gfc_next_ascii_char ();
650 if (!(ISALPHA (c
) || (c
== '_' && flag_allow_leading_underscore
)))
652 /* Special cases for unary minus and plus, which allows for a sensible
653 error message for code of the form 'c = exp(-a*b) )' where an
654 extra ')' appears at the end of statement. */
655 if (!gfc_error_flag_test () && c
!= '(' && c
!= '-' && c
!= '+')
656 gfc_error ("Invalid character in name at %C");
657 gfc_current_locus
= old_loc
;
667 if (i
> gfc_option
.max_identifier_length
)
669 gfc_error ("Name at %C is too long");
673 old_loc
= gfc_current_locus
;
674 c
= gfc_next_ascii_char ();
676 while (ISALNUM (c
) || c
== '_' || (flag_dollar_ok
&& c
== '$'));
678 if (c
== '$' && !flag_dollar_ok
)
680 gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to "
681 "allow it as an extension", &old_loc
);
686 gfc_current_locus
= old_loc
;
692 /* Match a symbol on the input. Modifies the pointer to the symbol
693 pointer if successful. */
696 gfc_match_sym_tree (gfc_symtree
**matched_symbol
, int host_assoc
)
698 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
701 m
= gfc_match_name (buffer
);
706 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
707 ? MATCH_ERROR
: MATCH_YES
;
709 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
, false))
717 gfc_match_symbol (gfc_symbol
**matched_symbol
, int host_assoc
)
722 m
= gfc_match_sym_tree (&st
, host_assoc
);
727 *matched_symbol
= st
->n
.sym
;
729 *matched_symbol
= NULL
;
732 *matched_symbol
= NULL
;
737 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
738 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
742 gfc_match_intrinsic_op (gfc_intrinsic_op
*result
)
744 locus orig_loc
= gfc_current_locus
;
747 gfc_gobble_whitespace ();
748 ch
= gfc_next_ascii_char ();
753 *result
= INTRINSIC_PLUS
;
758 *result
= INTRINSIC_MINUS
;
762 if (gfc_next_ascii_char () == '=')
765 *result
= INTRINSIC_EQ
;
771 if (gfc_peek_ascii_char () == '=')
774 gfc_next_ascii_char ();
775 *result
= INTRINSIC_LE
;
779 *result
= INTRINSIC_LT
;
783 if (gfc_peek_ascii_char () == '=')
786 gfc_next_ascii_char ();
787 *result
= INTRINSIC_GE
;
791 *result
= INTRINSIC_GT
;
795 if (gfc_peek_ascii_char () == '*')
798 gfc_next_ascii_char ();
799 *result
= INTRINSIC_POWER
;
803 *result
= INTRINSIC_TIMES
;
807 ch
= gfc_peek_ascii_char ();
811 gfc_next_ascii_char ();
812 *result
= INTRINSIC_NE
;
818 gfc_next_ascii_char ();
819 *result
= INTRINSIC_CONCAT
;
823 *result
= INTRINSIC_DIVIDE
;
827 ch
= gfc_next_ascii_char ();
831 if (gfc_next_ascii_char () == 'n'
832 && gfc_next_ascii_char () == 'd'
833 && gfc_next_ascii_char () == '.')
835 /* Matched ".and.". */
836 *result
= INTRINSIC_AND
;
842 if (gfc_next_ascii_char () == 'q')
844 ch
= gfc_next_ascii_char ();
847 /* Matched ".eq.". */
848 *result
= INTRINSIC_EQ_OS
;
853 if (gfc_next_ascii_char () == '.')
855 /* Matched ".eqv.". */
856 *result
= INTRINSIC_EQV
;
864 ch
= gfc_next_ascii_char ();
867 if (gfc_next_ascii_char () == '.')
869 /* Matched ".ge.". */
870 *result
= INTRINSIC_GE_OS
;
876 if (gfc_next_ascii_char () == '.')
878 /* Matched ".gt.". */
879 *result
= INTRINSIC_GT_OS
;
886 ch
= gfc_next_ascii_char ();
889 if (gfc_next_ascii_char () == '.')
891 /* Matched ".le.". */
892 *result
= INTRINSIC_LE_OS
;
898 if (gfc_next_ascii_char () == '.')
900 /* Matched ".lt.". */
901 *result
= INTRINSIC_LT_OS
;
908 ch
= gfc_next_ascii_char ();
911 ch
= gfc_next_ascii_char ();
914 /* Matched ".ne.". */
915 *result
= INTRINSIC_NE_OS
;
920 if (gfc_next_ascii_char () == 'v'
921 && gfc_next_ascii_char () == '.')
923 /* Matched ".neqv.". */
924 *result
= INTRINSIC_NEQV
;
931 if (gfc_next_ascii_char () == 't'
932 && gfc_next_ascii_char () == '.')
934 /* Matched ".not.". */
935 *result
= INTRINSIC_NOT
;
942 if (gfc_next_ascii_char () == 'r'
943 && gfc_next_ascii_char () == '.')
945 /* Matched ".or.". */
946 *result
= INTRINSIC_OR
;
952 if (gfc_next_ascii_char () == 'o'
953 && gfc_next_ascii_char () == 'r'
954 && gfc_next_ascii_char () == '.')
956 if (!gfc_notify_std (GFC_STD_LEGACY
, ".XOR. operator at %C"))
958 /* Matched ".xor." - equivalent to ".neqv.". */
959 *result
= INTRINSIC_NEQV
;
973 gfc_current_locus
= orig_loc
;
978 /* Match a loop control phrase:
980 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
982 If the final integer expression is not present, a constant unity
983 expression is returned. We don't return MATCH_ERROR until after
984 the equals sign is seen. */
987 gfc_match_iterator (gfc_iterator
*iter
, int init_flag
)
989 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
990 gfc_expr
*var
, *e1
, *e2
, *e3
;
996 /* Match the start of an iterator without affecting the symbol table. */
998 start
= gfc_current_locus
;
999 m
= gfc_match (" %n =", name
);
1000 gfc_current_locus
= start
;
1005 m
= gfc_match_variable (&var
, 0);
1009 if (var
->symtree
->n
.sym
->attr
.dimension
)
1011 gfc_error ("Loop variable at %C cannot be an array");
1015 /* F2008, C617 & C565. */
1016 if (var
->symtree
->n
.sym
->attr
.codimension
)
1018 gfc_error ("Loop variable at %C cannot be a coarray");
1022 if (var
->ref
!= NULL
)
1024 gfc_error ("Loop variable at %C cannot be a sub-component");
1028 gfc_match_char ('=');
1030 var
->symtree
->n
.sym
->attr
.implied_index
= 1;
1032 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
1035 if (m
== MATCH_ERROR
)
1038 if (gfc_match_char (',') != MATCH_YES
)
1041 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
1044 if (m
== MATCH_ERROR
)
1047 if (gfc_match_char (',') != MATCH_YES
)
1049 e3
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1053 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
1054 if (m
== MATCH_ERROR
)
1058 gfc_error ("Expected a step value in iterator at %C");
1070 gfc_error ("Syntax error in iterator at %C");
1081 /* Tries to match the next non-whitespace character on the input.
1082 This subroutine does not return MATCH_ERROR. */
1085 gfc_match_char (char c
)
1089 where
= gfc_current_locus
;
1090 gfc_gobble_whitespace ();
1092 if (gfc_next_ascii_char () == c
)
1095 gfc_current_locus
= where
;
1100 /* General purpose matching subroutine. The target string is a
1101 scanf-like format string in which spaces correspond to arbitrary
1102 whitespace (including no whitespace), characters correspond to
1103 themselves. The %-codes are:
1105 %% Literal percent sign
1106 %e Expression, pointer to a pointer is set
1107 %s Symbol, pointer to the symbol is set
1108 %n Name, character buffer is set to name
1109 %t Matches end of statement.
1110 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1111 %l Matches a statement label
1112 %v Matches a variable expression (an lvalue)
1113 % Matches a required space (in free form) and optional spaces. */
1116 gfc_match (const char *target
, ...)
1118 gfc_st_label
**label
;
1127 old_loc
= gfc_current_locus
;
1128 va_start (argp
, target
);
1138 gfc_gobble_whitespace ();
1149 vp
= va_arg (argp
, void **);
1150 n
= gfc_match_expr ((gfc_expr
**) vp
);
1161 vp
= va_arg (argp
, void **);
1162 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
1173 vp
= va_arg (argp
, void **);
1174 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
1185 np
= va_arg (argp
, char *);
1186 n
= gfc_match_name (np
);
1197 label
= va_arg (argp
, gfc_st_label
**);
1198 n
= gfc_match_st_label (label
);
1209 ip
= va_arg (argp
, int *);
1210 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
1221 if (gfc_match_eos () != MATCH_YES
)
1229 if (gfc_match_space () == MATCH_YES
)
1235 break; /* Fall through to character matcher. */
1238 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
1244 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1245 expect an upper case character here! */
1246 gcc_assert (TOLOWER (c
) == c
);
1248 if (c
== gfc_next_ascii_char ())
1258 /* Clean up after a failed match. */
1259 gfc_current_locus
= old_loc
;
1260 va_start (argp
, target
);
1263 for (; matches
> 0; matches
--)
1265 while (*p
++ != '%');
1273 /* Matches that don't have to be undone */
1278 (void) va_arg (argp
, void **);
1283 vp
= va_arg (argp
, void **);
1284 gfc_free_expr ((struct gfc_expr
*)*vp
);
1297 /*********************** Statement level matching **********************/
1299 /* Matches the start of a program unit, which is the program keyword
1300 followed by an obligatory symbol. */
1303 gfc_match_program (void)
1308 m
= gfc_match ("% %s%t", &sym
);
1312 gfc_error ("Invalid form of PROGRAM statement at %C");
1316 if (m
== MATCH_ERROR
)
1319 if (!gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
))
1322 gfc_new_block
= sym
;
1328 /* Match a simple assignment statement. */
1331 gfc_match_assignment (void)
1333 gfc_expr
*lvalue
, *rvalue
;
1337 old_loc
= gfc_current_locus
;
1340 m
= gfc_match (" %v =", &lvalue
);
1343 gfc_current_locus
= old_loc
;
1344 gfc_free_expr (lvalue
);
1349 m
= gfc_match (" %e%t", &rvalue
);
1352 && rvalue
->ts
.type
== BT_BOZ
1353 && lvalue
->ts
.type
== BT_CLASS
)
1356 gfc_error ("BOZ literal constant at %L is neither a DATA statement "
1357 "value nor an actual argument of INT/REAL/DBLE/CMPLX "
1358 "intrinsic subprogram", &rvalue
->where
);
1361 if (lvalue
->expr_type
== EXPR_CONSTANT
)
1363 /* This clobbers %len and %kind. */
1365 gfc_error ("Assignment to a constant expression at %C");
1370 gfc_current_locus
= old_loc
;
1371 gfc_free_expr (lvalue
);
1372 gfc_free_expr (rvalue
);
1376 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1378 new_st
.op
= EXEC_ASSIGN
;
1379 new_st
.expr1
= lvalue
;
1380 new_st
.expr2
= rvalue
;
1382 gfc_check_do_variable (lvalue
->symtree
);
1384 if (lvalue
->ts
.type
== BT_CLASS
)
1385 gfc_find_vtab (&rvalue
->ts
);
1391 /* Match a pointer assignment statement. */
1394 gfc_match_pointer_assignment (void)
1396 gfc_expr
*lvalue
, *rvalue
;
1400 old_loc
= gfc_current_locus
;
1402 lvalue
= rvalue
= NULL
;
1403 gfc_matching_ptr_assignment
= 0;
1404 gfc_matching_procptr_assignment
= 0;
1406 m
= gfc_match (" %v =>", &lvalue
);
1413 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1414 || gfc_is_proc_ptr_comp (lvalue
))
1415 gfc_matching_procptr_assignment
= 1;
1417 gfc_matching_ptr_assignment
= 1;
1419 m
= gfc_match (" %e%t", &rvalue
);
1420 gfc_matching_ptr_assignment
= 0;
1421 gfc_matching_procptr_assignment
= 0;
1425 new_st
.op
= EXEC_POINTER_ASSIGN
;
1426 new_st
.expr1
= lvalue
;
1427 new_st
.expr2
= rvalue
;
1432 gfc_current_locus
= old_loc
;
1433 gfc_free_expr (lvalue
);
1434 gfc_free_expr (rvalue
);
1439 /* We try to match an easy arithmetic IF statement. This only happens
1440 when just after having encountered a simple IF statement. This code
1441 is really duplicate with parts of the gfc_match_if code, but this is
1445 match_arithmetic_if (void)
1447 gfc_st_label
*l1
, *l2
, *l3
;
1451 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1455 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1456 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1457 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1459 gfc_free_expr (expr
);
1463 if (!gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
1464 "Arithmetic IF statement at %C"))
1467 new_st
.op
= EXEC_ARITHMETIC_IF
;
1468 new_st
.expr1
= expr
;
1477 /* The IF statement is a bit of a pain. First of all, there are three
1478 forms of it, the simple IF, the IF that starts a block and the
1481 There is a problem with the simple IF and that is the fact that we
1482 only have a single level of undo information on symbols. What this
1483 means is for a simple IF, we must re-match the whole IF statement
1484 multiple times in order to guarantee that the symbol table ends up
1485 in the proper state. */
1487 static match
match_simple_forall (void);
1488 static match
match_simple_where (void);
1491 gfc_match_if (gfc_statement
*if_type
)
1494 gfc_st_label
*l1
, *l2
, *l3
;
1495 locus old_loc
, old_loc2
;
1499 n
= gfc_match_label ();
1500 if (n
== MATCH_ERROR
)
1503 old_loc
= gfc_current_locus
;
1505 m
= gfc_match (" if ", &expr
);
1509 if (gfc_match_char ('(') != MATCH_YES
)
1511 gfc_error ("Missing %<(%> in IF-expression at %C");
1515 m
= gfc_match ("%e", &expr
);
1519 old_loc2
= gfc_current_locus
;
1520 gfc_current_locus
= old_loc
;
1522 if (gfc_match_parens () == MATCH_ERROR
)
1525 gfc_current_locus
= old_loc2
;
1527 if (gfc_match_char (')') != MATCH_YES
)
1529 gfc_error ("Syntax error in IF-expression at %C");
1530 gfc_free_expr (expr
);
1534 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1540 gfc_error ("Block label not appropriate for arithmetic IF "
1542 gfc_free_expr (expr
);
1546 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1547 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1548 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1550 gfc_free_expr (expr
);
1554 if (!gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
1555 "Arithmetic IF statement at %C"))
1558 new_st
.op
= EXEC_ARITHMETIC_IF
;
1559 new_st
.expr1
= expr
;
1564 *if_type
= ST_ARITHMETIC_IF
;
1568 if (gfc_match (" then%t") == MATCH_YES
)
1570 new_st
.op
= EXEC_IF
;
1571 new_st
.expr1
= expr
;
1572 *if_type
= ST_IF_BLOCK
;
1578 gfc_error ("Block label is not appropriate for IF statement at %C");
1579 gfc_free_expr (expr
);
1583 /* At this point the only thing left is a simple IF statement. At
1584 this point, n has to be MATCH_NO, so we don't have to worry about
1585 re-matching a block label. From what we've got so far, try
1586 matching an assignment. */
1588 *if_type
= ST_SIMPLE_IF
;
1590 m
= gfc_match_assignment ();
1594 gfc_free_expr (expr
);
1595 gfc_undo_symbols ();
1596 gfc_current_locus
= old_loc
;
1598 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1599 assignment was found. For MATCH_NO, continue to call the various
1601 if (m
== MATCH_ERROR
)
1604 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1606 m
= gfc_match_pointer_assignment ();
1610 gfc_free_expr (expr
);
1611 gfc_undo_symbols ();
1612 gfc_current_locus
= old_loc
;
1614 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1616 /* Look at the next keyword to see which matcher to call. Matching
1617 the keyword doesn't affect the symbol table, so we don't have to
1618 restore between tries. */
1620 #define match(string, subr, statement) \
1621 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1625 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1626 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1627 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1628 match ("call", gfc_match_call
, ST_CALL
)
1629 match ("change team", gfc_match_change_team
, ST_CHANGE_TEAM
)
1630 match ("close", gfc_match_close
, ST_CLOSE
)
1631 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1632 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1633 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1634 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1635 match ("end team", gfc_match_end_team
, ST_END_TEAM
)
1636 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
)
1637 match ("event post", gfc_match_event_post
, ST_EVENT_POST
)
1638 match ("event wait", gfc_match_event_wait
, ST_EVENT_WAIT
)
1639 match ("exit", gfc_match_exit
, ST_EXIT
)
1640 match ("fail image", gfc_match_fail_image
, ST_FAIL_IMAGE
)
1641 match ("flush", gfc_match_flush
, ST_FLUSH
)
1642 match ("forall", match_simple_forall
, ST_FORALL
)
1643 match ("form team", gfc_match_form_team
, ST_FORM_TEAM
)
1644 match ("go to", gfc_match_goto
, ST_GOTO
)
1645 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1646 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1647 match ("lock", gfc_match_lock
, ST_LOCK
)
1648 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1649 match ("open", gfc_match_open
, ST_OPEN
)
1650 match ("pause", gfc_match_pause
, ST_NONE
)
1651 match ("print", gfc_match_print
, ST_WRITE
)
1652 match ("read", gfc_match_read
, ST_READ
)
1653 match ("return", gfc_match_return
, ST_RETURN
)
1654 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1655 match ("stop", gfc_match_stop
, ST_STOP
)
1656 match ("wait", gfc_match_wait
, ST_WAIT
)
1657 match ("sync all", gfc_match_sync_all
, ST_SYNC_CALL
);
1658 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
1659 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
1660 match ("sync team", gfc_match_sync_team
, ST_SYNC_TEAM
)
1661 match ("unlock", gfc_match_unlock
, ST_UNLOCK
)
1662 match ("where", match_simple_where
, ST_WHERE
)
1663 match ("write", gfc_match_write
, ST_WRITE
)
1666 match ("type", gfc_match_print
, ST_WRITE
)
1668 /* All else has failed, so give up. See if any of the matchers has
1669 stored an error message of some sort. */
1670 if (!gfc_error_check ())
1671 gfc_error ("Syntax error in IF-clause after %C");
1673 gfc_free_expr (expr
);
1678 gfc_error ("Syntax error in IF-clause after %C");
1681 gfc_free_expr (expr
);
1685 /* At this point, we've matched the single IF and the action clause
1686 is in new_st. Rearrange things so that the IF statement appears
1689 p
= gfc_get_code (EXEC_IF
);
1690 p
->next
= XCNEW (gfc_code
);
1692 p
->next
->loc
= gfc_current_locus
;
1696 gfc_clear_new_st ();
1698 new_st
.op
= EXEC_IF
;
1707 /* Match an ELSE statement. */
1710 gfc_match_else (void)
1712 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1714 if (gfc_match_eos () == MATCH_YES
)
1717 if (gfc_match_name (name
) != MATCH_YES
1718 || gfc_current_block () == NULL
1719 || gfc_match_eos () != MATCH_YES
)
1721 gfc_error ("Invalid character(s) in ELSE statement after %C");
1725 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1727 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1728 name
, gfc_current_block ()->name
);
1736 /* Match an ELSE IF statement. */
1739 gfc_match_elseif (void)
1741 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1742 gfc_expr
*expr
, *then
;
1746 if (gfc_match_char ('(') != MATCH_YES
)
1748 gfc_error ("Missing %<(%> in ELSE IF expression at %C");
1752 m
= gfc_match (" %e ", &expr
);
1756 if (gfc_match_char (')') != MATCH_YES
)
1758 gfc_error ("Missing %<)%> in ELSE IF expression at %C");
1762 m
= gfc_match (" then ", &then
);
1764 where
= gfc_current_locus
;
1766 if (m
== MATCH_YES
&& (gfc_match_eos () == MATCH_YES
1767 || (gfc_current_block ()
1768 && gfc_match_name (name
) == MATCH_YES
)))
1771 if (gfc_match_eos () == MATCH_YES
)
1773 gfc_error ("Missing THEN in ELSE IF statement after %L", &where
);
1777 if (gfc_match_name (name
) != MATCH_YES
1778 || gfc_current_block () == NULL
1779 || gfc_match_eos () != MATCH_YES
)
1781 gfc_error ("Syntax error in ELSE IF statement after %L", &where
);
1785 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1787 gfc_error ("Label %qs after %L doesn't match IF label %qs",
1788 name
, &where
, gfc_current_block ()->name
);
1796 new_st
.op
= EXEC_IF
;
1797 new_st
.expr1
= expr
;
1801 gfc_free_expr (expr
);
1806 /* Free a gfc_iterator structure. */
1809 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1815 gfc_free_expr (iter
->var
);
1816 gfc_free_expr (iter
->start
);
1817 gfc_free_expr (iter
->end
);
1818 gfc_free_expr (iter
->step
);
1825 /* Match a CRITICAL statement. */
1827 gfc_match_critical (void)
1829 gfc_st_label
*label
= NULL
;
1831 if (gfc_match_label () == MATCH_ERROR
)
1834 if (gfc_match (" critical") != MATCH_YES
)
1837 if (gfc_match_st_label (&label
) == MATCH_ERROR
)
1840 if (gfc_match_eos () != MATCH_YES
)
1842 gfc_syntax_error (ST_CRITICAL
);
1846 if (gfc_pure (NULL
))
1848 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1852 if (gfc_find_state (COMP_DO_CONCURRENT
))
1854 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1859 gfc_unset_implicit_pure (NULL
);
1861 if (!gfc_notify_std (GFC_STD_F2008
, "CRITICAL statement at %C"))
1864 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1866 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1871 if (gfc_find_state (COMP_CRITICAL
))
1873 gfc_error ("Nested CRITICAL block at %C");
1877 new_st
.op
= EXEC_CRITICAL
;
1880 && !gfc_reference_st_label (label
, ST_LABEL_TARGET
))
1887 /* Match a BLOCK statement. */
1890 gfc_match_block (void)
1894 if (gfc_match_label () == MATCH_ERROR
)
1897 if (gfc_match (" block") != MATCH_YES
)
1900 /* For this to be a correct BLOCK statement, the line must end now. */
1901 m
= gfc_match_eos ();
1902 if (m
== MATCH_ERROR
)
1911 /* Match an ASSOCIATE statement. */
1914 gfc_match_associate (void)
1916 if (gfc_match_label () == MATCH_ERROR
)
1919 if (gfc_match (" associate") != MATCH_YES
)
1922 /* Match the association list. */
1923 if (gfc_match_char ('(') != MATCH_YES
)
1925 gfc_error ("Expected association list at %C");
1928 new_st
.ext
.block
.assoc
= NULL
;
1931 gfc_association_list
* newAssoc
= gfc_get_association_list ();
1932 gfc_association_list
* a
;
1934 /* Match the next association. */
1935 if (gfc_match (" %n =>", newAssoc
->name
) != MATCH_YES
)
1937 gfc_error ("Expected association at %C");
1938 goto assocListError
;
1941 if (gfc_match (" %e", &newAssoc
->target
) != MATCH_YES
)
1943 /* Have another go, allowing for procedure pointer selectors. */
1944 gfc_matching_procptr_assignment
= 1;
1945 if (gfc_match (" %e", &newAssoc
->target
) != MATCH_YES
)
1947 gfc_error ("Invalid association target at %C");
1948 goto assocListError
;
1950 gfc_matching_procptr_assignment
= 0;
1952 newAssoc
->where
= gfc_current_locus
;
1954 /* Check that the current name is not yet in the list. */
1955 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
1956 if (!strcmp (a
->name
, newAssoc
->name
))
1958 gfc_error ("Duplicate name %qs in association at %C",
1960 goto assocListError
;
1963 /* The target expression must not be coindexed. */
1964 if (gfc_is_coindexed (newAssoc
->target
))
1966 gfc_error ("Association target at %C must not be coindexed");
1967 goto assocListError
;
1970 /* The target expression cannot be a BOZ literal constant. */
1971 if (newAssoc
->target
->ts
.type
== BT_BOZ
)
1973 gfc_error ("Association target at %L cannot be a BOZ literal "
1974 "constant", &newAssoc
->target
->where
);
1975 goto assocListError
;
1978 /* The `variable' field is left blank for now; because the target is not
1979 yet resolved, we can't use gfc_has_vector_subscript to determine it
1980 for now. This is set during resolution. */
1982 /* Put it into the list. */
1983 newAssoc
->next
= new_st
.ext
.block
.assoc
;
1984 new_st
.ext
.block
.assoc
= newAssoc
;
1986 /* Try next one or end if closing parenthesis is found. */
1987 gfc_gobble_whitespace ();
1988 if (gfc_peek_char () == ')')
1990 if (gfc_match_char (',') != MATCH_YES
)
1992 gfc_error ("Expected %<)%> or %<,%> at %C");
2002 if (gfc_match_char (')') != MATCH_YES
)
2004 /* This should never happen as we peek above. */
2008 if (gfc_match_eos () != MATCH_YES
)
2010 gfc_error ("Junk after ASSOCIATE statement at %C");
2017 gfc_free_association_list (new_st
.ext
.block
.assoc
);
2022 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
2023 an accessible derived type. */
2026 match_derived_type_spec (gfc_typespec
*ts
)
2028 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2030 gfc_symbol
*derived
, *der_type
;
2031 match m
= MATCH_YES
;
2032 gfc_actual_arglist
*decl_type_param_list
= NULL
;
2033 bool is_pdt_template
= false;
2035 old_locus
= gfc_current_locus
;
2037 if (gfc_match ("%n", name
) != MATCH_YES
)
2039 gfc_current_locus
= old_locus
;
2043 gfc_find_symbol (name
, NULL
, 1, &derived
);
2045 /* Match the PDT spec list, if there. */
2046 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
)
2048 gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &der_type
);
2049 is_pdt_template
= der_type
2050 && der_type
->attr
.flavor
== FL_DERIVED
2051 && der_type
->attr
.pdt_template
;
2054 if (is_pdt_template
)
2055 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
2057 if (m
== MATCH_ERROR
)
2059 gfc_free_actual_arglist (decl_type_param_list
);
2063 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
&& derived
->attr
.generic
)
2064 derived
= gfc_find_dt_in_generic (derived
);
2066 /* If this is a PDT, find the specific instance. */
2067 if (m
== MATCH_YES
&& is_pdt_template
)
2069 gfc_namespace
*old_ns
;
2071 old_ns
= gfc_current_ns
;
2072 while (gfc_current_ns
&& gfc_current_ns
->parent
)
2073 gfc_current_ns
= gfc_current_ns
->parent
;
2075 if (type_param_spec_list
)
2076 gfc_free_actual_arglist (type_param_spec_list
);
2077 m
= gfc_get_pdt_instance (decl_type_param_list
, &der_type
,
2078 &type_param_spec_list
);
2079 gfc_free_actual_arglist (decl_type_param_list
);
2084 gcc_assert (!derived
->attr
.pdt_template
&& derived
->attr
.pdt_type
);
2085 gfc_set_sym_referenced (derived
);
2087 gfc_current_ns
= old_ns
;
2090 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
2092 ts
->type
= BT_DERIVED
;
2093 ts
->u
.derived
= derived
;
2097 gfc_current_locus
= old_locus
;
2102 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2103 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2104 It only includes the intrinsic types from the Fortran 2003 standard
2105 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2106 the implicit_flag is not needed, so it was removed. Derived types are
2107 identified by their name alone. */
2110 gfc_match_type_spec (gfc_typespec
*ts
)
2114 char c
, name
[GFC_MAX_SYMBOL_LEN
+ 1];
2117 gfc_gobble_whitespace ();
2118 old_locus
= gfc_current_locus
;
2120 /* If c isn't [a-z], then return immediately. */
2121 c
= gfc_peek_ascii_char ();
2125 type_param_spec_list
= NULL
;
2127 if (match_derived_type_spec (ts
) == MATCH_YES
)
2129 /* Enforce F03:C401. */
2130 if (ts
->u
.derived
->attr
.abstract
)
2132 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
2133 ts
->u
.derived
->name
, &old_locus
);
2139 if (gfc_match ("integer") == MATCH_YES
)
2141 ts
->type
= BT_INTEGER
;
2142 ts
->kind
= gfc_default_integer_kind
;
2146 if (gfc_match ("double precision") == MATCH_YES
)
2149 ts
->kind
= gfc_default_double_kind
;
2153 if (gfc_match ("complex") == MATCH_YES
)
2155 ts
->type
= BT_COMPLEX
;
2156 ts
->kind
= gfc_default_complex_kind
;
2160 if (gfc_match ("character") == MATCH_YES
)
2162 ts
->type
= BT_CHARACTER
;
2164 m
= gfc_match_char_spec (ts
);
2172 /* REAL is a real pain because it can be a type, intrinsic subprogram,
2173 or list item in a type-list of an OpenMP reduction clause. Need to
2174 differentiate REAL([KIND]=scalar-int-initialization-expr) from
2175 REAL(A,[KIND]) and REAL(KIND,A). Logically, when this code was
2176 written the use of LOGICAL as a type-spec or intrinsic subprogram
2179 m
= gfc_match (" %n", name
);
2181 && (strcmp (name
, "real") == 0 || strcmp (name
, "logical") == 0))
2190 ts
->kind
= gfc_default_real_kind
;
2194 ts
->type
= BT_LOGICAL
;
2195 ts
->kind
= gfc_default_logical_kind
;
2198 gfc_gobble_whitespace ();
2200 /* Prevent REAL*4, etc. */
2201 c
= gfc_peek_ascii_char ();
2204 gfc_error ("Invalid type-spec at %C");
2208 /* Found leading colon in REAL::, a trailing ')' in for example
2209 TYPE IS (REAL), or REAL, for an OpenMP list-item. */
2210 if (c
== ':' || c
== ')' || (flag_openmp
&& c
== ','))
2213 /* Found something other than the opening '(' in REAL(... */
2217 gfc_next_char (); /* Burn the '('. */
2219 /* Look for the optional KIND=. */
2220 where
= gfc_current_locus
;
2221 m
= gfc_match ("%n", name
);
2224 gfc_gobble_whitespace ();
2225 c
= gfc_next_char ();
2228 if (strcmp(name
, "a") == 0 || strcmp(name
, "l") == 0)
2230 else if (strcmp(name
, "kind") == 0)
2236 gfc_current_locus
= where
;
2239 gfc_current_locus
= where
;
2243 m
= gfc_match_init_expr (&e
);
2244 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
2247 /* If a comma appears, it is an intrinsic subprogram. */
2248 gfc_gobble_whitespace ();
2249 c
= gfc_peek_ascii_char ();
2256 /* If ')' appears, we have REAL(initialization-expr), here check for
2257 a scalar integer initialization-expr and valid kind parameter. */
2260 if (e
->ts
.type
!= BT_INTEGER
|| e
->rank
> 0)
2266 if (e
->expr_type
!= EXPR_CONSTANT
)
2269 gfc_next_char (); /* Burn the ')'. */
2270 ts
->kind
= (int) mpz_get_si (e
->value
.integer
);
2271 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
2273 gfc_error ("Invalid type-spec at %C");
2285 /* If a type is not matched, simply return MATCH_NO. */
2286 gfc_current_locus
= old_locus
;
2291 gfc_gobble_whitespace ();
2293 /* This prevents INTEGER*4, etc. */
2294 if (gfc_peek_ascii_char () == '*')
2296 gfc_error ("Invalid type-spec at %C");
2300 m
= gfc_match_kind_spec (ts
, false);
2302 /* No kind specifier found. */
2310 /******************** FORALL subroutines ********************/
2312 /* Free a list of FORALL iterators. */
2315 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
2317 gfc_forall_iterator
*next
;
2322 gfc_free_expr (iter
->var
);
2323 gfc_free_expr (iter
->start
);
2324 gfc_free_expr (iter
->end
);
2325 gfc_free_expr (iter
->stride
);
2332 /* Match an iterator as part of a FORALL statement. The format is:
2334 <var> = <start>:<end>[:<stride>]
2336 On MATCH_NO, the caller tests for the possibility that there is a
2337 scalar mask expression. */
2340 match_forall_iterator (gfc_forall_iterator
**result
)
2342 gfc_forall_iterator
*iter
;
2346 where
= gfc_current_locus
;
2347 iter
= XCNEW (gfc_forall_iterator
);
2349 m
= gfc_match_expr (&iter
->var
);
2353 if (gfc_match_char ('=') != MATCH_YES
2354 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
2360 m
= gfc_match_expr (&iter
->start
);
2364 if (gfc_match_char (':') != MATCH_YES
)
2367 m
= gfc_match_expr (&iter
->end
);
2370 if (m
== MATCH_ERROR
)
2373 if (gfc_match_char (':') == MATCH_NO
)
2374 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2377 m
= gfc_match_expr (&iter
->stride
);
2380 if (m
== MATCH_ERROR
)
2384 /* Mark the iteration variable's symbol as used as a FORALL index. */
2385 iter
->var
->symtree
->n
.sym
->forall_index
= true;
2391 gfc_error ("Syntax error in FORALL iterator at %C");
2396 gfc_current_locus
= where
;
2397 gfc_free_forall_iterator (iter
);
2402 /* Match the header of a FORALL statement. */
2405 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
2407 gfc_forall_iterator
*head
, *tail
, *new_iter
;
2411 gfc_gobble_whitespace ();
2416 if (gfc_match_char ('(') != MATCH_YES
)
2419 m
= match_forall_iterator (&new_iter
);
2420 if (m
== MATCH_ERROR
)
2425 head
= tail
= new_iter
;
2429 if (gfc_match_char (',') != MATCH_YES
)
2432 m
= match_forall_iterator (&new_iter
);
2433 if (m
== MATCH_ERROR
)
2438 tail
->next
= new_iter
;
2443 /* Have to have a mask expression. */
2445 m
= gfc_match_expr (&msk
);
2448 if (m
== MATCH_ERROR
)
2454 if (gfc_match_char (')') == MATCH_NO
)
2462 gfc_syntax_error (ST_FORALL
);
2465 gfc_free_expr (msk
);
2466 gfc_free_forall_iterator (head
);
2471 /* Match the rest of a simple FORALL statement that follows an
2475 match_simple_forall (void)
2477 gfc_forall_iterator
*head
;
2486 m
= match_forall_header (&head
, &mask
);
2493 m
= gfc_match_assignment ();
2495 if (m
== MATCH_ERROR
)
2499 m
= gfc_match_pointer_assignment ();
2500 if (m
== MATCH_ERROR
)
2506 c
= XCNEW (gfc_code
);
2508 c
->loc
= gfc_current_locus
;
2510 if (gfc_match_eos () != MATCH_YES
)
2513 gfc_clear_new_st ();
2514 new_st
.op
= EXEC_FORALL
;
2515 new_st
.expr1
= mask
;
2516 new_st
.ext
.forall_iterator
= head
;
2517 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2518 new_st
.block
->next
= c
;
2523 gfc_syntax_error (ST_FORALL
);
2526 gfc_free_forall_iterator (head
);
2527 gfc_free_expr (mask
);
2533 /* Match a FORALL statement. */
2536 gfc_match_forall (gfc_statement
*st
)
2538 gfc_forall_iterator
*head
;
2547 m0
= gfc_match_label ();
2548 if (m0
== MATCH_ERROR
)
2551 m
= gfc_match (" forall");
2555 m
= match_forall_header (&head
, &mask
);
2556 if (m
== MATCH_ERROR
)
2561 if (gfc_match_eos () == MATCH_YES
)
2563 *st
= ST_FORALL_BLOCK
;
2564 new_st
.op
= EXEC_FORALL
;
2565 new_st
.expr1
= mask
;
2566 new_st
.ext
.forall_iterator
= head
;
2570 m
= gfc_match_assignment ();
2571 if (m
== MATCH_ERROR
)
2575 m
= gfc_match_pointer_assignment ();
2576 if (m
== MATCH_ERROR
)
2582 c
= XCNEW (gfc_code
);
2584 c
->loc
= gfc_current_locus
;
2586 gfc_clear_new_st ();
2587 new_st
.op
= EXEC_FORALL
;
2588 new_st
.expr1
= mask
;
2589 new_st
.ext
.forall_iterator
= head
;
2590 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2591 new_st
.block
->next
= c
;
2597 gfc_syntax_error (ST_FORALL
);
2600 gfc_free_forall_iterator (head
);
2601 gfc_free_expr (mask
);
2602 gfc_free_statements (c
);
2607 /* Match a DO statement. */
2612 gfc_iterator iter
, *ip
;
2614 gfc_st_label
*label
;
2617 old_loc
= gfc_current_locus
;
2619 memset (&iter
, '\0', sizeof (gfc_iterator
));
2622 m
= gfc_match_label ();
2623 if (m
== MATCH_ERROR
)
2626 if (gfc_match (" do") != MATCH_YES
)
2629 m
= gfc_match_st_label (&label
);
2630 if (m
== MATCH_ERROR
)
2633 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2635 if (gfc_match_eos () == MATCH_YES
)
2637 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
2638 new_st
.op
= EXEC_DO_WHILE
;
2642 /* Match an optional comma, if no comma is found, a space is obligatory. */
2643 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
2646 /* Check for balanced parens. */
2648 if (gfc_match_parens () == MATCH_ERROR
)
2651 if (gfc_match (" concurrent") == MATCH_YES
)
2653 gfc_forall_iterator
*head
;
2656 if (!gfc_notify_std (GFC_STD_F2008
, "DO CONCURRENT construct at %C"))
2662 m
= match_forall_header (&head
, &mask
);
2666 if (m
== MATCH_ERROR
)
2667 goto concurr_cleanup
;
2669 if (gfc_match_eos () != MATCH_YES
)
2670 goto concurr_cleanup
;
2673 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2674 goto concurr_cleanup
;
2676 new_st
.label1
= label
;
2677 new_st
.op
= EXEC_DO_CONCURRENT
;
2678 new_st
.expr1
= mask
;
2679 new_st
.ext
.forall_iterator
= head
;
2684 gfc_syntax_error (ST_DO
);
2685 gfc_free_expr (mask
);
2686 gfc_free_forall_iterator (head
);
2690 /* See if we have a DO WHILE. */
2691 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
2693 new_st
.op
= EXEC_DO_WHILE
;
2697 /* The abortive DO WHILE may have done something to the symbol
2698 table, so we start over. */
2699 gfc_undo_symbols ();
2700 gfc_current_locus
= old_loc
;
2702 gfc_match_label (); /* This won't error. */
2703 gfc_match (" do "); /* This will work. */
2705 gfc_match_st_label (&label
); /* Can't error out. */
2706 gfc_match_char (','); /* Optional comma. */
2708 m
= gfc_match_iterator (&iter
, 0);
2711 if (m
== MATCH_ERROR
)
2714 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
2715 gfc_check_do_variable (iter
.var
->symtree
);
2717 if (gfc_match_eos () != MATCH_YES
)
2719 gfc_syntax_error (ST_DO
);
2723 new_st
.op
= EXEC_DO
;
2727 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2730 new_st
.label1
= label
;
2732 if (new_st
.op
== EXEC_DO_WHILE
)
2733 new_st
.expr1
= iter
.end
;
2736 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
2743 gfc_free_iterator (&iter
, 0);
2749 /* Match an EXIT or CYCLE statement. */
2752 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2754 gfc_state_data
*p
, *o
;
2759 if (gfc_match_eos () == MATCH_YES
)
2763 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2766 m
= gfc_match ("% %n%t", name
);
2767 if (m
== MATCH_ERROR
)
2771 gfc_syntax_error (st
);
2775 /* Find the corresponding symbol. If there's a BLOCK statement
2776 between here and the label, it is not in gfc_current_ns but a parent
2778 stree
= gfc_find_symtree_in_proc (name
, gfc_current_ns
);
2781 gfc_error ("Name %qs in %s statement at %C is unknown",
2782 name
, gfc_ascii_statement (st
));
2787 if (sym
->attr
.flavor
!= FL_LABEL
)
2789 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2790 name
, gfc_ascii_statement (st
));
2795 /* Find the loop specified by the label (or lack of a label). */
2796 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2797 if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2799 else if (p
->state
== COMP_CRITICAL
)
2801 gfc_error("%s statement at %C leaves CRITICAL construct",
2802 gfc_ascii_statement (st
));
2805 else if (p
->state
== COMP_DO_CONCURRENT
2806 && (op
== EXEC_EXIT
|| (sym
&& sym
!= p
->sym
)))
2808 /* F2008, C821 & C845. */
2809 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2810 gfc_ascii_statement (st
));
2813 else if ((sym
&& sym
== p
->sym
)
2814 || (!sym
&& (p
->state
== COMP_DO
2815 || p
->state
== COMP_DO_CONCURRENT
)))
2821 gfc_error ("%s statement at %C is not within a construct",
2822 gfc_ascii_statement (st
));
2824 gfc_error ("%s statement at %C is not within construct %qs",
2825 gfc_ascii_statement (st
), sym
->name
);
2830 /* Special checks for EXIT from non-loop constructs. */
2834 case COMP_DO_CONCURRENT
:
2838 /* This is already handled above. */
2841 case COMP_ASSOCIATE
:
2845 case COMP_SELECT_TYPE
:
2846 case COMP_SELECT_RANK
:
2848 if (op
== EXEC_CYCLE
)
2850 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2851 " construct %qs", sym
->name
);
2854 gcc_assert (op
== EXEC_EXIT
);
2855 if (!gfc_notify_std (GFC_STD_F2008
, "EXIT statement with no"
2856 " do-construct-name at %C"))
2861 gfc_error ("%s statement at %C is not applicable to construct %qs",
2862 gfc_ascii_statement (st
), sym
->name
);
2868 gfc_error (is_oacc (p
)
2869 ? G_("%s statement at %C leaving OpenACC structured block")
2870 : G_("%s statement at %C leaving OpenMP structured block"),
2871 gfc_ascii_statement (st
));
2875 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2879 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
2880 && (o
->head
->op
== EXEC_OACC_LOOP
2881 || o
->head
->op
== EXEC_OACC_PARALLEL_LOOP
2882 || o
->head
->op
== EXEC_OACC_SERIAL_LOOP
))
2885 gcc_assert (o
->head
->next
!= NULL
2886 && (o
->head
->next
->op
== EXEC_DO
2887 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2888 && o
->previous
!= NULL
2889 && o
->previous
->tail
->op
== o
->head
->op
);
2890 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2891 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2892 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2893 if (st
== ST_EXIT
&& cnt
<= collapse
)
2895 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2898 if (st
== ST_CYCLE
&& cnt
< collapse
)
2900 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2901 " !$ACC LOOP loop");
2907 && (o
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2908 && (o
->head
->op
== EXEC_OMP_DO
2909 || o
->head
->op
== EXEC_OMP_PARALLEL_DO
2910 || o
->head
->op
== EXEC_OMP_SIMD
2911 || o
->head
->op
== EXEC_OMP_DO_SIMD
2912 || o
->head
->op
== EXEC_OMP_PARALLEL_DO_SIMD
))
2915 gcc_assert (o
->head
->next
!= NULL
2916 && (o
->head
->next
->op
== EXEC_DO
2917 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2918 && o
->previous
!= NULL
2919 && o
->previous
->tail
->op
== o
->head
->op
);
2920 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
)
2922 if (o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2923 count
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2924 if (o
->previous
->tail
->ext
.omp_clauses
->orderedc
)
2925 count
= o
->previous
->tail
->ext
.omp_clauses
->orderedc
;
2927 if (st
== ST_EXIT
&& cnt
<= count
)
2929 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2932 if (st
== ST_CYCLE
&& cnt
< count
)
2934 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2940 /* Save the first statement in the construct - needed by the backend. */
2941 new_st
.ext
.which_construct
= p
->construct
;
2949 /* Match the EXIT statement. */
2952 gfc_match_exit (void)
2954 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2958 /* Match the CYCLE statement. */
2961 gfc_match_cycle (void)
2963 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2967 /* Match a stop-code after an (ERROR) STOP or PAUSE statement. The
2968 requirements for a stop-code differ in the standards.
2972 R840 stop-stmt is STOP [ stop-code ]
2973 R841 stop-code is scalar-char-constant
2974 or digit [ digit [ digit [ digit [ digit ] ] ] ]
2976 Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
2979 R855 stop-stmt is STOP [ stop-code ]
2980 R856 allstop-stmt is ALL STOP [ stop-code ]
2981 R857 stop-code is scalar-default-char-constant-expr
2982 or scalar-int-constant-expr
2984 For free-form source code, all standards contain a statement of the form:
2986 A blank shall be used to separate names, constants, or labels from
2987 adjacent keywords, names, constants, or labels.
2989 A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003,
2993 is valid, but it is invalid Fortran 2008. */
2996 gfc_match_stopcode (gfc_statement st
)
3002 /* Set f95 for -std=f95. */
3003 f95
= (gfc_option
.allow_std
== GFC_STD_OPT_F95
);
3005 /* Set f03 for -std=f2003. */
3006 f03
= (gfc_option
.allow_std
== GFC_STD_OPT_F03
);
3008 /* Set f08 for -std=f2008. */
3009 f08
= (gfc_option
.allow_std
== GFC_STD_OPT_F08
);
3011 /* Look for a blank between STOP and the stop-code for F2008 or later. */
3012 if (gfc_current_form
!= FORM_FIXED
&& !(f95
|| f03
))
3014 char c
= gfc_peek_ascii_char ();
3016 /* Look for end-of-statement. There is no stop-code. */
3017 if (c
== '\n' || c
== '!' || c
== ';')
3022 gfc_error ("Blank required in %s statement near %C",
3023 gfc_ascii_statement (st
));
3028 if (gfc_match_eos () != MATCH_YES
)
3033 /* First look for the F95 or F2003 digit [...] construct. */
3034 old_locus
= gfc_current_locus
;
3035 m
= gfc_match_small_int (&stopcode
);
3036 if (m
== MATCH_YES
&& (f95
|| f03
))
3040 gfc_error ("STOP code at %C cannot be negative");
3044 if (stopcode
> 99999)
3046 gfc_error ("STOP code at %C contains too many digits");
3051 /* Reset the locus and now load gfc_expr. */
3052 gfc_current_locus
= old_locus
;
3053 m
= gfc_match_expr (&e
);
3054 if (m
== MATCH_ERROR
)
3059 if (gfc_match_eos () != MATCH_YES
)
3063 if (gfc_pure (NULL
))
3065 if (st
== ST_ERROR_STOP
)
3067 if (!gfc_notify_std (GFC_STD_F2018
, "%s statement at %C in PURE "
3068 "procedure", gfc_ascii_statement (st
)))
3073 gfc_error ("%s statement not allowed in PURE procedure at %C",
3074 gfc_ascii_statement (st
));
3079 gfc_unset_implicit_pure (NULL
);
3081 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
))
3083 gfc_error ("Image control statement STOP at %C in CRITICAL block");
3086 if (st
== ST_STOP
&& gfc_find_state (COMP_DO_CONCURRENT
))
3088 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
3094 if (!gfc_simplify_expr (e
, 0))
3097 /* Test for F95 and F2003 style STOP stop-code. */
3098 if (e
->expr_type
!= EXPR_CONSTANT
&& (f95
|| f03
))
3100 gfc_error ("STOP code at %L must be a scalar CHARACTER constant "
3101 "or digit[digit[digit[digit[digit]]]]", &e
->where
);
3105 /* Use the machinery for an initialization expression to reduce the
3106 stop-code to a constant. */
3107 gfc_reduce_init_expr (e
);
3109 /* Test for F2008 style STOP stop-code. */
3110 if (e
->expr_type
!= EXPR_CONSTANT
&& f08
)
3112 gfc_error ("STOP code at %L must be a scalar default CHARACTER or "
3113 "INTEGER constant expression", &e
->where
);
3117 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
3119 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
3126 gfc_error ("STOP code at %L must be scalar", &e
->where
);
3130 if (e
->ts
.type
== BT_CHARACTER
3131 && e
->ts
.kind
!= gfc_default_character_kind
)
3133 gfc_error ("STOP code at %L must be default character KIND=%d",
3134 &e
->where
, (int) gfc_default_character_kind
);
3138 if (e
->ts
.type
== BT_INTEGER
&& e
->ts
.kind
!= gfc_default_integer_kind
)
3140 gfc_error ("STOP code at %L must be default integer KIND=%d",
3141 &e
->where
, (int) gfc_default_integer_kind
);
3151 new_st
.op
= EXEC_STOP
;
3154 new_st
.op
= EXEC_ERROR_STOP
;
3157 new_st
.op
= EXEC_PAUSE
;
3164 new_st
.ext
.stop_code
= -1;
3169 gfc_syntax_error (st
);
3178 /* Match the (deprecated) PAUSE statement. */
3181 gfc_match_pause (void)
3185 m
= gfc_match_stopcode (ST_PAUSE
);
3188 if (!gfc_notify_std (GFC_STD_F95_DEL
, "PAUSE statement at %C"))
3195 /* Match the STOP statement. */
3198 gfc_match_stop (void)
3200 return gfc_match_stopcode (ST_STOP
);
3204 /* Match the ERROR STOP statement. */
3207 gfc_match_error_stop (void)
3209 if (!gfc_notify_std (GFC_STD_F2008
, "ERROR STOP statement at %C"))
3212 return gfc_match_stopcode (ST_ERROR_STOP
);
3215 /* Match EVENT POST/WAIT statement. Syntax:
3216 EVENT POST ( event-variable [, sync-stat-list] )
3217 EVENT WAIT ( event-variable [, wait-spec-list] )
3219 wait-spec-list is sync-stat-list or until-spec
3220 until-spec is UNTIL_COUNT = scalar-int-expr
3221 sync-stat is STAT= or ERRMSG=. */
3224 event_statement (gfc_statement st
)
3227 gfc_expr
*tmp
, *eventvar
, *until_count
, *stat
, *errmsg
;
3228 bool saw_until_count
, saw_stat
, saw_errmsg
;
3230 tmp
= eventvar
= until_count
= stat
= errmsg
= NULL
;
3231 saw_until_count
= saw_stat
= saw_errmsg
= false;
3233 if (gfc_pure (NULL
))
3235 gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
3236 st
== ST_EVENT_POST
? "POST" : "WAIT");
3240 gfc_unset_implicit_pure (NULL
);
3242 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3244 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3248 if (gfc_find_state (COMP_CRITICAL
))
3250 gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
3251 st
== ST_EVENT_POST
? "POST" : "WAIT");
3255 if (gfc_find_state (COMP_DO_CONCURRENT
))
3257 gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
3258 "block", st
== ST_EVENT_POST
? "POST" : "WAIT");
3262 if (gfc_match_char ('(') != MATCH_YES
)
3265 if (gfc_match ("%e", &eventvar
) != MATCH_YES
)
3267 m
= gfc_match_char (',');
3268 if (m
== MATCH_ERROR
)
3272 m
= gfc_match_char (')');
3280 m
= gfc_match (" stat = %v", &tmp
);
3281 if (m
== MATCH_ERROR
)
3287 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3293 m
= gfc_match_char (',');
3301 m
= gfc_match (" errmsg = %v", &tmp
);
3302 if (m
== MATCH_ERROR
)
3308 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3314 m
= gfc_match_char (',');
3322 m
= gfc_match (" until_count = %e", &tmp
);
3323 if (m
== MATCH_ERROR
|| st
== ST_EVENT_POST
)
3327 if (saw_until_count
)
3329 gfc_error ("Redundant UNTIL_COUNT tag found at %L",
3334 saw_until_count
= true;
3336 m
= gfc_match_char (',');
3347 if (m
== MATCH_ERROR
)
3350 if (gfc_match (" )%t") != MATCH_YES
)
3357 new_st
.op
= EXEC_EVENT_POST
;
3360 new_st
.op
= EXEC_EVENT_WAIT
;
3366 new_st
.expr1
= eventvar
;
3367 new_st
.expr2
= stat
;
3368 new_st
.expr3
= errmsg
;
3369 new_st
.expr4
= until_count
;
3374 gfc_syntax_error (st
);
3377 if (until_count
!= tmp
)
3378 gfc_free_expr (until_count
);
3380 gfc_free_expr (errmsg
);
3382 gfc_free_expr (stat
);
3384 gfc_free_expr (tmp
);
3385 gfc_free_expr (eventvar
);
3393 gfc_match_event_post (void)
3395 if (!gfc_notify_std (GFC_STD_F2018
, "EVENT POST statement at %C"))
3398 return event_statement (ST_EVENT_POST
);
3403 gfc_match_event_wait (void)
3405 if (!gfc_notify_std (GFC_STD_F2018
, "EVENT WAIT statement at %C"))
3408 return event_statement (ST_EVENT_WAIT
);
3412 /* Match a FAIL IMAGE statement. */
3415 gfc_match_fail_image (void)
3417 if (!gfc_notify_std (GFC_STD_F2018
, "FAIL IMAGE statement at %C"))
3420 if (gfc_match_char ('(') == MATCH_YES
)
3423 new_st
.op
= EXEC_FAIL_IMAGE
;
3428 gfc_syntax_error (ST_FAIL_IMAGE
);
3433 /* Match a FORM TEAM statement. */
3436 gfc_match_form_team (void)
3439 gfc_expr
*teamid
,*team
;
3441 if (!gfc_notify_std (GFC_STD_F2018
, "FORM TEAM statement at %C"))
3444 if (gfc_match_char ('(') == MATCH_NO
)
3447 new_st
.op
= EXEC_FORM_TEAM
;
3449 if (gfc_match ("%e", &teamid
) != MATCH_YES
)
3451 m
= gfc_match_char (',');
3452 if (m
== MATCH_ERROR
)
3454 if (gfc_match ("%e", &team
) != MATCH_YES
)
3457 m
= gfc_match_char (')');
3461 new_st
.expr1
= teamid
;
3462 new_st
.expr2
= team
;
3467 gfc_syntax_error (ST_FORM_TEAM
);
3472 /* Match a CHANGE TEAM statement. */
3475 gfc_match_change_team (void)
3480 if (!gfc_notify_std (GFC_STD_F2018
, "CHANGE TEAM statement at %C"))
3483 if (gfc_match_char ('(') == MATCH_NO
)
3486 new_st
.op
= EXEC_CHANGE_TEAM
;
3488 if (gfc_match ("%e", &team
) != MATCH_YES
)
3491 m
= gfc_match_char (')');
3495 new_st
.expr1
= team
;
3500 gfc_syntax_error (ST_CHANGE_TEAM
);
3505 /* Match a END TEAM statement. */
3508 gfc_match_end_team (void)
3510 if (!gfc_notify_std (GFC_STD_F2018
, "END TEAM statement at %C"))
3513 if (gfc_match_char ('(') == MATCH_YES
)
3516 new_st
.op
= EXEC_END_TEAM
;
3521 gfc_syntax_error (ST_END_TEAM
);
3526 /* Match a SYNC TEAM statement. */
3529 gfc_match_sync_team (void)
3534 if (!gfc_notify_std (GFC_STD_F2018
, "SYNC TEAM statement at %C"))
3537 if (gfc_match_char ('(') == MATCH_NO
)
3540 new_st
.op
= EXEC_SYNC_TEAM
;
3542 if (gfc_match ("%e", &team
) != MATCH_YES
)
3545 m
= gfc_match_char (')');
3549 new_st
.expr1
= team
;
3554 gfc_syntax_error (ST_SYNC_TEAM
);
3559 /* Match LOCK/UNLOCK statement. Syntax:
3560 LOCK ( lock-variable [ , lock-stat-list ] )
3561 UNLOCK ( lock-variable [ , sync-stat-list ] )
3562 where lock-stat is ACQUIRED_LOCK or sync-stat
3563 and sync-stat is STAT= or ERRMSG=. */
3566 lock_unlock_statement (gfc_statement st
)
3569 gfc_expr
*tmp
, *lockvar
, *acq_lock
, *stat
, *errmsg
;
3570 bool saw_acq_lock
, saw_stat
, saw_errmsg
;
3572 tmp
= lockvar
= acq_lock
= stat
= errmsg
= NULL
;
3573 saw_acq_lock
= saw_stat
= saw_errmsg
= false;
3575 if (gfc_pure (NULL
))
3577 gfc_error ("Image control statement %s at %C in PURE procedure",
3578 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3582 gfc_unset_implicit_pure (NULL
);
3584 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3586 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3590 if (gfc_find_state (COMP_CRITICAL
))
3592 gfc_error ("Image control statement %s at %C in CRITICAL block",
3593 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3597 if (gfc_find_state (COMP_DO_CONCURRENT
))
3599 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
3600 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3604 if (gfc_match_char ('(') != MATCH_YES
)
3607 if (gfc_match ("%e", &lockvar
) != MATCH_YES
)
3609 m
= gfc_match_char (',');
3610 if (m
== MATCH_ERROR
)
3614 m
= gfc_match_char (')');
3622 m
= gfc_match (" stat = %v", &tmp
);
3623 if (m
== MATCH_ERROR
)
3629 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3635 m
= gfc_match_char (',');
3643 m
= gfc_match (" errmsg = %v", &tmp
);
3644 if (m
== MATCH_ERROR
)
3650 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3656 m
= gfc_match_char (',');
3664 m
= gfc_match (" acquired_lock = %v", &tmp
);
3665 if (m
== MATCH_ERROR
|| st
== ST_UNLOCK
)
3671 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L",
3676 saw_acq_lock
= true;
3678 m
= gfc_match_char (',');
3689 if (m
== MATCH_ERROR
)
3692 if (gfc_match (" )%t") != MATCH_YES
)
3699 new_st
.op
= EXEC_LOCK
;
3702 new_st
.op
= EXEC_UNLOCK
;
3708 new_st
.expr1
= lockvar
;
3709 new_st
.expr2
= stat
;
3710 new_st
.expr3
= errmsg
;
3711 new_st
.expr4
= acq_lock
;
3716 gfc_syntax_error (st
);
3719 if (acq_lock
!= tmp
)
3720 gfc_free_expr (acq_lock
);
3722 gfc_free_expr (errmsg
);
3724 gfc_free_expr (stat
);
3726 gfc_free_expr (tmp
);
3727 gfc_free_expr (lockvar
);
3734 gfc_match_lock (void)
3736 if (!gfc_notify_std (GFC_STD_F2008
, "LOCK statement at %C"))
3739 return lock_unlock_statement (ST_LOCK
);
3744 gfc_match_unlock (void)
3746 if (!gfc_notify_std (GFC_STD_F2008
, "UNLOCK statement at %C"))
3749 return lock_unlock_statement (ST_UNLOCK
);
3753 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
3754 SYNC ALL [(sync-stat-list)]
3755 SYNC MEMORY [(sync-stat-list)]
3756 SYNC IMAGES (image-set [, sync-stat-list] )
3757 with sync-stat is int-expr or *. */
3760 sync_statement (gfc_statement st
)
3763 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
3764 bool saw_stat
, saw_errmsg
;
3766 tmp
= imageset
= stat
= errmsg
= NULL
;
3767 saw_stat
= saw_errmsg
= false;
3769 if (gfc_pure (NULL
))
3771 gfc_error ("Image control statement SYNC at %C in PURE procedure");
3775 gfc_unset_implicit_pure (NULL
);
3777 if (!gfc_notify_std (GFC_STD_F2008
, "SYNC statement at %C"))
3780 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3782 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
3787 if (gfc_find_state (COMP_CRITICAL
))
3789 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3793 if (gfc_find_state (COMP_DO_CONCURRENT
))
3795 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3799 if (gfc_match_eos () == MATCH_YES
)
3801 if (st
== ST_SYNC_IMAGES
)
3806 if (gfc_match_char ('(') != MATCH_YES
)
3809 if (st
== ST_SYNC_IMAGES
)
3811 /* Denote '*' as imageset == NULL. */
3812 m
= gfc_match_char ('*');
3813 if (m
== MATCH_ERROR
)
3817 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
3820 m
= gfc_match_char (',');
3821 if (m
== MATCH_ERROR
)
3825 m
= gfc_match_char (')');
3834 m
= gfc_match (" stat = %v", &tmp
);
3835 if (m
== MATCH_ERROR
)
3841 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3847 if (gfc_match_char (',') == MATCH_YES
)
3854 m
= gfc_match (" errmsg = %v", &tmp
);
3855 if (m
== MATCH_ERROR
)
3861 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3867 if (gfc_match_char (',') == MATCH_YES
)
3877 if (gfc_match (" )%t") != MATCH_YES
)
3884 new_st
.op
= EXEC_SYNC_ALL
;
3886 case ST_SYNC_IMAGES
:
3887 new_st
.op
= EXEC_SYNC_IMAGES
;
3889 case ST_SYNC_MEMORY
:
3890 new_st
.op
= EXEC_SYNC_MEMORY
;
3896 new_st
.expr1
= imageset
;
3897 new_st
.expr2
= stat
;
3898 new_st
.expr3
= errmsg
;
3903 gfc_syntax_error (st
);
3907 gfc_free_expr (stat
);
3909 gfc_free_expr (errmsg
);
3911 gfc_free_expr (tmp
);
3912 gfc_free_expr (imageset
);
3918 /* Match SYNC ALL statement. */
3921 gfc_match_sync_all (void)
3923 return sync_statement (ST_SYNC_ALL
);
3927 /* Match SYNC IMAGES statement. */
3930 gfc_match_sync_images (void)
3932 return sync_statement (ST_SYNC_IMAGES
);
3936 /* Match SYNC MEMORY statement. */
3939 gfc_match_sync_memory (void)
3941 return sync_statement (ST_SYNC_MEMORY
);
3945 /* Match a CONTINUE statement. */
3948 gfc_match_continue (void)
3950 if (gfc_match_eos () != MATCH_YES
)
3952 gfc_syntax_error (ST_CONTINUE
);
3956 new_st
.op
= EXEC_CONTINUE
;
3961 /* Match the (deprecated) ASSIGN statement. */
3964 gfc_match_assign (void)
3967 gfc_st_label
*label
;
3969 if (gfc_match (" %l", &label
) == MATCH_YES
)
3971 if (!gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
))
3973 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
3975 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGN statement at %C"))
3978 expr
->symtree
->n
.sym
->attr
.assign
= 1;
3980 new_st
.op
= EXEC_LABEL_ASSIGN
;
3981 new_st
.label1
= label
;
3982 new_st
.expr1
= expr
;
3990 /* Match the GO TO statement. As a computed GOTO statement is
3991 matched, it is transformed into an equivalent SELECT block. No
3992 tree is necessary, and the resulting jumps-to-jumps are
3993 specifically optimized away by the back end. */
3996 gfc_match_goto (void)
3998 gfc_code
*head
, *tail
;
4001 gfc_st_label
*label
;
4005 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
4007 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
4010 new_st
.op
= EXEC_GOTO
;
4011 new_st
.label1
= label
;
4015 /* The assigned GO TO statement. */
4017 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
4019 if (!gfc_notify_std (GFC_STD_F95_DEL
, "Assigned GOTO statement at %C"))
4022 new_st
.op
= EXEC_GOTO
;
4023 new_st
.expr1
= expr
;
4025 if (gfc_match_eos () == MATCH_YES
)
4028 /* Match label list. */
4029 gfc_match_char (',');
4030 if (gfc_match_char ('(') != MATCH_YES
)
4032 gfc_syntax_error (ST_GOTO
);
4039 m
= gfc_match_st_label (&label
);
4043 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
4047 head
= tail
= gfc_get_code (EXEC_GOTO
);
4050 tail
->block
= gfc_get_code (EXEC_GOTO
);
4054 tail
->label1
= label
;
4056 while (gfc_match_char (',') == MATCH_YES
);
4058 if (gfc_match (")%t") != MATCH_YES
)
4063 gfc_error ("Statement label list in GOTO at %C cannot be empty");
4066 new_st
.block
= head
;
4071 /* Last chance is a computed GO TO statement. */
4072 if (gfc_match_char ('(') != MATCH_YES
)
4074 gfc_syntax_error (ST_GOTO
);
4083 m
= gfc_match_st_label (&label
);
4087 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
4091 head
= tail
= gfc_get_code (EXEC_SELECT
);
4094 tail
->block
= gfc_get_code (EXEC_SELECT
);
4098 cp
= gfc_get_case ();
4099 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
4102 tail
->ext
.block
.case_list
= cp
;
4104 tail
->next
= gfc_get_code (EXEC_GOTO
);
4105 tail
->next
->label1
= label
;
4107 while (gfc_match_char (',') == MATCH_YES
);
4109 if (gfc_match_char (')') != MATCH_YES
)
4114 gfc_error ("Statement label list in GOTO at %C cannot be empty");
4118 /* Get the rest of the statement. */
4119 gfc_match_char (',');
4121 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
4124 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Computed GOTO at %C"))
4127 /* At this point, a computed GOTO has been fully matched and an
4128 equivalent SELECT statement constructed. */
4130 new_st
.op
= EXEC_SELECT
;
4131 new_st
.expr1
= NULL
;
4133 /* Hack: For a "real" SELECT, the expression is in expr. We put
4134 it in expr2 so we can distinguish then and produce the correct
4136 new_st
.expr2
= expr
;
4137 new_st
.block
= head
;
4141 gfc_syntax_error (ST_GOTO
);
4143 gfc_free_statements (head
);
4148 /* Frees a list of gfc_alloc structures. */
4151 gfc_free_alloc_list (gfc_alloc
*p
)
4158 gfc_free_expr (p
->expr
);
4164 /* Match an ALLOCATE statement. */
4167 gfc_match_allocate (void)
4169 gfc_alloc
*head
, *tail
;
4170 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
4174 locus old_locus
, deferred_locus
, assumed_locus
;
4175 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, saw_deferred
, b1
, b2
, b3
;
4176 bool saw_unlimited
= false, saw_assumed
= false;
4179 stat
= errmsg
= source
= mold
= tmp
= NULL
;
4180 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= saw_deferred
= false;
4182 if (gfc_match_char ('(') != MATCH_YES
)
4184 gfc_syntax_error (ST_ALLOCATE
);
4188 /* Match an optional type-spec. */
4189 old_locus
= gfc_current_locus
;
4190 m
= gfc_match_type_spec (&ts
);
4191 if (m
== MATCH_ERROR
)
4193 else if (m
== MATCH_NO
)
4195 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
4197 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
4199 gfc_error ("Error in type-spec at %L", &old_locus
);
4203 ts
.type
= BT_UNKNOWN
;
4207 /* Needed for the F2008:C631 check below. */
4208 assumed_locus
= gfc_current_locus
;
4210 if (gfc_match (" :: ") == MATCH_YES
)
4212 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
4218 gfc_error ("Type-spec at %L cannot contain a deferred "
4219 "type parameter", &old_locus
);
4223 if (ts
.type
== BT_CHARACTER
)
4225 if (!ts
.u
.cl
->length
)
4228 ts
.u
.cl
->length_from_typespec
= true;
4231 if (type_param_spec_list
4232 && gfc_spec_list_type (type_param_spec_list
, NULL
)
4235 gfc_error ("The type parameter spec list in the type-spec at "
4236 "%L cannot contain DEFERRED parameters", &old_locus
);
4242 ts
.type
= BT_UNKNOWN
;
4243 gfc_current_locus
= old_locus
;
4250 head
= tail
= gfc_get_alloc ();
4253 tail
->next
= gfc_get_alloc ();
4257 m
= gfc_match_variable (&tail
->expr
, 0);
4260 if (m
== MATCH_ERROR
)
4263 if (tail
->expr
->expr_type
== EXPR_CONSTANT
)
4265 gfc_error ("Unexpected constant at %C");
4269 if (gfc_check_do_variable (tail
->expr
->symtree
))
4272 bool impure
= gfc_impure_variable (tail
->expr
->symtree
->n
.sym
);
4273 if (impure
&& gfc_pure (NULL
))
4275 gfc_error ("Bad allocate-object at %C for a PURE procedure");
4280 gfc_unset_implicit_pure (NULL
);
4282 /* F2008:C631 (R626) A type-param-value in a type-spec shall be an
4283 asterisk if and only if each allocate-object is a dummy argument
4284 for which the corresponding type parameter is assumed. */
4286 && (tail
->expr
->ts
.deferred
4287 || (tail
->expr
->ts
.u
.cl
&& tail
->expr
->ts
.u
.cl
->length
)
4288 || tail
->expr
->symtree
->n
.sym
->attr
.dummy
== 0))
4290 gfc_error ("Incompatible allocate-object at %C for CHARACTER "
4291 "type-spec at %L", &assumed_locus
);
4295 if (tail
->expr
->ts
.deferred
)
4297 saw_deferred
= true;
4298 deferred_locus
= tail
->expr
->where
;
4301 if (gfc_find_state (COMP_DO_CONCURRENT
)
4302 || gfc_find_state (COMP_CRITICAL
))
4305 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
4306 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
4307 if (ref
->type
== REF_COMPONENT
)
4308 coarray
= ref
->u
.c
.component
->attr
.codimension
;
4310 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
4312 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
4315 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
4317 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
4322 /* Check for F08:C628. */
4323 sym
= tail
->expr
->symtree
->n
.sym
;
4324 b1
= !(tail
->expr
->ref
4325 && (tail
->expr
->ref
->type
== REF_COMPONENT
4326 || tail
->expr
->ref
->type
== REF_ARRAY
));
4327 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4328 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
4329 || CLASS_DATA (sym
)->attr
.class_pointer
);
4331 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4332 || sym
->attr
.proc_pointer
);
4333 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
4334 && (sym
->ns
->proc_name
->attr
.allocatable
4335 || sym
->ns
->proc_name
->attr
.pointer
4336 || sym
->ns
->proc_name
->attr
.proc_pointer
);
4337 if (b1
&& b2
&& !b3
)
4339 gfc_error ("Allocate-object at %L is neither a data pointer "
4340 "nor an allocatable variable", &tail
->expr
->where
);
4344 /* The ALLOCATE statement had an optional typespec. Check the
4346 if (ts
.type
!= BT_UNKNOWN
)
4348 /* Enforce F03:C624. */
4349 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
4351 gfc_error ("Type of entity at %L is type incompatible with "
4352 "typespec", &tail
->expr
->where
);
4356 /* Enforce F03:C627. */
4357 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
4359 gfc_error ("Kind type parameter for entity at %L differs from "
4360 "the kind type parameter of the typespec",
4361 &tail
->expr
->where
);
4366 if (tail
->expr
->ts
.type
== BT_DERIVED
)
4367 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
4369 if (type_param_spec_list
)
4370 tail
->expr
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
4372 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
4374 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
4376 gfc_error ("Shape specification for allocatable scalar at %C");
4380 if (gfc_match_char (',') != MATCH_YES
)
4385 m
= gfc_match (" stat = %v", &tmp
);
4386 if (m
== MATCH_ERROR
)
4393 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4401 if (stat
->expr_type
== EXPR_CONSTANT
)
4403 gfc_error ("STAT tag at %L cannot be a constant", &stat
->where
);
4407 if (gfc_check_do_variable (stat
->symtree
))
4410 if (gfc_match_char (',') == MATCH_YES
)
4411 goto alloc_opt_list
;
4414 m
= gfc_match (" errmsg = %v", &tmp
);
4415 if (m
== MATCH_ERROR
)
4419 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
4425 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4433 if (gfc_match_char (',') == MATCH_YES
)
4434 goto alloc_opt_list
;
4437 m
= gfc_match (" source = %e", &tmp
);
4438 if (m
== MATCH_ERROR
)
4442 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
4448 gfc_error ("Redundant SOURCE tag found at %L", &tmp
->where
);
4452 /* The next 2 conditionals check C631. */
4453 if (ts
.type
!= BT_UNKNOWN
)
4455 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
4456 &tmp
->where
, &old_locus
);
4461 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
4462 " with more than a single allocate object",
4470 if (gfc_match_char (',') == MATCH_YES
)
4471 goto alloc_opt_list
;
4474 m
= gfc_match (" mold = %e", &tmp
);
4475 if (m
== MATCH_ERROR
)
4479 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
4482 /* Check F08:C636. */
4485 gfc_error ("Redundant MOLD tag found at %L", &tmp
->where
);
4489 /* Check F08:C637. */
4490 if (ts
.type
!= BT_UNKNOWN
)
4492 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
4493 &tmp
->where
, &old_locus
);
4502 if (gfc_match_char (',') == MATCH_YES
)
4503 goto alloc_opt_list
;
4506 gfc_gobble_whitespace ();
4508 if (gfc_peek_char () == ')')
4512 if (gfc_match (" )%t") != MATCH_YES
)
4515 /* Check F08:C637. */
4518 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
4519 &mold
->where
, &source
->where
);
4523 /* Check F03:C623, */
4524 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4526 gfc_error ("Allocate-object at %L with a deferred type parameter "
4527 "requires either a type-spec or SOURCE tag or a MOLD tag",
4532 /* Check F03:C625, */
4533 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4535 for (tail
= head
; tail
; tail
= tail
->next
)
4537 if (UNLIMITED_POLY (tail
->expr
))
4538 gfc_error ("Unlimited polymorphic allocate-object at %L "
4539 "requires either a type-spec or SOURCE tag "
4540 "or a MOLD tag", &tail
->expr
->where
);
4545 new_st
.op
= EXEC_ALLOCATE
;
4546 new_st
.expr1
= stat
;
4547 new_st
.expr2
= errmsg
;
4549 new_st
.expr3
= source
;
4551 new_st
.expr3
= mold
;
4552 new_st
.ext
.alloc
.list
= head
;
4553 new_st
.ext
.alloc
.ts
= ts
;
4555 if (type_param_spec_list
)
4556 gfc_free_actual_arglist (type_param_spec_list
);
4561 gfc_syntax_error (ST_ALLOCATE
);
4564 gfc_free_expr (errmsg
);
4565 gfc_free_expr (source
);
4566 gfc_free_expr (stat
);
4567 gfc_free_expr (mold
);
4568 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
4569 gfc_free_alloc_list (head
);
4570 if (type_param_spec_list
)
4571 gfc_free_actual_arglist (type_param_spec_list
);
4576 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
4577 a set of pointer assignments to intrinsic NULL(). */
4580 gfc_match_nullify (void)
4588 if (gfc_match_char ('(') != MATCH_YES
)
4593 m
= gfc_match_variable (&p
, 0);
4594 if (m
== MATCH_ERROR
)
4599 if (gfc_check_do_variable (p
->symtree
))
4603 if (gfc_is_coindexed (p
))
4605 gfc_error ("Pointer object at %C shall not be coindexed");
4609 /* Check for valid array pointer object. Bounds remapping is not
4610 allowed with NULLIFY. */
4613 gfc_ref
*remap
= p
->ref
;
4614 for (; remap
; remap
= remap
->next
)
4615 if (!remap
->next
&& remap
->type
== REF_ARRAY
4616 && remap
->u
.ar
.type
!= AR_FULL
)
4620 gfc_error ("NULLIFY does not allow bounds remapping for "
4621 "pointer object at %C");
4626 /* build ' => NULL() '. */
4627 e
= gfc_get_null_expr (&gfc_current_locus
);
4629 /* Chain to list. */
4633 tail
->op
= EXEC_POINTER_ASSIGN
;
4637 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
4644 if (gfc_match (" )%t") == MATCH_YES
)
4646 if (gfc_match_char (',') != MATCH_YES
)
4653 gfc_syntax_error (ST_NULLIFY
);
4656 gfc_free_statements (new_st
.next
);
4658 gfc_free_expr (new_st
.expr1
);
4659 new_st
.expr1
= NULL
;
4660 gfc_free_expr (new_st
.expr2
);
4661 new_st
.expr2
= NULL
;
4666 /* Match a DEALLOCATE statement. */
4669 gfc_match_deallocate (void)
4671 gfc_alloc
*head
, *tail
;
4672 gfc_expr
*stat
, *errmsg
, *tmp
;
4675 bool saw_stat
, saw_errmsg
, b1
, b2
;
4678 stat
= errmsg
= tmp
= NULL
;
4679 saw_stat
= saw_errmsg
= false;
4681 if (gfc_match_char ('(') != MATCH_YES
)
4687 head
= tail
= gfc_get_alloc ();
4690 tail
->next
= gfc_get_alloc ();
4694 m
= gfc_match_variable (&tail
->expr
, 0);
4695 if (m
== MATCH_ERROR
)
4700 if (tail
->expr
->expr_type
== EXPR_CONSTANT
)
4702 gfc_error ("Unexpected constant at %C");
4706 if (gfc_check_do_variable (tail
->expr
->symtree
))
4709 sym
= tail
->expr
->symtree
->n
.sym
;
4711 bool impure
= gfc_impure_variable (sym
);
4712 if (impure
&& gfc_pure (NULL
))
4714 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
4719 gfc_unset_implicit_pure (NULL
);
4721 if (gfc_is_coarray (tail
->expr
)
4722 && gfc_find_state (COMP_DO_CONCURRENT
))
4724 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
4728 if (gfc_is_coarray (tail
->expr
)
4729 && gfc_find_state (COMP_CRITICAL
))
4731 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
4735 /* FIXME: disable the checking on derived types. */
4736 b1
= !(tail
->expr
->ref
4737 && (tail
->expr
->ref
->type
== REF_COMPONENT
4738 || tail
->expr
->ref
->type
== REF_ARRAY
));
4739 if (sym
&& sym
->ts
.type
== BT_CLASS
)
4740 b2
= !(CLASS_DATA (sym
) && (CLASS_DATA (sym
)->attr
.allocatable
4741 || CLASS_DATA (sym
)->attr
.class_pointer
));
4743 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4744 || sym
->attr
.proc_pointer
);
4747 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
4748 "nor an allocatable variable");
4752 if (gfc_match_char (',') != MATCH_YES
)
4757 m
= gfc_match (" stat = %v", &tmp
);
4758 if (m
== MATCH_ERROR
)
4764 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4765 gfc_free_expr (tmp
);
4772 if (gfc_check_do_variable (stat
->symtree
))
4775 if (gfc_match_char (',') == MATCH_YES
)
4776 goto dealloc_opt_list
;
4779 m
= gfc_match (" errmsg = %v", &tmp
);
4780 if (m
== MATCH_ERROR
)
4784 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
4789 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4790 gfc_free_expr (tmp
);
4797 if (gfc_match_char (',') == MATCH_YES
)
4798 goto dealloc_opt_list
;
4801 gfc_gobble_whitespace ();
4803 if (gfc_peek_char () == ')')
4807 if (gfc_match (" )%t") != MATCH_YES
)
4810 new_st
.op
= EXEC_DEALLOCATE
;
4811 new_st
.expr1
= stat
;
4812 new_st
.expr2
= errmsg
;
4813 new_st
.ext
.alloc
.list
= head
;
4818 gfc_syntax_error (ST_DEALLOCATE
);
4821 gfc_free_expr (errmsg
);
4822 gfc_free_expr (stat
);
4823 gfc_free_alloc_list (head
);
4828 /* Match a RETURN statement. */
4831 gfc_match_return (void)
4835 gfc_compile_state s
;
4839 if (gfc_find_state (COMP_CRITICAL
))
4841 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4845 if (gfc_find_state (COMP_DO_CONCURRENT
))
4847 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4851 if (gfc_match_eos () == MATCH_YES
)
4854 if (!gfc_find_state (COMP_SUBROUTINE
))
4856 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4861 if (gfc_current_form
== FORM_FREE
)
4863 /* The following are valid, so we can't require a blank after the
4867 char c
= gfc_peek_ascii_char ();
4868 if (ISALPHA (c
) || ISDIGIT (c
))
4872 m
= gfc_match (" %e%t", &e
);
4875 if (m
== MATCH_ERROR
)
4878 gfc_syntax_error (ST_RETURN
);
4885 gfc_enclosing_unit (&s
);
4886 if (s
== COMP_PROGRAM
4887 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
4888 "main program at %C"))
4891 new_st
.op
= EXEC_RETURN
;
4898 /* Match the call of a type-bound procedure, if CALL%var has already been
4899 matched and var found to be a derived-type variable. */
4902 match_typebound_call (gfc_symtree
* varst
)
4907 base
= gfc_get_expr ();
4908 base
->expr_type
= EXPR_VARIABLE
;
4909 base
->symtree
= varst
;
4910 base
->where
= gfc_current_locus
;
4911 gfc_set_sym_referenced (varst
->n
.sym
);
4913 m
= gfc_match_varspec (base
, 0, true, true);
4915 gfc_error ("Expected component reference at %C");
4918 gfc_free_expr (base
);
4922 if (gfc_match_eos () != MATCH_YES
)
4924 gfc_error ("Junk after CALL at %C");
4925 gfc_free_expr (base
);
4929 if (base
->expr_type
== EXPR_COMPCALL
)
4930 new_st
.op
= EXEC_COMPCALL
;
4931 else if (base
->expr_type
== EXPR_PPC
)
4932 new_st
.op
= EXEC_CALL_PPC
;
4935 gfc_error ("Expected type-bound procedure or procedure pointer component "
4937 gfc_free_expr (base
);
4940 new_st
.expr1
= base
;
4946 /* Match a CALL statement. The tricky part here are possible
4947 alternate return specifiers. We handle these by having all
4948 "subroutines" actually return an integer via a register that gives
4949 the return number. If the call specifies alternate returns, we
4950 generate code for a SELECT statement whose case clauses contain
4951 GOTOs to the various labels. */
4954 gfc_match_call (void)
4956 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4957 gfc_actual_arglist
*a
, *arglist
;
4967 m
= gfc_match ("% %n", name
);
4973 if (gfc_get_ha_sym_tree (name
, &st
))
4978 /* If this is a variable of derived-type, it probably starts a type-bound
4980 if ((sym
->attr
.flavor
!= FL_PROCEDURE
4981 || gfc_is_function_return_value (sym
, gfc_current_ns
))
4982 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
4983 return match_typebound_call (st
);
4985 /* If it does not seem to be callable (include functions so that the
4986 right association is made. They are thrown out in resolution.)
4988 if (!sym
->attr
.generic
4989 && !sym
->attr
.subroutine
4990 && !sym
->attr
.function
)
4992 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
4994 /* ...create a symbol in this scope... */
4995 if (sym
->ns
!= gfc_current_ns
4996 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
4999 if (sym
!= st
->n
.sym
)
5003 /* ...and then to try to make the symbol into a subroutine. */
5004 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
5008 gfc_set_sym_referenced (sym
);
5010 if (gfc_match_eos () != MATCH_YES
)
5012 m
= gfc_match_actual_arglist (1, &arglist
);
5015 if (m
== MATCH_ERROR
)
5018 if (gfc_match_eos () != MATCH_YES
)
5022 /* Walk the argument list looking for invalid BOZ. */
5023 for (a
= arglist
; a
; a
= a
->next
)
5024 if (a
->expr
&& a
->expr
->ts
.type
== BT_BOZ
)
5026 gfc_error ("A BOZ literal constant at %L cannot appear as an actual "
5027 "argument in a subroutine reference", &a
->expr
->where
);
5032 /* If any alternate return labels were found, construct a SELECT
5033 statement that will jump to the right place. */
5036 for (a
= arglist
; a
; a
= a
->next
)
5037 if (a
->expr
== NULL
)
5045 gfc_symtree
*select_st
;
5046 gfc_symbol
*select_sym
;
5047 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5049 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
5050 sprintf (name
, "_result_%s", sym
->name
);
5051 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
5053 select_sym
= select_st
->n
.sym
;
5054 select_sym
->ts
.type
= BT_INTEGER
;
5055 select_sym
->ts
.kind
= gfc_default_integer_kind
;
5056 gfc_set_sym_referenced (select_sym
);
5057 c
->expr1
= gfc_get_expr ();
5058 c
->expr1
->expr_type
= EXPR_VARIABLE
;
5059 c
->expr1
->symtree
= select_st
;
5060 c
->expr1
->ts
= select_sym
->ts
;
5061 c
->expr1
->where
= gfc_current_locus
;
5064 for (a
= arglist
; a
; a
= a
->next
)
5066 if (a
->expr
!= NULL
)
5069 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
5074 c
->block
= gfc_get_code (EXEC_SELECT
);
5077 new_case
= gfc_get_case ();
5078 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
5079 new_case
->low
= new_case
->high
;
5080 c
->ext
.block
.case_list
= new_case
;
5082 c
->next
= gfc_get_code (EXEC_GOTO
);
5083 c
->next
->label1
= a
->label
;
5087 new_st
.op
= EXEC_CALL
;
5088 new_st
.symtree
= st
;
5089 new_st
.ext
.actual
= arglist
;
5094 gfc_syntax_error (ST_CALL
);
5097 gfc_free_actual_arglist (arglist
);
5102 /* Given a name, return a pointer to the common head structure,
5103 creating it if it does not exist. If FROM_MODULE is nonzero, we
5104 mangle the name so that it doesn't interfere with commons defined
5105 in the using namespace.
5106 TODO: Add to global symbol tree. */
5109 gfc_get_common (const char *name
, int from_module
)
5112 static int serial
= 0;
5113 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
5117 /* A use associated common block is only needed to correctly layout
5118 the variables it contains. */
5119 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
5120 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
5124 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
5127 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
5130 if (st
->n
.common
== NULL
)
5132 st
->n
.common
= gfc_get_common_head ();
5133 st
->n
.common
->where
= gfc_current_locus
;
5134 strcpy (st
->n
.common
->name
, name
);
5137 return st
->n
.common
;
5141 /* Match a common block name. */
5143 match
match_common_name (char *name
)
5147 if (gfc_match_char ('/') == MATCH_NO
)
5153 if (gfc_match_char ('/') == MATCH_YES
)
5159 m
= gfc_match_name (name
);
5161 if (m
== MATCH_ERROR
)
5163 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
5166 gfc_error ("Syntax error in common block name at %C");
5171 /* Match a COMMON statement. */
5174 gfc_match_common (void)
5176 gfc_symbol
*sym
, **head
, *tail
, *other
;
5177 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5184 /* COMMON has been matched. In free form source code, the next character
5185 needs to be whitespace or '/'. Check that here. Fixed form source
5186 code needs to be checked below. */
5187 c
= gfc_peek_ascii_char ();
5188 if (gfc_current_form
== FORM_FREE
&& !gfc_is_whitespace (c
) && c
!= '/')
5195 m
= match_common_name (name
);
5196 if (m
== MATCH_ERROR
)
5199 if (name
[0] == '\0')
5201 t
= &gfc_current_ns
->blank_common
;
5202 if (t
->head
== NULL
)
5203 t
->where
= gfc_current_locus
;
5207 t
= gfc_get_common (name
, 0);
5216 while (tail
->common_next
)
5217 tail
= tail
->common_next
;
5220 /* Grab the list of symbols. */
5223 m
= gfc_match_symbol (&sym
, 0);
5224 if (m
== MATCH_ERROR
)
5229 /* See if we know the current common block is bind(c), and if
5230 so, then see if we can check if the symbol is (which it'll
5231 need to be). This can happen if the bind(c) attr stmt was
5232 applied to the common block, and the variable(s) already
5233 defined, before declaring the common block. */
5234 if (t
->is_bind_c
== 1)
5236 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
5238 /* If we find an error, just print it and continue,
5239 cause it's just semantic, and we can see if there
5241 gfc_error_now ("Variable %qs at %L in common block %qs "
5242 "at %C must be declared with a C "
5243 "interoperable kind since common block "
5245 sym
->name
, &(sym
->declared_at
), t
->name
,
5249 if (sym
->attr
.is_bind_c
== 1)
5250 gfc_error_now ("Variable %qs in common block %qs at %C cannot "
5251 "be bind(c) since it is not global", sym
->name
,
5255 if (sym
->attr
.in_common
)
5257 gfc_error ("Symbol %qs at %C is already in a COMMON block",
5262 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
5263 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
5265 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol %qs at "
5266 "%C can only be COMMON in BLOCK DATA",
5271 /* Deal with an optional array specification after the
5273 m
= gfc_match_array_spec (&as
, true, true);
5274 if (m
== MATCH_ERROR
)
5279 if (as
->type
!= AS_EXPLICIT
)
5281 gfc_error ("Array specification for symbol %qs in COMMON "
5282 "at %C must be explicit", sym
->name
);
5286 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
5289 if (sym
->attr
.pointer
)
5291 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
5292 "POINTER array", sym
->name
);
5301 /* Add the in_common attribute, but ignore the reported errors
5302 if any, and continue matching. */
5303 gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
);
5305 sym
->common_block
= t
;
5306 sym
->common_block
->refs
++;
5309 tail
->common_next
= sym
;
5315 sym
->common_head
= t
;
5317 /* Check to see if the symbol is already in an equivalence group.
5318 If it is, set the other members as being in common. */
5319 if (sym
->attr
.in_equivalence
)
5321 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
5323 for (e2
= e1
; e2
; e2
= e2
->eq
)
5324 if (e2
->expr
->symtree
->n
.sym
== sym
)
5331 for (e2
= e1
; e2
; e2
= e2
->eq
)
5333 other
= e2
->expr
->symtree
->n
.sym
;
5334 if (other
->common_head
5335 && other
->common_head
!= sym
->common_head
)
5337 gfc_error ("Symbol %qs, in COMMON block %qs at "
5338 "%C is being indirectly equivalenced to "
5339 "another COMMON block %qs",
5340 sym
->name
, sym
->common_head
->name
,
5341 other
->common_head
->name
);
5344 other
->attr
.in_common
= 1;
5345 other
->common_head
= t
;
5351 gfc_gobble_whitespace ();
5352 if (gfc_match_eos () == MATCH_YES
)
5354 c
= gfc_peek_ascii_char ();
5359 /* In Fixed form source code, gfortran can end up here for an
5360 expression of the form COMMONI = RHS. This may not be an
5361 error, so return MATCH_NO. */
5362 if (gfc_current_form
== FORM_FIXED
&& c
== '=')
5364 gfc_free_array_spec (as
);
5370 gfc_match_char (',');
5372 gfc_gobble_whitespace ();
5373 if (gfc_peek_ascii_char () == '/')
5382 gfc_syntax_error (ST_COMMON
);
5385 gfc_free_array_spec (as
);
5390 /* Match a BLOCK DATA program unit. */
5393 gfc_match_block_data (void)
5395 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5399 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "BLOCK DATA construct at %L",
5400 &gfc_current_locus
))
5403 if (gfc_match_eos () == MATCH_YES
)
5405 gfc_new_block
= NULL
;
5409 m
= gfc_match ("% %n%t", name
);
5413 if (gfc_get_symbol (name
, NULL
, &sym
))
5416 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
5419 gfc_new_block
= sym
;
5425 /* Free a namelist structure. */
5428 gfc_free_namelist (gfc_namelist
*name
)
5432 for (; name
; name
= n
)
5440 /* Free an OpenMP namelist structure. */
5443 gfc_free_omp_namelist (gfc_omp_namelist
*name
)
5445 gfc_omp_namelist
*n
;
5447 for (; name
; name
= n
)
5449 gfc_free_expr (name
->expr
);
5452 if (name
->udr
->combiner
)
5453 gfc_free_statement (name
->udr
->combiner
);
5454 if (name
->udr
->initializer
)
5455 gfc_free_statement (name
->udr
->initializer
);
5464 /* Match a NAMELIST statement. */
5467 gfc_match_namelist (void)
5469 gfc_symbol
*group_name
, *sym
;
5473 m
= gfc_match (" / %s /", &group_name
);
5476 if (m
== MATCH_ERROR
)
5481 if (group_name
->ts
.type
!= BT_UNKNOWN
)
5483 gfc_error ("Namelist group name %qs at %C already has a basic "
5484 "type of %s", group_name
->name
,
5485 gfc_typename (&group_name
->ts
));
5489 if (group_name
->attr
.flavor
== FL_NAMELIST
5490 && group_name
->attr
.use_assoc
5491 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name %qs "
5492 "at %C already is USE associated and can"
5493 "not be respecified.", group_name
->name
))
5496 if (group_name
->attr
.flavor
!= FL_NAMELIST
5497 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
5498 group_name
->name
, NULL
))
5503 m
= gfc_match_symbol (&sym
, 1);
5506 if (m
== MATCH_ERROR
)
5509 if (sym
->attr
.in_namelist
== 0
5510 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
5513 /* Use gfc_error_check here, rather than goto error, so that
5514 these are the only errors for the next two lines. */
5515 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
5517 gfc_error ("Assumed size array %qs in namelist %qs at "
5518 "%C is not allowed", sym
->name
, group_name
->name
);
5522 nl
= gfc_get_namelist ();
5526 if (group_name
->namelist
== NULL
)
5527 group_name
->namelist
= group_name
->namelist_tail
= nl
;
5530 group_name
->namelist_tail
->next
= nl
;
5531 group_name
->namelist_tail
= nl
;
5534 if (gfc_match_eos () == MATCH_YES
)
5537 m
= gfc_match_char (',');
5539 if (gfc_match_char ('/') == MATCH_YES
)
5541 m2
= gfc_match (" %s /", &group_name
);
5542 if (m2
== MATCH_YES
)
5544 if (m2
== MATCH_ERROR
)
5558 gfc_syntax_error (ST_NAMELIST
);
5565 /* Match a MODULE statement. */
5568 gfc_match_module (void)
5572 m
= gfc_match (" %s%t", &gfc_new_block
);
5576 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
5577 gfc_new_block
->name
, NULL
))
5584 /* Free equivalence sets and lists. Recursively is the easiest way to
5588 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
5593 gfc_free_equiv (eq
->eq
);
5594 gfc_free_equiv_until (eq
->next
, stop
);
5595 gfc_free_expr (eq
->expr
);
5601 gfc_free_equiv (gfc_equiv
*eq
)
5603 gfc_free_equiv_until (eq
, NULL
);
5607 /* Match an EQUIVALENCE statement. */
5610 gfc_match_equivalence (void)
5612 gfc_equiv
*eq
, *set
, *tail
;
5616 gfc_common_head
*common_head
= NULL
;
5621 /* EQUIVALENCE has been matched. After gobbling any possible whitespace,
5622 the next character needs to be '('. Check that here, and return
5623 MATCH_NO for a variable of the form equivalencej. */
5624 gfc_gobble_whitespace ();
5625 c
= gfc_peek_ascii_char ();
5633 eq
= gfc_get_equiv ();
5637 eq
->next
= gfc_current_ns
->equiv
;
5638 gfc_current_ns
->equiv
= eq
;
5640 if (gfc_match_char ('(') != MATCH_YES
)
5644 common_flag
= FALSE
;
5649 m
= gfc_match_equiv_variable (&set
->expr
);
5650 if (m
== MATCH_ERROR
)
5655 /* count the number of objects. */
5658 if (gfc_match_char ('%') == MATCH_YES
)
5660 gfc_error ("Derived type component %C is not a "
5661 "permitted EQUIVALENCE member");
5665 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
5666 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5668 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
5669 "be an array section");
5673 sym
= set
->expr
->symtree
->n
.sym
;
5675 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
5678 if (sym
->attr
.in_common
)
5681 common_head
= sym
->common_head
;
5684 if (gfc_match_char (')') == MATCH_YES
)
5687 if (gfc_match_char (',') != MATCH_YES
)
5690 set
->eq
= gfc_get_equiv ();
5696 gfc_error ("EQUIVALENCE at %C requires two or more objects");
5700 /* If one of the members of an equivalence is in common, then
5701 mark them all as being in common. Before doing this, check
5702 that members of the equivalence group are not in different
5705 for (set
= eq
; set
; set
= set
->eq
)
5707 sym
= set
->expr
->symtree
->n
.sym
;
5708 if (sym
->common_head
&& sym
->common_head
!= common_head
)
5710 gfc_error ("Attempt to indirectly overlap COMMON "
5711 "blocks %s and %s by EQUIVALENCE at %C",
5712 sym
->common_head
->name
, common_head
->name
);
5715 sym
->attr
.in_common
= 1;
5716 sym
->common_head
= common_head
;
5719 if (gfc_match_eos () == MATCH_YES
)
5721 if (gfc_match_char (',') != MATCH_YES
)
5723 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
5728 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "EQUIVALENCE statement at %C"))
5734 gfc_syntax_error (ST_EQUIVALENCE
);
5740 gfc_free_equiv (gfc_current_ns
->equiv
);
5741 gfc_current_ns
->equiv
= eq
;
5747 /* Check that a statement function is not recursive. This is done by looking
5748 for the statement function symbol(sym) by looking recursively through its
5749 expression(e). If a reference to sym is found, true is returned.
5750 12.5.4 requires that any variable of function that is implicitly typed
5751 shall have that type confirmed by any subsequent type declaration. The
5752 implicit typing is conveniently done here. */
5754 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
5757 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
5763 switch (e
->expr_type
)
5766 if (e
->symtree
== NULL
)
5769 /* Check the name before testing for nested recursion! */
5770 if (sym
->name
== e
->symtree
->n
.sym
->name
)
5773 /* Catch recursion via other statement functions. */
5774 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
5775 && e
->symtree
->n
.sym
->value
5776 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
5779 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5780 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5785 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
5788 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5789 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5801 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
5803 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
5807 /* Match a statement function declaration. It is so easy to match
5808 non-statement function statements with a MATCH_ERROR as opposed to
5809 MATCH_NO that we suppress error message in most cases. */
5812 gfc_match_st_function (void)
5814 gfc_error_buffer old_error
;
5818 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5821 gfc_formal_arglist
*ptr
;
5823 /* Read the possible statement function name, and then check to see if
5824 a symbol is already present in the namespace. Record if it is a
5825 function and whether it has been referenced. */
5828 old_locus
= gfc_current_locus
;
5829 m
= gfc_match_name (name
);
5832 gfc_find_symbol (name
, NULL
, 1, &sym
);
5833 if (sym
&& sym
->attr
.function
&& !sym
->attr
.referenced
)
5840 gfc_current_locus
= old_locus
;
5841 m
= gfc_match_symbol (&sym
, 0);
5845 gfc_push_error (&old_error
);
5847 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
5850 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
5853 m
= gfc_match (" = %e%t", &expr
);
5857 gfc_free_error (&old_error
);
5859 if (m
== MATCH_ERROR
)
5862 if (recursive_stmt_fcn (expr
, sym
))
5864 gfc_error ("Statement function at %L is recursive", &expr
->where
);
5868 if (fcn
&& ptr
!= sym
->formal
)
5870 gfc_error ("Statement function %qs at %L conflicts with function name",
5871 sym
->name
, &expr
->where
);
5877 if ((gfc_current_state () == COMP_FUNCTION
5878 || gfc_current_state () == COMP_SUBROUTINE
)
5879 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
5881 gfc_error ("Statement function at %L cannot appear within an INTERFACE",
5886 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
5892 gfc_pop_error (&old_error
);
5897 /* Match an assignment to a pointer function (F2008). This could, in
5898 general be ambiguous with a statement function. In this implementation
5899 it remains so if it is the first statement after the specification
5903 gfc_match_ptr_fcn_assign (void)
5905 gfc_error_buffer old_error
;
5910 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5912 old_loc
= gfc_current_locus
;
5913 m
= gfc_match_name (name
);
5917 gfc_find_symbol (name
, NULL
, 1, &sym
);
5918 if (sym
&& sym
->attr
.flavor
!= FL_PROCEDURE
)
5921 gfc_push_error (&old_error
);
5923 if (sym
&& sym
->attr
.function
)
5924 goto match_actual_arglist
;
5926 gfc_current_locus
= old_loc
;
5927 m
= gfc_match_symbol (&sym
, 0);
5931 if (!gfc_add_procedure (&sym
->attr
, PROC_UNKNOWN
, sym
->name
, NULL
))
5934 match_actual_arglist
:
5935 gfc_current_locus
= old_loc
;
5936 m
= gfc_match (" %e", &expr
);
5940 new_st
.op
= EXEC_ASSIGN
;
5941 new_st
.expr1
= expr
;
5944 m
= gfc_match (" = %e%t", &expr
);
5948 new_st
.expr2
= expr
;
5952 gfc_pop_error (&old_error
);
5957 /***************** SELECT CASE subroutines ******************/
5959 /* Free a single case structure. */
5962 free_case (gfc_case
*p
)
5964 if (p
->low
== p
->high
)
5966 gfc_free_expr (p
->low
);
5967 gfc_free_expr (p
->high
);
5972 /* Free a list of case structures. */
5975 gfc_free_case_list (gfc_case
*p
)
5987 /* Match a single case selector. Combining the requirements of F08:C830
5988 and F08:C832 (R838) means that the case-value must have either CHARACTER,
5989 INTEGER, or LOGICAL type. */
5992 match_case_selector (gfc_case
**cp
)
5997 c
= gfc_get_case ();
5998 c
->where
= gfc_current_locus
;
6000 if (gfc_match_char (':') == MATCH_YES
)
6002 m
= gfc_match_init_expr (&c
->high
);
6005 if (m
== MATCH_ERROR
)
6008 if (c
->high
->ts
.type
!= BT_LOGICAL
&& c
->high
->ts
.type
!= BT_INTEGER
6009 && c
->high
->ts
.type
!= BT_CHARACTER
)
6011 gfc_error ("Expression in CASE selector at %L cannot be %s",
6012 &c
->high
->where
, gfc_typename (&c
->high
->ts
));
6018 m
= gfc_match_init_expr (&c
->low
);
6019 if (m
== MATCH_ERROR
)
6024 if (c
->low
->ts
.type
!= BT_LOGICAL
&& c
->low
->ts
.type
!= BT_INTEGER
6025 && c
->low
->ts
.type
!= BT_CHARACTER
)
6027 gfc_error ("Expression in CASE selector at %L cannot be %s",
6028 &c
->low
->where
, gfc_typename (&c
->low
->ts
));
6032 /* If we're not looking at a ':' now, make a range out of a single
6033 target. Else get the upper bound for the case range. */
6034 if (gfc_match_char (':') != MATCH_YES
)
6038 m
= gfc_match_init_expr (&c
->high
);
6039 if (m
== MATCH_ERROR
)
6041 /* MATCH_NO is fine. It's OK if nothing is there! */
6049 gfc_error ("Expected initialization expression in CASE at %C");
6057 /* Match the end of a case statement. */
6060 match_case_eos (void)
6062 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6065 if (gfc_match_eos () == MATCH_YES
)
6068 /* If the case construct doesn't have a case-construct-name, we
6069 should have matched the EOS. */
6070 if (!gfc_current_block ())
6073 gfc_gobble_whitespace ();
6075 m
= gfc_match_name (name
);
6079 if (strcmp (name
, gfc_current_block ()->name
) != 0)
6081 gfc_error ("Expected block name %qs of SELECT construct at %C",
6082 gfc_current_block ()->name
);
6086 return gfc_match_eos ();
6090 /* Match a SELECT statement. */
6093 gfc_match_select (void)
6098 m
= gfc_match_label ();
6099 if (m
== MATCH_ERROR
)
6102 m
= gfc_match (" select case ( %e )%t", &expr
);
6106 new_st
.op
= EXEC_SELECT
;
6107 new_st
.expr1
= expr
;
6113 /* Transfer the selector typespec to the associate name. */
6116 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
)
6119 gfc_symbol
*assoc_sym
;
6122 assoc_sym
= associate
->symtree
->n
.sym
;
6124 /* At this stage the expression rank and arrayspec dimensions have
6125 not been completely sorted out. We must get the expr2->rank
6126 right here, so that the correct class container is obtained. */
6127 ref
= selector
->ref
;
6128 while (ref
&& ref
->next
)
6131 if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
6132 && CLASS_DATA (selector
)->as
->type
== AS_ASSUMED_RANK
)
6134 assoc_sym
->attr
.dimension
= 1;
6135 assoc_sym
->as
= gfc_copy_array_spec (CLASS_DATA (selector
)->as
);
6136 goto build_class_sym
;
6138 else if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
6139 && ref
&& ref
->type
== REF_ARRAY
)
6141 /* Ensure that the array reference type is set. We cannot use
6142 gfc_resolve_expr at this point, so the usable parts of
6143 resolve.c(resolve_array_ref) are employed to do it. */
6144 if (ref
->u
.ar
.type
== AR_UNKNOWN
)
6146 ref
->u
.ar
.type
= AR_ELEMENT
;
6147 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
6148 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
6149 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
6150 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
6151 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
6153 ref
->u
.ar
.type
= AR_SECTION
;
6158 if (ref
->u
.ar
.type
== AR_FULL
)
6159 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
6160 else if (ref
->u
.ar
.type
== AR_SECTION
)
6161 selector
->rank
= ref
->u
.ar
.dimen
;
6165 rank
= selector
->rank
;
6170 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
6171 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
6172 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
6173 && ref
->u
.ar
.end
[i
] == NULL
6174 && ref
->u
.ar
.stride
[i
] == NULL
))
6179 assoc_sym
->attr
.dimension
= 1;
6180 assoc_sym
->as
= gfc_get_array_spec ();
6181 assoc_sym
->as
->rank
= rank
;
6182 assoc_sym
->as
->type
= AS_DEFERRED
;
6185 assoc_sym
->as
= NULL
;
6188 assoc_sym
->as
= NULL
;
6191 if (selector
->ts
.type
== BT_CLASS
)
6193 /* The correct class container has to be available. */
6194 assoc_sym
->ts
.type
= BT_CLASS
;
6195 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
6196 assoc_sym
->attr
.pointer
= 1;
6197 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
6202 /* Push the current selector onto the SELECT TYPE stack. */
6205 select_type_push (gfc_symbol
*sel
)
6207 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
6208 top
->selector
= sel
;
6210 top
->prev
= select_type_stack
;
6212 select_type_stack
= top
;
6216 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
6218 static gfc_symtree
*
6219 select_intrinsic_set_tmp (gfc_typespec
*ts
)
6221 char name
[GFC_MAX_SYMBOL_LEN
];
6223 HOST_WIDE_INT charlen
= 0;
6224 gfc_symbol
*selector
= select_type_stack
->selector
;
6227 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
6230 if (selector
->ts
.type
== BT_CLASS
&& !selector
->attr
.class_ok
)
6233 /* Case value == NULL corresponds to SELECT TYPE cases otherwise
6234 the values correspond to SELECT rank cases. */
6235 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
6236 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6237 charlen
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
6239 if (ts
->type
!= BT_CHARACTER
)
6240 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
6243 snprintf (name
, sizeof (name
),
6244 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
6245 gfc_basic_typename (ts
->type
), charlen
, ts
->kind
);
6247 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6249 gfc_add_type (sym
, ts
, NULL
);
6251 /* Copy across the array spec to the selector. */
6252 if (selector
->ts
.type
== BT_CLASS
6253 && (CLASS_DATA (selector
)->attr
.dimension
6254 || CLASS_DATA (selector
)->attr
.codimension
))
6256 sym
->attr
.pointer
= 1;
6257 sym
->attr
.dimension
= CLASS_DATA (selector
)->attr
.dimension
;
6258 sym
->attr
.codimension
= CLASS_DATA (selector
)->attr
.codimension
;
6259 sym
->as
= gfc_copy_array_spec (CLASS_DATA (selector
)->as
);
6262 gfc_set_sym_referenced (sym
);
6263 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, name
, NULL
);
6264 sym
->attr
.select_type_temporary
= 1;
6270 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
6273 select_type_set_tmp (gfc_typespec
*ts
)
6275 char name
[GFC_MAX_SYMBOL_LEN
];
6276 gfc_symtree
*tmp
= NULL
;
6277 gfc_symbol
*selector
= select_type_stack
->selector
;
6282 select_type_stack
->tmp
= NULL
;
6286 tmp
= select_intrinsic_set_tmp (ts
);
6293 if (ts
->type
== BT_CLASS
)
6294 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
6296 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
6298 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6300 gfc_add_type (sym
, ts
, NULL
);
6302 if (selector
->ts
.type
== BT_CLASS
&& selector
->attr
.class_ok
)
6305 = CLASS_DATA (selector
)->attr
.class_pointer
;
6307 /* Copy across the array spec to the selector. */
6308 if (CLASS_DATA (selector
)->attr
.dimension
6309 || CLASS_DATA (selector
)->attr
.codimension
)
6312 = CLASS_DATA (selector
)->attr
.dimension
;
6313 sym
->attr
.codimension
6314 = CLASS_DATA (selector
)->attr
.codimension
;
6316 = gfc_copy_array_spec (CLASS_DATA (selector
)->as
);
6320 gfc_set_sym_referenced (sym
);
6321 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, name
, NULL
);
6322 sym
->attr
.select_type_temporary
= 1;
6324 if (ts
->type
== BT_CLASS
)
6325 gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
6331 /* Add an association for it, so the rest of the parser knows it is
6332 an associate-name. The target will be set during resolution. */
6333 sym
->assoc
= gfc_get_association_list ();
6334 sym
->assoc
->dangling
= 1;
6335 sym
->assoc
->st
= tmp
;
6337 select_type_stack
->tmp
= tmp
;
6341 /* Match a SELECT TYPE statement. */
6344 gfc_match_select_type (void)
6346 gfc_expr
*expr1
, *expr2
= NULL
;
6348 char name
[GFC_MAX_SYMBOL_LEN
];
6351 gfc_namespace
*ns
= gfc_current_ns
;
6353 m
= gfc_match_label ();
6354 if (m
== MATCH_ERROR
)
6357 m
= gfc_match (" select type ( ");
6361 if (gfc_current_state() == COMP_MODULE
6362 || gfc_current_state() == COMP_SUBMODULE
)
6364 gfc_error ("SELECT TYPE at %C cannot appear in this scope");
6368 gfc_current_ns
= gfc_build_block_ns (ns
);
6369 m
= gfc_match (" %n => %e", name
, &expr2
);
6372 expr1
= gfc_get_expr ();
6373 expr1
->expr_type
= EXPR_VARIABLE
;
6374 expr1
->where
= expr2
->where
;
6375 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
6381 sym
= expr1
->symtree
->n
.sym
;
6382 if (expr2
->ts
.type
== BT_UNKNOWN
)
6383 sym
->attr
.untyped
= 1;
6385 copy_ts_from_selector_to_associate (expr1
, expr2
);
6387 sym
->attr
.flavor
= FL_VARIABLE
;
6388 sym
->attr
.referenced
= 1;
6389 sym
->attr
.class_ok
= 1;
6393 m
= gfc_match (" %e ", &expr1
);
6396 std::swap (ns
, gfc_current_ns
);
6397 gfc_free_namespace (ns
);
6402 m
= gfc_match (" )%t");
6405 gfc_error ("parse error in SELECT TYPE statement at %C");
6409 /* This ghastly expression seems to be needed to distinguish a CLASS
6410 array, which can have a reference, from other expressions that
6411 have references, such as derived type components, and are not
6412 allowed by the standard.
6413 TODO: see if it is sufficient to exclude component and substring
6415 class_array
= (expr1
->expr_type
== EXPR_VARIABLE
6416 && expr1
->ts
.type
== BT_CLASS
6417 && CLASS_DATA (expr1
)
6418 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
6419 && (CLASS_DATA (expr1
)->attr
.dimension
6420 || CLASS_DATA (expr1
)->attr
.codimension
)
6422 && expr1
->ref
->type
== REF_ARRAY
6423 && expr1
->ref
->u
.ar
.type
== AR_FULL
6424 && expr1
->ref
->next
== NULL
);
6426 /* Check for F03:C811 (F08:C835). */
6427 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
6428 || (!class_array
&& expr1
->ref
!= NULL
)))
6430 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
6431 "use associate-name=>");
6436 new_st
.op
= EXEC_SELECT_TYPE
;
6437 new_st
.expr1
= expr1
;
6438 new_st
.expr2
= expr2
;
6439 new_st
.ext
.block
.ns
= gfc_current_ns
;
6441 select_type_push (expr1
->symtree
->n
.sym
);
6442 gfc_current_ns
= ns
;
6447 gfc_free_expr (expr1
);
6448 gfc_free_expr (expr2
);
6449 gfc_undo_symbols ();
6450 std::swap (ns
, gfc_current_ns
);
6451 gfc_free_namespace (ns
);
6456 /* Set the temporary for the current intrinsic SELECT RANK selector. */
6459 select_rank_set_tmp (gfc_typespec
*ts
, int *case_value
)
6461 char name
[2 * GFC_MAX_SYMBOL_LEN
];
6462 char tname
[GFC_MAX_SYMBOL_LEN
];
6464 gfc_symbol
*selector
= select_type_stack
->selector
;
6467 HOST_WIDE_INT charlen
= 0;
6469 if (case_value
== NULL
)
6472 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
6473 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6474 charlen
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
6476 if (ts
->type
== BT_CLASS
)
6477 sprintf (tname
, "class_%s", ts
->u
.derived
->name
);
6478 else if (ts
->type
== BT_DERIVED
)
6479 sprintf (tname
, "type_%s", ts
->u
.derived
->name
);
6480 else if (ts
->type
!= BT_CHARACTER
)
6481 sprintf (tname
, "%s_%d", gfc_basic_typename (ts
->type
), ts
->kind
);
6483 sprintf (tname
, "%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
6484 gfc_basic_typename (ts
->type
), charlen
, ts
->kind
);
6486 /* Case value == NULL corresponds to SELECT TYPE cases otherwise
6487 the values correspond to SELECT rank cases. */
6488 if (*case_value
>=0)
6489 sprintf (name
, "__tmp_%s_rank_%d", tname
, *case_value
);
6491 sprintf (name
, "__tmp_%s_rank_m%d", tname
, -*case_value
);
6493 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
6497 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6499 gfc_add_type (sym
, ts
, NULL
);
6501 /* Copy across the array spec to the selector. */
6502 if (selector
->ts
.type
== BT_CLASS
)
6504 sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
6505 sym
->attr
.pointer
= CLASS_DATA (selector
)->attr
.pointer
;
6506 sym
->attr
.allocatable
= CLASS_DATA (selector
)->attr
.allocatable
;
6507 sym
->attr
.target
= CLASS_DATA (selector
)->attr
.target
;
6508 sym
->attr
.class_ok
= 0;
6509 if (case_value
&& *case_value
!= 0)
6511 sym
->attr
.dimension
= 1;
6512 sym
->as
= gfc_copy_array_spec (CLASS_DATA (selector
)->as
);
6513 if (*case_value
> 0)
6515 sym
->as
->type
= AS_DEFERRED
;
6516 sym
->as
->rank
= *case_value
;
6518 else if (*case_value
== -1)
6520 sym
->as
->type
= AS_ASSUMED_SIZE
;
6527 sym
->attr
.pointer
= selector
->attr
.pointer
;
6528 sym
->attr
.allocatable
= selector
->attr
.allocatable
;
6529 sym
->attr
.target
= selector
->attr
.target
;
6530 if (case_value
&& *case_value
!= 0)
6532 sym
->attr
.dimension
= 1;
6533 sym
->as
= gfc_copy_array_spec (selector
->as
);
6534 if (*case_value
> 0)
6536 sym
->as
->type
= AS_DEFERRED
;
6537 sym
->as
->rank
= *case_value
;
6539 else if (*case_value
== -1)
6541 sym
->as
->type
= AS_ASSUMED_SIZE
;
6547 gfc_set_sym_referenced (sym
);
6548 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, name
, NULL
);
6549 sym
->attr
.select_type_temporary
= 1;
6551 sym
->attr
.select_rank_temporary
= 1;
6553 if (ts
->type
== BT_CLASS
)
6554 gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
6556 /* Add an association for it, so the rest of the parser knows it is
6557 an associate-name. The target will be set during resolution. */
6558 sym
->assoc
= gfc_get_association_list ();
6559 sym
->assoc
->dangling
= 1;
6560 sym
->assoc
->st
= tmp
;
6562 select_type_stack
->tmp
= tmp
;
6566 /* Match a SELECT RANK statement. */
6569 gfc_match_select_rank (void)
6571 gfc_expr
*expr1
, *expr2
= NULL
;
6573 char name
[GFC_MAX_SYMBOL_LEN
];
6574 gfc_symbol
*sym
, *sym2
;
6575 gfc_namespace
*ns
= gfc_current_ns
;
6576 gfc_array_spec
*as
= NULL
;
6578 m
= gfc_match_label ();
6579 if (m
== MATCH_ERROR
)
6582 m
= gfc_match (" select rank ( ");
6586 if (!gfc_notify_std (GFC_STD_F2018
, "SELECT RANK statement at %C"))
6589 gfc_current_ns
= gfc_build_block_ns (ns
);
6590 m
= gfc_match (" %n => %e", name
, &expr2
);
6593 expr1
= gfc_get_expr ();
6594 expr1
->expr_type
= EXPR_VARIABLE
;
6595 expr1
->where
= expr2
->where
;
6596 expr1
->ref
= gfc_copy_ref (expr2
->ref
);
6597 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
6603 sym
= expr1
->symtree
->n
.sym
;
6607 sym2
= expr2
->symtree
->n
.sym
;
6608 as
= sym2
->ts
.type
== BT_CLASS
? CLASS_DATA (sym2
)->as
: sym2
->as
;
6611 if (expr2
->expr_type
!= EXPR_VARIABLE
6612 || !(as
&& as
->type
== AS_ASSUMED_RANK
))
6614 gfc_error ("The SELECT RANK selector at %C must be an assumed "
6620 if (expr2
->ts
.type
== BT_CLASS
)
6622 copy_ts_from_selector_to_associate (expr1
, expr2
);
6624 sym
->attr
.flavor
= FL_VARIABLE
;
6625 sym
->attr
.referenced
= 1;
6626 sym
->attr
.class_ok
= 1;
6627 CLASS_DATA (sym
)->attr
.allocatable
= CLASS_DATA (sym2
)->attr
.allocatable
;
6628 CLASS_DATA (sym
)->attr
.pointer
= CLASS_DATA (sym2
)->attr
.pointer
;
6629 CLASS_DATA (sym
)->attr
.target
= CLASS_DATA (sym2
)->attr
.target
;
6630 sym
->attr
.pointer
= 1;
6635 sym
->as
= gfc_copy_array_spec (sym2
->as
);
6636 sym
->attr
.dimension
= 1;
6638 sym
->attr
.flavor
= FL_VARIABLE
;
6639 sym
->attr
.referenced
= 1;
6640 sym
->attr
.class_ok
= sym2
->attr
.class_ok
;
6641 sym
->attr
.allocatable
= sym2
->attr
.allocatable
;
6642 sym
->attr
.pointer
= sym2
->attr
.pointer
;
6643 sym
->attr
.target
= sym2
->attr
.target
;
6648 m
= gfc_match (" %e ", &expr1
);
6652 std::swap (ns
, gfc_current_ns
);
6653 gfc_free_namespace (ns
);
6659 sym
= expr1
->symtree
->n
.sym
;
6660 as
= sym
->ts
.type
== BT_CLASS
? CLASS_DATA (sym
)->as
: sym
->as
;
6663 if (expr1
->expr_type
!= EXPR_VARIABLE
6664 || !(as
&& as
->type
== AS_ASSUMED_RANK
))
6666 gfc_error("The SELECT RANK selector at %C must be an assumed "
6673 m
= gfc_match (" )%t");
6676 gfc_error ("parse error in SELECT RANK statement at %C");
6680 new_st
.op
= EXEC_SELECT_RANK
;
6681 new_st
.expr1
= expr1
;
6682 new_st
.expr2
= expr2
;
6683 new_st
.ext
.block
.ns
= gfc_current_ns
;
6685 select_type_push (expr1
->symtree
->n
.sym
);
6686 gfc_current_ns
= ns
;
6691 gfc_free_expr (expr1
);
6692 gfc_free_expr (expr2
);
6693 gfc_undo_symbols ();
6694 std::swap (ns
, gfc_current_ns
);
6695 gfc_free_namespace (ns
);
6700 /* Match a CASE statement. */
6703 gfc_match_case (void)
6705 gfc_case
*c
, *head
, *tail
;
6710 if (gfc_current_state () != COMP_SELECT
)
6712 gfc_error ("Unexpected CASE statement at %C");
6716 if (gfc_match ("% default") == MATCH_YES
)
6718 m
= match_case_eos ();
6721 if (m
== MATCH_ERROR
)
6724 new_st
.op
= EXEC_SELECT
;
6725 c
= gfc_get_case ();
6726 c
->where
= gfc_current_locus
;
6727 new_st
.ext
.block
.case_list
= c
;
6731 if (gfc_match_char ('(') != MATCH_YES
)
6736 if (match_case_selector (&c
) == MATCH_ERROR
)
6746 if (gfc_match_char (')') == MATCH_YES
)
6748 if (gfc_match_char (',') != MATCH_YES
)
6752 m
= match_case_eos ();
6755 if (m
== MATCH_ERROR
)
6758 new_st
.op
= EXEC_SELECT
;
6759 new_st
.ext
.block
.case_list
= head
;
6764 gfc_error ("Syntax error in CASE specification at %C");
6767 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
6772 /* Match a TYPE IS statement. */
6775 gfc_match_type_is (void)
6780 if (gfc_current_state () != COMP_SELECT_TYPE
)
6782 gfc_error ("Unexpected TYPE IS statement at %C");
6786 if (gfc_match_char ('(') != MATCH_YES
)
6789 c
= gfc_get_case ();
6790 c
->where
= gfc_current_locus
;
6792 m
= gfc_match_type_spec (&c
->ts
);
6795 if (m
== MATCH_ERROR
)
6798 if (gfc_match_char (')') != MATCH_YES
)
6801 m
= match_case_eos ();
6804 if (m
== MATCH_ERROR
)
6807 new_st
.op
= EXEC_SELECT_TYPE
;
6808 new_st
.ext
.block
.case_list
= c
;
6810 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
6811 && (c
->ts
.u
.derived
->attr
.sequence
6812 || c
->ts
.u
.derived
->attr
.is_bind_c
))
6814 gfc_error ("The type-spec shall not specify a sequence derived "
6815 "type or a type with the BIND attribute in SELECT "
6816 "TYPE at %C [F2003:C815]");
6820 if (c
->ts
.type
== BT_DERIVED
6821 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
6822 && gfc_spec_list_type (type_param_spec_list
, c
->ts
.u
.derived
)
6825 gfc_error ("All the LEN type parameters in the TYPE IS statement "
6826 "at %C must be ASSUMED");
6830 /* Create temporary variable. */
6831 select_type_set_tmp (&c
->ts
);
6836 gfc_error ("Syntax error in TYPE IS specification at %C");
6840 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6845 /* Match a CLASS IS or CLASS DEFAULT statement. */
6848 gfc_match_class_is (void)
6853 if (gfc_current_state () != COMP_SELECT_TYPE
)
6856 if (gfc_match ("% default") == MATCH_YES
)
6858 m
= match_case_eos ();
6861 if (m
== MATCH_ERROR
)
6864 new_st
.op
= EXEC_SELECT_TYPE
;
6865 c
= gfc_get_case ();
6866 c
->where
= gfc_current_locus
;
6867 c
->ts
.type
= BT_UNKNOWN
;
6868 new_st
.ext
.block
.case_list
= c
;
6869 select_type_set_tmp (NULL
);
6873 m
= gfc_match ("% is");
6876 if (m
== MATCH_ERROR
)
6879 if (gfc_match_char ('(') != MATCH_YES
)
6882 c
= gfc_get_case ();
6883 c
->where
= gfc_current_locus
;
6885 m
= match_derived_type_spec (&c
->ts
);
6888 if (m
== MATCH_ERROR
)
6891 if (c
->ts
.type
== BT_DERIVED
)
6892 c
->ts
.type
= BT_CLASS
;
6894 if (gfc_match_char (')') != MATCH_YES
)
6897 m
= match_case_eos ();
6900 if (m
== MATCH_ERROR
)
6903 new_st
.op
= EXEC_SELECT_TYPE
;
6904 new_st
.ext
.block
.case_list
= c
;
6906 /* Create temporary variable. */
6907 select_type_set_tmp (&c
->ts
);
6912 gfc_error ("Syntax error in CLASS IS specification at %C");
6916 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6921 /* Match a RANK statement. */
6924 gfc_match_rank_is (void)
6930 if (gfc_current_state () != COMP_SELECT_RANK
)
6932 gfc_error ("Unexpected RANK statement at %C");
6936 if (gfc_match ("% default") == MATCH_YES
)
6938 m
= match_case_eos ();
6941 if (m
== MATCH_ERROR
)
6944 new_st
.op
= EXEC_SELECT_RANK
;
6945 c
= gfc_get_case ();
6946 c
->ts
.type
= BT_UNKNOWN
;
6947 c
->where
= gfc_current_locus
;
6948 new_st
.ext
.block
.case_list
= c
;
6949 select_type_stack
->tmp
= NULL
;
6953 if (gfc_match_char ('(') != MATCH_YES
)
6956 c
= gfc_get_case ();
6957 c
->where
= gfc_current_locus
;
6958 c
->ts
= select_type_stack
->selector
->ts
;
6960 m
= gfc_match_expr (&c
->low
);
6963 if (gfc_match_char ('*') == MATCH_YES
)
6964 c
->low
= gfc_get_int_expr (gfc_default_integer_kind
,
6971 else if (m
== MATCH_YES
)
6974 if (c
->low
->expr_type
!= EXPR_CONSTANT
6975 || c
->low
->ts
.type
!= BT_INTEGER
6978 gfc_error ("The SELECT RANK CASE expression at %C must be a "
6979 "scalar, integer constant");
6983 case_value
= (int) mpz_get_si (c
->low
->value
.integer
);
6985 if ((case_value
< 0) || (case_value
> GFC_MAX_DIMENSIONS
))
6987 gfc_error ("The value of the SELECT RANK CASE expression at "
6988 "%C must not be less than zero or greater than %d",
6989 GFC_MAX_DIMENSIONS
);
6996 if (gfc_match_char (')') != MATCH_YES
)
6999 m
= match_case_eos ();
7002 if (m
== MATCH_ERROR
)
7005 new_st
.op
= EXEC_SELECT_RANK
;
7006 new_st
.ext
.block
.case_list
= c
;
7008 /* Create temporary variable. Recycle the select type code. */
7009 select_rank_set_tmp (&c
->ts
, &case_value
);
7014 gfc_error ("Syntax error in RANK specification at %C");
7018 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
7022 /********************* WHERE subroutines ********************/
7024 /* Match the rest of a simple WHERE statement that follows an IF statement.
7028 match_simple_where (void)
7034 m
= gfc_match (" ( %e )", &expr
);
7038 m
= gfc_match_assignment ();
7041 if (m
== MATCH_ERROR
)
7044 if (gfc_match_eos () != MATCH_YES
)
7047 c
= gfc_get_code (EXEC_WHERE
);
7050 c
->next
= XCNEW (gfc_code
);
7052 c
->next
->loc
= gfc_current_locus
;
7053 gfc_clear_new_st ();
7055 new_st
.op
= EXEC_WHERE
;
7061 gfc_syntax_error (ST_WHERE
);
7064 gfc_free_expr (expr
);
7069 /* Match a WHERE statement. */
7072 gfc_match_where (gfc_statement
*st
)
7078 m0
= gfc_match_label ();
7079 if (m0
== MATCH_ERROR
)
7082 m
= gfc_match (" where ( %e )", &expr
);
7086 if (gfc_match_eos () == MATCH_YES
)
7088 *st
= ST_WHERE_BLOCK
;
7089 new_st
.op
= EXEC_WHERE
;
7090 new_st
.expr1
= expr
;
7094 m
= gfc_match_assignment ();
7096 gfc_syntax_error (ST_WHERE
);
7100 gfc_free_expr (expr
);
7104 /* We've got a simple WHERE statement. */
7106 c
= gfc_get_code (EXEC_WHERE
);
7109 /* Put in the assignment. It will not be processed by add_statement, so we
7110 need to copy the location here. */
7112 c
->next
= XCNEW (gfc_code
);
7114 c
->next
->loc
= gfc_current_locus
;
7115 gfc_clear_new_st ();
7117 new_st
.op
= EXEC_WHERE
;
7124 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
7125 new_st if successful. */
7128 gfc_match_elsewhere (void)
7130 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7134 if (gfc_current_state () != COMP_WHERE
)
7136 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
7142 if (gfc_match_char ('(') == MATCH_YES
)
7144 m
= gfc_match_expr (&expr
);
7147 if (m
== MATCH_ERROR
)
7150 if (gfc_match_char (')') != MATCH_YES
)
7154 if (gfc_match_eos () != MATCH_YES
)
7156 /* Only makes sense if we have a where-construct-name. */
7157 if (!gfc_current_block ())
7162 /* Better be a name at this point. */
7163 m
= gfc_match_name (name
);
7166 if (m
== MATCH_ERROR
)
7169 if (gfc_match_eos () != MATCH_YES
)
7172 if (strcmp (name
, gfc_current_block ()->name
) != 0)
7174 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
7175 name
, gfc_current_block ()->name
);
7180 new_st
.op
= EXEC_WHERE
;
7181 new_st
.expr1
= expr
;
7185 gfc_syntax_error (ST_ELSEWHERE
);
7188 gfc_free_expr (expr
);