1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000-2019 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
29 int gfc_matching_ptr_assignment
= 0;
30 int gfc_matching_procptr_assignment
= 0;
31 bool gfc_matching_prefix
= false;
33 /* Stack of SELECT TYPE statements. */
34 gfc_select_type_stack
*select_type_stack
= NULL
;
36 /* List of type parameter expressions. */
37 gfc_actual_arglist
*type_param_spec_list
;
39 /* For debugging and diagnostic purposes. Return the textual representation
40 of the intrinsic operator OP. */
42 gfc_op2string (gfc_intrinsic_op op
)
50 case INTRINSIC_UMINUS
:
56 case INTRINSIC_CONCAT
:
60 case INTRINSIC_DIVIDE
:
99 case INTRINSIC_ASSIGN
:
102 case INTRINSIC_PARENTHESES
:
109 case INTRINSIC_FORMATTED
:
111 case INTRINSIC_UNFORMATTED
:
112 return "unformatted";
118 gfc_internal_error ("gfc_op2string(): Bad code");
123 /******************** Generic matching subroutines ************************/
125 /* Matches a member separator. With standard FORTRAN this is '%', but with
126 DEC structures we must carefully match dot ('.').
127 Because operators are spelled ".op.", a dotted string such as "x.y.z..."
128 can be either a component reference chain or a combination of binary
130 There is no real way to win because the string may be grammatically
131 ambiguous. The following rules help avoid ambiguities - they match
132 some behavior of other (older) compilers. If the rules here are changed
133 the test cases should be updated. If the user has problems with these rules
134 they probably deserve the consequences. Consider "x.y.z":
135 (1) If any user defined operator ".y." exists, this is always y(x,z)
136 (even if ".y." is the wrong type and/or x has a member y).
137 (2) Otherwise if x has a member y, and y is itself a derived type,
138 this is (x->y)->z, even if an intrinsic operator exists which
140 (3) If x has no member y or (x->y) is not a derived type but ".y."
141 is an intrinsic operator (such as ".eq."), this is y(x,z).
142 (4) Lastly if there is no operator ".y." and x has no member "y", it is an
144 It is worth noting that the logic here does not support mixed use of member
145 accessors within a single string. That is, even if x has component y and y
146 has component z, the following are all syntax errors:
147 "x%y.z" "x.y%z" "(x.y).z" "(x%y)%z"
151 gfc_match_member_sep(gfc_symbol
*sym
)
153 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
154 locus dot_loc
, start_loc
;
155 gfc_intrinsic_op iop
;
158 gfc_component
*c
= NULL
;
160 /* What a relief: '%' is an unambiguous member separator. */
161 if (gfc_match_char ('%') == MATCH_YES
)
164 /* Beware ye who enter here. */
165 if (!flag_dec_structure
|| !sym
)
170 /* We may be given either a derived type variable or the derived type
171 declaration itself (which actually contains the components);
172 we need the latter to search for components. */
173 if (gfc_fl_struct (sym
->attr
.flavor
))
175 else if (gfc_bt_struct (sym
->ts
.type
))
176 tsym
= sym
->ts
.u
.derived
;
178 iop
= INTRINSIC_NONE
;
182 /* If we have to reject come back here later. */
183 start_loc
= gfc_current_locus
;
185 /* Look for a component access next. */
186 if (gfc_match_char ('.') != MATCH_YES
)
189 /* If we accept, come back here. */
190 dot_loc
= gfc_current_locus
;
192 /* Try to match a symbol name following the dot. */
193 if (gfc_match_name (name
) != MATCH_YES
)
195 gfc_error ("Expected structure component or operator name "
200 /* If no dot follows we have "x.y" which should be a component access. */
201 if (gfc_match_char ('.') != MATCH_YES
)
204 /* Now we have a string "x.y.z" which could be a nested member access
205 (x->y)->z or a binary operation y on x and z. */
207 /* First use any user-defined operators ".y." */
208 if (gfc_find_uop (name
, sym
->ns
) != NULL
)
211 /* Match accesses to existing derived-type components for
212 derived-type vars: "x.y.z" = (x->y)->z */
213 c
= gfc_find_component(tsym
, name
, false, true, NULL
);
214 if (c
&& (gfc_bt_struct (c
->ts
.type
) || c
->ts
.type
== BT_CLASS
))
217 /* If y is not a component or has no members, try intrinsic operators. */
218 gfc_current_locus
= start_loc
;
219 if (gfc_match_intrinsic_op (&iop
) != MATCH_YES
)
221 /* If ".y." is not an intrinsic operator but y was a valid non-
222 structure component, match and leave the trailing dot to be
227 gfc_error ("%qs is neither a defined operator nor a "
228 "structure component in dotted string at %C", name
);
232 /* .y. is an intrinsic operator, overriding any possible member access. */
235 /* Return keeping the current locus consistent with the match result. */
239 gfc_current_locus
= start_loc
;
242 gfc_current_locus
= dot_loc
;
247 /* This function scans the current statement counting the opened and closed
248 parenthesis to make sure they are balanced. */
251 gfc_match_parens (void)
253 locus old_loc
, where
;
255 gfc_instring instring
;
258 old_loc
= gfc_current_locus
;
260 instring
= NONSTRING
;
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
);
1351 if (lvalue
->expr_type
== EXPR_CONSTANT
)
1353 /* This clobbers %len and %kind. */
1355 gfc_error ("Assignment to a constant expression at %C");
1360 gfc_current_locus
= old_loc
;
1361 gfc_free_expr (lvalue
);
1362 gfc_free_expr (rvalue
);
1366 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1368 new_st
.op
= EXEC_ASSIGN
;
1369 new_st
.expr1
= lvalue
;
1370 new_st
.expr2
= rvalue
;
1372 gfc_check_do_variable (lvalue
->symtree
);
1374 if (lvalue
->ts
.type
== BT_CLASS
)
1375 gfc_find_vtab (&rvalue
->ts
);
1381 /* Match a pointer assignment statement. */
1384 gfc_match_pointer_assignment (void)
1386 gfc_expr
*lvalue
, *rvalue
;
1390 old_loc
= gfc_current_locus
;
1392 lvalue
= rvalue
= NULL
;
1393 gfc_matching_ptr_assignment
= 0;
1394 gfc_matching_procptr_assignment
= 0;
1396 m
= gfc_match (" %v =>", &lvalue
);
1403 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1404 || gfc_is_proc_ptr_comp (lvalue
))
1405 gfc_matching_procptr_assignment
= 1;
1407 gfc_matching_ptr_assignment
= 1;
1409 m
= gfc_match (" %e%t", &rvalue
);
1410 gfc_matching_ptr_assignment
= 0;
1411 gfc_matching_procptr_assignment
= 0;
1415 new_st
.op
= EXEC_POINTER_ASSIGN
;
1416 new_st
.expr1
= lvalue
;
1417 new_st
.expr2
= rvalue
;
1422 gfc_current_locus
= old_loc
;
1423 gfc_free_expr (lvalue
);
1424 gfc_free_expr (rvalue
);
1429 /* We try to match an easy arithmetic IF statement. This only happens
1430 when just after having encountered a simple IF statement. This code
1431 is really duplicate with parts of the gfc_match_if code, but this is
1435 match_arithmetic_if (void)
1437 gfc_st_label
*l1
, *l2
, *l3
;
1441 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1445 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1446 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1447 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1449 gfc_free_expr (expr
);
1453 if (!gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
1454 "Arithmetic IF statement at %C"))
1457 new_st
.op
= EXEC_ARITHMETIC_IF
;
1458 new_st
.expr1
= expr
;
1467 /* The IF statement is a bit of a pain. First of all, there are three
1468 forms of it, the simple IF, the IF that starts a block and the
1471 There is a problem with the simple IF and that is the fact that we
1472 only have a single level of undo information on symbols. What this
1473 means is for a simple IF, we must re-match the whole IF statement
1474 multiple times in order to guarantee that the symbol table ends up
1475 in the proper state. */
1477 static match
match_simple_forall (void);
1478 static match
match_simple_where (void);
1481 gfc_match_if (gfc_statement
*if_type
)
1484 gfc_st_label
*l1
, *l2
, *l3
;
1485 locus old_loc
, old_loc2
;
1489 n
= gfc_match_label ();
1490 if (n
== MATCH_ERROR
)
1493 old_loc
= gfc_current_locus
;
1495 m
= gfc_match (" if ", &expr
);
1499 if (gfc_match_char ('(') != MATCH_YES
)
1501 gfc_error ("Missing %<(%> in IF-expression at %C");
1505 m
= gfc_match ("%e", &expr
);
1509 old_loc2
= gfc_current_locus
;
1510 gfc_current_locus
= old_loc
;
1512 if (gfc_match_parens () == MATCH_ERROR
)
1515 gfc_current_locus
= old_loc2
;
1517 if (gfc_match_char (')') != MATCH_YES
)
1519 gfc_error ("Syntax error in IF-expression at %C");
1520 gfc_free_expr (expr
);
1524 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1530 gfc_error ("Block label not appropriate for arithmetic IF "
1532 gfc_free_expr (expr
);
1536 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1537 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1538 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1540 gfc_free_expr (expr
);
1544 if (!gfc_notify_std (GFC_STD_F95_OBS
| GFC_STD_F2018_DEL
,
1545 "Arithmetic IF statement at %C"))
1548 new_st
.op
= EXEC_ARITHMETIC_IF
;
1549 new_st
.expr1
= expr
;
1554 *if_type
= ST_ARITHMETIC_IF
;
1558 if (gfc_match (" then%t") == MATCH_YES
)
1560 new_st
.op
= EXEC_IF
;
1561 new_st
.expr1
= expr
;
1562 *if_type
= ST_IF_BLOCK
;
1568 gfc_error ("Block label is not appropriate for IF statement at %C");
1569 gfc_free_expr (expr
);
1573 /* At this point the only thing left is a simple IF statement. At
1574 this point, n has to be MATCH_NO, so we don't have to worry about
1575 re-matching a block label. From what we've got so far, try
1576 matching an assignment. */
1578 *if_type
= ST_SIMPLE_IF
;
1580 m
= gfc_match_assignment ();
1584 gfc_free_expr (expr
);
1585 gfc_undo_symbols ();
1586 gfc_current_locus
= old_loc
;
1588 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1589 assignment was found. For MATCH_NO, continue to call the various
1591 if (m
== MATCH_ERROR
)
1594 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1596 m
= gfc_match_pointer_assignment ();
1600 gfc_free_expr (expr
);
1601 gfc_undo_symbols ();
1602 gfc_current_locus
= old_loc
;
1604 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1606 /* Look at the next keyword to see which matcher to call. Matching
1607 the keyword doesn't affect the symbol table, so we don't have to
1608 restore between tries. */
1610 #define match(string, subr, statement) \
1611 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1615 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1616 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1617 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1618 match ("call", gfc_match_call
, ST_CALL
)
1619 match ("change team", gfc_match_change_team
, ST_CHANGE_TEAM
)
1620 match ("close", gfc_match_close
, ST_CLOSE
)
1621 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1622 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1623 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1624 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1625 match ("end team", gfc_match_end_team
, ST_END_TEAM
)
1626 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
)
1627 match ("event post", gfc_match_event_post
, ST_EVENT_POST
)
1628 match ("event wait", gfc_match_event_wait
, ST_EVENT_WAIT
)
1629 match ("exit", gfc_match_exit
, ST_EXIT
)
1630 match ("fail image", gfc_match_fail_image
, ST_FAIL_IMAGE
)
1631 match ("flush", gfc_match_flush
, ST_FLUSH
)
1632 match ("forall", match_simple_forall
, ST_FORALL
)
1633 match ("form team", gfc_match_form_team
, ST_FORM_TEAM
)
1634 match ("go to", gfc_match_goto
, ST_GOTO
)
1635 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1636 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1637 match ("lock", gfc_match_lock
, ST_LOCK
)
1638 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1639 match ("open", gfc_match_open
, ST_OPEN
)
1640 match ("pause", gfc_match_pause
, ST_NONE
)
1641 match ("print", gfc_match_print
, ST_WRITE
)
1642 match ("read", gfc_match_read
, ST_READ
)
1643 match ("return", gfc_match_return
, ST_RETURN
)
1644 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1645 match ("stop", gfc_match_stop
, ST_STOP
)
1646 match ("wait", gfc_match_wait
, ST_WAIT
)
1647 match ("sync all", gfc_match_sync_all
, ST_SYNC_CALL
);
1648 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
1649 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
1650 match ("sync team", gfc_match_sync_team
, ST_SYNC_TEAM
)
1651 match ("unlock", gfc_match_unlock
, ST_UNLOCK
)
1652 match ("where", match_simple_where
, ST_WHERE
)
1653 match ("write", gfc_match_write
, ST_WRITE
)
1656 match ("type", gfc_match_print
, ST_WRITE
)
1658 /* All else has failed, so give up. See if any of the matchers has
1659 stored an error message of some sort. */
1660 if (!gfc_error_check ())
1661 gfc_error ("Syntax error in IF-clause after %C");
1663 gfc_free_expr (expr
);
1668 gfc_error ("Syntax error in IF-clause after %C");
1671 gfc_free_expr (expr
);
1675 /* At this point, we've matched the single IF and the action clause
1676 is in new_st. Rearrange things so that the IF statement appears
1679 p
= gfc_get_code (EXEC_IF
);
1680 p
->next
= XCNEW (gfc_code
);
1682 p
->next
->loc
= gfc_current_locus
;
1686 gfc_clear_new_st ();
1688 new_st
.op
= EXEC_IF
;
1697 /* Match an ELSE statement. */
1700 gfc_match_else (void)
1702 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1704 if (gfc_match_eos () == MATCH_YES
)
1707 if (gfc_match_name (name
) != MATCH_YES
1708 || gfc_current_block () == NULL
1709 || gfc_match_eos () != MATCH_YES
)
1711 gfc_error ("Invalid character(s) in ELSE statement after %C");
1715 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1717 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1718 name
, gfc_current_block ()->name
);
1726 /* Match an ELSE IF statement. */
1729 gfc_match_elseif (void)
1731 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1732 gfc_expr
*expr
, *then
;
1736 if (gfc_match_char ('(') != MATCH_YES
)
1738 gfc_error ("Missing %<(%> in ELSE IF expression at %C");
1742 m
= gfc_match (" %e ", &expr
);
1746 if (gfc_match_char (')') != MATCH_YES
)
1748 gfc_error ("Missing %<)%> in ELSE IF expression at %C");
1752 m
= gfc_match (" then ", &then
);
1754 where
= gfc_current_locus
;
1756 if (m
== MATCH_YES
&& (gfc_match_eos () == MATCH_YES
1757 || (gfc_current_block ()
1758 && gfc_match_name (name
) == MATCH_YES
)))
1761 if (gfc_match_eos () == MATCH_YES
)
1763 gfc_error ("Missing THEN in ELSE IF statement after %L", &where
);
1767 if (gfc_match_name (name
) != MATCH_YES
1768 || gfc_current_block () == NULL
1769 || gfc_match_eos () != MATCH_YES
)
1771 gfc_error ("Syntax error in ELSE IF statement after %L", &where
);
1775 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1777 gfc_error ("Label %qs after %L doesn't match IF label %qs",
1778 name
, &where
, gfc_current_block ()->name
);
1786 new_st
.op
= EXEC_IF
;
1787 new_st
.expr1
= expr
;
1791 gfc_free_expr (expr
);
1796 /* Free a gfc_iterator structure. */
1799 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1805 gfc_free_expr (iter
->var
);
1806 gfc_free_expr (iter
->start
);
1807 gfc_free_expr (iter
->end
);
1808 gfc_free_expr (iter
->step
);
1815 /* Match a CRITICAL statement. */
1817 gfc_match_critical (void)
1819 gfc_st_label
*label
= NULL
;
1821 if (gfc_match_label () == MATCH_ERROR
)
1824 if (gfc_match (" critical") != MATCH_YES
)
1827 if (gfc_match_st_label (&label
) == MATCH_ERROR
)
1830 if (gfc_match_eos () != MATCH_YES
)
1832 gfc_syntax_error (ST_CRITICAL
);
1836 if (gfc_pure (NULL
))
1838 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1842 if (gfc_find_state (COMP_DO_CONCURRENT
))
1844 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1849 gfc_unset_implicit_pure (NULL
);
1851 if (!gfc_notify_std (GFC_STD_F2008
, "CRITICAL statement at %C"))
1854 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1856 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1861 if (gfc_find_state (COMP_CRITICAL
))
1863 gfc_error ("Nested CRITICAL block at %C");
1867 new_st
.op
= EXEC_CRITICAL
;
1870 && !gfc_reference_st_label (label
, ST_LABEL_TARGET
))
1877 /* Match a BLOCK statement. */
1880 gfc_match_block (void)
1884 if (gfc_match_label () == MATCH_ERROR
)
1887 if (gfc_match (" block") != MATCH_YES
)
1890 /* For this to be a correct BLOCK statement, the line must end now. */
1891 m
= gfc_match_eos ();
1892 if (m
== MATCH_ERROR
)
1901 /* Match an ASSOCIATE statement. */
1904 gfc_match_associate (void)
1906 if (gfc_match_label () == MATCH_ERROR
)
1909 if (gfc_match (" associate") != MATCH_YES
)
1912 /* Match the association list. */
1913 if (gfc_match_char ('(') != MATCH_YES
)
1915 gfc_error ("Expected association list at %C");
1918 new_st
.ext
.block
.assoc
= NULL
;
1921 gfc_association_list
* newAssoc
= gfc_get_association_list ();
1922 gfc_association_list
* a
;
1924 /* Match the next association. */
1925 if (gfc_match (" %n =>", newAssoc
->name
) != MATCH_YES
)
1927 gfc_error ("Expected association at %C");
1928 goto assocListError
;
1931 if (gfc_match (" %e", &newAssoc
->target
) != MATCH_YES
)
1933 /* Have another go, allowing for procedure pointer selectors. */
1934 gfc_matching_procptr_assignment
= 1;
1935 if (gfc_match (" %e", &newAssoc
->target
) != MATCH_YES
)
1937 gfc_error ("Invalid association target at %C");
1938 goto assocListError
;
1940 gfc_matching_procptr_assignment
= 0;
1942 newAssoc
->where
= gfc_current_locus
;
1944 /* Check that the current name is not yet in the list. */
1945 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
1946 if (!strcmp (a
->name
, newAssoc
->name
))
1948 gfc_error ("Duplicate name %qs in association at %C",
1950 goto assocListError
;
1953 /* The target expression must not be coindexed. */
1954 if (gfc_is_coindexed (newAssoc
->target
))
1956 gfc_error ("Association target at %C must not be coindexed");
1957 goto assocListError
;
1960 /* The `variable' field is left blank for now; because the target is not
1961 yet resolved, we can't use gfc_has_vector_subscript to determine it
1962 for now. This is set during resolution. */
1964 /* Put it into the list. */
1965 newAssoc
->next
= new_st
.ext
.block
.assoc
;
1966 new_st
.ext
.block
.assoc
= newAssoc
;
1968 /* Try next one or end if closing parenthesis is found. */
1969 gfc_gobble_whitespace ();
1970 if (gfc_peek_char () == ')')
1972 if (gfc_match_char (',') != MATCH_YES
)
1974 gfc_error ("Expected %<)%> or %<,%> at %C");
1984 if (gfc_match_char (')') != MATCH_YES
)
1986 /* This should never happen as we peek above. */
1990 if (gfc_match_eos () != MATCH_YES
)
1992 gfc_error ("Junk after ASSOCIATE statement at %C");
1999 gfc_free_association_list (new_st
.ext
.block
.assoc
);
2004 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
2005 an accessible derived type. */
2008 match_derived_type_spec (gfc_typespec
*ts
)
2010 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2012 gfc_symbol
*derived
, *der_type
;
2013 match m
= MATCH_YES
;
2014 gfc_actual_arglist
*decl_type_param_list
= NULL
;
2015 bool is_pdt_template
= false;
2017 old_locus
= gfc_current_locus
;
2019 if (gfc_match ("%n", name
) != MATCH_YES
)
2021 gfc_current_locus
= old_locus
;
2025 gfc_find_symbol (name
, NULL
, 1, &derived
);
2027 /* Match the PDT spec list, if there. */
2028 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
)
2030 gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &der_type
);
2031 is_pdt_template
= der_type
2032 && der_type
->attr
.flavor
== FL_DERIVED
2033 && der_type
->attr
.pdt_template
;
2036 if (is_pdt_template
)
2037 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
2039 if (m
== MATCH_ERROR
)
2041 gfc_free_actual_arglist (decl_type_param_list
);
2045 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
&& derived
->attr
.generic
)
2046 derived
= gfc_find_dt_in_generic (derived
);
2048 /* If this is a PDT, find the specific instance. */
2049 if (m
== MATCH_YES
&& is_pdt_template
)
2051 gfc_namespace
*old_ns
;
2053 old_ns
= gfc_current_ns
;
2054 while (gfc_current_ns
&& gfc_current_ns
->parent
)
2055 gfc_current_ns
= gfc_current_ns
->parent
;
2057 if (type_param_spec_list
)
2058 gfc_free_actual_arglist (type_param_spec_list
);
2059 m
= gfc_get_pdt_instance (decl_type_param_list
, &der_type
,
2060 &type_param_spec_list
);
2061 gfc_free_actual_arglist (decl_type_param_list
);
2066 gcc_assert (!derived
->attr
.pdt_template
&& derived
->attr
.pdt_type
);
2067 gfc_set_sym_referenced (derived
);
2069 gfc_current_ns
= old_ns
;
2072 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
2074 ts
->type
= BT_DERIVED
;
2075 ts
->u
.derived
= derived
;
2079 gfc_current_locus
= old_locus
;
2084 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2085 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2086 It only includes the intrinsic types from the Fortran 2003 standard
2087 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2088 the implicit_flag is not needed, so it was removed. Derived types are
2089 identified by their name alone. */
2092 gfc_match_type_spec (gfc_typespec
*ts
)
2096 char c
, name
[GFC_MAX_SYMBOL_LEN
+ 1];
2099 gfc_gobble_whitespace ();
2100 old_locus
= gfc_current_locus
;
2102 /* If c isn't [a-z], then return immediately. */
2103 c
= gfc_peek_ascii_char ();
2107 type_param_spec_list
= NULL
;
2109 if (match_derived_type_spec (ts
) == MATCH_YES
)
2111 /* Enforce F03:C401. */
2112 if (ts
->u
.derived
->attr
.abstract
)
2114 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
2115 ts
->u
.derived
->name
, &old_locus
);
2121 if (gfc_match ("integer") == MATCH_YES
)
2123 ts
->type
= BT_INTEGER
;
2124 ts
->kind
= gfc_default_integer_kind
;
2128 if (gfc_match ("double precision") == MATCH_YES
)
2131 ts
->kind
= gfc_default_double_kind
;
2135 if (gfc_match ("complex") == MATCH_YES
)
2137 ts
->type
= BT_COMPLEX
;
2138 ts
->kind
= gfc_default_complex_kind
;
2142 if (gfc_match ("character") == MATCH_YES
)
2144 ts
->type
= BT_CHARACTER
;
2146 m
= gfc_match_char_spec (ts
);
2154 /* REAL is a real pain because it can be a type, intrinsic subprogram,
2155 or list item in a type-list of an OpenMP reduction clause. Need to
2156 differentiate REAL([KIND]=scalar-int-initialization-expr) from
2157 REAL(A,[KIND]) and REAL(KIND,A). Logically, when this code was
2158 written the use of LOGICAL as a type-spec or intrinsic subprogram
2161 m
= gfc_match (" %n", name
);
2163 && (strcmp (name
, "real") == 0 || strcmp (name
, "logical") == 0))
2172 ts
->kind
= gfc_default_real_kind
;
2176 ts
->type
= BT_LOGICAL
;
2177 ts
->kind
= gfc_default_logical_kind
;
2180 gfc_gobble_whitespace ();
2182 /* Prevent REAL*4, etc. */
2183 c
= gfc_peek_ascii_char ();
2186 gfc_error ("Invalid type-spec at %C");
2190 /* Found leading colon in REAL::, a trailing ')' in for example
2191 TYPE IS (REAL), or REAL, for an OpenMP list-item. */
2192 if (c
== ':' || c
== ')' || (flag_openmp
&& c
== ','))
2195 /* Found something other than the opening '(' in REAL(... */
2199 gfc_next_char (); /* Burn the '('. */
2201 /* Look for the optional KIND=. */
2202 where
= gfc_current_locus
;
2203 m
= gfc_match ("%n", name
);
2206 gfc_gobble_whitespace ();
2207 c
= gfc_next_char ();
2210 if (strcmp(name
, "a") == 0 || strcmp(name
, "l") == 0)
2212 else if (strcmp(name
, "kind") == 0)
2218 gfc_current_locus
= where
;
2221 gfc_current_locus
= where
;
2225 m
= gfc_match_init_expr (&e
);
2226 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
2229 /* If a comma appears, it is an intrinsic subprogram. */
2230 gfc_gobble_whitespace ();
2231 c
= gfc_peek_ascii_char ();
2238 /* If ')' appears, we have REAL(initialization-expr), here check for
2239 a scalar integer initialization-expr and valid kind parameter. */
2242 if (e
->ts
.type
!= BT_INTEGER
|| e
->rank
> 0)
2248 if (e
->expr_type
!= EXPR_CONSTANT
)
2251 gfc_next_char (); /* Burn the ')'. */
2252 ts
->kind
= (int) mpz_get_si (e
->value
.integer
);
2253 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
2255 gfc_error ("Invalid type-spec at %C");
2267 /* If a type is not matched, simply return MATCH_NO. */
2268 gfc_current_locus
= old_locus
;
2273 gfc_gobble_whitespace ();
2275 /* This prevents INTEGER*4, etc. */
2276 if (gfc_peek_ascii_char () == '*')
2278 gfc_error ("Invalid type-spec at %C");
2282 m
= gfc_match_kind_spec (ts
, false);
2284 /* No kind specifier found. */
2292 /******************** FORALL subroutines ********************/
2294 /* Free a list of FORALL iterators. */
2297 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
2299 gfc_forall_iterator
*next
;
2304 gfc_free_expr (iter
->var
);
2305 gfc_free_expr (iter
->start
);
2306 gfc_free_expr (iter
->end
);
2307 gfc_free_expr (iter
->stride
);
2314 /* Match an iterator as part of a FORALL statement. The format is:
2316 <var> = <start>:<end>[:<stride>]
2318 On MATCH_NO, the caller tests for the possibility that there is a
2319 scalar mask expression. */
2322 match_forall_iterator (gfc_forall_iterator
**result
)
2324 gfc_forall_iterator
*iter
;
2328 where
= gfc_current_locus
;
2329 iter
= XCNEW (gfc_forall_iterator
);
2331 m
= gfc_match_expr (&iter
->var
);
2335 if (gfc_match_char ('=') != MATCH_YES
2336 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
2342 m
= gfc_match_expr (&iter
->start
);
2346 if (gfc_match_char (':') != MATCH_YES
)
2349 m
= gfc_match_expr (&iter
->end
);
2352 if (m
== MATCH_ERROR
)
2355 if (gfc_match_char (':') == MATCH_NO
)
2356 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2359 m
= gfc_match_expr (&iter
->stride
);
2362 if (m
== MATCH_ERROR
)
2366 /* Mark the iteration variable's symbol as used as a FORALL index. */
2367 iter
->var
->symtree
->n
.sym
->forall_index
= true;
2373 gfc_error ("Syntax error in FORALL iterator at %C");
2378 gfc_current_locus
= where
;
2379 gfc_free_forall_iterator (iter
);
2384 /* Match the header of a FORALL statement. */
2387 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
2389 gfc_forall_iterator
*head
, *tail
, *new_iter
;
2393 gfc_gobble_whitespace ();
2398 if (gfc_match_char ('(') != MATCH_YES
)
2401 m
= match_forall_iterator (&new_iter
);
2402 if (m
== MATCH_ERROR
)
2407 head
= tail
= new_iter
;
2411 if (gfc_match_char (',') != MATCH_YES
)
2414 m
= match_forall_iterator (&new_iter
);
2415 if (m
== MATCH_ERROR
)
2420 tail
->next
= new_iter
;
2425 /* Have to have a mask expression. */
2427 m
= gfc_match_expr (&msk
);
2430 if (m
== MATCH_ERROR
)
2436 if (gfc_match_char (')') == MATCH_NO
)
2444 gfc_syntax_error (ST_FORALL
);
2447 gfc_free_expr (msk
);
2448 gfc_free_forall_iterator (head
);
2453 /* Match the rest of a simple FORALL statement that follows an
2457 match_simple_forall (void)
2459 gfc_forall_iterator
*head
;
2468 m
= match_forall_header (&head
, &mask
);
2475 m
= gfc_match_assignment ();
2477 if (m
== MATCH_ERROR
)
2481 m
= gfc_match_pointer_assignment ();
2482 if (m
== MATCH_ERROR
)
2488 c
= XCNEW (gfc_code
);
2490 c
->loc
= gfc_current_locus
;
2492 if (gfc_match_eos () != MATCH_YES
)
2495 gfc_clear_new_st ();
2496 new_st
.op
= EXEC_FORALL
;
2497 new_st
.expr1
= mask
;
2498 new_st
.ext
.forall_iterator
= head
;
2499 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2500 new_st
.block
->next
= c
;
2505 gfc_syntax_error (ST_FORALL
);
2508 gfc_free_forall_iterator (head
);
2509 gfc_free_expr (mask
);
2515 /* Match a FORALL statement. */
2518 gfc_match_forall (gfc_statement
*st
)
2520 gfc_forall_iterator
*head
;
2529 m0
= gfc_match_label ();
2530 if (m0
== MATCH_ERROR
)
2533 m
= gfc_match (" forall");
2537 m
= match_forall_header (&head
, &mask
);
2538 if (m
== MATCH_ERROR
)
2543 if (gfc_match_eos () == MATCH_YES
)
2545 *st
= ST_FORALL_BLOCK
;
2546 new_st
.op
= EXEC_FORALL
;
2547 new_st
.expr1
= mask
;
2548 new_st
.ext
.forall_iterator
= head
;
2552 m
= gfc_match_assignment ();
2553 if (m
== MATCH_ERROR
)
2557 m
= gfc_match_pointer_assignment ();
2558 if (m
== MATCH_ERROR
)
2564 c
= XCNEW (gfc_code
);
2566 c
->loc
= gfc_current_locus
;
2568 gfc_clear_new_st ();
2569 new_st
.op
= EXEC_FORALL
;
2570 new_st
.expr1
= mask
;
2571 new_st
.ext
.forall_iterator
= head
;
2572 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2573 new_st
.block
->next
= c
;
2579 gfc_syntax_error (ST_FORALL
);
2582 gfc_free_forall_iterator (head
);
2583 gfc_free_expr (mask
);
2584 gfc_free_statements (c
);
2589 /* Match a DO statement. */
2594 gfc_iterator iter
, *ip
;
2596 gfc_st_label
*label
;
2599 old_loc
= gfc_current_locus
;
2601 memset (&iter
, '\0', sizeof (gfc_iterator
));
2604 m
= gfc_match_label ();
2605 if (m
== MATCH_ERROR
)
2608 if (gfc_match (" do") != MATCH_YES
)
2611 m
= gfc_match_st_label (&label
);
2612 if (m
== MATCH_ERROR
)
2615 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2617 if (gfc_match_eos () == MATCH_YES
)
2619 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
2620 new_st
.op
= EXEC_DO_WHILE
;
2624 /* Match an optional comma, if no comma is found, a space is obligatory. */
2625 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
2628 /* Check for balanced parens. */
2630 if (gfc_match_parens () == MATCH_ERROR
)
2633 if (gfc_match (" concurrent") == MATCH_YES
)
2635 gfc_forall_iterator
*head
;
2638 if (!gfc_notify_std (GFC_STD_F2008
, "DO CONCURRENT construct at %C"))
2644 m
= match_forall_header (&head
, &mask
);
2648 if (m
== MATCH_ERROR
)
2649 goto concurr_cleanup
;
2651 if (gfc_match_eos () != MATCH_YES
)
2652 goto concurr_cleanup
;
2655 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2656 goto concurr_cleanup
;
2658 new_st
.label1
= label
;
2659 new_st
.op
= EXEC_DO_CONCURRENT
;
2660 new_st
.expr1
= mask
;
2661 new_st
.ext
.forall_iterator
= head
;
2666 gfc_syntax_error (ST_DO
);
2667 gfc_free_expr (mask
);
2668 gfc_free_forall_iterator (head
);
2672 /* See if we have a DO WHILE. */
2673 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
2675 new_st
.op
= EXEC_DO_WHILE
;
2679 /* The abortive DO WHILE may have done something to the symbol
2680 table, so we start over. */
2681 gfc_undo_symbols ();
2682 gfc_current_locus
= old_loc
;
2684 gfc_match_label (); /* This won't error. */
2685 gfc_match (" do "); /* This will work. */
2687 gfc_match_st_label (&label
); /* Can't error out. */
2688 gfc_match_char (','); /* Optional comma. */
2690 m
= gfc_match_iterator (&iter
, 0);
2693 if (m
== MATCH_ERROR
)
2696 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
2697 gfc_check_do_variable (iter
.var
->symtree
);
2699 if (gfc_match_eos () != MATCH_YES
)
2701 gfc_syntax_error (ST_DO
);
2705 new_st
.op
= EXEC_DO
;
2709 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2712 new_st
.label1
= label
;
2714 if (new_st
.op
== EXEC_DO_WHILE
)
2715 new_st
.expr1
= iter
.end
;
2718 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
2725 gfc_free_iterator (&iter
, 0);
2731 /* Match an EXIT or CYCLE statement. */
2734 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2736 gfc_state_data
*p
, *o
;
2741 if (gfc_match_eos () == MATCH_YES
)
2745 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2748 m
= gfc_match ("% %n%t", name
);
2749 if (m
== MATCH_ERROR
)
2753 gfc_syntax_error (st
);
2757 /* Find the corresponding symbol. If there's a BLOCK statement
2758 between here and the label, it is not in gfc_current_ns but a parent
2760 stree
= gfc_find_symtree_in_proc (name
, gfc_current_ns
);
2763 gfc_error ("Name %qs in %s statement at %C is unknown",
2764 name
, gfc_ascii_statement (st
));
2769 if (sym
->attr
.flavor
!= FL_LABEL
)
2771 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2772 name
, gfc_ascii_statement (st
));
2777 /* Find the loop specified by the label (or lack of a label). */
2778 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2779 if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2781 else if (p
->state
== COMP_CRITICAL
)
2783 gfc_error("%s statement at %C leaves CRITICAL construct",
2784 gfc_ascii_statement (st
));
2787 else if (p
->state
== COMP_DO_CONCURRENT
2788 && (op
== EXEC_EXIT
|| (sym
&& sym
!= p
->sym
)))
2790 /* F2008, C821 & C845. */
2791 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2792 gfc_ascii_statement (st
));
2795 else if ((sym
&& sym
== p
->sym
)
2796 || (!sym
&& (p
->state
== COMP_DO
2797 || p
->state
== COMP_DO_CONCURRENT
)))
2803 gfc_error ("%s statement at %C is not within a construct",
2804 gfc_ascii_statement (st
));
2806 gfc_error ("%s statement at %C is not within construct %qs",
2807 gfc_ascii_statement (st
), sym
->name
);
2812 /* Special checks for EXIT from non-loop constructs. */
2816 case COMP_DO_CONCURRENT
:
2820 /* This is already handled above. */
2823 case COMP_ASSOCIATE
:
2827 case COMP_SELECT_TYPE
:
2828 case COMP_SELECT_RANK
:
2830 if (op
== EXEC_CYCLE
)
2832 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2833 " construct %qs", sym
->name
);
2836 gcc_assert (op
== EXEC_EXIT
);
2837 if (!gfc_notify_std (GFC_STD_F2008
, "EXIT statement with no"
2838 " do-construct-name at %C"))
2843 gfc_error ("%s statement at %C is not applicable to construct %qs",
2844 gfc_ascii_statement (st
), sym
->name
);
2850 gfc_error (is_oacc (p
)
2851 ? G_("%s statement at %C leaving OpenACC structured block")
2852 : G_("%s statement at %C leaving OpenMP structured block"),
2853 gfc_ascii_statement (st
));
2857 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2861 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
2862 && (o
->head
->op
== EXEC_OACC_LOOP
2863 || o
->head
->op
== EXEC_OACC_PARALLEL_LOOP
2864 || o
->head
->op
== EXEC_OACC_SERIAL_LOOP
))
2867 gcc_assert (o
->head
->next
!= NULL
2868 && (o
->head
->next
->op
== EXEC_DO
2869 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2870 && o
->previous
!= NULL
2871 && o
->previous
->tail
->op
== o
->head
->op
);
2872 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2873 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2874 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2875 if (st
== ST_EXIT
&& cnt
<= collapse
)
2877 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2880 if (st
== ST_CYCLE
&& cnt
< collapse
)
2882 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2883 " !$ACC LOOP loop");
2889 && (o
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2890 && (o
->head
->op
== EXEC_OMP_DO
2891 || o
->head
->op
== EXEC_OMP_PARALLEL_DO
2892 || o
->head
->op
== EXEC_OMP_SIMD
2893 || o
->head
->op
== EXEC_OMP_DO_SIMD
2894 || o
->head
->op
== EXEC_OMP_PARALLEL_DO_SIMD
))
2897 gcc_assert (o
->head
->next
!= NULL
2898 && (o
->head
->next
->op
== EXEC_DO
2899 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2900 && o
->previous
!= NULL
2901 && o
->previous
->tail
->op
== o
->head
->op
);
2902 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
)
2904 if (o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2905 count
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2906 if (o
->previous
->tail
->ext
.omp_clauses
->orderedc
)
2907 count
= o
->previous
->tail
->ext
.omp_clauses
->orderedc
;
2909 if (st
== ST_EXIT
&& cnt
<= count
)
2911 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2914 if (st
== ST_CYCLE
&& cnt
< count
)
2916 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2922 /* Save the first statement in the construct - needed by the backend. */
2923 new_st
.ext
.which_construct
= p
->construct
;
2931 /* Match the EXIT statement. */
2934 gfc_match_exit (void)
2936 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2940 /* Match the CYCLE statement. */
2943 gfc_match_cycle (void)
2945 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2949 /* Match a stop-code after an (ERROR) STOP or PAUSE statement. The
2950 requirements for a stop-code differ in the standards.
2954 R840 stop-stmt is STOP [ stop-code ]
2955 R841 stop-code is scalar-char-constant
2956 or digit [ digit [ digit [ digit [ digit ] ] ] ]
2958 Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
2961 R855 stop-stmt is STOP [ stop-code ]
2962 R856 allstop-stmt is ALL STOP [ stop-code ]
2963 R857 stop-code is scalar-default-char-constant-expr
2964 or scalar-int-constant-expr
2966 For free-form source code, all standards contain a statement of the form:
2968 A blank shall be used to separate names, constants, or labels from
2969 adjacent keywords, names, constants, or labels.
2971 A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003,
2975 is valid, but it is invalid Fortran 2008. */
2978 gfc_match_stopcode (gfc_statement st
)
2984 /* Set f95 for -std=f95. */
2985 f95
= (gfc_option
.allow_std
== GFC_STD_OPT_F95
);
2987 /* Set f03 for -std=f2003. */
2988 f03
= (gfc_option
.allow_std
== GFC_STD_OPT_F03
);
2990 /* Set f08 for -std=f2008. */
2991 f08
= (gfc_option
.allow_std
== GFC_STD_OPT_F08
);
2993 /* Look for a blank between STOP and the stop-code for F2008 or later. */
2994 if (gfc_current_form
!= FORM_FIXED
&& !(f95
|| f03
))
2996 char c
= gfc_peek_ascii_char ();
2998 /* Look for end-of-statement. There is no stop-code. */
2999 if (c
== '\n' || c
== '!' || c
== ';')
3004 gfc_error ("Blank required in %s statement near %C",
3005 gfc_ascii_statement (st
));
3010 if (gfc_match_eos () != MATCH_YES
)
3015 /* First look for the F95 or F2003 digit [...] construct. */
3016 old_locus
= gfc_current_locus
;
3017 m
= gfc_match_small_int (&stopcode
);
3018 if (m
== MATCH_YES
&& (f95
|| f03
))
3022 gfc_error ("STOP code at %C cannot be negative");
3026 if (stopcode
> 99999)
3028 gfc_error ("STOP code at %C contains too many digits");
3033 /* Reset the locus and now load gfc_expr. */
3034 gfc_current_locus
= old_locus
;
3035 m
= gfc_match_expr (&e
);
3036 if (m
== MATCH_ERROR
)
3041 if (gfc_match_eos () != MATCH_YES
)
3045 if (gfc_pure (NULL
))
3047 if (st
== ST_ERROR_STOP
)
3049 if (!gfc_notify_std (GFC_STD_F2018
, "%s statement at %C in PURE "
3050 "procedure", gfc_ascii_statement (st
)))
3055 gfc_error ("%s statement not allowed in PURE procedure at %C",
3056 gfc_ascii_statement (st
));
3061 gfc_unset_implicit_pure (NULL
);
3063 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
))
3065 gfc_error ("Image control statement STOP at %C in CRITICAL block");
3068 if (st
== ST_STOP
&& gfc_find_state (COMP_DO_CONCURRENT
))
3070 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
3076 if (!gfc_simplify_expr (e
, 0))
3079 /* Test for F95 and F2003 style STOP stop-code. */
3080 if (e
->expr_type
!= EXPR_CONSTANT
&& (f95
|| f03
))
3082 gfc_error ("STOP code at %L must be a scalar CHARACTER constant "
3083 "or digit[digit[digit[digit[digit]]]]", &e
->where
);
3087 /* Use the machinery for an initialization expression to reduce the
3088 stop-code to a constant. */
3089 gfc_reduce_init_expr (e
);
3091 /* Test for F2008 style STOP stop-code. */
3092 if (e
->expr_type
!= EXPR_CONSTANT
&& f08
)
3094 gfc_error ("STOP code at %L must be a scalar default CHARACTER or "
3095 "INTEGER constant expression", &e
->where
);
3099 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
3101 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
3108 gfc_error ("STOP code at %L must be scalar", &e
->where
);
3112 if (e
->ts
.type
== BT_CHARACTER
3113 && e
->ts
.kind
!= gfc_default_character_kind
)
3115 gfc_error ("STOP code at %L must be default character KIND=%d",
3116 &e
->where
, (int) gfc_default_character_kind
);
3120 if (e
->ts
.type
== BT_INTEGER
&& e
->ts
.kind
!= gfc_default_integer_kind
)
3122 gfc_error ("STOP code at %L must be default integer KIND=%d",
3123 &e
->where
, (int) gfc_default_integer_kind
);
3133 new_st
.op
= EXEC_STOP
;
3136 new_st
.op
= EXEC_ERROR_STOP
;
3139 new_st
.op
= EXEC_PAUSE
;
3146 new_st
.ext
.stop_code
= -1;
3151 gfc_syntax_error (st
);
3160 /* Match the (deprecated) PAUSE statement. */
3163 gfc_match_pause (void)
3167 m
= gfc_match_stopcode (ST_PAUSE
);
3170 if (!gfc_notify_std (GFC_STD_F95_DEL
, "PAUSE statement at %C"))
3177 /* Match the STOP statement. */
3180 gfc_match_stop (void)
3182 return gfc_match_stopcode (ST_STOP
);
3186 /* Match the ERROR STOP statement. */
3189 gfc_match_error_stop (void)
3191 if (!gfc_notify_std (GFC_STD_F2008
, "ERROR STOP statement at %C"))
3194 return gfc_match_stopcode (ST_ERROR_STOP
);
3197 /* Match EVENT POST/WAIT statement. Syntax:
3198 EVENT POST ( event-variable [, sync-stat-list] )
3199 EVENT WAIT ( event-variable [, wait-spec-list] )
3201 wait-spec-list is sync-stat-list or until-spec
3202 until-spec is UNTIL_COUNT = scalar-int-expr
3203 sync-stat is STAT= or ERRMSG=. */
3206 event_statement (gfc_statement st
)
3209 gfc_expr
*tmp
, *eventvar
, *until_count
, *stat
, *errmsg
;
3210 bool saw_until_count
, saw_stat
, saw_errmsg
;
3212 tmp
= eventvar
= until_count
= stat
= errmsg
= NULL
;
3213 saw_until_count
= saw_stat
= saw_errmsg
= false;
3215 if (gfc_pure (NULL
))
3217 gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
3218 st
== ST_EVENT_POST
? "POST" : "WAIT");
3222 gfc_unset_implicit_pure (NULL
);
3224 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3226 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3230 if (gfc_find_state (COMP_CRITICAL
))
3232 gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
3233 st
== ST_EVENT_POST
? "POST" : "WAIT");
3237 if (gfc_find_state (COMP_DO_CONCURRENT
))
3239 gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
3240 "block", st
== ST_EVENT_POST
? "POST" : "WAIT");
3244 if (gfc_match_char ('(') != MATCH_YES
)
3247 if (gfc_match ("%e", &eventvar
) != MATCH_YES
)
3249 m
= gfc_match_char (',');
3250 if (m
== MATCH_ERROR
)
3254 m
= gfc_match_char (')');
3262 m
= gfc_match (" stat = %v", &tmp
);
3263 if (m
== MATCH_ERROR
)
3269 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3275 m
= gfc_match_char (',');
3283 m
= gfc_match (" errmsg = %v", &tmp
);
3284 if (m
== MATCH_ERROR
)
3290 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3296 m
= gfc_match_char (',');
3304 m
= gfc_match (" until_count = %e", &tmp
);
3305 if (m
== MATCH_ERROR
|| st
== ST_EVENT_POST
)
3309 if (saw_until_count
)
3311 gfc_error ("Redundant UNTIL_COUNT tag found at %L",
3316 saw_until_count
= true;
3318 m
= gfc_match_char (',');
3329 if (m
== MATCH_ERROR
)
3332 if (gfc_match (" )%t") != MATCH_YES
)
3339 new_st
.op
= EXEC_EVENT_POST
;
3342 new_st
.op
= EXEC_EVENT_WAIT
;
3348 new_st
.expr1
= eventvar
;
3349 new_st
.expr2
= stat
;
3350 new_st
.expr3
= errmsg
;
3351 new_st
.expr4
= until_count
;
3356 gfc_syntax_error (st
);
3359 if (until_count
!= tmp
)
3360 gfc_free_expr (until_count
);
3362 gfc_free_expr (errmsg
);
3364 gfc_free_expr (stat
);
3366 gfc_free_expr (tmp
);
3367 gfc_free_expr (eventvar
);
3375 gfc_match_event_post (void)
3377 if (!gfc_notify_std (GFC_STD_F2018
, "EVENT POST statement at %C"))
3380 return event_statement (ST_EVENT_POST
);
3385 gfc_match_event_wait (void)
3387 if (!gfc_notify_std (GFC_STD_F2018
, "EVENT WAIT statement at %C"))
3390 return event_statement (ST_EVENT_WAIT
);
3394 /* Match a FAIL IMAGE statement. */
3397 gfc_match_fail_image (void)
3399 if (!gfc_notify_std (GFC_STD_F2018
, "FAIL IMAGE statement at %C"))
3402 if (gfc_match_char ('(') == MATCH_YES
)
3405 new_st
.op
= EXEC_FAIL_IMAGE
;
3410 gfc_syntax_error (ST_FAIL_IMAGE
);
3415 /* Match a FORM TEAM statement. */
3418 gfc_match_form_team (void)
3421 gfc_expr
*teamid
,*team
;
3423 if (!gfc_notify_std (GFC_STD_F2018
, "FORM TEAM statement at %C"))
3426 if (gfc_match_char ('(') == MATCH_NO
)
3429 new_st
.op
= EXEC_FORM_TEAM
;
3431 if (gfc_match ("%e", &teamid
) != MATCH_YES
)
3433 m
= gfc_match_char (',');
3434 if (m
== MATCH_ERROR
)
3436 if (gfc_match ("%e", &team
) != MATCH_YES
)
3439 m
= gfc_match_char (')');
3443 new_st
.expr1
= teamid
;
3444 new_st
.expr2
= team
;
3449 gfc_syntax_error (ST_FORM_TEAM
);
3454 /* Match a CHANGE TEAM statement. */
3457 gfc_match_change_team (void)
3462 if (!gfc_notify_std (GFC_STD_F2018
, "CHANGE TEAM statement at %C"))
3465 if (gfc_match_char ('(') == MATCH_NO
)
3468 new_st
.op
= EXEC_CHANGE_TEAM
;
3470 if (gfc_match ("%e", &team
) != MATCH_YES
)
3473 m
= gfc_match_char (')');
3477 new_st
.expr1
= team
;
3482 gfc_syntax_error (ST_CHANGE_TEAM
);
3487 /* Match a END TEAM statement. */
3490 gfc_match_end_team (void)
3492 if (!gfc_notify_std (GFC_STD_F2018
, "END TEAM statement at %C"))
3495 if (gfc_match_char ('(') == MATCH_YES
)
3498 new_st
.op
= EXEC_END_TEAM
;
3503 gfc_syntax_error (ST_END_TEAM
);
3508 /* Match a SYNC TEAM statement. */
3511 gfc_match_sync_team (void)
3516 if (!gfc_notify_std (GFC_STD_F2018
, "SYNC TEAM statement at %C"))
3519 if (gfc_match_char ('(') == MATCH_NO
)
3522 new_st
.op
= EXEC_SYNC_TEAM
;
3524 if (gfc_match ("%e", &team
) != MATCH_YES
)
3527 m
= gfc_match_char (')');
3531 new_st
.expr1
= team
;
3536 gfc_syntax_error (ST_SYNC_TEAM
);
3541 /* Match LOCK/UNLOCK statement. Syntax:
3542 LOCK ( lock-variable [ , lock-stat-list ] )
3543 UNLOCK ( lock-variable [ , sync-stat-list ] )
3544 where lock-stat is ACQUIRED_LOCK or sync-stat
3545 and sync-stat is STAT= or ERRMSG=. */
3548 lock_unlock_statement (gfc_statement st
)
3551 gfc_expr
*tmp
, *lockvar
, *acq_lock
, *stat
, *errmsg
;
3552 bool saw_acq_lock
, saw_stat
, saw_errmsg
;
3554 tmp
= lockvar
= acq_lock
= stat
= errmsg
= NULL
;
3555 saw_acq_lock
= saw_stat
= saw_errmsg
= false;
3557 if (gfc_pure (NULL
))
3559 gfc_error ("Image control statement %s at %C in PURE procedure",
3560 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3564 gfc_unset_implicit_pure (NULL
);
3566 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3568 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3572 if (gfc_find_state (COMP_CRITICAL
))
3574 gfc_error ("Image control statement %s at %C in CRITICAL block",
3575 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3579 if (gfc_find_state (COMP_DO_CONCURRENT
))
3581 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
3582 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3586 if (gfc_match_char ('(') != MATCH_YES
)
3589 if (gfc_match ("%e", &lockvar
) != MATCH_YES
)
3591 m
= gfc_match_char (',');
3592 if (m
== MATCH_ERROR
)
3596 m
= gfc_match_char (')');
3604 m
= gfc_match (" stat = %v", &tmp
);
3605 if (m
== MATCH_ERROR
)
3611 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3617 m
= gfc_match_char (',');
3625 m
= gfc_match (" errmsg = %v", &tmp
);
3626 if (m
== MATCH_ERROR
)
3632 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3638 m
= gfc_match_char (',');
3646 m
= gfc_match (" acquired_lock = %v", &tmp
);
3647 if (m
== MATCH_ERROR
|| st
== ST_UNLOCK
)
3653 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L",
3658 saw_acq_lock
= true;
3660 m
= gfc_match_char (',');
3671 if (m
== MATCH_ERROR
)
3674 if (gfc_match (" )%t") != MATCH_YES
)
3681 new_st
.op
= EXEC_LOCK
;
3684 new_st
.op
= EXEC_UNLOCK
;
3690 new_st
.expr1
= lockvar
;
3691 new_st
.expr2
= stat
;
3692 new_st
.expr3
= errmsg
;
3693 new_st
.expr4
= acq_lock
;
3698 gfc_syntax_error (st
);
3701 if (acq_lock
!= tmp
)
3702 gfc_free_expr (acq_lock
);
3704 gfc_free_expr (errmsg
);
3706 gfc_free_expr (stat
);
3708 gfc_free_expr (tmp
);
3709 gfc_free_expr (lockvar
);
3716 gfc_match_lock (void)
3718 if (!gfc_notify_std (GFC_STD_F2008
, "LOCK statement at %C"))
3721 return lock_unlock_statement (ST_LOCK
);
3726 gfc_match_unlock (void)
3728 if (!gfc_notify_std (GFC_STD_F2008
, "UNLOCK statement at %C"))
3731 return lock_unlock_statement (ST_UNLOCK
);
3735 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
3736 SYNC ALL [(sync-stat-list)]
3737 SYNC MEMORY [(sync-stat-list)]
3738 SYNC IMAGES (image-set [, sync-stat-list] )
3739 with sync-stat is int-expr or *. */
3742 sync_statement (gfc_statement st
)
3745 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
3746 bool saw_stat
, saw_errmsg
;
3748 tmp
= imageset
= stat
= errmsg
= NULL
;
3749 saw_stat
= saw_errmsg
= false;
3751 if (gfc_pure (NULL
))
3753 gfc_error ("Image control statement SYNC at %C in PURE procedure");
3757 gfc_unset_implicit_pure (NULL
);
3759 if (!gfc_notify_std (GFC_STD_F2008
, "SYNC statement at %C"))
3762 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3764 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
3769 if (gfc_find_state (COMP_CRITICAL
))
3771 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3775 if (gfc_find_state (COMP_DO_CONCURRENT
))
3777 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3781 if (gfc_match_eos () == MATCH_YES
)
3783 if (st
== ST_SYNC_IMAGES
)
3788 if (gfc_match_char ('(') != MATCH_YES
)
3791 if (st
== ST_SYNC_IMAGES
)
3793 /* Denote '*' as imageset == NULL. */
3794 m
= gfc_match_char ('*');
3795 if (m
== MATCH_ERROR
)
3799 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
3802 m
= gfc_match_char (',');
3803 if (m
== MATCH_ERROR
)
3807 m
= gfc_match_char (')');
3816 m
= gfc_match (" stat = %v", &tmp
);
3817 if (m
== MATCH_ERROR
)
3823 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3829 if (gfc_match_char (',') == MATCH_YES
)
3836 m
= gfc_match (" errmsg = %v", &tmp
);
3837 if (m
== MATCH_ERROR
)
3843 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3849 if (gfc_match_char (',') == MATCH_YES
)
3859 if (gfc_match (" )%t") != MATCH_YES
)
3866 new_st
.op
= EXEC_SYNC_ALL
;
3868 case ST_SYNC_IMAGES
:
3869 new_st
.op
= EXEC_SYNC_IMAGES
;
3871 case ST_SYNC_MEMORY
:
3872 new_st
.op
= EXEC_SYNC_MEMORY
;
3878 new_st
.expr1
= imageset
;
3879 new_st
.expr2
= stat
;
3880 new_st
.expr3
= errmsg
;
3885 gfc_syntax_error (st
);
3889 gfc_free_expr (stat
);
3891 gfc_free_expr (errmsg
);
3893 gfc_free_expr (tmp
);
3894 gfc_free_expr (imageset
);
3900 /* Match SYNC ALL statement. */
3903 gfc_match_sync_all (void)
3905 return sync_statement (ST_SYNC_ALL
);
3909 /* Match SYNC IMAGES statement. */
3912 gfc_match_sync_images (void)
3914 return sync_statement (ST_SYNC_IMAGES
);
3918 /* Match SYNC MEMORY statement. */
3921 gfc_match_sync_memory (void)
3923 return sync_statement (ST_SYNC_MEMORY
);
3927 /* Match a CONTINUE statement. */
3930 gfc_match_continue (void)
3932 if (gfc_match_eos () != MATCH_YES
)
3934 gfc_syntax_error (ST_CONTINUE
);
3938 new_st
.op
= EXEC_CONTINUE
;
3943 /* Match the (deprecated) ASSIGN statement. */
3946 gfc_match_assign (void)
3949 gfc_st_label
*label
;
3951 if (gfc_match (" %l", &label
) == MATCH_YES
)
3953 if (!gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
))
3955 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
3957 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGN statement at %C"))
3960 expr
->symtree
->n
.sym
->attr
.assign
= 1;
3962 new_st
.op
= EXEC_LABEL_ASSIGN
;
3963 new_st
.label1
= label
;
3964 new_st
.expr1
= expr
;
3972 /* Match the GO TO statement. As a computed GOTO statement is
3973 matched, it is transformed into an equivalent SELECT block. No
3974 tree is necessary, and the resulting jumps-to-jumps are
3975 specifically optimized away by the back end. */
3978 gfc_match_goto (void)
3980 gfc_code
*head
, *tail
;
3983 gfc_st_label
*label
;
3987 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
3989 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3992 new_st
.op
= EXEC_GOTO
;
3993 new_st
.label1
= label
;
3997 /* The assigned GO TO statement. */
3999 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
4001 if (!gfc_notify_std (GFC_STD_F95_DEL
, "Assigned GOTO statement at %C"))
4004 new_st
.op
= EXEC_GOTO
;
4005 new_st
.expr1
= expr
;
4007 if (gfc_match_eos () == MATCH_YES
)
4010 /* Match label list. */
4011 gfc_match_char (',');
4012 if (gfc_match_char ('(') != MATCH_YES
)
4014 gfc_syntax_error (ST_GOTO
);
4021 m
= gfc_match_st_label (&label
);
4025 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
4029 head
= tail
= gfc_get_code (EXEC_GOTO
);
4032 tail
->block
= gfc_get_code (EXEC_GOTO
);
4036 tail
->label1
= label
;
4038 while (gfc_match_char (',') == MATCH_YES
);
4040 if (gfc_match (")%t") != MATCH_YES
)
4045 gfc_error ("Statement label list in GOTO at %C cannot be empty");
4048 new_st
.block
= head
;
4053 /* Last chance is a computed GO TO statement. */
4054 if (gfc_match_char ('(') != MATCH_YES
)
4056 gfc_syntax_error (ST_GOTO
);
4065 m
= gfc_match_st_label (&label
);
4069 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
4073 head
= tail
= gfc_get_code (EXEC_SELECT
);
4076 tail
->block
= gfc_get_code (EXEC_SELECT
);
4080 cp
= gfc_get_case ();
4081 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
4084 tail
->ext
.block
.case_list
= cp
;
4086 tail
->next
= gfc_get_code (EXEC_GOTO
);
4087 tail
->next
->label1
= label
;
4089 while (gfc_match_char (',') == MATCH_YES
);
4091 if (gfc_match_char (')') != MATCH_YES
)
4096 gfc_error ("Statement label list in GOTO at %C cannot be empty");
4100 /* Get the rest of the statement. */
4101 gfc_match_char (',');
4103 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
4106 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Computed GOTO at %C"))
4109 /* At this point, a computed GOTO has been fully matched and an
4110 equivalent SELECT statement constructed. */
4112 new_st
.op
= EXEC_SELECT
;
4113 new_st
.expr1
= NULL
;
4115 /* Hack: For a "real" SELECT, the expression is in expr. We put
4116 it in expr2 so we can distinguish then and produce the correct
4118 new_st
.expr2
= expr
;
4119 new_st
.block
= head
;
4123 gfc_syntax_error (ST_GOTO
);
4125 gfc_free_statements (head
);
4130 /* Frees a list of gfc_alloc structures. */
4133 gfc_free_alloc_list (gfc_alloc
*p
)
4140 gfc_free_expr (p
->expr
);
4146 /* Match an ALLOCATE statement. */
4149 gfc_match_allocate (void)
4151 gfc_alloc
*head
, *tail
;
4152 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
4156 locus old_locus
, deferred_locus
, assumed_locus
;
4157 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, saw_deferred
, b1
, b2
, b3
;
4158 bool saw_unlimited
= false, saw_assumed
= false;
4161 stat
= errmsg
= source
= mold
= tmp
= NULL
;
4162 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= saw_deferred
= false;
4164 if (gfc_match_char ('(') != MATCH_YES
)
4166 gfc_syntax_error (ST_ALLOCATE
);
4170 /* Match an optional type-spec. */
4171 old_locus
= gfc_current_locus
;
4172 m
= gfc_match_type_spec (&ts
);
4173 if (m
== MATCH_ERROR
)
4175 else if (m
== MATCH_NO
)
4177 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
4179 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
4181 gfc_error ("Error in type-spec at %L", &old_locus
);
4185 ts
.type
= BT_UNKNOWN
;
4189 /* Needed for the F2008:C631 check below. */
4190 assumed_locus
= gfc_current_locus
;
4192 if (gfc_match (" :: ") == MATCH_YES
)
4194 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
4200 gfc_error ("Type-spec at %L cannot contain a deferred "
4201 "type parameter", &old_locus
);
4205 if (ts
.type
== BT_CHARACTER
)
4207 if (!ts
.u
.cl
->length
)
4210 ts
.u
.cl
->length_from_typespec
= true;
4213 if (type_param_spec_list
4214 && gfc_spec_list_type (type_param_spec_list
, NULL
)
4217 gfc_error ("The type parameter spec list in the type-spec at "
4218 "%L cannot contain DEFERRED parameters", &old_locus
);
4224 ts
.type
= BT_UNKNOWN
;
4225 gfc_current_locus
= old_locus
;
4232 head
= tail
= gfc_get_alloc ();
4235 tail
->next
= gfc_get_alloc ();
4239 m
= gfc_match_variable (&tail
->expr
, 0);
4242 if (m
== MATCH_ERROR
)
4245 if (tail
->expr
->expr_type
== EXPR_CONSTANT
)
4247 gfc_error ("Unexpected constant at %C");
4251 if (gfc_check_do_variable (tail
->expr
->symtree
))
4254 bool impure
= gfc_impure_variable (tail
->expr
->symtree
->n
.sym
);
4255 if (impure
&& gfc_pure (NULL
))
4257 gfc_error ("Bad allocate-object at %C for a PURE procedure");
4262 gfc_unset_implicit_pure (NULL
);
4264 /* F2008:C631 (R626) A type-param-value in a type-spec shall be an
4265 asterisk if and only if each allocate-object is a dummy argument
4266 for which the corresponding type parameter is assumed. */
4268 && (tail
->expr
->ts
.deferred
4269 || (tail
->expr
->ts
.u
.cl
&& tail
->expr
->ts
.u
.cl
->length
)
4270 || tail
->expr
->symtree
->n
.sym
->attr
.dummy
== 0))
4272 gfc_error ("Incompatible allocate-object at %C for CHARACTER "
4273 "type-spec at %L", &assumed_locus
);
4277 if (tail
->expr
->ts
.deferred
)
4279 saw_deferred
= true;
4280 deferred_locus
= tail
->expr
->where
;
4283 if (gfc_find_state (COMP_DO_CONCURRENT
)
4284 || gfc_find_state (COMP_CRITICAL
))
4287 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
4288 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
4289 if (ref
->type
== REF_COMPONENT
)
4290 coarray
= ref
->u
.c
.component
->attr
.codimension
;
4292 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
4294 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
4297 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
4299 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
4304 /* Check for F08:C628. */
4305 sym
= tail
->expr
->symtree
->n
.sym
;
4306 b1
= !(tail
->expr
->ref
4307 && (tail
->expr
->ref
->type
== REF_COMPONENT
4308 || tail
->expr
->ref
->type
== REF_ARRAY
));
4309 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4310 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
4311 || CLASS_DATA (sym
)->attr
.class_pointer
);
4313 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4314 || sym
->attr
.proc_pointer
);
4315 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
4316 && (sym
->ns
->proc_name
->attr
.allocatable
4317 || sym
->ns
->proc_name
->attr
.pointer
4318 || sym
->ns
->proc_name
->attr
.proc_pointer
);
4319 if (b1
&& b2
&& !b3
)
4321 gfc_error ("Allocate-object at %L is neither a data pointer "
4322 "nor an allocatable variable", &tail
->expr
->where
);
4326 /* The ALLOCATE statement had an optional typespec. Check the
4328 if (ts
.type
!= BT_UNKNOWN
)
4330 /* Enforce F03:C624. */
4331 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
4333 gfc_error ("Type of entity at %L is type incompatible with "
4334 "typespec", &tail
->expr
->where
);
4338 /* Enforce F03:C627. */
4339 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
4341 gfc_error ("Kind type parameter for entity at %L differs from "
4342 "the kind type parameter of the typespec",
4343 &tail
->expr
->where
);
4348 if (tail
->expr
->ts
.type
== BT_DERIVED
)
4349 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
4351 if (type_param_spec_list
)
4352 tail
->expr
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
4354 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
4356 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
4358 gfc_error ("Shape specification for allocatable scalar at %C");
4362 if (gfc_match_char (',') != MATCH_YES
)
4367 m
= gfc_match (" stat = %v", &tmp
);
4368 if (m
== MATCH_ERROR
)
4375 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4383 if (stat
->expr_type
== EXPR_CONSTANT
)
4385 gfc_error ("STAT tag at %L cannot be a constant", &stat
->where
);
4389 if (gfc_check_do_variable (stat
->symtree
))
4392 if (gfc_match_char (',') == MATCH_YES
)
4393 goto alloc_opt_list
;
4396 m
= gfc_match (" errmsg = %v", &tmp
);
4397 if (m
== MATCH_ERROR
)
4401 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
4407 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4415 if (gfc_match_char (',') == MATCH_YES
)
4416 goto alloc_opt_list
;
4419 m
= gfc_match (" source = %e", &tmp
);
4420 if (m
== MATCH_ERROR
)
4424 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
4430 gfc_error ("Redundant SOURCE tag found at %L", &tmp
->where
);
4434 /* The next 2 conditionals check C631. */
4435 if (ts
.type
!= BT_UNKNOWN
)
4437 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
4438 &tmp
->where
, &old_locus
);
4443 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
4444 " with more than a single allocate object",
4452 if (gfc_match_char (',') == MATCH_YES
)
4453 goto alloc_opt_list
;
4456 m
= gfc_match (" mold = %e", &tmp
);
4457 if (m
== MATCH_ERROR
)
4461 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
4464 /* Check F08:C636. */
4467 gfc_error ("Redundant MOLD tag found at %L", &tmp
->where
);
4471 /* Check F08:C637. */
4472 if (ts
.type
!= BT_UNKNOWN
)
4474 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
4475 &tmp
->where
, &old_locus
);
4484 if (gfc_match_char (',') == MATCH_YES
)
4485 goto alloc_opt_list
;
4488 gfc_gobble_whitespace ();
4490 if (gfc_peek_char () == ')')
4494 if (gfc_match (" )%t") != MATCH_YES
)
4497 /* Check F08:C637. */
4500 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
4501 &mold
->where
, &source
->where
);
4505 /* Check F03:C623, */
4506 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4508 gfc_error ("Allocate-object at %L with a deferred type parameter "
4509 "requires either a type-spec or SOURCE tag or a MOLD tag",
4514 /* Check F03:C625, */
4515 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4517 for (tail
= head
; tail
; tail
= tail
->next
)
4519 if (UNLIMITED_POLY (tail
->expr
))
4520 gfc_error ("Unlimited polymorphic allocate-object at %L "
4521 "requires either a type-spec or SOURCE tag "
4522 "or a MOLD tag", &tail
->expr
->where
);
4527 new_st
.op
= EXEC_ALLOCATE
;
4528 new_st
.expr1
= stat
;
4529 new_st
.expr2
= errmsg
;
4531 new_st
.expr3
= source
;
4533 new_st
.expr3
= mold
;
4534 new_st
.ext
.alloc
.list
= head
;
4535 new_st
.ext
.alloc
.ts
= ts
;
4537 if (type_param_spec_list
)
4538 gfc_free_actual_arglist (type_param_spec_list
);
4543 gfc_syntax_error (ST_ALLOCATE
);
4546 gfc_free_expr (errmsg
);
4547 gfc_free_expr (source
);
4548 gfc_free_expr (stat
);
4549 gfc_free_expr (mold
);
4550 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
4551 gfc_free_alloc_list (head
);
4552 if (type_param_spec_list
)
4553 gfc_free_actual_arglist (type_param_spec_list
);
4558 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
4559 a set of pointer assignments to intrinsic NULL(). */
4562 gfc_match_nullify (void)
4570 if (gfc_match_char ('(') != MATCH_YES
)
4575 m
= gfc_match_variable (&p
, 0);
4576 if (m
== MATCH_ERROR
)
4581 if (gfc_check_do_variable (p
->symtree
))
4585 if (gfc_is_coindexed (p
))
4587 gfc_error ("Pointer object at %C shall not be coindexed");
4591 /* build ' => NULL() '. */
4592 e
= gfc_get_null_expr (&gfc_current_locus
);
4594 /* Chain to list. */
4598 tail
->op
= EXEC_POINTER_ASSIGN
;
4602 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
4609 if (gfc_match (" )%t") == MATCH_YES
)
4611 if (gfc_match_char (',') != MATCH_YES
)
4618 gfc_syntax_error (ST_NULLIFY
);
4621 gfc_free_statements (new_st
.next
);
4623 gfc_free_expr (new_st
.expr1
);
4624 new_st
.expr1
= NULL
;
4625 gfc_free_expr (new_st
.expr2
);
4626 new_st
.expr2
= NULL
;
4631 /* Match a DEALLOCATE statement. */
4634 gfc_match_deallocate (void)
4636 gfc_alloc
*head
, *tail
;
4637 gfc_expr
*stat
, *errmsg
, *tmp
;
4640 bool saw_stat
, saw_errmsg
, b1
, b2
;
4643 stat
= errmsg
= tmp
= NULL
;
4644 saw_stat
= saw_errmsg
= false;
4646 if (gfc_match_char ('(') != MATCH_YES
)
4652 head
= tail
= gfc_get_alloc ();
4655 tail
->next
= gfc_get_alloc ();
4659 m
= gfc_match_variable (&tail
->expr
, 0);
4660 if (m
== MATCH_ERROR
)
4665 if (tail
->expr
->expr_type
== EXPR_CONSTANT
)
4667 gfc_error ("Unexpected constant at %C");
4671 if (gfc_check_do_variable (tail
->expr
->symtree
))
4674 sym
= tail
->expr
->symtree
->n
.sym
;
4676 bool impure
= gfc_impure_variable (sym
);
4677 if (impure
&& gfc_pure (NULL
))
4679 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
4684 gfc_unset_implicit_pure (NULL
);
4686 if (gfc_is_coarray (tail
->expr
)
4687 && gfc_find_state (COMP_DO_CONCURRENT
))
4689 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
4693 if (gfc_is_coarray (tail
->expr
)
4694 && gfc_find_state (COMP_CRITICAL
))
4696 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
4700 /* FIXME: disable the checking on derived types. */
4701 b1
= !(tail
->expr
->ref
4702 && (tail
->expr
->ref
->type
== REF_COMPONENT
4703 || tail
->expr
->ref
->type
== REF_ARRAY
));
4704 if (sym
&& sym
->ts
.type
== BT_CLASS
)
4705 b2
= !(CLASS_DATA (sym
) && (CLASS_DATA (sym
)->attr
.allocatable
4706 || CLASS_DATA (sym
)->attr
.class_pointer
));
4708 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4709 || sym
->attr
.proc_pointer
);
4712 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
4713 "nor an allocatable variable");
4717 if (gfc_match_char (',') != MATCH_YES
)
4722 m
= gfc_match (" stat = %v", &tmp
);
4723 if (m
== MATCH_ERROR
)
4729 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4730 gfc_free_expr (tmp
);
4737 if (gfc_check_do_variable (stat
->symtree
))
4740 if (gfc_match_char (',') == MATCH_YES
)
4741 goto dealloc_opt_list
;
4744 m
= gfc_match (" errmsg = %v", &tmp
);
4745 if (m
== MATCH_ERROR
)
4749 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
4754 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4755 gfc_free_expr (tmp
);
4762 if (gfc_match_char (',') == MATCH_YES
)
4763 goto dealloc_opt_list
;
4766 gfc_gobble_whitespace ();
4768 if (gfc_peek_char () == ')')
4772 if (gfc_match (" )%t") != MATCH_YES
)
4775 new_st
.op
= EXEC_DEALLOCATE
;
4776 new_st
.expr1
= stat
;
4777 new_st
.expr2
= errmsg
;
4778 new_st
.ext
.alloc
.list
= head
;
4783 gfc_syntax_error (ST_DEALLOCATE
);
4786 gfc_free_expr (errmsg
);
4787 gfc_free_expr (stat
);
4788 gfc_free_alloc_list (head
);
4793 /* Match a RETURN statement. */
4796 gfc_match_return (void)
4800 gfc_compile_state s
;
4804 if (gfc_find_state (COMP_CRITICAL
))
4806 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4810 if (gfc_find_state (COMP_DO_CONCURRENT
))
4812 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4816 if (gfc_match_eos () == MATCH_YES
)
4819 if (!gfc_find_state (COMP_SUBROUTINE
))
4821 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4826 if (gfc_current_form
== FORM_FREE
)
4828 /* The following are valid, so we can't require a blank after the
4832 char c
= gfc_peek_ascii_char ();
4833 if (ISALPHA (c
) || ISDIGIT (c
))
4837 m
= gfc_match (" %e%t", &e
);
4840 if (m
== MATCH_ERROR
)
4843 gfc_syntax_error (ST_RETURN
);
4850 gfc_enclosing_unit (&s
);
4851 if (s
== COMP_PROGRAM
4852 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
4853 "main program at %C"))
4856 new_st
.op
= EXEC_RETURN
;
4863 /* Match the call of a type-bound procedure, if CALL%var has already been
4864 matched and var found to be a derived-type variable. */
4867 match_typebound_call (gfc_symtree
* varst
)
4872 base
= gfc_get_expr ();
4873 base
->expr_type
= EXPR_VARIABLE
;
4874 base
->symtree
= varst
;
4875 base
->where
= gfc_current_locus
;
4876 gfc_set_sym_referenced (varst
->n
.sym
);
4878 m
= gfc_match_varspec (base
, 0, true, true);
4880 gfc_error ("Expected component reference at %C");
4883 gfc_free_expr (base
);
4887 if (gfc_match_eos () != MATCH_YES
)
4889 gfc_error ("Junk after CALL at %C");
4890 gfc_free_expr (base
);
4894 if (base
->expr_type
== EXPR_COMPCALL
)
4895 new_st
.op
= EXEC_COMPCALL
;
4896 else if (base
->expr_type
== EXPR_PPC
)
4897 new_st
.op
= EXEC_CALL_PPC
;
4900 gfc_error ("Expected type-bound procedure or procedure pointer component "
4902 gfc_free_expr (base
);
4905 new_st
.expr1
= base
;
4911 /* Match a CALL statement. The tricky part here are possible
4912 alternate return specifiers. We handle these by having all
4913 "subroutines" actually return an integer via a register that gives
4914 the return number. If the call specifies alternate returns, we
4915 generate code for a SELECT statement whose case clauses contain
4916 GOTOs to the various labels. */
4919 gfc_match_call (void)
4921 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4922 gfc_actual_arglist
*a
, *arglist
;
4932 m
= gfc_match ("% %n", name
);
4938 if (gfc_get_ha_sym_tree (name
, &st
))
4943 /* If this is a variable of derived-type, it probably starts a type-bound
4945 if ((sym
->attr
.flavor
!= FL_PROCEDURE
4946 || gfc_is_function_return_value (sym
, gfc_current_ns
))
4947 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
4948 return match_typebound_call (st
);
4950 /* If it does not seem to be callable (include functions so that the
4951 right association is made. They are thrown out in resolution.)
4953 if (!sym
->attr
.generic
4954 && !sym
->attr
.subroutine
4955 && !sym
->attr
.function
)
4957 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
4959 /* ...create a symbol in this scope... */
4960 if (sym
->ns
!= gfc_current_ns
4961 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
4964 if (sym
!= st
->n
.sym
)
4968 /* ...and then to try to make the symbol into a subroutine. */
4969 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
4973 gfc_set_sym_referenced (sym
);
4975 if (gfc_match_eos () != MATCH_YES
)
4977 m
= gfc_match_actual_arglist (1, &arglist
);
4980 if (m
== MATCH_ERROR
)
4983 if (gfc_match_eos () != MATCH_YES
)
4987 /* Walk the argument list looking for invalid BOZ. */
4988 for (a
= arglist
; a
; a
= a
->next
)
4989 if (a
->expr
&& a
->expr
->ts
.type
== BT_BOZ
)
4991 gfc_error ("A BOZ literal constant at %L cannot appear as an actual "
4992 "argument in a subroutine reference", &a
->expr
->where
);
4997 /* If any alternate return labels were found, construct a SELECT
4998 statement that will jump to the right place. */
5001 for (a
= arglist
; a
; a
= a
->next
)
5002 if (a
->expr
== NULL
)
5010 gfc_symtree
*select_st
;
5011 gfc_symbol
*select_sym
;
5012 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5014 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
5015 sprintf (name
, "_result_%s", sym
->name
);
5016 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
5018 select_sym
= select_st
->n
.sym
;
5019 select_sym
->ts
.type
= BT_INTEGER
;
5020 select_sym
->ts
.kind
= gfc_default_integer_kind
;
5021 gfc_set_sym_referenced (select_sym
);
5022 c
->expr1
= gfc_get_expr ();
5023 c
->expr1
->expr_type
= EXPR_VARIABLE
;
5024 c
->expr1
->symtree
= select_st
;
5025 c
->expr1
->ts
= select_sym
->ts
;
5026 c
->expr1
->where
= gfc_current_locus
;
5029 for (a
= arglist
; a
; a
= a
->next
)
5031 if (a
->expr
!= NULL
)
5034 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
5039 c
->block
= gfc_get_code (EXEC_SELECT
);
5042 new_case
= gfc_get_case ();
5043 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
5044 new_case
->low
= new_case
->high
;
5045 c
->ext
.block
.case_list
= new_case
;
5047 c
->next
= gfc_get_code (EXEC_GOTO
);
5048 c
->next
->label1
= a
->label
;
5052 new_st
.op
= EXEC_CALL
;
5053 new_st
.symtree
= st
;
5054 new_st
.ext
.actual
= arglist
;
5059 gfc_syntax_error (ST_CALL
);
5062 gfc_free_actual_arglist (arglist
);
5067 /* Given a name, return a pointer to the common head structure,
5068 creating it if it does not exist. If FROM_MODULE is nonzero, we
5069 mangle the name so that it doesn't interfere with commons defined
5070 in the using namespace.
5071 TODO: Add to global symbol tree. */
5074 gfc_get_common (const char *name
, int from_module
)
5077 static int serial
= 0;
5078 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
5082 /* A use associated common block is only needed to correctly layout
5083 the variables it contains. */
5084 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
5085 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
5089 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
5092 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
5095 if (st
->n
.common
== NULL
)
5097 st
->n
.common
= gfc_get_common_head ();
5098 st
->n
.common
->where
= gfc_current_locus
;
5099 strcpy (st
->n
.common
->name
, name
);
5102 return st
->n
.common
;
5106 /* Match a common block name. */
5108 match
match_common_name (char *name
)
5112 if (gfc_match_char ('/') == MATCH_NO
)
5118 if (gfc_match_char ('/') == MATCH_YES
)
5124 m
= gfc_match_name (name
);
5126 if (m
== MATCH_ERROR
)
5128 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
5131 gfc_error ("Syntax error in common block name at %C");
5136 /* Match a COMMON statement. */
5139 gfc_match_common (void)
5141 gfc_symbol
*sym
, **head
, *tail
, *other
;
5142 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5149 /* COMMON has been matched. In free form source code, the next character
5150 needs to be whitespace or '/'. Check that here. Fixed form source
5151 code needs to be checked below. */
5152 c
= gfc_peek_ascii_char ();
5153 if (gfc_current_form
== FORM_FREE
&& !gfc_is_whitespace (c
) && c
!= '/')
5160 m
= match_common_name (name
);
5161 if (m
== MATCH_ERROR
)
5164 if (name
[0] == '\0')
5166 t
= &gfc_current_ns
->blank_common
;
5167 if (t
->head
== NULL
)
5168 t
->where
= gfc_current_locus
;
5172 t
= gfc_get_common (name
, 0);
5181 while (tail
->common_next
)
5182 tail
= tail
->common_next
;
5185 /* Grab the list of symbols. */
5188 m
= gfc_match_symbol (&sym
, 0);
5189 if (m
== MATCH_ERROR
)
5194 /* See if we know the current common block is bind(c), and if
5195 so, then see if we can check if the symbol is (which it'll
5196 need to be). This can happen if the bind(c) attr stmt was
5197 applied to the common block, and the variable(s) already
5198 defined, before declaring the common block. */
5199 if (t
->is_bind_c
== 1)
5201 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
5203 /* If we find an error, just print it and continue,
5204 cause it's just semantic, and we can see if there
5206 gfc_error_now ("Variable %qs at %L in common block %qs "
5207 "at %C must be declared with a C "
5208 "interoperable kind since common block "
5210 sym
->name
, &(sym
->declared_at
), t
->name
,
5214 if (sym
->attr
.is_bind_c
== 1)
5215 gfc_error_now ("Variable %qs in common block %qs at %C cannot "
5216 "be bind(c) since it is not global", sym
->name
,
5220 if (sym
->attr
.in_common
)
5222 gfc_error ("Symbol %qs at %C is already in a COMMON block",
5227 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
5228 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
5230 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol %qs at "
5231 "%C can only be COMMON in BLOCK DATA",
5236 /* Deal with an optional array specification after the
5238 m
= gfc_match_array_spec (&as
, true, true);
5239 if (m
== MATCH_ERROR
)
5244 if (as
->type
!= AS_EXPLICIT
)
5246 gfc_error ("Array specification for symbol %qs in COMMON "
5247 "at %C must be explicit", sym
->name
);
5251 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
5254 if (sym
->attr
.pointer
)
5256 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
5257 "POINTER array", sym
->name
);
5266 /* Add the in_common attribute, but ignore the reported errors
5267 if any, and continue matching. */
5268 gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
);
5270 sym
->common_block
= t
;
5271 sym
->common_block
->refs
++;
5274 tail
->common_next
= sym
;
5280 sym
->common_head
= t
;
5282 /* Check to see if the symbol is already in an equivalence group.
5283 If it is, set the other members as being in common. */
5284 if (sym
->attr
.in_equivalence
)
5286 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
5288 for (e2
= e1
; e2
; e2
= e2
->eq
)
5289 if (e2
->expr
->symtree
->n
.sym
== sym
)
5296 for (e2
= e1
; e2
; e2
= e2
->eq
)
5298 other
= e2
->expr
->symtree
->n
.sym
;
5299 if (other
->common_head
5300 && other
->common_head
!= sym
->common_head
)
5302 gfc_error ("Symbol %qs, in COMMON block %qs at "
5303 "%C is being indirectly equivalenced to "
5304 "another COMMON block %qs",
5305 sym
->name
, sym
->common_head
->name
,
5306 other
->common_head
->name
);
5309 other
->attr
.in_common
= 1;
5310 other
->common_head
= t
;
5316 gfc_gobble_whitespace ();
5317 if (gfc_match_eos () == MATCH_YES
)
5319 c
= gfc_peek_ascii_char ();
5324 /* In Fixed form source code, gfortran can end up here for an
5325 expression of the form COMMONI = RHS. This may not be an
5326 error, so return MATCH_NO. */
5327 if (gfc_current_form
== FORM_FIXED
&& c
== '=')
5329 gfc_free_array_spec (as
);
5335 gfc_match_char (',');
5337 gfc_gobble_whitespace ();
5338 if (gfc_peek_ascii_char () == '/')
5347 gfc_syntax_error (ST_COMMON
);
5350 gfc_free_array_spec (as
);
5355 /* Match a BLOCK DATA program unit. */
5358 gfc_match_block_data (void)
5360 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5364 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "BLOCK DATA construct at %L",
5365 &gfc_current_locus
))
5368 if (gfc_match_eos () == MATCH_YES
)
5370 gfc_new_block
= NULL
;
5374 m
= gfc_match ("% %n%t", name
);
5378 if (gfc_get_symbol (name
, NULL
, &sym
))
5381 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
5384 gfc_new_block
= sym
;
5390 /* Free a namelist structure. */
5393 gfc_free_namelist (gfc_namelist
*name
)
5397 for (; name
; name
= n
)
5405 /* Free an OpenMP namelist structure. */
5408 gfc_free_omp_namelist (gfc_omp_namelist
*name
)
5410 gfc_omp_namelist
*n
;
5412 for (; name
; name
= n
)
5414 gfc_free_expr (name
->expr
);
5417 if (name
->udr
->combiner
)
5418 gfc_free_statement (name
->udr
->combiner
);
5419 if (name
->udr
->initializer
)
5420 gfc_free_statement (name
->udr
->initializer
);
5429 /* Match a NAMELIST statement. */
5432 gfc_match_namelist (void)
5434 gfc_symbol
*group_name
, *sym
;
5438 m
= gfc_match (" / %s /", &group_name
);
5441 if (m
== MATCH_ERROR
)
5446 if (group_name
->ts
.type
!= BT_UNKNOWN
)
5448 gfc_error ("Namelist group name %qs at %C already has a basic "
5449 "type of %s", group_name
->name
,
5450 gfc_typename (&group_name
->ts
));
5454 if (group_name
->attr
.flavor
== FL_NAMELIST
5455 && group_name
->attr
.use_assoc
5456 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name %qs "
5457 "at %C already is USE associated and can"
5458 "not be respecified.", group_name
->name
))
5461 if (group_name
->attr
.flavor
!= FL_NAMELIST
5462 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
5463 group_name
->name
, NULL
))
5468 m
= gfc_match_symbol (&sym
, 1);
5471 if (m
== MATCH_ERROR
)
5474 if (sym
->attr
.in_namelist
== 0
5475 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
5478 /* Use gfc_error_check here, rather than goto error, so that
5479 these are the only errors for the next two lines. */
5480 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
5482 gfc_error ("Assumed size array %qs in namelist %qs at "
5483 "%C is not allowed", sym
->name
, group_name
->name
);
5487 nl
= gfc_get_namelist ();
5491 if (group_name
->namelist
== NULL
)
5492 group_name
->namelist
= group_name
->namelist_tail
= nl
;
5495 group_name
->namelist_tail
->next
= nl
;
5496 group_name
->namelist_tail
= nl
;
5499 if (gfc_match_eos () == MATCH_YES
)
5502 m
= gfc_match_char (',');
5504 if (gfc_match_char ('/') == MATCH_YES
)
5506 m2
= gfc_match (" %s /", &group_name
);
5507 if (m2
== MATCH_YES
)
5509 if (m2
== MATCH_ERROR
)
5523 gfc_syntax_error (ST_NAMELIST
);
5530 /* Match a MODULE statement. */
5533 gfc_match_module (void)
5537 m
= gfc_match (" %s%t", &gfc_new_block
);
5541 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
5542 gfc_new_block
->name
, NULL
))
5549 /* Free equivalence sets and lists. Recursively is the easiest way to
5553 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
5558 gfc_free_equiv (eq
->eq
);
5559 gfc_free_equiv_until (eq
->next
, stop
);
5560 gfc_free_expr (eq
->expr
);
5566 gfc_free_equiv (gfc_equiv
*eq
)
5568 gfc_free_equiv_until (eq
, NULL
);
5572 /* Match an EQUIVALENCE statement. */
5575 gfc_match_equivalence (void)
5577 gfc_equiv
*eq
, *set
, *tail
;
5581 gfc_common_head
*common_head
= NULL
;
5586 /* EQUIVALENCE has been matched. After gobbling any possible whitespace,
5587 the next character needs to be '('. Check that here, and return
5588 MATCH_NO for a variable of the form equivalencej. */
5589 gfc_gobble_whitespace ();
5590 c
= gfc_peek_ascii_char ();
5598 eq
= gfc_get_equiv ();
5602 eq
->next
= gfc_current_ns
->equiv
;
5603 gfc_current_ns
->equiv
= eq
;
5605 if (gfc_match_char ('(') != MATCH_YES
)
5609 common_flag
= FALSE
;
5614 m
= gfc_match_equiv_variable (&set
->expr
);
5615 if (m
== MATCH_ERROR
)
5620 /* count the number of objects. */
5623 if (gfc_match_char ('%') == MATCH_YES
)
5625 gfc_error ("Derived type component %C is not a "
5626 "permitted EQUIVALENCE member");
5630 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
5631 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5633 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
5634 "be an array section");
5638 sym
= set
->expr
->symtree
->n
.sym
;
5640 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
5643 if (sym
->attr
.in_common
)
5646 common_head
= sym
->common_head
;
5649 if (gfc_match_char (')') == MATCH_YES
)
5652 if (gfc_match_char (',') != MATCH_YES
)
5655 set
->eq
= gfc_get_equiv ();
5661 gfc_error ("EQUIVALENCE at %C requires two or more objects");
5665 /* If one of the members of an equivalence is in common, then
5666 mark them all as being in common. Before doing this, check
5667 that members of the equivalence group are not in different
5670 for (set
= eq
; set
; set
= set
->eq
)
5672 sym
= set
->expr
->symtree
->n
.sym
;
5673 if (sym
->common_head
&& sym
->common_head
!= common_head
)
5675 gfc_error ("Attempt to indirectly overlap COMMON "
5676 "blocks %s and %s by EQUIVALENCE at %C",
5677 sym
->common_head
->name
, common_head
->name
);
5680 sym
->attr
.in_common
= 1;
5681 sym
->common_head
= common_head
;
5684 if (gfc_match_eos () == MATCH_YES
)
5686 if (gfc_match_char (',') != MATCH_YES
)
5688 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
5693 if (!gfc_notify_std (GFC_STD_F2018_OBS
, "EQUIVALENCE statement at %C"))
5699 gfc_syntax_error (ST_EQUIVALENCE
);
5705 gfc_free_equiv (gfc_current_ns
->equiv
);
5706 gfc_current_ns
->equiv
= eq
;
5712 /* Check that a statement function is not recursive. This is done by looking
5713 for the statement function symbol(sym) by looking recursively through its
5714 expression(e). If a reference to sym is found, true is returned.
5715 12.5.4 requires that any variable of function that is implicitly typed
5716 shall have that type confirmed by any subsequent type declaration. The
5717 implicit typing is conveniently done here. */
5719 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
5722 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
5728 switch (e
->expr_type
)
5731 if (e
->symtree
== NULL
)
5734 /* Check the name before testing for nested recursion! */
5735 if (sym
->name
== e
->symtree
->n
.sym
->name
)
5738 /* Catch recursion via other statement functions. */
5739 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
5740 && e
->symtree
->n
.sym
->value
5741 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
5744 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5745 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5750 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
5753 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5754 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5766 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
5768 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
5772 /* Match a statement function declaration. It is so easy to match
5773 non-statement function statements with a MATCH_ERROR as opposed to
5774 MATCH_NO that we suppress error message in most cases. */
5777 gfc_match_st_function (void)
5779 gfc_error_buffer old_error
;
5783 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5786 gfc_formal_arglist
*ptr
;
5788 /* Read the possible statement function name, and then check to see if
5789 a symbol is already present in the namespace. Record if it is a
5790 function and whether it has been referenced. */
5793 old_locus
= gfc_current_locus
;
5794 m
= gfc_match_name (name
);
5797 gfc_find_symbol (name
, NULL
, 1, &sym
);
5798 if (sym
&& sym
->attr
.function
&& !sym
->attr
.referenced
)
5805 gfc_current_locus
= old_locus
;
5806 m
= gfc_match_symbol (&sym
, 0);
5810 gfc_push_error (&old_error
);
5812 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
5815 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
5818 m
= gfc_match (" = %e%t", &expr
);
5822 gfc_free_error (&old_error
);
5824 if (m
== MATCH_ERROR
)
5827 if (recursive_stmt_fcn (expr
, sym
))
5829 gfc_error ("Statement function at %L is recursive", &expr
->where
);
5833 if (fcn
&& ptr
!= sym
->formal
)
5835 gfc_error ("Statement function %qs at %L conflicts with function name",
5836 sym
->name
, &expr
->where
);
5842 if ((gfc_current_state () == COMP_FUNCTION
5843 || gfc_current_state () == COMP_SUBROUTINE
)
5844 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
5846 gfc_error ("Statement function at %L cannot appear within an INTERFACE",
5851 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
5857 gfc_pop_error (&old_error
);
5862 /* Match an assignment to a pointer function (F2008). This could, in
5863 general be ambiguous with a statement function. In this implementation
5864 it remains so if it is the first statement after the specification
5868 gfc_match_ptr_fcn_assign (void)
5870 gfc_error_buffer old_error
;
5875 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5877 old_loc
= gfc_current_locus
;
5878 m
= gfc_match_name (name
);
5882 gfc_find_symbol (name
, NULL
, 1, &sym
);
5883 if (sym
&& sym
->attr
.flavor
!= FL_PROCEDURE
)
5886 gfc_push_error (&old_error
);
5888 if (sym
&& sym
->attr
.function
)
5889 goto match_actual_arglist
;
5891 gfc_current_locus
= old_loc
;
5892 m
= gfc_match_symbol (&sym
, 0);
5896 if (!gfc_add_procedure (&sym
->attr
, PROC_UNKNOWN
, sym
->name
, NULL
))
5899 match_actual_arglist
:
5900 gfc_current_locus
= old_loc
;
5901 m
= gfc_match (" %e", &expr
);
5905 new_st
.op
= EXEC_ASSIGN
;
5906 new_st
.expr1
= expr
;
5909 m
= gfc_match (" = %e%t", &expr
);
5913 new_st
.expr2
= expr
;
5917 gfc_pop_error (&old_error
);
5922 /***************** SELECT CASE subroutines ******************/
5924 /* Free a single case structure. */
5927 free_case (gfc_case
*p
)
5929 if (p
->low
== p
->high
)
5931 gfc_free_expr (p
->low
);
5932 gfc_free_expr (p
->high
);
5937 /* Free a list of case structures. */
5940 gfc_free_case_list (gfc_case
*p
)
5952 /* Match a single case selector. Combining the requirements of F08:C830
5953 and F08:C832 (R838) means that the case-value must have either CHARACTER,
5954 INTEGER, or LOGICAL type. */
5957 match_case_selector (gfc_case
**cp
)
5962 c
= gfc_get_case ();
5963 c
->where
= gfc_current_locus
;
5965 if (gfc_match_char (':') == MATCH_YES
)
5967 m
= gfc_match_init_expr (&c
->high
);
5970 if (m
== MATCH_ERROR
)
5973 if (c
->high
->ts
.type
!= BT_LOGICAL
&& c
->high
->ts
.type
!= BT_INTEGER
5974 && c
->high
->ts
.type
!= BT_CHARACTER
)
5976 gfc_error ("Expression in CASE selector at %L cannot be %s",
5977 &c
->high
->where
, gfc_typename (&c
->high
->ts
));
5983 m
= gfc_match_init_expr (&c
->low
);
5984 if (m
== MATCH_ERROR
)
5989 if (c
->low
->ts
.type
!= BT_LOGICAL
&& c
->low
->ts
.type
!= BT_INTEGER
5990 && c
->low
->ts
.type
!= BT_CHARACTER
)
5992 gfc_error ("Expression in CASE selector at %L cannot be %s",
5993 &c
->low
->where
, gfc_typename (&c
->low
->ts
));
5997 /* If we're not looking at a ':' now, make a range out of a single
5998 target. Else get the upper bound for the case range. */
5999 if (gfc_match_char (':') != MATCH_YES
)
6003 m
= gfc_match_init_expr (&c
->high
);
6004 if (m
== MATCH_ERROR
)
6006 /* MATCH_NO is fine. It's OK if nothing is there! */
6014 gfc_error ("Expected initialization expression in CASE at %C");
6022 /* Match the end of a case statement. */
6025 match_case_eos (void)
6027 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6030 if (gfc_match_eos () == MATCH_YES
)
6033 /* If the case construct doesn't have a case-construct-name, we
6034 should have matched the EOS. */
6035 if (!gfc_current_block ())
6038 gfc_gobble_whitespace ();
6040 m
= gfc_match_name (name
);
6044 if (strcmp (name
, gfc_current_block ()->name
) != 0)
6046 gfc_error ("Expected block name %qs of SELECT construct at %C",
6047 gfc_current_block ()->name
);
6051 return gfc_match_eos ();
6055 /* Match a SELECT statement. */
6058 gfc_match_select (void)
6063 m
= gfc_match_label ();
6064 if (m
== MATCH_ERROR
)
6067 m
= gfc_match (" select case ( %e )%t", &expr
);
6071 new_st
.op
= EXEC_SELECT
;
6072 new_st
.expr1
= expr
;
6078 /* Transfer the selector typespec to the associate name. */
6081 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
)
6084 gfc_symbol
*assoc_sym
;
6087 assoc_sym
= associate
->symtree
->n
.sym
;
6089 /* At this stage the expression rank and arrayspec dimensions have
6090 not been completely sorted out. We must get the expr2->rank
6091 right here, so that the correct class container is obtained. */
6092 ref
= selector
->ref
;
6093 while (ref
&& ref
->next
)
6096 if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
6097 && CLASS_DATA (selector
)->as
->type
== AS_ASSUMED_RANK
)
6099 assoc_sym
->attr
.dimension
= 1;
6100 assoc_sym
->as
= gfc_copy_array_spec (CLASS_DATA (selector
)->as
);
6101 goto build_class_sym
;
6103 else if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
6104 && ref
&& ref
->type
== REF_ARRAY
)
6106 /* Ensure that the array reference type is set. We cannot use
6107 gfc_resolve_expr at this point, so the usable parts of
6108 resolve.c(resolve_array_ref) are employed to do it. */
6109 if (ref
->u
.ar
.type
== AR_UNKNOWN
)
6111 ref
->u
.ar
.type
= AR_ELEMENT
;
6112 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
6113 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
6114 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
6115 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
6116 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
6118 ref
->u
.ar
.type
= AR_SECTION
;
6123 if (ref
->u
.ar
.type
== AR_FULL
)
6124 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
6125 else if (ref
->u
.ar
.type
== AR_SECTION
)
6126 selector
->rank
= ref
->u
.ar
.dimen
;
6130 rank
= selector
->rank
;
6135 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
6136 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
6137 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
6138 && ref
->u
.ar
.end
[i
] == NULL
6139 && ref
->u
.ar
.stride
[i
] == NULL
))
6144 assoc_sym
->attr
.dimension
= 1;
6145 assoc_sym
->as
= gfc_get_array_spec ();
6146 assoc_sym
->as
->rank
= rank
;
6147 assoc_sym
->as
->type
= AS_DEFERRED
;
6150 assoc_sym
->as
= NULL
;
6153 assoc_sym
->as
= NULL
;
6156 if (selector
->ts
.type
== BT_CLASS
)
6158 /* The correct class container has to be available. */
6159 assoc_sym
->ts
.type
= BT_CLASS
;
6160 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
6161 assoc_sym
->attr
.pointer
= 1;
6162 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
6167 /* Push the current selector onto the SELECT TYPE stack. */
6170 select_type_push (gfc_symbol
*sel
)
6172 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
6173 top
->selector
= sel
;
6175 top
->prev
= select_type_stack
;
6177 select_type_stack
= top
;
6181 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
6183 static gfc_symtree
*
6184 select_intrinsic_set_tmp (gfc_typespec
*ts
)
6186 char name
[GFC_MAX_SYMBOL_LEN
];
6188 HOST_WIDE_INT charlen
= 0;
6189 gfc_symbol
*selector
= select_type_stack
->selector
;
6192 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
6195 if (selector
->ts
.type
== BT_CLASS
&& !selector
->attr
.class_ok
)
6198 /* Case value == NULL corresponds to SELECT TYPE cases otherwise
6199 the values correspond to SELECT rank cases. */
6200 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
6201 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6202 charlen
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
6204 if (ts
->type
!= BT_CHARACTER
)
6205 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
6208 snprintf (name
, sizeof (name
),
6209 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
6210 gfc_basic_typename (ts
->type
), charlen
, ts
->kind
);
6212 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6214 gfc_add_type (sym
, ts
, NULL
);
6216 /* Copy across the array spec to the selector. */
6217 if (selector
->ts
.type
== BT_CLASS
6218 && (CLASS_DATA (selector
)->attr
.dimension
6219 || CLASS_DATA (selector
)->attr
.codimension
))
6221 sym
->attr
.pointer
= 1;
6222 sym
->attr
.dimension
= CLASS_DATA (selector
)->attr
.dimension
;
6223 sym
->attr
.codimension
= CLASS_DATA (selector
)->attr
.codimension
;
6224 sym
->as
= gfc_copy_array_spec (CLASS_DATA (selector
)->as
);
6227 gfc_set_sym_referenced (sym
);
6228 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, name
, NULL
);
6229 sym
->attr
.select_type_temporary
= 1;
6235 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
6238 select_type_set_tmp (gfc_typespec
*ts
)
6240 char name
[GFC_MAX_SYMBOL_LEN
];
6241 gfc_symtree
*tmp
= NULL
;
6242 gfc_symbol
*selector
= select_type_stack
->selector
;
6247 select_type_stack
->tmp
= NULL
;
6251 tmp
= select_intrinsic_set_tmp (ts
);
6258 if (ts
->type
== BT_CLASS
)
6259 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
6261 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
6263 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6265 gfc_add_type (sym
, ts
, NULL
);
6267 if (selector
->ts
.type
== BT_CLASS
&& selector
->attr
.class_ok
)
6270 = CLASS_DATA (selector
)->attr
.class_pointer
;
6272 /* Copy across the array spec to the selector. */
6273 if (CLASS_DATA (selector
)->attr
.dimension
6274 || CLASS_DATA (selector
)->attr
.codimension
)
6277 = CLASS_DATA (selector
)->attr
.dimension
;
6278 sym
->attr
.codimension
6279 = CLASS_DATA (selector
)->attr
.codimension
;
6281 = gfc_copy_array_spec (CLASS_DATA (selector
)->as
);
6285 gfc_set_sym_referenced (sym
);
6286 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, name
, NULL
);
6287 sym
->attr
.select_type_temporary
= 1;
6289 if (ts
->type
== BT_CLASS
)
6290 gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
6296 /* Add an association for it, so the rest of the parser knows it is
6297 an associate-name. The target will be set during resolution. */
6298 sym
->assoc
= gfc_get_association_list ();
6299 sym
->assoc
->dangling
= 1;
6300 sym
->assoc
->st
= tmp
;
6302 select_type_stack
->tmp
= tmp
;
6306 /* Match a SELECT TYPE statement. */
6309 gfc_match_select_type (void)
6311 gfc_expr
*expr1
, *expr2
= NULL
;
6313 char name
[GFC_MAX_SYMBOL_LEN
];
6316 gfc_namespace
*ns
= gfc_current_ns
;
6318 m
= gfc_match_label ();
6319 if (m
== MATCH_ERROR
)
6322 m
= gfc_match (" select type ( ");
6326 if (gfc_current_state() == COMP_MODULE
6327 || gfc_current_state() == COMP_SUBMODULE
)
6329 gfc_error ("SELECT TYPE at %C cannot appear in this scope");
6333 gfc_current_ns
= gfc_build_block_ns (ns
);
6334 m
= gfc_match (" %n => %e", name
, &expr2
);
6337 expr1
= gfc_get_expr ();
6338 expr1
->expr_type
= EXPR_VARIABLE
;
6339 expr1
->where
= expr2
->where
;
6340 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
6346 sym
= expr1
->symtree
->n
.sym
;
6347 if (expr2
->ts
.type
== BT_UNKNOWN
)
6348 sym
->attr
.untyped
= 1;
6350 copy_ts_from_selector_to_associate (expr1
, expr2
);
6352 sym
->attr
.flavor
= FL_VARIABLE
;
6353 sym
->attr
.referenced
= 1;
6354 sym
->attr
.class_ok
= 1;
6358 m
= gfc_match (" %e ", &expr1
);
6361 std::swap (ns
, gfc_current_ns
);
6362 gfc_free_namespace (ns
);
6367 m
= gfc_match (" )%t");
6370 gfc_error ("parse error in SELECT TYPE statement at %C");
6374 /* This ghastly expression seems to be needed to distinguish a CLASS
6375 array, which can have a reference, from other expressions that
6376 have references, such as derived type components, and are not
6377 allowed by the standard.
6378 TODO: see if it is sufficient to exclude component and substring
6380 class_array
= (expr1
->expr_type
== EXPR_VARIABLE
6381 && expr1
->ts
.type
== BT_CLASS
6382 && CLASS_DATA (expr1
)
6383 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
6384 && (CLASS_DATA (expr1
)->attr
.dimension
6385 || CLASS_DATA (expr1
)->attr
.codimension
)
6387 && expr1
->ref
->type
== REF_ARRAY
6388 && expr1
->ref
->u
.ar
.type
== AR_FULL
6389 && expr1
->ref
->next
== NULL
);
6391 /* Check for F03:C811 (F08:C835). */
6392 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
6393 || (!class_array
&& expr1
->ref
!= NULL
)))
6395 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
6396 "use associate-name=>");
6401 new_st
.op
= EXEC_SELECT_TYPE
;
6402 new_st
.expr1
= expr1
;
6403 new_st
.expr2
= expr2
;
6404 new_st
.ext
.block
.ns
= gfc_current_ns
;
6406 select_type_push (expr1
->symtree
->n
.sym
);
6407 gfc_current_ns
= ns
;
6412 gfc_free_expr (expr1
);
6413 gfc_free_expr (expr2
);
6414 gfc_undo_symbols ();
6415 std::swap (ns
, gfc_current_ns
);
6416 gfc_free_namespace (ns
);
6421 /* Set the temporary for the current intrinsic SELECT RANK selector. */
6424 select_rank_set_tmp (gfc_typespec
*ts
, int *case_value
)
6426 char name
[2 * GFC_MAX_SYMBOL_LEN
];
6427 char tname
[GFC_MAX_SYMBOL_LEN
];
6429 gfc_symbol
*selector
= select_type_stack
->selector
;
6432 HOST_WIDE_INT charlen
= 0;
6434 if (case_value
== NULL
)
6437 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
6438 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6439 charlen
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
6441 if (ts
->type
== BT_CLASS
)
6442 sprintf (tname
, "class_%s", ts
->u
.derived
->name
);
6443 else if (ts
->type
== BT_DERIVED
)
6444 sprintf (tname
, "type_%s", ts
->u
.derived
->name
);
6445 else if (ts
->type
!= BT_CHARACTER
)
6446 sprintf (tname
, "%s_%d", gfc_basic_typename (ts
->type
), ts
->kind
);
6448 sprintf (tname
, "%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
6449 gfc_basic_typename (ts
->type
), charlen
, ts
->kind
);
6451 /* Case value == NULL corresponds to SELECT TYPE cases otherwise
6452 the values correspond to SELECT rank cases. */
6453 if (*case_value
>=0)
6454 sprintf (name
, "__tmp_%s_rank_%d", tname
, *case_value
);
6456 sprintf (name
, "__tmp_%s_rank_m%d", tname
, -*case_value
);
6458 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
6462 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6464 gfc_add_type (sym
, ts
, NULL
);
6466 /* Copy across the array spec to the selector. */
6467 if (selector
->ts
.type
== BT_CLASS
)
6469 sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
6470 sym
->attr
.pointer
= CLASS_DATA (selector
)->attr
.pointer
;
6471 sym
->attr
.allocatable
= CLASS_DATA (selector
)->attr
.allocatable
;
6472 sym
->attr
.target
= CLASS_DATA (selector
)->attr
.target
;
6473 sym
->attr
.class_ok
= 0;
6474 if (case_value
&& *case_value
!= 0)
6476 sym
->attr
.dimension
= 1;
6477 sym
->as
= gfc_copy_array_spec (CLASS_DATA (selector
)->as
);
6478 if (*case_value
> 0)
6480 sym
->as
->type
= AS_DEFERRED
;
6481 sym
->as
->rank
= *case_value
;
6483 else if (*case_value
== -1)
6485 sym
->as
->type
= AS_ASSUMED_SIZE
;
6492 sym
->attr
.pointer
= selector
->attr
.pointer
;
6493 sym
->attr
.allocatable
= selector
->attr
.allocatable
;
6494 sym
->attr
.target
= selector
->attr
.target
;
6495 if (case_value
&& *case_value
!= 0)
6497 sym
->attr
.dimension
= 1;
6498 sym
->as
= gfc_copy_array_spec (selector
->as
);
6499 if (*case_value
> 0)
6501 sym
->as
->type
= AS_DEFERRED
;
6502 sym
->as
->rank
= *case_value
;
6504 else if (*case_value
== -1)
6506 sym
->as
->type
= AS_ASSUMED_SIZE
;
6512 gfc_set_sym_referenced (sym
);
6513 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, name
, NULL
);
6514 sym
->attr
.select_type_temporary
= 1;
6516 sym
->attr
.select_rank_temporary
= 1;
6518 if (ts
->type
== BT_CLASS
)
6519 gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
6521 /* Add an association for it, so the rest of the parser knows it is
6522 an associate-name. The target will be set during resolution. */
6523 sym
->assoc
= gfc_get_association_list ();
6524 sym
->assoc
->dangling
= 1;
6525 sym
->assoc
->st
= tmp
;
6527 select_type_stack
->tmp
= tmp
;
6531 /* Match a SELECT RANK statement. */
6534 gfc_match_select_rank (void)
6536 gfc_expr
*expr1
, *expr2
= NULL
;
6538 char name
[GFC_MAX_SYMBOL_LEN
];
6539 gfc_symbol
*sym
, *sym2
;
6540 gfc_namespace
*ns
= gfc_current_ns
;
6541 gfc_array_spec
*as
= NULL
;
6543 m
= gfc_match_label ();
6544 if (m
== MATCH_ERROR
)
6547 m
= gfc_match (" select rank ( ");
6551 if (!gfc_notify_std (GFC_STD_F2018
, "SELECT RANK statement at %C"))
6554 gfc_current_ns
= gfc_build_block_ns (ns
);
6555 m
= gfc_match (" %n => %e", name
, &expr2
);
6558 expr1
= gfc_get_expr ();
6559 expr1
->expr_type
= EXPR_VARIABLE
;
6560 expr1
->where
= expr2
->where
;
6561 expr1
->ref
= gfc_copy_ref (expr2
->ref
);
6562 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
6568 sym
= expr1
->symtree
->n
.sym
;
6572 sym2
= expr2
->symtree
->n
.sym
;
6573 as
= sym2
->ts
.type
== BT_CLASS
? CLASS_DATA (sym2
)->as
: sym2
->as
;
6576 if (expr2
->expr_type
!= EXPR_VARIABLE
6577 || !(as
&& as
->type
== AS_ASSUMED_RANK
))
6579 gfc_error ("The SELECT RANK selector at %C must be an assumed "
6585 if (expr2
->ts
.type
== BT_CLASS
)
6587 copy_ts_from_selector_to_associate (expr1
, expr2
);
6589 sym
->attr
.flavor
= FL_VARIABLE
;
6590 sym
->attr
.referenced
= 1;
6591 sym
->attr
.class_ok
= 1;
6592 CLASS_DATA (sym
)->attr
.allocatable
= CLASS_DATA (sym2
)->attr
.allocatable
;
6593 CLASS_DATA (sym
)->attr
.pointer
= CLASS_DATA (sym2
)->attr
.pointer
;
6594 CLASS_DATA (sym
)->attr
.target
= CLASS_DATA (sym2
)->attr
.target
;
6595 sym
->attr
.pointer
= 1;
6600 sym
->as
= gfc_copy_array_spec (sym2
->as
);
6601 sym
->attr
.dimension
= 1;
6603 sym
->attr
.flavor
= FL_VARIABLE
;
6604 sym
->attr
.referenced
= 1;
6605 sym
->attr
.class_ok
= sym2
->attr
.class_ok
;
6606 sym
->attr
.allocatable
= sym2
->attr
.allocatable
;
6607 sym
->attr
.pointer
= sym2
->attr
.pointer
;
6608 sym
->attr
.target
= sym2
->attr
.target
;
6613 m
= gfc_match (" %e ", &expr1
);
6617 std::swap (ns
, gfc_current_ns
);
6618 gfc_free_namespace (ns
);
6624 sym
= expr1
->symtree
->n
.sym
;
6625 as
= sym
->ts
.type
== BT_CLASS
? CLASS_DATA (sym
)->as
: sym
->as
;
6628 if (expr1
->expr_type
!= EXPR_VARIABLE
6629 || !(as
&& as
->type
== AS_ASSUMED_RANK
))
6631 gfc_error("The SELECT RANK selector at %C must be an assumed "
6638 m
= gfc_match (" )%t");
6641 gfc_error ("parse error in SELECT RANK statement at %C");
6645 new_st
.op
= EXEC_SELECT_RANK
;
6646 new_st
.expr1
= expr1
;
6647 new_st
.expr2
= expr2
;
6648 new_st
.ext
.block
.ns
= gfc_current_ns
;
6650 select_type_push (expr1
->symtree
->n
.sym
);
6651 gfc_current_ns
= ns
;
6656 gfc_free_expr (expr1
);
6657 gfc_free_expr (expr2
);
6658 gfc_undo_symbols ();
6659 std::swap (ns
, gfc_current_ns
);
6660 gfc_free_namespace (ns
);
6665 /* Match a CASE statement. */
6668 gfc_match_case (void)
6670 gfc_case
*c
, *head
, *tail
;
6675 if (gfc_current_state () != COMP_SELECT
)
6677 gfc_error ("Unexpected CASE statement at %C");
6681 if (gfc_match ("% default") == MATCH_YES
)
6683 m
= match_case_eos ();
6686 if (m
== MATCH_ERROR
)
6689 new_st
.op
= EXEC_SELECT
;
6690 c
= gfc_get_case ();
6691 c
->where
= gfc_current_locus
;
6692 new_st
.ext
.block
.case_list
= c
;
6696 if (gfc_match_char ('(') != MATCH_YES
)
6701 if (match_case_selector (&c
) == MATCH_ERROR
)
6711 if (gfc_match_char (')') == MATCH_YES
)
6713 if (gfc_match_char (',') != MATCH_YES
)
6717 m
= match_case_eos ();
6720 if (m
== MATCH_ERROR
)
6723 new_st
.op
= EXEC_SELECT
;
6724 new_st
.ext
.block
.case_list
= head
;
6729 gfc_error ("Syntax error in CASE specification at %C");
6732 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
6737 /* Match a TYPE IS statement. */
6740 gfc_match_type_is (void)
6745 if (gfc_current_state () != COMP_SELECT_TYPE
)
6747 gfc_error ("Unexpected TYPE IS statement at %C");
6751 if (gfc_match_char ('(') != MATCH_YES
)
6754 c
= gfc_get_case ();
6755 c
->where
= gfc_current_locus
;
6757 m
= gfc_match_type_spec (&c
->ts
);
6760 if (m
== MATCH_ERROR
)
6763 if (gfc_match_char (')') != MATCH_YES
)
6766 m
= match_case_eos ();
6769 if (m
== MATCH_ERROR
)
6772 new_st
.op
= EXEC_SELECT_TYPE
;
6773 new_st
.ext
.block
.case_list
= c
;
6775 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
6776 && (c
->ts
.u
.derived
->attr
.sequence
6777 || c
->ts
.u
.derived
->attr
.is_bind_c
))
6779 gfc_error ("The type-spec shall not specify a sequence derived "
6780 "type or a type with the BIND attribute in SELECT "
6781 "TYPE at %C [F2003:C815]");
6785 if (c
->ts
.type
== BT_DERIVED
6786 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
6787 && gfc_spec_list_type (type_param_spec_list
, c
->ts
.u
.derived
)
6790 gfc_error ("All the LEN type parameters in the TYPE IS statement "
6791 "at %C must be ASSUMED");
6795 /* Create temporary variable. */
6796 select_type_set_tmp (&c
->ts
);
6801 gfc_error ("Syntax error in TYPE IS specification at %C");
6805 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6810 /* Match a CLASS IS or CLASS DEFAULT statement. */
6813 gfc_match_class_is (void)
6818 if (gfc_current_state () != COMP_SELECT_TYPE
)
6821 if (gfc_match ("% default") == MATCH_YES
)
6823 m
= match_case_eos ();
6826 if (m
== MATCH_ERROR
)
6829 new_st
.op
= EXEC_SELECT_TYPE
;
6830 c
= gfc_get_case ();
6831 c
->where
= gfc_current_locus
;
6832 c
->ts
.type
= BT_UNKNOWN
;
6833 new_st
.ext
.block
.case_list
= c
;
6834 select_type_set_tmp (NULL
);
6838 m
= gfc_match ("% is");
6841 if (m
== MATCH_ERROR
)
6844 if (gfc_match_char ('(') != MATCH_YES
)
6847 c
= gfc_get_case ();
6848 c
->where
= gfc_current_locus
;
6850 m
= match_derived_type_spec (&c
->ts
);
6853 if (m
== MATCH_ERROR
)
6856 if (c
->ts
.type
== BT_DERIVED
)
6857 c
->ts
.type
= BT_CLASS
;
6859 if (gfc_match_char (')') != MATCH_YES
)
6862 m
= match_case_eos ();
6865 if (m
== MATCH_ERROR
)
6868 new_st
.op
= EXEC_SELECT_TYPE
;
6869 new_st
.ext
.block
.case_list
= c
;
6871 /* Create temporary variable. */
6872 select_type_set_tmp (&c
->ts
);
6877 gfc_error ("Syntax error in CLASS IS specification at %C");
6881 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6886 /* Match a RANK statement. */
6889 gfc_match_rank_is (void)
6895 if (gfc_current_state () != COMP_SELECT_RANK
)
6897 gfc_error ("Unexpected RANK statement at %C");
6901 if (gfc_match ("% default") == MATCH_YES
)
6903 m
= match_case_eos ();
6906 if (m
== MATCH_ERROR
)
6909 new_st
.op
= EXEC_SELECT_RANK
;
6910 c
= gfc_get_case ();
6911 c
->ts
.type
= BT_UNKNOWN
;
6912 c
->where
= gfc_current_locus
;
6913 new_st
.ext
.block
.case_list
= c
;
6914 select_type_stack
->tmp
= NULL
;
6918 if (gfc_match_char ('(') != MATCH_YES
)
6921 c
= gfc_get_case ();
6922 c
->where
= gfc_current_locus
;
6923 c
->ts
= select_type_stack
->selector
->ts
;
6925 m
= gfc_match_expr (&c
->low
);
6928 if (gfc_match_char ('*') == MATCH_YES
)
6929 c
->low
= gfc_get_int_expr (gfc_default_integer_kind
,
6936 else if (m
== MATCH_YES
)
6939 if (c
->low
->expr_type
!= EXPR_CONSTANT
6940 || c
->low
->ts
.type
!= BT_INTEGER
6943 gfc_error ("The SELECT RANK CASE expression at %C must be a "
6944 "scalar, integer constant");
6948 case_value
= (int) mpz_get_si (c
->low
->value
.integer
);
6950 if ((case_value
< 0) || (case_value
> GFC_MAX_DIMENSIONS
))
6952 gfc_error ("The value of the SELECT RANK CASE expression at "
6953 "%C must not be less than zero or greater than %d",
6954 GFC_MAX_DIMENSIONS
);
6961 if (gfc_match_char (')') != MATCH_YES
)
6964 m
= match_case_eos ();
6967 if (m
== MATCH_ERROR
)
6970 new_st
.op
= EXEC_SELECT_RANK
;
6971 new_st
.ext
.block
.case_list
= c
;
6973 /* Create temporary variable. Recycle the select type code. */
6974 select_rank_set_tmp (&c
->ts
, &case_value
);
6979 gfc_error ("Syntax error in RANK specification at %C");
6983 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6987 /********************* WHERE subroutines ********************/
6989 /* Match the rest of a simple WHERE statement that follows an IF statement.
6993 match_simple_where (void)
6999 m
= gfc_match (" ( %e )", &expr
);
7003 m
= gfc_match_assignment ();
7006 if (m
== MATCH_ERROR
)
7009 if (gfc_match_eos () != MATCH_YES
)
7012 c
= gfc_get_code (EXEC_WHERE
);
7015 c
->next
= XCNEW (gfc_code
);
7017 c
->next
->loc
= gfc_current_locus
;
7018 gfc_clear_new_st ();
7020 new_st
.op
= EXEC_WHERE
;
7026 gfc_syntax_error (ST_WHERE
);
7029 gfc_free_expr (expr
);
7034 /* Match a WHERE statement. */
7037 gfc_match_where (gfc_statement
*st
)
7043 m0
= gfc_match_label ();
7044 if (m0
== MATCH_ERROR
)
7047 m
= gfc_match (" where ( %e )", &expr
);
7051 if (gfc_match_eos () == MATCH_YES
)
7053 *st
= ST_WHERE_BLOCK
;
7054 new_st
.op
= EXEC_WHERE
;
7055 new_st
.expr1
= expr
;
7059 m
= gfc_match_assignment ();
7061 gfc_syntax_error (ST_WHERE
);
7065 gfc_free_expr (expr
);
7069 /* We've got a simple WHERE statement. */
7071 c
= gfc_get_code (EXEC_WHERE
);
7074 /* Put in the assignment. It will not be processed by add_statement, so we
7075 need to copy the location here. */
7077 c
->next
= XCNEW (gfc_code
);
7079 c
->next
->loc
= gfc_current_locus
;
7080 gfc_clear_new_st ();
7082 new_st
.op
= EXEC_WHERE
;
7089 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
7090 new_st if successful. */
7093 gfc_match_elsewhere (void)
7095 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7099 if (gfc_current_state () != COMP_WHERE
)
7101 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
7107 if (gfc_match_char ('(') == MATCH_YES
)
7109 m
= gfc_match_expr (&expr
);
7112 if (m
== MATCH_ERROR
)
7115 if (gfc_match_char (')') != MATCH_YES
)
7119 if (gfc_match_eos () != MATCH_YES
)
7121 /* Only makes sense if we have a where-construct-name. */
7122 if (!gfc_current_block ())
7127 /* Better be a name at this point. */
7128 m
= gfc_match_name (name
);
7131 if (m
== MATCH_ERROR
)
7134 if (gfc_match_eos () != MATCH_YES
)
7137 if (strcmp (name
, gfc_current_block ()->name
) != 0)
7139 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
7140 name
, gfc_current_block ()->name
);
7145 new_st
.op
= EXEC_WHERE
;
7146 new_st
.expr1
= expr
;
7150 gfc_syntax_error (ST_ELSEWHERE
);
7153 gfc_free_expr (expr
);