1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000-2018 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
29 int gfc_matching_ptr_assignment
= 0;
30 int gfc_matching_procptr_assignment
= 0;
31 bool gfc_matching_prefix
= false;
33 /* Stack of SELECT TYPE statements. */
34 gfc_select_type_stack
*select_type_stack
= NULL
;
36 /* List of type parameter expressions. */
37 gfc_actual_arglist
*type_param_spec_list
;
39 /* For debugging and diagnostic purposes. Return the textual representation
40 of the intrinsic operator OP. */
42 gfc_op2string (gfc_intrinsic_op op
)
50 case INTRINSIC_UMINUS
:
56 case INTRINSIC_CONCAT
:
60 case INTRINSIC_DIVIDE
:
99 case INTRINSIC_ASSIGN
:
102 case INTRINSIC_PARENTHESES
:
109 case INTRINSIC_FORMATTED
:
111 case INTRINSIC_UNFORMATTED
:
112 return "unformatted";
118 gfc_internal_error ("gfc_op2string(): Bad code");
123 /******************** Generic matching subroutines ************************/
125 /* Matches a member separator. With standard FORTRAN this is '%', but with
126 DEC structures we must carefully match dot ('.').
127 Because operators are spelled ".op.", a dotted string such as "x.y.z..."
128 can be either a component reference chain or a combination of binary
130 There is no real way to win because the string may be grammatically
131 ambiguous. The following rules help avoid ambiguities - they match
132 some behavior of other (older) compilers. If the rules here are changed
133 the test cases should be updated. If the user has problems with these rules
134 they probably deserve the consequences. Consider "x.y.z":
135 (1) If any user defined operator ".y." exists, this is always y(x,z)
136 (even if ".y." is the wrong type and/or x has a member y).
137 (2) Otherwise if x has a member y, and y is itself a derived type,
138 this is (x->y)->z, even if an intrinsic operator exists which
140 (3) If x has no member y or (x->y) is not a derived type but ".y."
141 is an intrinsic operator (such as ".eq."), this is y(x,z).
142 (4) Lastly if there is no operator ".y." and x has no member "y", it is an
144 It is worth noting that the logic here does not support mixed use of member
145 accessors within a single string. That is, even if x has component y and y
146 has component z, the following are all syntax errors:
147 "x%y.z" "x.y%z" "(x.y).z" "(x%y)%z"
151 gfc_match_member_sep(gfc_symbol
*sym
)
153 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
154 locus dot_loc
, start_loc
;
155 gfc_intrinsic_op iop
;
158 gfc_component
*c
= NULL
;
160 /* What a relief: '%' is an unambiguous member separator. */
161 if (gfc_match_char ('%') == MATCH_YES
)
164 /* Beware ye who enter here. */
165 if (!flag_dec_structure
|| !sym
)
170 /* We may be given either a derived type variable or the derived type
171 declaration itself (which actually contains the components);
172 we need the latter to search for components. */
173 if (gfc_fl_struct (sym
->attr
.flavor
))
175 else if (gfc_bt_struct (sym
->ts
.type
))
176 tsym
= sym
->ts
.u
.derived
;
178 iop
= INTRINSIC_NONE
;
182 /* If we have to reject come back here later. */
183 start_loc
= gfc_current_locus
;
185 /* Look for a component access next. */
186 if (gfc_match_char ('.') != MATCH_YES
)
189 /* If we accept, come back here. */
190 dot_loc
= gfc_current_locus
;
192 /* Try to match a symbol name following the dot. */
193 if (gfc_match_name (name
) != MATCH_YES
)
195 gfc_error ("Expected structure component or operator name "
200 /* If no dot follows we have "x.y" which should be a component access. */
201 if (gfc_match_char ('.') != MATCH_YES
)
204 /* Now we have a string "x.y.z" which could be a nested member access
205 (x->y)->z or a binary operation y on x and z. */
207 /* First use any user-defined operators ".y." */
208 if (gfc_find_uop (name
, sym
->ns
) != NULL
)
211 /* Match accesses to existing derived-type components for
212 derived-type vars: "x.y.z" = (x->y)->z */
213 c
= gfc_find_component(tsym
, name
, false, true, NULL
);
214 if (c
&& (gfc_bt_struct (c
->ts
.type
) || c
->ts
.type
== BT_CLASS
))
217 /* If y is not a component or has no members, try intrinsic operators. */
218 gfc_current_locus
= start_loc
;
219 if (gfc_match_intrinsic_op (&iop
) != MATCH_YES
)
221 /* If ".y." is not an intrinsic operator but y was a valid non-
222 structure component, match and leave the trailing dot to be
227 gfc_error ("%qs is neither a defined operator nor a "
228 "structure component in dotted string at %C", name
);
232 /* .y. is an intrinsic operator, overriding any possible member access. */
235 /* Return keeping the current locus consistent with the match result. */
239 gfc_current_locus
= start_loc
;
242 gfc_current_locus
= dot_loc
;
247 /* This function scans the current statement counting the opened and closed
248 parenthesis to make sure they are balanced. */
251 gfc_match_parens (void)
253 locus old_loc
, where
;
255 gfc_instring instring
;
258 old_loc
= gfc_current_locus
;
260 instring
= NONSTRING
;
265 c
= gfc_next_char_literal (instring
);
268 if (quote
== ' ' && ((c
== '\'') || (c
== '"')))
271 instring
= INSTRING_WARN
;
274 if (quote
!= ' ' && c
== quote
)
277 instring
= NONSTRING
;
281 if (c
== '(' && quote
== ' ')
284 where
= gfc_current_locus
;
286 if (c
== ')' && quote
== ' ')
289 where
= gfc_current_locus
;
293 gfc_current_locus
= old_loc
;
297 gfc_error ("Missing %<)%> in statement at or before %L", &where
);
302 gfc_error ("Missing %<(%> in statement at or before %L", &where
);
310 /* See if the next character is a special character that has
311 escaped by a \ via the -fbackslash option. */
314 gfc_match_special_char (gfc_char_t
*res
)
322 switch ((c
= gfc_next_char_literal (INSTRING_WARN
)))
355 /* Hexadecimal form of wide characters. */
356 len
= (c
== 'x' ? 2 : (c
== 'u' ? 4 : 8));
358 for (i
= 0; i
< len
; i
++)
360 char buf
[2] = { '\0', '\0' };
362 c
= gfc_next_char_literal (INSTRING_WARN
);
363 if (!gfc_wide_fits_in_byte (c
)
364 || !gfc_check_digit ((unsigned char) c
, 16))
367 buf
[0] = (unsigned char) c
;
369 n
+= strtol (buf
, NULL
, 16);
375 /* Unknown backslash codes are simply not expanded. */
384 /* In free form, match at least one space. Always matches in fixed
388 gfc_match_space (void)
393 if (gfc_current_form
== FORM_FIXED
)
396 old_loc
= gfc_current_locus
;
398 c
= gfc_next_ascii_char ();
399 if (!gfc_is_whitespace (c
))
401 gfc_current_locus
= old_loc
;
405 gfc_gobble_whitespace ();
411 /* Match an end of statement. End of statement is optional
412 whitespace, followed by a ';' or '\n' or comment '!'. If a
413 semicolon is found, we continue to eat whitespace and semicolons. */
426 old_loc
= gfc_current_locus
;
427 gfc_gobble_whitespace ();
429 c
= gfc_next_ascii_char ();
435 c
= gfc_next_ascii_char ();
452 gfc_current_locus
= old_loc
;
453 return (flag
) ? MATCH_YES
: MATCH_NO
;
457 /* Match a literal integer on the input, setting the value on
458 MATCH_YES. Literal ints occur in kind-parameters as well as
459 old-style character length specifications. If cnt is non-NULL it
460 will be set to the number of digits. */
463 gfc_match_small_literal_int (int *value
, int *cnt
)
469 old_loc
= gfc_current_locus
;
472 gfc_gobble_whitespace ();
473 c
= gfc_next_ascii_char ();
479 gfc_current_locus
= old_loc
;
488 old_loc
= gfc_current_locus
;
489 c
= gfc_next_ascii_char ();
494 i
= 10 * i
+ c
- '0';
499 gfc_error ("Integer too large at %C");
504 gfc_current_locus
= old_loc
;
513 /* Match a small, constant integer expression, like in a kind
514 statement. On MATCH_YES, 'value' is set. */
517 gfc_match_small_int (int *value
)
523 m
= gfc_match_expr (&expr
);
527 if (gfc_extract_int (expr
, &i
, 1))
529 gfc_free_expr (expr
);
536 /* This function is the same as the gfc_match_small_int, except that
537 we're keeping the pointer to the expr. This function could just be
538 removed and the previously mentioned one modified, though all calls
539 to it would have to be modified then (and there were a number of
540 them). Return MATCH_ERROR if fail to extract the int; otherwise,
541 return the result of gfc_match_expr(). The expr (if any) that was
542 matched is returned in the parameter expr. */
545 gfc_match_small_int_expr (int *value
, gfc_expr
**expr
)
550 m
= gfc_match_expr (expr
);
554 if (gfc_extract_int (*expr
, &i
, 1))
562 /* Matches a statement label. Uses gfc_match_small_literal_int() to
563 do most of the work. */
566 gfc_match_st_label (gfc_st_label
**label
)
572 old_loc
= gfc_current_locus
;
574 m
= gfc_match_small_literal_int (&i
, &cnt
);
580 gfc_error ("Too many digits in statement label at %C");
586 gfc_error ("Statement label at %C is zero");
590 *label
= gfc_get_st_label (i
);
595 gfc_current_locus
= old_loc
;
600 /* Match and validate a label associated with a named IF, DO or SELECT
601 statement. If the symbol does not have the label attribute, we add
602 it. We also make sure the symbol does not refer to another
603 (active) block. A matched label is pointed to by gfc_new_block. */
606 gfc_match_label (void)
608 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
611 gfc_new_block
= NULL
;
613 m
= gfc_match (" %n :", name
);
617 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
619 gfc_error ("Label name %qs at %C is ambiguous", name
);
623 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
625 gfc_error ("Duplicate construct label %qs at %C", name
);
629 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
630 gfc_new_block
->name
, NULL
))
637 /* See if the current input looks like a name of some sort. Modifies
638 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
639 Note that options.c restricts max_identifier_length to not more
640 than GFC_MAX_SYMBOL_LEN. */
643 gfc_match_name (char *buffer
)
649 old_loc
= gfc_current_locus
;
650 gfc_gobble_whitespace ();
652 c
= gfc_next_ascii_char ();
653 if (!(ISALPHA (c
) || (c
== '_' && flag_allow_leading_underscore
)))
655 /* Special cases for unary minus and plus, which allows for a sensible
656 error message for code of the form 'c = exp(-a*b) )' where an
657 extra ')' appears at the end of statement. */
658 if (!gfc_error_flag_test () && c
!= '(' && c
!= '-' && c
!= '+')
659 gfc_error ("Invalid character in name at %C");
660 gfc_current_locus
= old_loc
;
670 if (i
> gfc_option
.max_identifier_length
)
672 gfc_error ("Name at %C is too long");
676 old_loc
= gfc_current_locus
;
677 c
= gfc_next_ascii_char ();
679 while (ISALNUM (c
) || c
== '_' || (flag_dollar_ok
&& c
== '$'));
681 if (c
== '$' && !flag_dollar_ok
)
683 gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to "
684 "allow it as an extension", &old_loc
);
689 gfc_current_locus
= old_loc
;
695 /* Match a symbol on the input. Modifies the pointer to the symbol
696 pointer if successful. */
699 gfc_match_sym_tree (gfc_symtree
**matched_symbol
, int host_assoc
)
701 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
704 m
= gfc_match_name (buffer
);
709 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
710 ? MATCH_ERROR
: MATCH_YES
;
712 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
, false))
720 gfc_match_symbol (gfc_symbol
**matched_symbol
, int host_assoc
)
725 m
= gfc_match_sym_tree (&st
, host_assoc
);
730 *matched_symbol
= st
->n
.sym
;
732 *matched_symbol
= NULL
;
735 *matched_symbol
= NULL
;
740 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
741 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
745 gfc_match_intrinsic_op (gfc_intrinsic_op
*result
)
747 locus orig_loc
= gfc_current_locus
;
750 gfc_gobble_whitespace ();
751 ch
= gfc_next_ascii_char ();
756 *result
= INTRINSIC_PLUS
;
761 *result
= INTRINSIC_MINUS
;
765 if (gfc_next_ascii_char () == '=')
768 *result
= INTRINSIC_EQ
;
774 if (gfc_peek_ascii_char () == '=')
777 gfc_next_ascii_char ();
778 *result
= INTRINSIC_LE
;
782 *result
= INTRINSIC_LT
;
786 if (gfc_peek_ascii_char () == '=')
789 gfc_next_ascii_char ();
790 *result
= INTRINSIC_GE
;
794 *result
= INTRINSIC_GT
;
798 if (gfc_peek_ascii_char () == '*')
801 gfc_next_ascii_char ();
802 *result
= INTRINSIC_POWER
;
806 *result
= INTRINSIC_TIMES
;
810 ch
= gfc_peek_ascii_char ();
814 gfc_next_ascii_char ();
815 *result
= INTRINSIC_NE
;
821 gfc_next_ascii_char ();
822 *result
= INTRINSIC_CONCAT
;
826 *result
= INTRINSIC_DIVIDE
;
830 ch
= gfc_next_ascii_char ();
834 if (gfc_next_ascii_char () == 'n'
835 && gfc_next_ascii_char () == 'd'
836 && gfc_next_ascii_char () == '.')
838 /* Matched ".and.". */
839 *result
= INTRINSIC_AND
;
845 if (gfc_next_ascii_char () == 'q')
847 ch
= gfc_next_ascii_char ();
850 /* Matched ".eq.". */
851 *result
= INTRINSIC_EQ_OS
;
856 if (gfc_next_ascii_char () == '.')
858 /* Matched ".eqv.". */
859 *result
= INTRINSIC_EQV
;
867 ch
= gfc_next_ascii_char ();
870 if (gfc_next_ascii_char () == '.')
872 /* Matched ".ge.". */
873 *result
= INTRINSIC_GE_OS
;
879 if (gfc_next_ascii_char () == '.')
881 /* Matched ".gt.". */
882 *result
= INTRINSIC_GT_OS
;
889 ch
= gfc_next_ascii_char ();
892 if (gfc_next_ascii_char () == '.')
894 /* Matched ".le.". */
895 *result
= INTRINSIC_LE_OS
;
901 if (gfc_next_ascii_char () == '.')
903 /* Matched ".lt.". */
904 *result
= INTRINSIC_LT_OS
;
911 ch
= gfc_next_ascii_char ();
914 ch
= gfc_next_ascii_char ();
917 /* Matched ".ne.". */
918 *result
= INTRINSIC_NE_OS
;
923 if (gfc_next_ascii_char () == 'v'
924 && gfc_next_ascii_char () == '.')
926 /* Matched ".neqv.". */
927 *result
= INTRINSIC_NEQV
;
934 if (gfc_next_ascii_char () == 't'
935 && gfc_next_ascii_char () == '.')
937 /* Matched ".not.". */
938 *result
= INTRINSIC_NOT
;
945 if (gfc_next_ascii_char () == 'r'
946 && gfc_next_ascii_char () == '.')
948 /* Matched ".or.". */
949 *result
= INTRINSIC_OR
;
955 if (gfc_next_ascii_char () == 'o'
956 && gfc_next_ascii_char () == 'r'
957 && gfc_next_ascii_char () == '.')
959 if (!gfc_notify_std (GFC_STD_LEGACY
, ".XOR. operator at %C"))
961 /* Matched ".xor." - equivalent to ".neqv.". */
962 *result
= INTRINSIC_NEQV
;
976 gfc_current_locus
= orig_loc
;
981 /* Match a loop control phrase:
983 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
985 If the final integer expression is not present, a constant unity
986 expression is returned. We don't return MATCH_ERROR until after
987 the equals sign is seen. */
990 gfc_match_iterator (gfc_iterator
*iter
, int init_flag
)
992 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
993 gfc_expr
*var
, *e1
, *e2
, *e3
;
999 /* Match the start of an iterator without affecting the symbol table. */
1001 start
= gfc_current_locus
;
1002 m
= gfc_match (" %n =", name
);
1003 gfc_current_locus
= start
;
1008 m
= gfc_match_variable (&var
, 0);
1012 if (var
->symtree
->n
.sym
->attr
.dimension
)
1014 gfc_error ("Loop variable at %C cannot be an array");
1018 /* F2008, C617 & C565. */
1019 if (var
->symtree
->n
.sym
->attr
.codimension
)
1021 gfc_error ("Loop variable at %C cannot be a coarray");
1025 if (var
->ref
!= NULL
)
1027 gfc_error ("Loop variable at %C cannot be a sub-component");
1031 gfc_match_char ('=');
1033 var
->symtree
->n
.sym
->attr
.implied_index
= 1;
1035 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
1038 if (m
== MATCH_ERROR
)
1041 if (gfc_match_char (',') != MATCH_YES
)
1044 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
1047 if (m
== MATCH_ERROR
)
1050 if (gfc_match_char (',') != MATCH_YES
)
1052 e3
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1056 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
1057 if (m
== MATCH_ERROR
)
1061 gfc_error ("Expected a step value in iterator at %C");
1073 gfc_error ("Syntax error in iterator at %C");
1084 /* Tries to match the next non-whitespace character on the input.
1085 This subroutine does not return MATCH_ERROR. */
1088 gfc_match_char (char c
)
1092 where
= gfc_current_locus
;
1093 gfc_gobble_whitespace ();
1095 if (gfc_next_ascii_char () == c
)
1098 gfc_current_locus
= where
;
1103 /* General purpose matching subroutine. The target string is a
1104 scanf-like format string in which spaces correspond to arbitrary
1105 whitespace (including no whitespace), characters correspond to
1106 themselves. The %-codes are:
1108 %% Literal percent sign
1109 %e Expression, pointer to a pointer is set
1110 %s Symbol, pointer to the symbol is set
1111 %n Name, character buffer is set to name
1112 %t Matches end of statement.
1113 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1114 %l Matches a statement label
1115 %v Matches a variable expression (an lvalue)
1116 % Matches a required space (in free form) and optional spaces. */
1119 gfc_match (const char *target
, ...)
1121 gfc_st_label
**label
;
1130 old_loc
= gfc_current_locus
;
1131 va_start (argp
, target
);
1141 gfc_gobble_whitespace ();
1152 vp
= va_arg (argp
, void **);
1153 n
= gfc_match_expr ((gfc_expr
**) vp
);
1164 vp
= va_arg (argp
, void **);
1165 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
1176 vp
= va_arg (argp
, void **);
1177 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
1188 np
= va_arg (argp
, char *);
1189 n
= gfc_match_name (np
);
1200 label
= va_arg (argp
, gfc_st_label
**);
1201 n
= gfc_match_st_label (label
);
1212 ip
= va_arg (argp
, int *);
1213 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
1224 if (gfc_match_eos () != MATCH_YES
)
1232 if (gfc_match_space () == MATCH_YES
)
1238 break; /* Fall through to character matcher. */
1241 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
1247 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1248 expect an upper case character here! */
1249 gcc_assert (TOLOWER (c
) == c
);
1251 if (c
== gfc_next_ascii_char ())
1261 /* Clean up after a failed match. */
1262 gfc_current_locus
= old_loc
;
1263 va_start (argp
, target
);
1266 for (; matches
> 0; matches
--)
1268 while (*p
++ != '%');
1276 /* Matches that don't have to be undone */
1281 (void) va_arg (argp
, void **);
1286 vp
= va_arg (argp
, void **);
1287 gfc_free_expr ((struct gfc_expr
*)*vp
);
1300 /*********************** Statement level matching **********************/
1302 /* Matches the start of a program unit, which is the program keyword
1303 followed by an obligatory symbol. */
1306 gfc_match_program (void)
1311 m
= gfc_match ("% %s%t", &sym
);
1315 gfc_error ("Invalid form of PROGRAM statement at %C");
1319 if (m
== MATCH_ERROR
)
1322 if (!gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
))
1325 gfc_new_block
= sym
;
1331 /* Match a simple assignment statement. */
1334 gfc_match_assignment (void)
1336 gfc_expr
*lvalue
, *rvalue
;
1340 old_loc
= gfc_current_locus
;
1343 m
= gfc_match (" %v =", &lvalue
);
1346 gfc_current_locus
= old_loc
;
1347 gfc_free_expr (lvalue
);
1352 m
= gfc_match (" %e%t", &rvalue
);
1355 gfc_current_locus
= old_loc
;
1356 gfc_free_expr (lvalue
);
1357 gfc_free_expr (rvalue
);
1361 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1363 new_st
.op
= EXEC_ASSIGN
;
1364 new_st
.expr1
= lvalue
;
1365 new_st
.expr2
= rvalue
;
1367 gfc_check_do_variable (lvalue
->symtree
);
1373 /* Match a pointer assignment statement. */
1376 gfc_match_pointer_assignment (void)
1378 gfc_expr
*lvalue
, *rvalue
;
1382 old_loc
= gfc_current_locus
;
1384 lvalue
= rvalue
= NULL
;
1385 gfc_matching_ptr_assignment
= 0;
1386 gfc_matching_procptr_assignment
= 0;
1388 m
= gfc_match (" %v =>", &lvalue
);
1395 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1396 || gfc_is_proc_ptr_comp (lvalue
))
1397 gfc_matching_procptr_assignment
= 1;
1399 gfc_matching_ptr_assignment
= 1;
1401 m
= gfc_match (" %e%t", &rvalue
);
1402 gfc_matching_ptr_assignment
= 0;
1403 gfc_matching_procptr_assignment
= 0;
1407 new_st
.op
= EXEC_POINTER_ASSIGN
;
1408 new_st
.expr1
= lvalue
;
1409 new_st
.expr2
= rvalue
;
1414 gfc_current_locus
= old_loc
;
1415 gfc_free_expr (lvalue
);
1416 gfc_free_expr (rvalue
);
1421 /* We try to match an easy arithmetic IF statement. This only happens
1422 when just after having encountered a simple IF statement. This code
1423 is really duplicate with parts of the gfc_match_if code, but this is
1427 match_arithmetic_if (void)
1429 gfc_st_label
*l1
, *l2
, *l3
;
1433 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1437 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1438 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1439 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1441 gfc_free_expr (expr
);
1445 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Arithmetic IF statement at %C"))
1448 new_st
.op
= EXEC_ARITHMETIC_IF
;
1449 new_st
.expr1
= expr
;
1458 /* The IF statement is a bit of a pain. First of all, there are three
1459 forms of it, the simple IF, the IF that starts a block and the
1462 There is a problem with the simple IF and that is the fact that we
1463 only have a single level of undo information on symbols. What this
1464 means is for a simple IF, we must re-match the whole IF statement
1465 multiple times in order to guarantee that the symbol table ends up
1466 in the proper state. */
1468 static match
match_simple_forall (void);
1469 static match
match_simple_where (void);
1472 gfc_match_if (gfc_statement
*if_type
)
1475 gfc_st_label
*l1
, *l2
, *l3
;
1476 locus old_loc
, old_loc2
;
1480 n
= gfc_match_label ();
1481 if (n
== MATCH_ERROR
)
1484 old_loc
= gfc_current_locus
;
1486 m
= gfc_match (" if ( %e", &expr
);
1490 old_loc2
= gfc_current_locus
;
1491 gfc_current_locus
= old_loc
;
1493 if (gfc_match_parens () == MATCH_ERROR
)
1496 gfc_current_locus
= old_loc2
;
1498 if (gfc_match_char (')') != MATCH_YES
)
1500 gfc_error ("Syntax error in IF-expression at %C");
1501 gfc_free_expr (expr
);
1505 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1511 gfc_error ("Block label not appropriate for arithmetic IF "
1513 gfc_free_expr (expr
);
1517 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1518 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1519 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1521 gfc_free_expr (expr
);
1525 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Arithmetic IF statement at %C"))
1528 new_st
.op
= EXEC_ARITHMETIC_IF
;
1529 new_st
.expr1
= expr
;
1534 *if_type
= ST_ARITHMETIC_IF
;
1538 if (gfc_match (" then%t") == MATCH_YES
)
1540 new_st
.op
= EXEC_IF
;
1541 new_st
.expr1
= expr
;
1542 *if_type
= ST_IF_BLOCK
;
1548 gfc_error ("Block label is not appropriate for IF statement at %C");
1549 gfc_free_expr (expr
);
1553 /* At this point the only thing left is a simple IF statement. At
1554 this point, n has to be MATCH_NO, so we don't have to worry about
1555 re-matching a block label. From what we've got so far, try
1556 matching an assignment. */
1558 *if_type
= ST_SIMPLE_IF
;
1560 m
= gfc_match_assignment ();
1564 gfc_free_expr (expr
);
1565 gfc_undo_symbols ();
1566 gfc_current_locus
= old_loc
;
1568 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1569 assignment was found. For MATCH_NO, continue to call the various
1571 if (m
== MATCH_ERROR
)
1574 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1576 m
= gfc_match_pointer_assignment ();
1580 gfc_free_expr (expr
);
1581 gfc_undo_symbols ();
1582 gfc_current_locus
= old_loc
;
1584 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1586 /* Look at the next keyword to see which matcher to call. Matching
1587 the keyword doesn't affect the symbol table, so we don't have to
1588 restore between tries. */
1590 #define match(string, subr, statement) \
1591 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1595 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1596 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1597 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1598 match ("call", gfc_match_call
, ST_CALL
)
1599 match ("change team", gfc_match_change_team
, ST_CHANGE_TEAM
)
1600 match ("close", gfc_match_close
, ST_CLOSE
)
1601 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1602 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1603 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1604 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1605 match ("end team", gfc_match_end_team
, ST_END_TEAM
)
1606 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
)
1607 match ("event post", gfc_match_event_post
, ST_EVENT_POST
)
1608 match ("event wait", gfc_match_event_wait
, ST_EVENT_WAIT
)
1609 match ("exit", gfc_match_exit
, ST_EXIT
)
1610 match ("fail image", gfc_match_fail_image
, ST_FAIL_IMAGE
)
1611 match ("flush", gfc_match_flush
, ST_FLUSH
)
1612 match ("forall", match_simple_forall
, ST_FORALL
)
1613 match ("form team", gfc_match_form_team
, ST_FORM_TEAM
)
1614 match ("go to", gfc_match_goto
, ST_GOTO
)
1615 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1616 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1617 match ("lock", gfc_match_lock
, ST_LOCK
)
1618 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1619 match ("open", gfc_match_open
, ST_OPEN
)
1620 match ("pause", gfc_match_pause
, ST_NONE
)
1621 match ("print", gfc_match_print
, ST_WRITE
)
1622 match ("read", gfc_match_read
, ST_READ
)
1623 match ("return", gfc_match_return
, ST_RETURN
)
1624 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1625 match ("stop", gfc_match_stop
, ST_STOP
)
1626 match ("wait", gfc_match_wait
, ST_WAIT
)
1627 match ("sync all", gfc_match_sync_all
, ST_SYNC_CALL
);
1628 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
1629 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
1630 match ("sync team", gfc_match_sync_team
, ST_SYNC_TEAM
)
1631 match ("unlock", gfc_match_unlock
, ST_UNLOCK
)
1632 match ("where", match_simple_where
, ST_WHERE
)
1633 match ("write", gfc_match_write
, ST_WRITE
)
1636 match ("type", gfc_match_print
, ST_WRITE
)
1638 /* The gfc_match_assignment() above may have returned a MATCH_NO
1639 where the assignment was to a named constant. Check that
1640 special case here. */
1641 m
= gfc_match_assignment ();
1644 gfc_error ("Cannot assign to a named constant at %C");
1645 gfc_free_expr (expr
);
1646 gfc_undo_symbols ();
1647 gfc_current_locus
= old_loc
;
1651 /* All else has failed, so give up. See if any of the matchers has
1652 stored an error message of some sort. */
1653 if (!gfc_error_check ())
1654 gfc_error ("Unclassifiable statement in IF-clause at %C");
1656 gfc_free_expr (expr
);
1661 gfc_error ("Syntax error in IF-clause at %C");
1664 gfc_free_expr (expr
);
1668 /* At this point, we've matched the single IF and the action clause
1669 is in new_st. Rearrange things so that the IF statement appears
1672 p
= gfc_get_code (EXEC_IF
);
1673 p
->next
= XCNEW (gfc_code
);
1675 p
->next
->loc
= gfc_current_locus
;
1679 gfc_clear_new_st ();
1681 new_st
.op
= EXEC_IF
;
1690 /* Match an ELSE statement. */
1693 gfc_match_else (void)
1695 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1697 if (gfc_match_eos () == MATCH_YES
)
1700 if (gfc_match_name (name
) != MATCH_YES
1701 || gfc_current_block () == NULL
1702 || gfc_match_eos () != MATCH_YES
)
1704 gfc_error ("Unexpected junk after ELSE statement at %C");
1708 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1710 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1711 name
, gfc_current_block ()->name
);
1719 /* Match an ELSE IF statement. */
1722 gfc_match_elseif (void)
1724 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1728 m
= gfc_match (" ( %e ) then", &expr
);
1732 if (gfc_match_eos () == MATCH_YES
)
1735 if (gfc_match_name (name
) != MATCH_YES
1736 || gfc_current_block () == NULL
1737 || gfc_match_eos () != MATCH_YES
)
1739 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1743 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1745 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1746 name
, gfc_current_block ()->name
);
1751 new_st
.op
= EXEC_IF
;
1752 new_st
.expr1
= expr
;
1756 gfc_free_expr (expr
);
1761 /* Free a gfc_iterator structure. */
1764 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1770 gfc_free_expr (iter
->var
);
1771 gfc_free_expr (iter
->start
);
1772 gfc_free_expr (iter
->end
);
1773 gfc_free_expr (iter
->step
);
1780 /* Match a CRITICAL statement. */
1782 gfc_match_critical (void)
1784 gfc_st_label
*label
= NULL
;
1786 if (gfc_match_label () == MATCH_ERROR
)
1789 if (gfc_match (" critical") != MATCH_YES
)
1792 if (gfc_match_st_label (&label
) == MATCH_ERROR
)
1795 if (gfc_match_eos () != MATCH_YES
)
1797 gfc_syntax_error (ST_CRITICAL
);
1801 if (gfc_pure (NULL
))
1803 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1807 if (gfc_find_state (COMP_DO_CONCURRENT
))
1809 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1814 gfc_unset_implicit_pure (NULL
);
1816 if (!gfc_notify_std (GFC_STD_F2008
, "CRITICAL statement at %C"))
1819 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1821 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1826 if (gfc_find_state (COMP_CRITICAL
))
1828 gfc_error ("Nested CRITICAL block at %C");
1832 new_st
.op
= EXEC_CRITICAL
;
1835 && !gfc_reference_st_label (label
, ST_LABEL_TARGET
))
1842 /* Match a BLOCK statement. */
1845 gfc_match_block (void)
1849 if (gfc_match_label () == MATCH_ERROR
)
1852 if (gfc_match (" block") != MATCH_YES
)
1855 /* For this to be a correct BLOCK statement, the line must end now. */
1856 m
= gfc_match_eos ();
1857 if (m
== MATCH_ERROR
)
1866 /* Match an ASSOCIATE statement. */
1869 gfc_match_associate (void)
1871 if (gfc_match_label () == MATCH_ERROR
)
1874 if (gfc_match (" associate") != MATCH_YES
)
1877 /* Match the association list. */
1878 if (gfc_match_char ('(') != MATCH_YES
)
1880 gfc_error ("Expected association list at %C");
1883 new_st
.ext
.block
.assoc
= NULL
;
1886 gfc_association_list
* newAssoc
= gfc_get_association_list ();
1887 gfc_association_list
* a
;
1889 /* Match the next association. */
1890 if (gfc_match (" %n => %e", newAssoc
->name
, &newAssoc
->target
)
1893 /* Have another go, allowing for procedure pointer selectors. */
1894 gfc_matching_procptr_assignment
= 1;
1895 if (gfc_match (" %n => %e", newAssoc
->name
, &newAssoc
->target
)
1898 gfc_error ("Expected association at %C");
1899 goto assocListError
;
1901 gfc_matching_procptr_assignment
= 0;
1903 newAssoc
->where
= gfc_current_locus
;
1905 /* Check that the current name is not yet in the list. */
1906 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
1907 if (!strcmp (a
->name
, newAssoc
->name
))
1909 gfc_error ("Duplicate name %qs in association at %C",
1911 goto assocListError
;
1914 /* The target expression must not be coindexed. */
1915 if (gfc_is_coindexed (newAssoc
->target
))
1917 gfc_error ("Association target at %C must not be coindexed");
1918 goto assocListError
;
1921 /* The `variable' field is left blank for now; because the target is not
1922 yet resolved, we can't use gfc_has_vector_subscript to determine it
1923 for now. This is set during resolution. */
1925 /* Put it into the list. */
1926 newAssoc
->next
= new_st
.ext
.block
.assoc
;
1927 new_st
.ext
.block
.assoc
= newAssoc
;
1929 /* Try next one or end if closing parenthesis is found. */
1930 gfc_gobble_whitespace ();
1931 if (gfc_peek_char () == ')')
1933 if (gfc_match_char (',') != MATCH_YES
)
1935 gfc_error ("Expected %<)%> or %<,%> at %C");
1945 if (gfc_match_char (')') != MATCH_YES
)
1947 /* This should never happen as we peek above. */
1951 if (gfc_match_eos () != MATCH_YES
)
1953 gfc_error ("Junk after ASSOCIATE statement at %C");
1960 gfc_free_association_list (new_st
.ext
.block
.assoc
);
1965 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1966 an accessible derived type. */
1969 match_derived_type_spec (gfc_typespec
*ts
)
1971 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1973 gfc_symbol
*derived
, *der_type
;
1974 match m
= MATCH_YES
;
1975 gfc_actual_arglist
*decl_type_param_list
= NULL
;
1976 bool is_pdt_template
= false;
1978 old_locus
= gfc_current_locus
;
1980 if (gfc_match ("%n", name
) != MATCH_YES
)
1982 gfc_current_locus
= old_locus
;
1986 gfc_find_symbol (name
, NULL
, 1, &derived
);
1988 /* Match the PDT spec list, if there. */
1989 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
)
1991 gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &der_type
);
1992 is_pdt_template
= der_type
1993 && der_type
->attr
.flavor
== FL_DERIVED
1994 && der_type
->attr
.pdt_template
;
1997 if (is_pdt_template
)
1998 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
2000 if (m
== MATCH_ERROR
)
2002 gfc_free_actual_arglist (decl_type_param_list
);
2006 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
&& derived
->attr
.generic
)
2007 derived
= gfc_find_dt_in_generic (derived
);
2009 /* If this is a PDT, find the specific instance. */
2010 if (m
== MATCH_YES
&& is_pdt_template
)
2012 gfc_namespace
*old_ns
;
2014 old_ns
= gfc_current_ns
;
2015 while (gfc_current_ns
&& gfc_current_ns
->parent
)
2016 gfc_current_ns
= gfc_current_ns
->parent
;
2018 if (type_param_spec_list
)
2019 gfc_free_actual_arglist (type_param_spec_list
);
2020 m
= gfc_get_pdt_instance (decl_type_param_list
, &der_type
,
2021 &type_param_spec_list
);
2022 gfc_free_actual_arglist (decl_type_param_list
);
2027 gcc_assert (!derived
->attr
.pdt_template
&& derived
->attr
.pdt_type
);
2028 gfc_set_sym_referenced (derived
);
2030 gfc_current_ns
= old_ns
;
2033 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
2035 ts
->type
= BT_DERIVED
;
2036 ts
->u
.derived
= derived
;
2040 gfc_current_locus
= old_locus
;
2045 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2046 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2047 It only includes the intrinsic types from the Fortran 2003 standard
2048 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2049 the implicit_flag is not needed, so it was removed. Derived types are
2050 identified by their name alone. */
2053 gfc_match_type_spec (gfc_typespec
*ts
)
2057 char c
, name
[GFC_MAX_SYMBOL_LEN
+ 1];
2060 gfc_gobble_whitespace ();
2061 old_locus
= gfc_current_locus
;
2063 /* If c isn't [a-z], then return immediately. */
2064 c
= gfc_peek_ascii_char ();
2068 type_param_spec_list
= NULL
;
2070 if (match_derived_type_spec (ts
) == MATCH_YES
)
2072 /* Enforce F03:C401. */
2073 if (ts
->u
.derived
->attr
.abstract
)
2075 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
2076 ts
->u
.derived
->name
, &old_locus
);
2082 if (gfc_match ("integer") == MATCH_YES
)
2084 ts
->type
= BT_INTEGER
;
2085 ts
->kind
= gfc_default_integer_kind
;
2089 if (gfc_match ("double precision") == MATCH_YES
)
2092 ts
->kind
= gfc_default_double_kind
;
2096 if (gfc_match ("complex") == MATCH_YES
)
2098 ts
->type
= BT_COMPLEX
;
2099 ts
->kind
= gfc_default_complex_kind
;
2103 if (gfc_match ("character") == MATCH_YES
)
2105 ts
->type
= BT_CHARACTER
;
2107 m
= gfc_match_char_spec (ts
);
2108 if (ts
->u
.cl
&& ts
->u
.cl
->length
)
2109 gfc_resolve_expr (ts
->u
.cl
->length
);
2117 /* REAL is a real pain because it can be a type, intrinsic subprogram,
2118 or list item in a type-list of an OpenMP reduction clause. Need to
2119 differentiate REAL([KIND]=scalar-int-initialization-expr) from
2120 REAL(A,[KIND]) and REAL(KIND,A). Logically, when this code was
2121 written the use of LOGICAL as a type-spec or intrinsic subprogram
2124 m
= gfc_match (" %n", name
);
2126 && (strcmp (name
, "real") == 0 || strcmp (name
, "logical") == 0))
2135 ts
->kind
= gfc_default_real_kind
;
2139 ts
->type
= BT_LOGICAL
;
2140 ts
->kind
= gfc_default_logical_kind
;
2143 gfc_gobble_whitespace ();
2145 /* Prevent REAL*4, etc. */
2146 c
= gfc_peek_ascii_char ();
2149 gfc_error ("Invalid type-spec at %C");
2153 /* Found leading colon in REAL::, a trailing ')' in for example
2154 TYPE IS (REAL), or REAL, for an OpenMP list-item. */
2155 if (c
== ':' || c
== ')' || (flag_openmp
&& c
== ','))
2158 /* Found something other than the opening '(' in REAL(... */
2162 gfc_next_char (); /* Burn the '('. */
2164 /* Look for the optional KIND=. */
2165 where
= gfc_current_locus
;
2166 m
= gfc_match ("%n", name
);
2169 gfc_gobble_whitespace ();
2170 c
= gfc_next_char ();
2173 if (strcmp(name
, "a") == 0 || strcmp(name
, "l") == 0)
2175 else if (strcmp(name
, "kind") == 0)
2181 gfc_current_locus
= where
;
2184 gfc_current_locus
= where
;
2188 m
= gfc_match_init_expr (&e
);
2189 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
2192 /* If a comma appears, it is an intrinsic subprogram. */
2193 gfc_gobble_whitespace ();
2194 c
= gfc_peek_ascii_char ();
2201 /* If ')' appears, we have REAL(initialization-expr), here check for
2202 a scalar integer initialization-expr and valid kind parameter. */
2205 if (e
->ts
.type
!= BT_INTEGER
|| e
->rank
> 0)
2211 gfc_next_char (); /* Burn the ')'. */
2212 ts
->kind
= (int) mpz_get_si (e
->value
.integer
);
2213 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
2215 gfc_error ("Invalid type-spec at %C");
2225 /* If a type is not matched, simply return MATCH_NO. */
2226 gfc_current_locus
= old_locus
;
2231 gfc_gobble_whitespace ();
2233 /* This prevents INTEGER*4, etc. */
2234 if (gfc_peek_ascii_char () == '*')
2236 gfc_error ("Invalid type-spec at %C");
2240 m
= gfc_match_kind_spec (ts
, false);
2242 /* No kind specifier found. */
2250 /******************** FORALL subroutines ********************/
2252 /* Free a list of FORALL iterators. */
2255 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
2257 gfc_forall_iterator
*next
;
2262 gfc_free_expr (iter
->var
);
2263 gfc_free_expr (iter
->start
);
2264 gfc_free_expr (iter
->end
);
2265 gfc_free_expr (iter
->stride
);
2272 /* Match an iterator as part of a FORALL statement. The format is:
2274 <var> = <start>:<end>[:<stride>]
2276 On MATCH_NO, the caller tests for the possibility that there is a
2277 scalar mask expression. */
2280 match_forall_iterator (gfc_forall_iterator
**result
)
2282 gfc_forall_iterator
*iter
;
2286 where
= gfc_current_locus
;
2287 iter
= XCNEW (gfc_forall_iterator
);
2289 m
= gfc_match_expr (&iter
->var
);
2293 if (gfc_match_char ('=') != MATCH_YES
2294 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
2300 m
= gfc_match_expr (&iter
->start
);
2304 if (gfc_match_char (':') != MATCH_YES
)
2307 m
= gfc_match_expr (&iter
->end
);
2310 if (m
== MATCH_ERROR
)
2313 if (gfc_match_char (':') == MATCH_NO
)
2314 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2317 m
= gfc_match_expr (&iter
->stride
);
2320 if (m
== MATCH_ERROR
)
2324 /* Mark the iteration variable's symbol as used as a FORALL index. */
2325 iter
->var
->symtree
->n
.sym
->forall_index
= true;
2331 gfc_error ("Syntax error in FORALL iterator at %C");
2336 gfc_current_locus
= where
;
2337 gfc_free_forall_iterator (iter
);
2342 /* Match the header of a FORALL statement. */
2345 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
2347 gfc_forall_iterator
*head
, *tail
, *new_iter
;
2351 gfc_gobble_whitespace ();
2356 if (gfc_match_char ('(') != MATCH_YES
)
2359 m
= match_forall_iterator (&new_iter
);
2360 if (m
== MATCH_ERROR
)
2365 head
= tail
= new_iter
;
2369 if (gfc_match_char (',') != MATCH_YES
)
2372 m
= match_forall_iterator (&new_iter
);
2373 if (m
== MATCH_ERROR
)
2378 tail
->next
= new_iter
;
2383 /* Have to have a mask expression. */
2385 m
= gfc_match_expr (&msk
);
2388 if (m
== MATCH_ERROR
)
2394 if (gfc_match_char (')') == MATCH_NO
)
2402 gfc_syntax_error (ST_FORALL
);
2405 gfc_free_expr (msk
);
2406 gfc_free_forall_iterator (head
);
2411 /* Match the rest of a simple FORALL statement that follows an
2415 match_simple_forall (void)
2417 gfc_forall_iterator
*head
;
2426 m
= match_forall_header (&head
, &mask
);
2433 m
= gfc_match_assignment ();
2435 if (m
== MATCH_ERROR
)
2439 m
= gfc_match_pointer_assignment ();
2440 if (m
== MATCH_ERROR
)
2446 c
= XCNEW (gfc_code
);
2448 c
->loc
= gfc_current_locus
;
2450 if (gfc_match_eos () != MATCH_YES
)
2453 gfc_clear_new_st ();
2454 new_st
.op
= EXEC_FORALL
;
2455 new_st
.expr1
= mask
;
2456 new_st
.ext
.forall_iterator
= head
;
2457 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2458 new_st
.block
->next
= c
;
2463 gfc_syntax_error (ST_FORALL
);
2466 gfc_free_forall_iterator (head
);
2467 gfc_free_expr (mask
);
2473 /* Match a FORALL statement. */
2476 gfc_match_forall (gfc_statement
*st
)
2478 gfc_forall_iterator
*head
;
2487 m0
= gfc_match_label ();
2488 if (m0
== MATCH_ERROR
)
2491 m
= gfc_match (" forall");
2495 m
= match_forall_header (&head
, &mask
);
2496 if (m
== MATCH_ERROR
)
2501 if (gfc_match_eos () == MATCH_YES
)
2503 *st
= ST_FORALL_BLOCK
;
2504 new_st
.op
= EXEC_FORALL
;
2505 new_st
.expr1
= mask
;
2506 new_st
.ext
.forall_iterator
= head
;
2510 m
= gfc_match_assignment ();
2511 if (m
== MATCH_ERROR
)
2515 m
= gfc_match_pointer_assignment ();
2516 if (m
== MATCH_ERROR
)
2522 c
= XCNEW (gfc_code
);
2524 c
->loc
= gfc_current_locus
;
2526 gfc_clear_new_st ();
2527 new_st
.op
= EXEC_FORALL
;
2528 new_st
.expr1
= mask
;
2529 new_st
.ext
.forall_iterator
= head
;
2530 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2531 new_st
.block
->next
= c
;
2537 gfc_syntax_error (ST_FORALL
);
2540 gfc_free_forall_iterator (head
);
2541 gfc_free_expr (mask
);
2542 gfc_free_statements (c
);
2547 /* Match a DO statement. */
2552 gfc_iterator iter
, *ip
;
2554 gfc_st_label
*label
;
2557 old_loc
= gfc_current_locus
;
2559 memset (&iter
, '\0', sizeof (gfc_iterator
));
2562 m
= gfc_match_label ();
2563 if (m
== MATCH_ERROR
)
2566 if (gfc_match (" do") != MATCH_YES
)
2569 m
= gfc_match_st_label (&label
);
2570 if (m
== MATCH_ERROR
)
2573 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2575 if (gfc_match_eos () == MATCH_YES
)
2577 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
2578 new_st
.op
= EXEC_DO_WHILE
;
2582 /* Match an optional comma, if no comma is found, a space is obligatory. */
2583 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
2586 /* Check for balanced parens. */
2588 if (gfc_match_parens () == MATCH_ERROR
)
2591 if (gfc_match (" concurrent") == MATCH_YES
)
2593 gfc_forall_iterator
*head
;
2596 if (!gfc_notify_std (GFC_STD_F2008
, "DO CONCURRENT construct at %C"))
2602 m
= match_forall_header (&head
, &mask
);
2606 if (m
== MATCH_ERROR
)
2607 goto concurr_cleanup
;
2609 if (gfc_match_eos () != MATCH_YES
)
2610 goto concurr_cleanup
;
2613 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2614 goto concurr_cleanup
;
2616 new_st
.label1
= label
;
2617 new_st
.op
= EXEC_DO_CONCURRENT
;
2618 new_st
.expr1
= mask
;
2619 new_st
.ext
.forall_iterator
= head
;
2624 gfc_syntax_error (ST_DO
);
2625 gfc_free_expr (mask
);
2626 gfc_free_forall_iterator (head
);
2630 /* See if we have a DO WHILE. */
2631 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
2633 new_st
.op
= EXEC_DO_WHILE
;
2637 /* The abortive DO WHILE may have done something to the symbol
2638 table, so we start over. */
2639 gfc_undo_symbols ();
2640 gfc_current_locus
= old_loc
;
2642 gfc_match_label (); /* This won't error. */
2643 gfc_match (" do "); /* This will work. */
2645 gfc_match_st_label (&label
); /* Can't error out. */
2646 gfc_match_char (','); /* Optional comma. */
2648 m
= gfc_match_iterator (&iter
, 0);
2651 if (m
== MATCH_ERROR
)
2654 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
2655 gfc_check_do_variable (iter
.var
->symtree
);
2657 if (gfc_match_eos () != MATCH_YES
)
2659 gfc_syntax_error (ST_DO
);
2663 new_st
.op
= EXEC_DO
;
2667 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2670 new_st
.label1
= label
;
2672 if (new_st
.op
== EXEC_DO_WHILE
)
2673 new_st
.expr1
= iter
.end
;
2676 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
2683 gfc_free_iterator (&iter
, 0);
2689 /* Match an EXIT or CYCLE statement. */
2692 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2694 gfc_state_data
*p
, *o
;
2699 if (gfc_match_eos () == MATCH_YES
)
2703 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2706 m
= gfc_match ("% %n%t", name
);
2707 if (m
== MATCH_ERROR
)
2711 gfc_syntax_error (st
);
2715 /* Find the corresponding symbol. If there's a BLOCK statement
2716 between here and the label, it is not in gfc_current_ns but a parent
2718 stree
= gfc_find_symtree_in_proc (name
, gfc_current_ns
);
2721 gfc_error ("Name %qs in %s statement at %C is unknown",
2722 name
, gfc_ascii_statement (st
));
2727 if (sym
->attr
.flavor
!= FL_LABEL
)
2729 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2730 name
, gfc_ascii_statement (st
));
2735 /* Find the loop specified by the label (or lack of a label). */
2736 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2737 if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2739 else if (p
->state
== COMP_CRITICAL
)
2741 gfc_error("%s statement at %C leaves CRITICAL construct",
2742 gfc_ascii_statement (st
));
2745 else if (p
->state
== COMP_DO_CONCURRENT
2746 && (op
== EXEC_EXIT
|| (sym
&& sym
!= p
->sym
)))
2748 /* F2008, C821 & C845. */
2749 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2750 gfc_ascii_statement (st
));
2753 else if ((sym
&& sym
== p
->sym
)
2754 || (!sym
&& (p
->state
== COMP_DO
2755 || p
->state
== COMP_DO_CONCURRENT
)))
2761 gfc_error ("%s statement at %C is not within a construct",
2762 gfc_ascii_statement (st
));
2764 gfc_error ("%s statement at %C is not within construct %qs",
2765 gfc_ascii_statement (st
), sym
->name
);
2770 /* Special checks for EXIT from non-loop constructs. */
2774 case COMP_DO_CONCURRENT
:
2778 /* This is already handled above. */
2781 case COMP_ASSOCIATE
:
2785 case COMP_SELECT_TYPE
:
2787 if (op
== EXEC_CYCLE
)
2789 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2790 " construct %qs", sym
->name
);
2793 gcc_assert (op
== EXEC_EXIT
);
2794 if (!gfc_notify_std (GFC_STD_F2008
, "EXIT statement with no"
2795 " do-construct-name at %C"))
2800 gfc_error ("%s statement at %C is not applicable to construct %qs",
2801 gfc_ascii_statement (st
), sym
->name
);
2807 gfc_error (is_oacc (p
)
2808 ? G_("%s statement at %C leaving OpenACC structured block")
2809 : G_("%s statement at %C leaving OpenMP structured block"),
2810 gfc_ascii_statement (st
));
2814 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2818 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
2819 && (o
->head
->op
== EXEC_OACC_LOOP
2820 || o
->head
->op
== EXEC_OACC_PARALLEL_LOOP
))
2823 gcc_assert (o
->head
->next
!= NULL
2824 && (o
->head
->next
->op
== EXEC_DO
2825 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2826 && o
->previous
!= NULL
2827 && o
->previous
->tail
->op
== o
->head
->op
);
2828 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2829 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2830 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2831 if (st
== ST_EXIT
&& cnt
<= collapse
)
2833 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2836 if (st
== ST_CYCLE
&& cnt
< collapse
)
2838 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2839 " !$ACC LOOP loop");
2845 && (o
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2846 && (o
->head
->op
== EXEC_OMP_DO
2847 || o
->head
->op
== EXEC_OMP_PARALLEL_DO
2848 || o
->head
->op
== EXEC_OMP_SIMD
2849 || o
->head
->op
== EXEC_OMP_DO_SIMD
2850 || o
->head
->op
== EXEC_OMP_PARALLEL_DO_SIMD
))
2853 gcc_assert (o
->head
->next
!= NULL
2854 && (o
->head
->next
->op
== EXEC_DO
2855 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2856 && o
->previous
!= NULL
2857 && o
->previous
->tail
->op
== o
->head
->op
);
2858 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
)
2860 if (o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2861 count
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2862 if (o
->previous
->tail
->ext
.omp_clauses
->orderedc
)
2863 count
= o
->previous
->tail
->ext
.omp_clauses
->orderedc
;
2865 if (st
== ST_EXIT
&& cnt
<= count
)
2867 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2870 if (st
== ST_CYCLE
&& cnt
< count
)
2872 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2878 /* Save the first statement in the construct - needed by the backend. */
2879 new_st
.ext
.which_construct
= p
->construct
;
2887 /* Match the EXIT statement. */
2890 gfc_match_exit (void)
2892 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2896 /* Match the CYCLE statement. */
2899 gfc_match_cycle (void)
2901 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2905 /* Match a stop-code after an (ERROR) STOP or PAUSE statement. The
2906 requirements for a stop-code differ in the standards.
2910 R840 stop-stmt is STOP [ stop-code ]
2911 R841 stop-code is scalar-char-constant
2912 or digit [ digit [ digit [ digit [ digit ] ] ] ]
2914 Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
2917 R855 stop-stmt is STOP [ stop-code ]
2918 R856 allstop-stmt is ALL STOP [ stop-code ]
2919 R857 stop-code is scalar-default-char-constant-expr
2920 or scalar-int-constant-expr
2922 For free-form source code, all standards contain a statement of the form:
2924 A blank shall be used to separate names, constants, or labels from
2925 adjacent keywords, names, constants, or labels.
2927 A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003,
2931 is valid, but it is invalid Fortran 2008. */
2934 gfc_match_stopcode (gfc_statement st
)
2940 /* Set f95 for -std=f95. */
2941 f95
= gfc_option
.allow_std
== (GFC_STD_F95_OBS
| GFC_STD_F95
| GFC_STD_F77
2942 | GFC_STD_F2008_OBS
);
2944 /* Set f03 for -std=f2003. */
2945 f03
= gfc_option
.allow_std
== (GFC_STD_F95_OBS
| GFC_STD_F95
| GFC_STD_F77
2946 | GFC_STD_F2008_OBS
| GFC_STD_F2003
);
2948 /* Look for a blank between STOP and the stop-code for F2008 or later. */
2949 if (gfc_current_form
!= FORM_FIXED
&& !(f95
|| f03
))
2951 char c
= gfc_peek_ascii_char ();
2953 /* Look for end-of-statement. There is no stop-code. */
2954 if (c
== '\n' || c
== '!' || c
== ';')
2959 gfc_error ("Blank required in %s statement near %C",
2960 gfc_ascii_statement (st
));
2965 if (gfc_match_eos () != MATCH_YES
)
2970 /* First look for the F95 or F2003 digit [...] construct. */
2971 old_locus
= gfc_current_locus
;
2972 m
= gfc_match_small_int (&stopcode
);
2973 if (m
== MATCH_YES
&& (f95
|| f03
))
2977 gfc_error ("STOP code at %C cannot be negative");
2981 if (stopcode
> 99999)
2983 gfc_error ("STOP code at %C contains too many digits");
2988 /* Reset the locus and now load gfc_expr. */
2989 gfc_current_locus
= old_locus
;
2990 m
= gfc_match_expr (&e
);
2991 if (m
== MATCH_ERROR
)
2996 if (gfc_match_eos () != MATCH_YES
)
3000 if (gfc_pure (NULL
))
3002 if (st
== ST_ERROR_STOP
)
3004 if (!gfc_notify_std (GFC_STD_F2018
, "%s statement at %C in PURE "
3005 "procedure", gfc_ascii_statement (st
)))
3010 gfc_error ("%s statement not allowed in PURE procedure at %C",
3011 gfc_ascii_statement (st
));
3016 gfc_unset_implicit_pure (NULL
);
3018 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
))
3020 gfc_error ("Image control statement STOP at %C in CRITICAL block");
3023 if (st
== ST_STOP
&& gfc_find_state (COMP_DO_CONCURRENT
))
3025 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
3031 gfc_simplify_expr (e
, 0);
3033 /* Test for F95 and F2003 style STOP stop-code. */
3034 if (e
->expr_type
!= EXPR_CONSTANT
&& (f95
|| f03
))
3036 gfc_error ("STOP code at %L must be a scalar CHARACTER constant or "
3037 "digit[digit[digit[digit[digit]]]]", &e
->where
);
3041 /* Use the machinery for an initialization expression to reduce the
3042 stop-code to a constant. */
3043 gfc_init_expr_flag
= true;
3044 gfc_reduce_init_expr (e
);
3045 gfc_init_expr_flag
= false;
3047 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
3049 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
3056 gfc_error ("STOP code at %L must be scalar", &e
->where
);
3060 if (e
->ts
.type
== BT_CHARACTER
3061 && e
->ts
.kind
!= gfc_default_character_kind
)
3063 gfc_error ("STOP code at %L must be default character KIND=%d",
3064 &e
->where
, (int) gfc_default_character_kind
);
3068 if (e
->ts
.type
== BT_INTEGER
&& e
->ts
.kind
!= gfc_default_integer_kind
)
3070 gfc_error ("STOP code at %L must be default integer KIND=%d",
3071 &e
->where
, (int) gfc_default_integer_kind
);
3081 new_st
.op
= EXEC_STOP
;
3084 new_st
.op
= EXEC_ERROR_STOP
;
3087 new_st
.op
= EXEC_PAUSE
;
3094 new_st
.ext
.stop_code
= -1;
3099 gfc_syntax_error (st
);
3108 /* Match the (deprecated) PAUSE statement. */
3111 gfc_match_pause (void)
3115 m
= gfc_match_stopcode (ST_PAUSE
);
3118 if (!gfc_notify_std (GFC_STD_F95_DEL
, "PAUSE statement at %C"))
3125 /* Match the STOP statement. */
3128 gfc_match_stop (void)
3130 return gfc_match_stopcode (ST_STOP
);
3134 /* Match the ERROR STOP statement. */
3137 gfc_match_error_stop (void)
3139 if (!gfc_notify_std (GFC_STD_F2008
, "ERROR STOP statement at %C"))
3142 return gfc_match_stopcode (ST_ERROR_STOP
);
3145 /* Match EVENT POST/WAIT statement. Syntax:
3146 EVENT POST ( event-variable [, sync-stat-list] )
3147 EVENT WAIT ( event-variable [, wait-spec-list] )
3149 wait-spec-list is sync-stat-list or until-spec
3150 until-spec is UNTIL_COUNT = scalar-int-expr
3151 sync-stat is STAT= or ERRMSG=. */
3154 event_statement (gfc_statement st
)
3157 gfc_expr
*tmp
, *eventvar
, *until_count
, *stat
, *errmsg
;
3158 bool saw_until_count
, saw_stat
, saw_errmsg
;
3160 tmp
= eventvar
= until_count
= stat
= errmsg
= NULL
;
3161 saw_until_count
= saw_stat
= saw_errmsg
= false;
3163 if (gfc_pure (NULL
))
3165 gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
3166 st
== ST_EVENT_POST
? "POST" : "WAIT");
3170 gfc_unset_implicit_pure (NULL
);
3172 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3174 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3178 if (gfc_find_state (COMP_CRITICAL
))
3180 gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
3181 st
== ST_EVENT_POST
? "POST" : "WAIT");
3185 if (gfc_find_state (COMP_DO_CONCURRENT
))
3187 gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
3188 "block", st
== ST_EVENT_POST
? "POST" : "WAIT");
3192 if (gfc_match_char ('(') != MATCH_YES
)
3195 if (gfc_match ("%e", &eventvar
) != MATCH_YES
)
3197 m
= gfc_match_char (',');
3198 if (m
== MATCH_ERROR
)
3202 m
= gfc_match_char (')');
3210 m
= gfc_match (" stat = %v", &tmp
);
3211 if (m
== MATCH_ERROR
)
3217 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3223 m
= gfc_match_char (',');
3231 m
= gfc_match (" errmsg = %v", &tmp
);
3232 if (m
== MATCH_ERROR
)
3238 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3244 m
= gfc_match_char (',');
3252 m
= gfc_match (" until_count = %e", &tmp
);
3253 if (m
== MATCH_ERROR
|| st
== ST_EVENT_POST
)
3257 if (saw_until_count
)
3259 gfc_error ("Redundant UNTIL_COUNT tag found at %L",
3264 saw_until_count
= true;
3266 m
= gfc_match_char (',');
3277 if (m
== MATCH_ERROR
)
3280 if (gfc_match (" )%t") != MATCH_YES
)
3287 new_st
.op
= EXEC_EVENT_POST
;
3290 new_st
.op
= EXEC_EVENT_WAIT
;
3296 new_st
.expr1
= eventvar
;
3297 new_st
.expr2
= stat
;
3298 new_st
.expr3
= errmsg
;
3299 new_st
.expr4
= until_count
;
3304 gfc_syntax_error (st
);
3307 if (until_count
!= tmp
)
3308 gfc_free_expr (until_count
);
3310 gfc_free_expr (errmsg
);
3312 gfc_free_expr (stat
);
3314 gfc_free_expr (tmp
);
3315 gfc_free_expr (eventvar
);
3323 gfc_match_event_post (void)
3325 if (!gfc_notify_std (GFC_STD_F2008_TS
, "EVENT POST statement at %C"))
3328 return event_statement (ST_EVENT_POST
);
3333 gfc_match_event_wait (void)
3335 if (!gfc_notify_std (GFC_STD_F2008_TS
, "EVENT WAIT statement at %C"))
3338 return event_statement (ST_EVENT_WAIT
);
3342 /* Match a FAIL IMAGE statement. */
3345 gfc_match_fail_image (void)
3347 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FAIL IMAGE statement at %C"))
3350 if (gfc_match_char ('(') == MATCH_YES
)
3353 new_st
.op
= EXEC_FAIL_IMAGE
;
3358 gfc_syntax_error (ST_FAIL_IMAGE
);
3363 /* Match a FORM TEAM statement. */
3366 gfc_match_form_team (void)
3369 gfc_expr
*teamid
,*team
;
3371 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FORM TEAM statement at %C"))
3374 if (gfc_match_char ('(') == MATCH_NO
)
3377 new_st
.op
= EXEC_FORM_TEAM
;
3379 if (gfc_match ("%e", &teamid
) != MATCH_YES
)
3381 m
= gfc_match_char (',');
3382 if (m
== MATCH_ERROR
)
3384 if (gfc_match ("%e", &team
) != MATCH_YES
)
3387 m
= gfc_match_char (')');
3391 new_st
.expr1
= teamid
;
3392 new_st
.expr2
= team
;
3397 gfc_syntax_error (ST_FORM_TEAM
);
3402 /* Match a CHANGE TEAM statement. */
3405 gfc_match_change_team (void)
3410 if (!gfc_notify_std (GFC_STD_F2008_TS
, "CHANGE TEAM statement at %C"))
3413 if (gfc_match_char ('(') == MATCH_NO
)
3416 new_st
.op
= EXEC_CHANGE_TEAM
;
3418 if (gfc_match ("%e", &team
) != MATCH_YES
)
3421 m
= gfc_match_char (')');
3425 new_st
.expr1
= team
;
3430 gfc_syntax_error (ST_CHANGE_TEAM
);
3435 /* Match a END TEAM statement. */
3438 gfc_match_end_team (void)
3440 if (!gfc_notify_std (GFC_STD_F2008_TS
, "END TEAM statement at %C"))
3443 if (gfc_match_char ('(') == MATCH_YES
)
3446 new_st
.op
= EXEC_END_TEAM
;
3451 gfc_syntax_error (ST_END_TEAM
);
3456 /* Match a SYNC TEAM statement. */
3459 gfc_match_sync_team (void)
3464 if (!gfc_notify_std (GFC_STD_F2008_TS
, "SYNC TEAM statement at %C"))
3467 if (gfc_match_char ('(') == MATCH_NO
)
3470 new_st
.op
= EXEC_SYNC_TEAM
;
3472 if (gfc_match ("%e", &team
) != MATCH_YES
)
3475 m
= gfc_match_char (')');
3479 new_st
.expr1
= team
;
3484 gfc_syntax_error (ST_SYNC_TEAM
);
3489 /* Match LOCK/UNLOCK statement. Syntax:
3490 LOCK ( lock-variable [ , lock-stat-list ] )
3491 UNLOCK ( lock-variable [ , sync-stat-list ] )
3492 where lock-stat is ACQUIRED_LOCK or sync-stat
3493 and sync-stat is STAT= or ERRMSG=. */
3496 lock_unlock_statement (gfc_statement st
)
3499 gfc_expr
*tmp
, *lockvar
, *acq_lock
, *stat
, *errmsg
;
3500 bool saw_acq_lock
, saw_stat
, saw_errmsg
;
3502 tmp
= lockvar
= acq_lock
= stat
= errmsg
= NULL
;
3503 saw_acq_lock
= saw_stat
= saw_errmsg
= false;
3505 if (gfc_pure (NULL
))
3507 gfc_error ("Image control statement %s at %C in PURE procedure",
3508 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3512 gfc_unset_implicit_pure (NULL
);
3514 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3516 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3520 if (gfc_find_state (COMP_CRITICAL
))
3522 gfc_error ("Image control statement %s at %C in CRITICAL block",
3523 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3527 if (gfc_find_state (COMP_DO_CONCURRENT
))
3529 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
3530 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3534 if (gfc_match_char ('(') != MATCH_YES
)
3537 if (gfc_match ("%e", &lockvar
) != MATCH_YES
)
3539 m
= gfc_match_char (',');
3540 if (m
== MATCH_ERROR
)
3544 m
= gfc_match_char (')');
3552 m
= gfc_match (" stat = %v", &tmp
);
3553 if (m
== MATCH_ERROR
)
3559 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3565 m
= gfc_match_char (',');
3573 m
= gfc_match (" errmsg = %v", &tmp
);
3574 if (m
== MATCH_ERROR
)
3580 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3586 m
= gfc_match_char (',');
3594 m
= gfc_match (" acquired_lock = %v", &tmp
);
3595 if (m
== MATCH_ERROR
|| st
== ST_UNLOCK
)
3601 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L",
3606 saw_acq_lock
= true;
3608 m
= gfc_match_char (',');
3619 if (m
== MATCH_ERROR
)
3622 if (gfc_match (" )%t") != MATCH_YES
)
3629 new_st
.op
= EXEC_LOCK
;
3632 new_st
.op
= EXEC_UNLOCK
;
3638 new_st
.expr1
= lockvar
;
3639 new_st
.expr2
= stat
;
3640 new_st
.expr3
= errmsg
;
3641 new_st
.expr4
= acq_lock
;
3646 gfc_syntax_error (st
);
3649 if (acq_lock
!= tmp
)
3650 gfc_free_expr (acq_lock
);
3652 gfc_free_expr (errmsg
);
3654 gfc_free_expr (stat
);
3656 gfc_free_expr (tmp
);
3657 gfc_free_expr (lockvar
);
3664 gfc_match_lock (void)
3666 if (!gfc_notify_std (GFC_STD_F2008
, "LOCK statement at %C"))
3669 return lock_unlock_statement (ST_LOCK
);
3674 gfc_match_unlock (void)
3676 if (!gfc_notify_std (GFC_STD_F2008
, "UNLOCK statement at %C"))
3679 return lock_unlock_statement (ST_UNLOCK
);
3683 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
3684 SYNC ALL [(sync-stat-list)]
3685 SYNC MEMORY [(sync-stat-list)]
3686 SYNC IMAGES (image-set [, sync-stat-list] )
3687 with sync-stat is int-expr or *. */
3690 sync_statement (gfc_statement st
)
3693 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
3694 bool saw_stat
, saw_errmsg
;
3696 tmp
= imageset
= stat
= errmsg
= NULL
;
3697 saw_stat
= saw_errmsg
= false;
3699 if (gfc_pure (NULL
))
3701 gfc_error ("Image control statement SYNC at %C in PURE procedure");
3705 gfc_unset_implicit_pure (NULL
);
3707 if (!gfc_notify_std (GFC_STD_F2008
, "SYNC statement at %C"))
3710 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3712 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
3717 if (gfc_find_state (COMP_CRITICAL
))
3719 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3723 if (gfc_find_state (COMP_DO_CONCURRENT
))
3725 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3729 if (gfc_match_eos () == MATCH_YES
)
3731 if (st
== ST_SYNC_IMAGES
)
3736 if (gfc_match_char ('(') != MATCH_YES
)
3739 if (st
== ST_SYNC_IMAGES
)
3741 /* Denote '*' as imageset == NULL. */
3742 m
= gfc_match_char ('*');
3743 if (m
== MATCH_ERROR
)
3747 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
3750 m
= gfc_match_char (',');
3751 if (m
== MATCH_ERROR
)
3755 m
= gfc_match_char (')');
3764 m
= gfc_match (" stat = %v", &tmp
);
3765 if (m
== MATCH_ERROR
)
3771 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3777 if (gfc_match_char (',') == MATCH_YES
)
3784 m
= gfc_match (" errmsg = %v", &tmp
);
3785 if (m
== MATCH_ERROR
)
3791 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3797 if (gfc_match_char (',') == MATCH_YES
)
3807 if (gfc_match (" )%t") != MATCH_YES
)
3814 new_st
.op
= EXEC_SYNC_ALL
;
3816 case ST_SYNC_IMAGES
:
3817 new_st
.op
= EXEC_SYNC_IMAGES
;
3819 case ST_SYNC_MEMORY
:
3820 new_st
.op
= EXEC_SYNC_MEMORY
;
3826 new_st
.expr1
= imageset
;
3827 new_st
.expr2
= stat
;
3828 new_st
.expr3
= errmsg
;
3833 gfc_syntax_error (st
);
3837 gfc_free_expr (stat
);
3839 gfc_free_expr (errmsg
);
3841 gfc_free_expr (tmp
);
3842 gfc_free_expr (imageset
);
3848 /* Match SYNC ALL statement. */
3851 gfc_match_sync_all (void)
3853 return sync_statement (ST_SYNC_ALL
);
3857 /* Match SYNC IMAGES statement. */
3860 gfc_match_sync_images (void)
3862 return sync_statement (ST_SYNC_IMAGES
);
3866 /* Match SYNC MEMORY statement. */
3869 gfc_match_sync_memory (void)
3871 return sync_statement (ST_SYNC_MEMORY
);
3875 /* Match a CONTINUE statement. */
3878 gfc_match_continue (void)
3880 if (gfc_match_eos () != MATCH_YES
)
3882 gfc_syntax_error (ST_CONTINUE
);
3886 new_st
.op
= EXEC_CONTINUE
;
3891 /* Match the (deprecated) ASSIGN statement. */
3894 gfc_match_assign (void)
3897 gfc_st_label
*label
;
3899 if (gfc_match (" %l", &label
) == MATCH_YES
)
3901 if (!gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
))
3903 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
3905 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGN statement at %C"))
3908 expr
->symtree
->n
.sym
->attr
.assign
= 1;
3910 new_st
.op
= EXEC_LABEL_ASSIGN
;
3911 new_st
.label1
= label
;
3912 new_st
.expr1
= expr
;
3920 /* Match the GO TO statement. As a computed GOTO statement is
3921 matched, it is transformed into an equivalent SELECT block. No
3922 tree is necessary, and the resulting jumps-to-jumps are
3923 specifically optimized away by the back end. */
3926 gfc_match_goto (void)
3928 gfc_code
*head
, *tail
;
3931 gfc_st_label
*label
;
3935 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
3937 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3940 new_st
.op
= EXEC_GOTO
;
3941 new_st
.label1
= label
;
3945 /* The assigned GO TO statement. */
3947 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
3949 if (!gfc_notify_std (GFC_STD_F95_DEL
, "Assigned GOTO statement at %C"))
3952 new_st
.op
= EXEC_GOTO
;
3953 new_st
.expr1
= expr
;
3955 if (gfc_match_eos () == MATCH_YES
)
3958 /* Match label list. */
3959 gfc_match_char (',');
3960 if (gfc_match_char ('(') != MATCH_YES
)
3962 gfc_syntax_error (ST_GOTO
);
3969 m
= gfc_match_st_label (&label
);
3973 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3977 head
= tail
= gfc_get_code (EXEC_GOTO
);
3980 tail
->block
= gfc_get_code (EXEC_GOTO
);
3984 tail
->label1
= label
;
3986 while (gfc_match_char (',') == MATCH_YES
);
3988 if (gfc_match (")%t") != MATCH_YES
)
3993 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3996 new_st
.block
= head
;
4001 /* Last chance is a computed GO TO statement. */
4002 if (gfc_match_char ('(') != MATCH_YES
)
4004 gfc_syntax_error (ST_GOTO
);
4013 m
= gfc_match_st_label (&label
);
4017 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
4021 head
= tail
= gfc_get_code (EXEC_SELECT
);
4024 tail
->block
= gfc_get_code (EXEC_SELECT
);
4028 cp
= gfc_get_case ();
4029 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
4032 tail
->ext
.block
.case_list
= cp
;
4034 tail
->next
= gfc_get_code (EXEC_GOTO
);
4035 tail
->next
->label1
= label
;
4037 while (gfc_match_char (',') == MATCH_YES
);
4039 if (gfc_match_char (')') != MATCH_YES
)
4044 gfc_error ("Statement label list in GOTO at %C cannot be empty");
4048 /* Get the rest of the statement. */
4049 gfc_match_char (',');
4051 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
4054 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Computed GOTO at %C"))
4057 /* At this point, a computed GOTO has been fully matched and an
4058 equivalent SELECT statement constructed. */
4060 new_st
.op
= EXEC_SELECT
;
4061 new_st
.expr1
= NULL
;
4063 /* Hack: For a "real" SELECT, the expression is in expr. We put
4064 it in expr2 so we can distinguish then and produce the correct
4066 new_st
.expr2
= expr
;
4067 new_st
.block
= head
;
4071 gfc_syntax_error (ST_GOTO
);
4073 gfc_free_statements (head
);
4078 /* Frees a list of gfc_alloc structures. */
4081 gfc_free_alloc_list (gfc_alloc
*p
)
4088 gfc_free_expr (p
->expr
);
4094 /* Match an ALLOCATE statement. */
4097 gfc_match_allocate (void)
4099 gfc_alloc
*head
, *tail
;
4100 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
4104 locus old_locus
, deferred_locus
, assumed_locus
;
4105 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, saw_deferred
, b1
, b2
, b3
;
4106 bool saw_unlimited
= false, saw_assumed
= false;
4109 stat
= errmsg
= source
= mold
= tmp
= NULL
;
4110 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= saw_deferred
= false;
4112 if (gfc_match_char ('(') != MATCH_YES
)
4114 gfc_syntax_error (ST_ALLOCATE
);
4118 /* Match an optional type-spec. */
4119 old_locus
= gfc_current_locus
;
4120 m
= gfc_match_type_spec (&ts
);
4121 if (m
== MATCH_ERROR
)
4123 else if (m
== MATCH_NO
)
4125 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
4127 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
4129 gfc_error ("Error in type-spec at %L", &old_locus
);
4133 ts
.type
= BT_UNKNOWN
;
4137 /* Needed for the F2008:C631 check below. */
4138 assumed_locus
= gfc_current_locus
;
4140 if (gfc_match (" :: ") == MATCH_YES
)
4142 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
4148 gfc_error ("Type-spec at %L cannot contain a deferred "
4149 "type parameter", &old_locus
);
4153 if (ts
.type
== BT_CHARACTER
)
4155 if (!ts
.u
.cl
->length
)
4158 ts
.u
.cl
->length_from_typespec
= true;
4161 if (type_param_spec_list
4162 && gfc_spec_list_type (type_param_spec_list
, NULL
)
4165 gfc_error ("The type parameter spec list in the type-spec at "
4166 "%L cannot contain DEFERRED parameters", &old_locus
);
4172 ts
.type
= BT_UNKNOWN
;
4173 gfc_current_locus
= old_locus
;
4180 head
= tail
= gfc_get_alloc ();
4183 tail
->next
= gfc_get_alloc ();
4187 m
= gfc_match_variable (&tail
->expr
, 0);
4190 if (m
== MATCH_ERROR
)
4193 if (gfc_check_do_variable (tail
->expr
->symtree
))
4196 bool impure
= gfc_impure_variable (tail
->expr
->symtree
->n
.sym
);
4197 if (impure
&& gfc_pure (NULL
))
4199 gfc_error ("Bad allocate-object at %C for a PURE procedure");
4204 gfc_unset_implicit_pure (NULL
);
4206 /* F2008:C631 (R626) A type-param-value in a type-spec shall be an
4207 asterisk if and only if each allocate-object is a dummy argument
4208 for which the corresponding type parameter is assumed. */
4210 && (tail
->expr
->ts
.deferred
4211 || (tail
->expr
->ts
.u
.cl
&& tail
->expr
->ts
.u
.cl
->length
)
4212 || tail
->expr
->symtree
->n
.sym
->attr
.dummy
== 0))
4214 gfc_error ("Incompatible allocate-object at %C for CHARACTER "
4215 "type-spec at %L", &assumed_locus
);
4219 if (tail
->expr
->ts
.deferred
)
4221 saw_deferred
= true;
4222 deferred_locus
= tail
->expr
->where
;
4225 if (gfc_find_state (COMP_DO_CONCURRENT
)
4226 || gfc_find_state (COMP_CRITICAL
))
4229 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
4230 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
4231 if (ref
->type
== REF_COMPONENT
)
4232 coarray
= ref
->u
.c
.component
->attr
.codimension
;
4234 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
4236 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
4239 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
4241 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
4246 /* Check for F08:C628. */
4247 sym
= tail
->expr
->symtree
->n
.sym
;
4248 b1
= !(tail
->expr
->ref
4249 && (tail
->expr
->ref
->type
== REF_COMPONENT
4250 || tail
->expr
->ref
->type
== REF_ARRAY
));
4251 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4252 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
4253 || CLASS_DATA (sym
)->attr
.class_pointer
);
4255 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4256 || sym
->attr
.proc_pointer
);
4257 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
4258 && (sym
->ns
->proc_name
->attr
.allocatable
4259 || sym
->ns
->proc_name
->attr
.pointer
4260 || sym
->ns
->proc_name
->attr
.proc_pointer
);
4261 if (b1
&& b2
&& !b3
)
4263 gfc_error ("Allocate-object at %L is neither a data pointer "
4264 "nor an allocatable variable", &tail
->expr
->where
);
4268 /* The ALLOCATE statement had an optional typespec. Check the
4270 if (ts
.type
!= BT_UNKNOWN
)
4272 /* Enforce F03:C624. */
4273 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
4275 gfc_error ("Type of entity at %L is type incompatible with "
4276 "typespec", &tail
->expr
->where
);
4280 /* Enforce F03:C627. */
4281 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
4283 gfc_error ("Kind type parameter for entity at %L differs from "
4284 "the kind type parameter of the typespec",
4285 &tail
->expr
->where
);
4290 if (tail
->expr
->ts
.type
== BT_DERIVED
)
4291 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
4293 if (type_param_spec_list
)
4294 tail
->expr
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
4296 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
4298 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
4300 gfc_error ("Shape specification for allocatable scalar at %C");
4304 if (gfc_match_char (',') != MATCH_YES
)
4309 m
= gfc_match (" stat = %v", &tmp
);
4310 if (m
== MATCH_ERROR
)
4317 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4325 if (gfc_check_do_variable (stat
->symtree
))
4328 if (gfc_match_char (',') == MATCH_YES
)
4329 goto alloc_opt_list
;
4332 m
= gfc_match (" errmsg = %v", &tmp
);
4333 if (m
== MATCH_ERROR
)
4337 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
4343 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4351 if (gfc_match_char (',') == MATCH_YES
)
4352 goto alloc_opt_list
;
4355 m
= gfc_match (" source = %e", &tmp
);
4356 if (m
== MATCH_ERROR
)
4360 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
4366 gfc_error ("Redundant SOURCE tag found at %L", &tmp
->where
);
4370 /* The next 2 conditionals check C631. */
4371 if (ts
.type
!= BT_UNKNOWN
)
4373 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
4374 &tmp
->where
, &old_locus
);
4379 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
4380 " with more than a single allocate object",
4388 if (gfc_match_char (',') == MATCH_YES
)
4389 goto alloc_opt_list
;
4392 m
= gfc_match (" mold = %e", &tmp
);
4393 if (m
== MATCH_ERROR
)
4397 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
4400 /* Check F08:C636. */
4403 gfc_error ("Redundant MOLD tag found at %L", &tmp
->where
);
4407 /* Check F08:C637. */
4408 if (ts
.type
!= BT_UNKNOWN
)
4410 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
4411 &tmp
->where
, &old_locus
);
4420 if (gfc_match_char (',') == MATCH_YES
)
4421 goto alloc_opt_list
;
4424 gfc_gobble_whitespace ();
4426 if (gfc_peek_char () == ')')
4430 if (gfc_match (" )%t") != MATCH_YES
)
4433 /* Check F08:C637. */
4436 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
4437 &mold
->where
, &source
->where
);
4441 /* Check F03:C623, */
4442 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4444 gfc_error ("Allocate-object at %L with a deferred type parameter "
4445 "requires either a type-spec or SOURCE tag or a MOLD tag",
4450 /* Check F03:C625, */
4451 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4453 for (tail
= head
; tail
; tail
= tail
->next
)
4455 if (UNLIMITED_POLY (tail
->expr
))
4456 gfc_error ("Unlimited polymorphic allocate-object at %L "
4457 "requires either a type-spec or SOURCE tag "
4458 "or a MOLD tag", &tail
->expr
->where
);
4463 new_st
.op
= EXEC_ALLOCATE
;
4464 new_st
.expr1
= stat
;
4465 new_st
.expr2
= errmsg
;
4467 new_st
.expr3
= source
;
4469 new_st
.expr3
= mold
;
4470 new_st
.ext
.alloc
.list
= head
;
4471 new_st
.ext
.alloc
.ts
= ts
;
4473 if (type_param_spec_list
)
4474 gfc_free_actual_arglist (type_param_spec_list
);
4479 gfc_syntax_error (ST_ALLOCATE
);
4482 gfc_free_expr (errmsg
);
4483 gfc_free_expr (source
);
4484 gfc_free_expr (stat
);
4485 gfc_free_expr (mold
);
4486 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
4487 gfc_free_alloc_list (head
);
4488 if (type_param_spec_list
)
4489 gfc_free_actual_arglist (type_param_spec_list
);
4494 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
4495 a set of pointer assignments to intrinsic NULL(). */
4498 gfc_match_nullify (void)
4506 if (gfc_match_char ('(') != MATCH_YES
)
4511 m
= gfc_match_variable (&p
, 0);
4512 if (m
== MATCH_ERROR
)
4517 if (gfc_check_do_variable (p
->symtree
))
4521 if (gfc_is_coindexed (p
))
4523 gfc_error ("Pointer object at %C shall not be coindexed");
4527 /* build ' => NULL() '. */
4528 e
= gfc_get_null_expr (&gfc_current_locus
);
4530 /* Chain to list. */
4534 tail
->op
= EXEC_POINTER_ASSIGN
;
4538 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
4545 if (gfc_match (" )%t") == MATCH_YES
)
4547 if (gfc_match_char (',') != MATCH_YES
)
4554 gfc_syntax_error (ST_NULLIFY
);
4557 gfc_free_statements (new_st
.next
);
4559 gfc_free_expr (new_st
.expr1
);
4560 new_st
.expr1
= NULL
;
4561 gfc_free_expr (new_st
.expr2
);
4562 new_st
.expr2
= NULL
;
4567 /* Match a DEALLOCATE statement. */
4570 gfc_match_deallocate (void)
4572 gfc_alloc
*head
, *tail
;
4573 gfc_expr
*stat
, *errmsg
, *tmp
;
4576 bool saw_stat
, saw_errmsg
, b1
, b2
;
4579 stat
= errmsg
= tmp
= NULL
;
4580 saw_stat
= saw_errmsg
= false;
4582 if (gfc_match_char ('(') != MATCH_YES
)
4588 head
= tail
= gfc_get_alloc ();
4591 tail
->next
= gfc_get_alloc ();
4595 m
= gfc_match_variable (&tail
->expr
, 0);
4596 if (m
== MATCH_ERROR
)
4601 if (gfc_check_do_variable (tail
->expr
->symtree
))
4604 sym
= tail
->expr
->symtree
->n
.sym
;
4606 bool impure
= gfc_impure_variable (sym
);
4607 if (impure
&& gfc_pure (NULL
))
4609 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
4614 gfc_unset_implicit_pure (NULL
);
4616 if (gfc_is_coarray (tail
->expr
)
4617 && gfc_find_state (COMP_DO_CONCURRENT
))
4619 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
4623 if (gfc_is_coarray (tail
->expr
)
4624 && gfc_find_state (COMP_CRITICAL
))
4626 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
4630 /* FIXME: disable the checking on derived types. */
4631 b1
= !(tail
->expr
->ref
4632 && (tail
->expr
->ref
->type
== REF_COMPONENT
4633 || tail
->expr
->ref
->type
== REF_ARRAY
));
4634 if (sym
&& sym
->ts
.type
== BT_CLASS
)
4635 b2
= !(CLASS_DATA (sym
) && (CLASS_DATA (sym
)->attr
.allocatable
4636 || CLASS_DATA (sym
)->attr
.class_pointer
));
4638 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4639 || sym
->attr
.proc_pointer
);
4642 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
4643 "nor an allocatable variable");
4647 if (gfc_match_char (',') != MATCH_YES
)
4652 m
= gfc_match (" stat = %v", &tmp
);
4653 if (m
== MATCH_ERROR
)
4659 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4660 gfc_free_expr (tmp
);
4667 if (gfc_check_do_variable (stat
->symtree
))
4670 if (gfc_match_char (',') == MATCH_YES
)
4671 goto dealloc_opt_list
;
4674 m
= gfc_match (" errmsg = %v", &tmp
);
4675 if (m
== MATCH_ERROR
)
4679 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
4684 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4685 gfc_free_expr (tmp
);
4692 if (gfc_match_char (',') == MATCH_YES
)
4693 goto dealloc_opt_list
;
4696 gfc_gobble_whitespace ();
4698 if (gfc_peek_char () == ')')
4702 if (gfc_match (" )%t") != MATCH_YES
)
4705 new_st
.op
= EXEC_DEALLOCATE
;
4706 new_st
.expr1
= stat
;
4707 new_st
.expr2
= errmsg
;
4708 new_st
.ext
.alloc
.list
= head
;
4713 gfc_syntax_error (ST_DEALLOCATE
);
4716 gfc_free_expr (errmsg
);
4717 gfc_free_expr (stat
);
4718 gfc_free_alloc_list (head
);
4723 /* Match a RETURN statement. */
4726 gfc_match_return (void)
4730 gfc_compile_state s
;
4734 if (gfc_find_state (COMP_CRITICAL
))
4736 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4740 if (gfc_find_state (COMP_DO_CONCURRENT
))
4742 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4746 if (gfc_match_eos () == MATCH_YES
)
4749 if (!gfc_find_state (COMP_SUBROUTINE
))
4751 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4756 if (gfc_current_form
== FORM_FREE
)
4758 /* The following are valid, so we can't require a blank after the
4762 char c
= gfc_peek_ascii_char ();
4763 if (ISALPHA (c
) || ISDIGIT (c
))
4767 m
= gfc_match (" %e%t", &e
);
4770 if (m
== MATCH_ERROR
)
4773 gfc_syntax_error (ST_RETURN
);
4780 gfc_enclosing_unit (&s
);
4781 if (s
== COMP_PROGRAM
4782 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
4783 "main program at %C"))
4786 new_st
.op
= EXEC_RETURN
;
4793 /* Match the call of a type-bound procedure, if CALL%var has already been
4794 matched and var found to be a derived-type variable. */
4797 match_typebound_call (gfc_symtree
* varst
)
4802 base
= gfc_get_expr ();
4803 base
->expr_type
= EXPR_VARIABLE
;
4804 base
->symtree
= varst
;
4805 base
->where
= gfc_current_locus
;
4806 gfc_set_sym_referenced (varst
->n
.sym
);
4808 m
= gfc_match_varspec (base
, 0, true, true);
4810 gfc_error ("Expected component reference at %C");
4813 gfc_free_expr (base
);
4817 if (gfc_match_eos () != MATCH_YES
)
4819 gfc_error ("Junk after CALL at %C");
4820 gfc_free_expr (base
);
4824 if (base
->expr_type
== EXPR_COMPCALL
)
4825 new_st
.op
= EXEC_COMPCALL
;
4826 else if (base
->expr_type
== EXPR_PPC
)
4827 new_st
.op
= EXEC_CALL_PPC
;
4830 gfc_error ("Expected type-bound procedure or procedure pointer component "
4832 gfc_free_expr (base
);
4835 new_st
.expr1
= base
;
4841 /* Match a CALL statement. The tricky part here are possible
4842 alternate return specifiers. We handle these by having all
4843 "subroutines" actually return an integer via a register that gives
4844 the return number. If the call specifies alternate returns, we
4845 generate code for a SELECT statement whose case clauses contain
4846 GOTOs to the various labels. */
4849 gfc_match_call (void)
4851 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4852 gfc_actual_arglist
*a
, *arglist
;
4862 m
= gfc_match ("% %n", name
);
4868 if (gfc_get_ha_sym_tree (name
, &st
))
4873 /* If this is a variable of derived-type, it probably starts a type-bound
4875 if ((sym
->attr
.flavor
!= FL_PROCEDURE
4876 || gfc_is_function_return_value (sym
, gfc_current_ns
))
4877 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
4878 return match_typebound_call (st
);
4880 /* If it does not seem to be callable (include functions so that the
4881 right association is made. They are thrown out in resolution.)
4883 if (!sym
->attr
.generic
4884 && !sym
->attr
.subroutine
4885 && !sym
->attr
.function
)
4887 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
4889 /* ...create a symbol in this scope... */
4890 if (sym
->ns
!= gfc_current_ns
4891 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
4894 if (sym
!= st
->n
.sym
)
4898 /* ...and then to try to make the symbol into a subroutine. */
4899 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
4903 gfc_set_sym_referenced (sym
);
4905 if (gfc_match_eos () != MATCH_YES
)
4907 m
= gfc_match_actual_arglist (1, &arglist
);
4910 if (m
== MATCH_ERROR
)
4913 if (gfc_match_eos () != MATCH_YES
)
4917 /* If any alternate return labels were found, construct a SELECT
4918 statement that will jump to the right place. */
4921 for (a
= arglist
; a
; a
= a
->next
)
4922 if (a
->expr
== NULL
)
4930 gfc_symtree
*select_st
;
4931 gfc_symbol
*select_sym
;
4932 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4934 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
4935 sprintf (name
, "_result_%s", sym
->name
);
4936 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
4938 select_sym
= select_st
->n
.sym
;
4939 select_sym
->ts
.type
= BT_INTEGER
;
4940 select_sym
->ts
.kind
= gfc_default_integer_kind
;
4941 gfc_set_sym_referenced (select_sym
);
4942 c
->expr1
= gfc_get_expr ();
4943 c
->expr1
->expr_type
= EXPR_VARIABLE
;
4944 c
->expr1
->symtree
= select_st
;
4945 c
->expr1
->ts
= select_sym
->ts
;
4946 c
->expr1
->where
= gfc_current_locus
;
4949 for (a
= arglist
; a
; a
= a
->next
)
4951 if (a
->expr
!= NULL
)
4954 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
4959 c
->block
= gfc_get_code (EXEC_SELECT
);
4962 new_case
= gfc_get_case ();
4963 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
4964 new_case
->low
= new_case
->high
;
4965 c
->ext
.block
.case_list
= new_case
;
4967 c
->next
= gfc_get_code (EXEC_GOTO
);
4968 c
->next
->label1
= a
->label
;
4972 new_st
.op
= EXEC_CALL
;
4973 new_st
.symtree
= st
;
4974 new_st
.ext
.actual
= arglist
;
4979 gfc_syntax_error (ST_CALL
);
4982 gfc_free_actual_arglist (arglist
);
4987 /* Given a name, return a pointer to the common head structure,
4988 creating it if it does not exist. If FROM_MODULE is nonzero, we
4989 mangle the name so that it doesn't interfere with commons defined
4990 in the using namespace.
4991 TODO: Add to global symbol tree. */
4994 gfc_get_common (const char *name
, int from_module
)
4997 static int serial
= 0;
4998 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
5002 /* A use associated common block is only needed to correctly layout
5003 the variables it contains. */
5004 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
5005 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
5009 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
5012 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
5015 if (st
->n
.common
== NULL
)
5017 st
->n
.common
= gfc_get_common_head ();
5018 st
->n
.common
->where
= gfc_current_locus
;
5019 strcpy (st
->n
.common
->name
, name
);
5022 return st
->n
.common
;
5026 /* Match a common block name. */
5028 match
match_common_name (char *name
)
5032 if (gfc_match_char ('/') == MATCH_NO
)
5038 if (gfc_match_char ('/') == MATCH_YES
)
5044 m
= gfc_match_name (name
);
5046 if (m
== MATCH_ERROR
)
5048 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
5051 gfc_error ("Syntax error in common block name at %C");
5056 /* Match a COMMON statement. */
5059 gfc_match_common (void)
5061 gfc_symbol
*sym
, **head
, *tail
, *other
;
5062 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5072 m
= match_common_name (name
);
5073 if (m
== MATCH_ERROR
)
5076 if (name
[0] == '\0')
5078 t
= &gfc_current_ns
->blank_common
;
5079 if (t
->head
== NULL
)
5080 t
->where
= gfc_current_locus
;
5084 t
= gfc_get_common (name
, 0);
5093 while (tail
->common_next
)
5094 tail
= tail
->common_next
;
5097 /* Grab the list of symbols. */
5100 m
= gfc_match_symbol (&sym
, 0);
5101 if (m
== MATCH_ERROR
)
5106 /* See if we know the current common block is bind(c), and if
5107 so, then see if we can check if the symbol is (which it'll
5108 need to be). This can happen if the bind(c) attr stmt was
5109 applied to the common block, and the variable(s) already
5110 defined, before declaring the common block. */
5111 if (t
->is_bind_c
== 1)
5113 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
5115 /* If we find an error, just print it and continue,
5116 cause it's just semantic, and we can see if there
5118 gfc_error_now ("Variable %qs at %L in common block %qs "
5119 "at %C must be declared with a C "
5120 "interoperable kind since common block "
5122 sym
->name
, &(sym
->declared_at
), t
->name
,
5126 if (sym
->attr
.is_bind_c
== 1)
5127 gfc_error_now ("Variable %qs in common block %qs at %C can not "
5128 "be bind(c) since it is not global", sym
->name
,
5132 if (sym
->attr
.in_common
)
5134 gfc_error ("Symbol %qs at %C is already in a COMMON block",
5139 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
5140 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
5142 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol %qs at "
5143 "%C can only be COMMON in BLOCK DATA",
5148 /* Deal with an optional array specification after the
5150 m
= gfc_match_array_spec (&as
, true, true);
5151 if (m
== MATCH_ERROR
)
5156 if (as
->type
!= AS_EXPLICIT
)
5158 gfc_error ("Array specification for symbol %qs in COMMON "
5159 "at %C must be explicit", sym
->name
);
5163 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
5166 if (sym
->attr
.pointer
)
5168 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
5169 "POINTER array", sym
->name
);
5178 /* Add the in_common attribute, but ignore the reported errors
5179 if any, and continue matching. */
5180 gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
);
5182 sym
->common_block
= t
;
5183 sym
->common_block
->refs
++;
5186 tail
->common_next
= sym
;
5192 sym
->common_head
= t
;
5194 /* Check to see if the symbol is already in an equivalence group.
5195 If it is, set the other members as being in common. */
5196 if (sym
->attr
.in_equivalence
)
5198 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
5200 for (e2
= e1
; e2
; e2
= e2
->eq
)
5201 if (e2
->expr
->symtree
->n
.sym
== sym
)
5208 for (e2
= e1
; e2
; e2
= e2
->eq
)
5210 other
= e2
->expr
->symtree
->n
.sym
;
5211 if (other
->common_head
5212 && other
->common_head
!= sym
->common_head
)
5214 gfc_error ("Symbol %qs, in COMMON block %qs at "
5215 "%C is being indirectly equivalenced to "
5216 "another COMMON block %qs",
5217 sym
->name
, sym
->common_head
->name
,
5218 other
->common_head
->name
);
5221 other
->attr
.in_common
= 1;
5222 other
->common_head
= t
;
5228 gfc_gobble_whitespace ();
5229 if (gfc_match_eos () == MATCH_YES
)
5231 if (gfc_peek_ascii_char () == '/')
5233 if (gfc_match_char (',') != MATCH_YES
)
5235 gfc_gobble_whitespace ();
5236 if (gfc_peek_ascii_char () == '/')
5245 gfc_syntax_error (ST_COMMON
);
5248 gfc_free_array_spec (as
);
5253 /* Match a BLOCK DATA program unit. */
5256 gfc_match_block_data (void)
5258 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5262 if (gfc_match_eos () == MATCH_YES
)
5264 gfc_new_block
= NULL
;
5268 m
= gfc_match ("% %n%t", name
);
5272 if (gfc_get_symbol (name
, NULL
, &sym
))
5275 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
5278 gfc_new_block
= sym
;
5284 /* Free a namelist structure. */
5287 gfc_free_namelist (gfc_namelist
*name
)
5291 for (; name
; name
= n
)
5299 /* Free an OpenMP namelist structure. */
5302 gfc_free_omp_namelist (gfc_omp_namelist
*name
)
5304 gfc_omp_namelist
*n
;
5306 for (; name
; name
= n
)
5308 gfc_free_expr (name
->expr
);
5311 if (name
->udr
->combiner
)
5312 gfc_free_statement (name
->udr
->combiner
);
5313 if (name
->udr
->initializer
)
5314 gfc_free_statement (name
->udr
->initializer
);
5323 /* Match a NAMELIST statement. */
5326 gfc_match_namelist (void)
5328 gfc_symbol
*group_name
, *sym
;
5332 m
= gfc_match (" / %s /", &group_name
);
5335 if (m
== MATCH_ERROR
)
5340 if (group_name
->ts
.type
!= BT_UNKNOWN
)
5342 gfc_error ("Namelist group name %qs at %C already has a basic "
5343 "type of %s", group_name
->name
,
5344 gfc_typename (&group_name
->ts
));
5348 if (group_name
->attr
.flavor
== FL_NAMELIST
5349 && group_name
->attr
.use_assoc
5350 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name %qs "
5351 "at %C already is USE associated and can"
5352 "not be respecified.", group_name
->name
))
5355 if (group_name
->attr
.flavor
!= FL_NAMELIST
5356 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
5357 group_name
->name
, NULL
))
5362 m
= gfc_match_symbol (&sym
, 1);
5365 if (m
== MATCH_ERROR
)
5368 if (sym
->attr
.in_namelist
== 0
5369 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
5372 /* Use gfc_error_check here, rather than goto error, so that
5373 these are the only errors for the next two lines. */
5374 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
5376 gfc_error ("Assumed size array %qs in namelist %qs at "
5377 "%C is not allowed", sym
->name
, group_name
->name
);
5381 nl
= gfc_get_namelist ();
5385 if (group_name
->namelist
== NULL
)
5386 group_name
->namelist
= group_name
->namelist_tail
= nl
;
5389 group_name
->namelist_tail
->next
= nl
;
5390 group_name
->namelist_tail
= nl
;
5393 if (gfc_match_eos () == MATCH_YES
)
5396 m
= gfc_match_char (',');
5398 if (gfc_match_char ('/') == MATCH_YES
)
5400 m2
= gfc_match (" %s /", &group_name
);
5401 if (m2
== MATCH_YES
)
5403 if (m2
== MATCH_ERROR
)
5417 gfc_syntax_error (ST_NAMELIST
);
5424 /* Match a MODULE statement. */
5427 gfc_match_module (void)
5431 m
= gfc_match (" %s%t", &gfc_new_block
);
5435 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
5436 gfc_new_block
->name
, NULL
))
5443 /* Free equivalence sets and lists. Recursively is the easiest way to
5447 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
5452 gfc_free_equiv (eq
->eq
);
5453 gfc_free_equiv_until (eq
->next
, stop
);
5454 gfc_free_expr (eq
->expr
);
5460 gfc_free_equiv (gfc_equiv
*eq
)
5462 gfc_free_equiv_until (eq
, NULL
);
5466 /* Match an EQUIVALENCE statement. */
5469 gfc_match_equivalence (void)
5471 gfc_equiv
*eq
, *set
, *tail
;
5475 gfc_common_head
*common_head
= NULL
;
5483 eq
= gfc_get_equiv ();
5487 eq
->next
= gfc_current_ns
->equiv
;
5488 gfc_current_ns
->equiv
= eq
;
5490 if (gfc_match_char ('(') != MATCH_YES
)
5494 common_flag
= FALSE
;
5499 m
= gfc_match_equiv_variable (&set
->expr
);
5500 if (m
== MATCH_ERROR
)
5505 /* count the number of objects. */
5508 if (gfc_match_char ('%') == MATCH_YES
)
5510 gfc_error ("Derived type component %C is not a "
5511 "permitted EQUIVALENCE member");
5515 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
5516 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5518 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
5519 "be an array section");
5523 sym
= set
->expr
->symtree
->n
.sym
;
5525 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
5528 if (sym
->attr
.in_common
)
5531 common_head
= sym
->common_head
;
5534 if (gfc_match_char (')') == MATCH_YES
)
5537 if (gfc_match_char (',') != MATCH_YES
)
5540 set
->eq
= gfc_get_equiv ();
5546 gfc_error ("EQUIVALENCE at %C requires two or more objects");
5550 /* If one of the members of an equivalence is in common, then
5551 mark them all as being in common. Before doing this, check
5552 that members of the equivalence group are not in different
5555 for (set
= eq
; set
; set
= set
->eq
)
5557 sym
= set
->expr
->symtree
->n
.sym
;
5558 if (sym
->common_head
&& sym
->common_head
!= common_head
)
5560 gfc_error ("Attempt to indirectly overlap COMMON "
5561 "blocks %s and %s by EQUIVALENCE at %C",
5562 sym
->common_head
->name
, common_head
->name
);
5565 sym
->attr
.in_common
= 1;
5566 sym
->common_head
= common_head
;
5569 if (gfc_match_eos () == MATCH_YES
)
5571 if (gfc_match_char (',') != MATCH_YES
)
5573 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
5581 gfc_syntax_error (ST_EQUIVALENCE
);
5587 gfc_free_equiv (gfc_current_ns
->equiv
);
5588 gfc_current_ns
->equiv
= eq
;
5594 /* Check that a statement function is not recursive. This is done by looking
5595 for the statement function symbol(sym) by looking recursively through its
5596 expression(e). If a reference to sym is found, true is returned.
5597 12.5.4 requires that any variable of function that is implicitly typed
5598 shall have that type confirmed by any subsequent type declaration. The
5599 implicit typing is conveniently done here. */
5601 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
5604 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
5610 switch (e
->expr_type
)
5613 if (e
->symtree
== NULL
)
5616 /* Check the name before testing for nested recursion! */
5617 if (sym
->name
== e
->symtree
->n
.sym
->name
)
5620 /* Catch recursion via other statement functions. */
5621 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
5622 && e
->symtree
->n
.sym
->value
5623 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
5626 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5627 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5632 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
5635 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5636 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5648 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
5650 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
5654 /* Match a statement function declaration. It is so easy to match
5655 non-statement function statements with a MATCH_ERROR as opposed to
5656 MATCH_NO that we suppress error message in most cases. */
5659 gfc_match_st_function (void)
5661 gfc_error_buffer old_error
;
5666 m
= gfc_match_symbol (&sym
, 0);
5670 gfc_push_error (&old_error
);
5672 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
5675 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
5678 m
= gfc_match (" = %e%t", &expr
);
5682 gfc_free_error (&old_error
);
5684 if (m
== MATCH_ERROR
)
5687 if (recursive_stmt_fcn (expr
, sym
))
5689 gfc_error ("Statement function at %L is recursive", &expr
->where
);
5695 if ((gfc_current_state () == COMP_FUNCTION
5696 || gfc_current_state () == COMP_SUBROUTINE
)
5697 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
5699 gfc_error ("Statement function at %L cannot appear within an INTERFACE",
5704 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
5710 gfc_pop_error (&old_error
);
5715 /* Match an assignment to a pointer function (F2008). This could, in
5716 general be ambiguous with a statement function. In this implementation
5717 it remains so if it is the first statement after the specification
5721 gfc_match_ptr_fcn_assign (void)
5723 gfc_error_buffer old_error
;
5728 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5730 old_loc
= gfc_current_locus
;
5731 m
= gfc_match_name (name
);
5735 gfc_find_symbol (name
, NULL
, 1, &sym
);
5736 if (sym
&& sym
->attr
.flavor
!= FL_PROCEDURE
)
5739 gfc_push_error (&old_error
);
5741 if (sym
&& sym
->attr
.function
)
5742 goto match_actual_arglist
;
5744 gfc_current_locus
= old_loc
;
5745 m
= gfc_match_symbol (&sym
, 0);
5749 if (!gfc_add_procedure (&sym
->attr
, PROC_UNKNOWN
, sym
->name
, NULL
))
5752 match_actual_arglist
:
5753 gfc_current_locus
= old_loc
;
5754 m
= gfc_match (" %e", &expr
);
5758 new_st
.op
= EXEC_ASSIGN
;
5759 new_st
.expr1
= expr
;
5762 m
= gfc_match (" = %e%t", &expr
);
5766 new_st
.expr2
= expr
;
5770 gfc_pop_error (&old_error
);
5775 /***************** SELECT CASE subroutines ******************/
5777 /* Free a single case structure. */
5780 free_case (gfc_case
*p
)
5782 if (p
->low
== p
->high
)
5784 gfc_free_expr (p
->low
);
5785 gfc_free_expr (p
->high
);
5790 /* Free a list of case structures. */
5793 gfc_free_case_list (gfc_case
*p
)
5805 /* Match a single case selector. Combining the requirements of F08:C830
5806 and F08:C832 (R838) means that the case-value must have either CHARACTER,
5807 INTEGER, or LOGICAL type. */
5810 match_case_selector (gfc_case
**cp
)
5815 c
= gfc_get_case ();
5816 c
->where
= gfc_current_locus
;
5818 if (gfc_match_char (':') == MATCH_YES
)
5820 m
= gfc_match_init_expr (&c
->high
);
5823 if (m
== MATCH_ERROR
)
5826 if (c
->high
->ts
.type
!= BT_LOGICAL
&& c
->high
->ts
.type
!= BT_INTEGER
5827 && c
->high
->ts
.type
!= BT_CHARACTER
)
5829 gfc_error ("Expression in CASE selector at %L cannot be %s",
5830 &c
->high
->where
, gfc_typename (&c
->high
->ts
));
5836 m
= gfc_match_init_expr (&c
->low
);
5837 if (m
== MATCH_ERROR
)
5842 if (c
->low
->ts
.type
!= BT_LOGICAL
&& c
->low
->ts
.type
!= BT_INTEGER
5843 && c
->low
->ts
.type
!= BT_CHARACTER
)
5845 gfc_error ("Expression in CASE selector at %L cannot be %s",
5846 &c
->low
->where
, gfc_typename (&c
->low
->ts
));
5850 /* If we're not looking at a ':' now, make a range out of a single
5851 target. Else get the upper bound for the case range. */
5852 if (gfc_match_char (':') != MATCH_YES
)
5856 m
= gfc_match_init_expr (&c
->high
);
5857 if (m
== MATCH_ERROR
)
5859 /* MATCH_NO is fine. It's OK if nothing is there! */
5867 gfc_error ("Expected initialization expression in CASE at %C");
5875 /* Match the end of a case statement. */
5878 match_case_eos (void)
5880 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5883 if (gfc_match_eos () == MATCH_YES
)
5886 /* If the case construct doesn't have a case-construct-name, we
5887 should have matched the EOS. */
5888 if (!gfc_current_block ())
5891 gfc_gobble_whitespace ();
5893 m
= gfc_match_name (name
);
5897 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5899 gfc_error ("Expected block name %qs of SELECT construct at %C",
5900 gfc_current_block ()->name
);
5904 return gfc_match_eos ();
5908 /* Match a SELECT statement. */
5911 gfc_match_select (void)
5916 m
= gfc_match_label ();
5917 if (m
== MATCH_ERROR
)
5920 m
= gfc_match (" select case ( %e )%t", &expr
);
5924 new_st
.op
= EXEC_SELECT
;
5925 new_st
.expr1
= expr
;
5931 /* Transfer the selector typespec to the associate name. */
5934 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
)
5937 gfc_symbol
*assoc_sym
;
5939 assoc_sym
= associate
->symtree
->n
.sym
;
5941 /* At this stage the expression rank and arrayspec dimensions have
5942 not been completely sorted out. We must get the expr2->rank
5943 right here, so that the correct class container is obtained. */
5944 ref
= selector
->ref
;
5945 while (ref
&& ref
->next
)
5948 if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
5949 && ref
&& ref
->type
== REF_ARRAY
)
5951 /* Ensure that the array reference type is set. We cannot use
5952 gfc_resolve_expr at this point, so the usable parts of
5953 resolve.c(resolve_array_ref) are employed to do it. */
5954 if (ref
->u
.ar
.type
== AR_UNKNOWN
)
5956 ref
->u
.ar
.type
= AR_ELEMENT
;
5957 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
5958 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5959 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
5960 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
5961 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
5963 ref
->u
.ar
.type
= AR_SECTION
;
5968 if (ref
->u
.ar
.type
== AR_FULL
)
5969 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
5970 else if (ref
->u
.ar
.type
== AR_SECTION
)
5971 selector
->rank
= ref
->u
.ar
.dimen
;
5978 assoc_sym
->attr
.dimension
= 1;
5979 assoc_sym
->as
= gfc_get_array_spec ();
5980 assoc_sym
->as
->rank
= selector
->rank
;
5981 assoc_sym
->as
->type
= AS_DEFERRED
;
5984 assoc_sym
->as
= NULL
;
5986 if (selector
->ts
.type
== BT_CLASS
)
5988 /* The correct class container has to be available. */
5989 assoc_sym
->ts
.type
= BT_CLASS
;
5990 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
5991 assoc_sym
->attr
.pointer
= 1;
5992 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
5997 /* Push the current selector onto the SELECT TYPE stack. */
6000 select_type_push (gfc_symbol
*sel
)
6002 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
6003 top
->selector
= sel
;
6005 top
->prev
= select_type_stack
;
6007 select_type_stack
= top
;
6011 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
6013 static gfc_symtree
*
6014 select_intrinsic_set_tmp (gfc_typespec
*ts
)
6016 char name
[GFC_MAX_SYMBOL_LEN
];
6018 HOST_WIDE_INT charlen
= 0;
6020 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
6023 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
6024 && !select_type_stack
->selector
->attr
.class_ok
)
6027 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
6028 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6029 charlen
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
6031 if (ts
->type
!= BT_CHARACTER
)
6032 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
6035 snprintf (name
, sizeof (name
), "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
6036 gfc_basic_typename (ts
->type
), charlen
, ts
->kind
);
6038 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6039 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
6041 /* Copy across the array spec to the selector. */
6042 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
6043 && (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
6044 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
))
6046 tmp
->n
.sym
->attr
.pointer
= 1;
6047 tmp
->n
.sym
->attr
.dimension
6048 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
6049 tmp
->n
.sym
->attr
.codimension
6050 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
6052 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
6055 gfc_set_sym_referenced (tmp
->n
.sym
);
6056 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
6057 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
6063 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
6066 select_type_set_tmp (gfc_typespec
*ts
)
6068 char name
[GFC_MAX_SYMBOL_LEN
];
6069 gfc_symtree
*tmp
= NULL
;
6073 select_type_stack
->tmp
= NULL
;
6077 tmp
= select_intrinsic_set_tmp (ts
);
6084 if (ts
->type
== BT_CLASS
)
6085 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
6087 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
6088 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6089 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
6091 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
6092 && select_type_stack
->selector
->attr
.class_ok
)
6094 tmp
->n
.sym
->attr
.pointer
6095 = CLASS_DATA (select_type_stack
->selector
)->attr
.class_pointer
;
6097 /* Copy across the array spec to the selector. */
6098 if (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
6099 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
)
6101 tmp
->n
.sym
->attr
.dimension
6102 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
6103 tmp
->n
.sym
->attr
.codimension
6104 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
6106 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
6110 gfc_set_sym_referenced (tmp
->n
.sym
);
6111 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
6112 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
6114 if (ts
->type
== BT_CLASS
)
6115 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
6119 /* Add an association for it, so the rest of the parser knows it is
6120 an associate-name. The target will be set during resolution. */
6121 tmp
->n
.sym
->assoc
= gfc_get_association_list ();
6122 tmp
->n
.sym
->assoc
->dangling
= 1;
6123 tmp
->n
.sym
->assoc
->st
= tmp
;
6125 select_type_stack
->tmp
= tmp
;
6129 /* Match a SELECT TYPE statement. */
6132 gfc_match_select_type (void)
6134 gfc_expr
*expr1
, *expr2
= NULL
;
6136 char name
[GFC_MAX_SYMBOL_LEN
];
6139 gfc_namespace
*ns
= gfc_current_ns
;
6141 m
= gfc_match_label ();
6142 if (m
== MATCH_ERROR
)
6145 m
= gfc_match (" select type ( ");
6149 gfc_current_ns
= gfc_build_block_ns (ns
);
6150 m
= gfc_match (" %n => %e", name
, &expr2
);
6153 expr1
= gfc_get_expr ();
6154 expr1
->expr_type
= EXPR_VARIABLE
;
6155 expr1
->where
= expr2
->where
;
6156 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
6162 sym
= expr1
->symtree
->n
.sym
;
6163 if (expr2
->ts
.type
== BT_UNKNOWN
)
6164 sym
->attr
.untyped
= 1;
6166 copy_ts_from_selector_to_associate (expr1
, expr2
);
6168 sym
->attr
.flavor
= FL_VARIABLE
;
6169 sym
->attr
.referenced
= 1;
6170 sym
->attr
.class_ok
= 1;
6174 m
= gfc_match (" %e ", &expr1
);
6177 std::swap (ns
, gfc_current_ns
);
6178 gfc_free_namespace (ns
);
6183 m
= gfc_match (" )%t");
6186 gfc_error ("parse error in SELECT TYPE statement at %C");
6190 /* This ghastly expression seems to be needed to distinguish a CLASS
6191 array, which can have a reference, from other expressions that
6192 have references, such as derived type components, and are not
6193 allowed by the standard.
6194 TODO: see if it is sufficient to exclude component and substring
6196 class_array
= (expr1
->expr_type
== EXPR_VARIABLE
6197 && expr1
->ts
.type
== BT_CLASS
6198 && CLASS_DATA (expr1
)
6199 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
6200 && (CLASS_DATA (expr1
)->attr
.dimension
6201 || CLASS_DATA (expr1
)->attr
.codimension
)
6203 && expr1
->ref
->type
== REF_ARRAY
6204 && expr1
->ref
->u
.ar
.type
== AR_FULL
6205 && expr1
->ref
->next
== NULL
);
6207 /* Check for F03:C811 (F08:C835). */
6208 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
6209 || (!class_array
&& expr1
->ref
!= NULL
)))
6211 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
6212 "use associate-name=>");
6217 new_st
.op
= EXEC_SELECT_TYPE
;
6218 new_st
.expr1
= expr1
;
6219 new_st
.expr2
= expr2
;
6220 new_st
.ext
.block
.ns
= gfc_current_ns
;
6222 select_type_push (expr1
->symtree
->n
.sym
);
6223 gfc_current_ns
= ns
;
6228 gfc_free_expr (expr1
);
6229 gfc_free_expr (expr2
);
6230 gfc_undo_symbols ();
6231 std::swap (ns
, gfc_current_ns
);
6232 gfc_free_namespace (ns
);
6237 /* Match a CASE statement. */
6240 gfc_match_case (void)
6242 gfc_case
*c
, *head
, *tail
;
6247 if (gfc_current_state () != COMP_SELECT
)
6249 gfc_error ("Unexpected CASE statement at %C");
6253 if (gfc_match ("% default") == MATCH_YES
)
6255 m
= match_case_eos ();
6258 if (m
== MATCH_ERROR
)
6261 new_st
.op
= EXEC_SELECT
;
6262 c
= gfc_get_case ();
6263 c
->where
= gfc_current_locus
;
6264 new_st
.ext
.block
.case_list
= c
;
6268 if (gfc_match_char ('(') != MATCH_YES
)
6273 if (match_case_selector (&c
) == MATCH_ERROR
)
6283 if (gfc_match_char (')') == MATCH_YES
)
6285 if (gfc_match_char (',') != MATCH_YES
)
6289 m
= match_case_eos ();
6292 if (m
== MATCH_ERROR
)
6295 new_st
.op
= EXEC_SELECT
;
6296 new_st
.ext
.block
.case_list
= head
;
6301 gfc_error ("Syntax error in CASE specification at %C");
6304 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
6309 /* Match a TYPE IS statement. */
6312 gfc_match_type_is (void)
6317 if (gfc_current_state () != COMP_SELECT_TYPE
)
6319 gfc_error ("Unexpected TYPE IS statement at %C");
6323 if (gfc_match_char ('(') != MATCH_YES
)
6326 c
= gfc_get_case ();
6327 c
->where
= gfc_current_locus
;
6329 m
= gfc_match_type_spec (&c
->ts
);
6332 if (m
== MATCH_ERROR
)
6335 if (gfc_match_char (')') != MATCH_YES
)
6338 m
= match_case_eos ();
6341 if (m
== MATCH_ERROR
)
6344 new_st
.op
= EXEC_SELECT_TYPE
;
6345 new_st
.ext
.block
.case_list
= c
;
6347 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
6348 && (c
->ts
.u
.derived
->attr
.sequence
6349 || c
->ts
.u
.derived
->attr
.is_bind_c
))
6351 gfc_error ("The type-spec shall not specify a sequence derived "
6352 "type or a type with the BIND attribute in SELECT "
6353 "TYPE at %C [F2003:C815]");
6357 if (c
->ts
.type
== BT_DERIVED
6358 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
6359 && gfc_spec_list_type (type_param_spec_list
, c
->ts
.u
.derived
)
6362 gfc_error ("All the LEN type parameters in the TYPE IS statement "
6363 "at %C must be ASSUMED");
6367 /* Create temporary variable. */
6368 select_type_set_tmp (&c
->ts
);
6373 gfc_error ("Syntax error in TYPE IS specification at %C");
6377 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6382 /* Match a CLASS IS or CLASS DEFAULT statement. */
6385 gfc_match_class_is (void)
6390 if (gfc_current_state () != COMP_SELECT_TYPE
)
6393 if (gfc_match ("% default") == MATCH_YES
)
6395 m
= match_case_eos ();
6398 if (m
== MATCH_ERROR
)
6401 new_st
.op
= EXEC_SELECT_TYPE
;
6402 c
= gfc_get_case ();
6403 c
->where
= gfc_current_locus
;
6404 c
->ts
.type
= BT_UNKNOWN
;
6405 new_st
.ext
.block
.case_list
= c
;
6406 select_type_set_tmp (NULL
);
6410 m
= gfc_match ("% is");
6413 if (m
== MATCH_ERROR
)
6416 if (gfc_match_char ('(') != MATCH_YES
)
6419 c
= gfc_get_case ();
6420 c
->where
= gfc_current_locus
;
6422 m
= match_derived_type_spec (&c
->ts
);
6425 if (m
== MATCH_ERROR
)
6428 if (c
->ts
.type
== BT_DERIVED
)
6429 c
->ts
.type
= BT_CLASS
;
6431 if (gfc_match_char (')') != MATCH_YES
)
6434 m
= match_case_eos ();
6437 if (m
== MATCH_ERROR
)
6440 new_st
.op
= EXEC_SELECT_TYPE
;
6441 new_st
.ext
.block
.case_list
= c
;
6443 /* Create temporary variable. */
6444 select_type_set_tmp (&c
->ts
);
6449 gfc_error ("Syntax error in CLASS IS specification at %C");
6453 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6458 /********************* WHERE subroutines ********************/
6460 /* Match the rest of a simple WHERE statement that follows an IF statement.
6464 match_simple_where (void)
6470 m
= gfc_match (" ( %e )", &expr
);
6474 m
= gfc_match_assignment ();
6477 if (m
== MATCH_ERROR
)
6480 if (gfc_match_eos () != MATCH_YES
)
6483 c
= gfc_get_code (EXEC_WHERE
);
6486 c
->next
= XCNEW (gfc_code
);
6488 c
->next
->loc
= gfc_current_locus
;
6489 gfc_clear_new_st ();
6491 new_st
.op
= EXEC_WHERE
;
6497 gfc_syntax_error (ST_WHERE
);
6500 gfc_free_expr (expr
);
6505 /* Match a WHERE statement. */
6508 gfc_match_where (gfc_statement
*st
)
6514 m0
= gfc_match_label ();
6515 if (m0
== MATCH_ERROR
)
6518 m
= gfc_match (" where ( %e )", &expr
);
6522 if (gfc_match_eos () == MATCH_YES
)
6524 *st
= ST_WHERE_BLOCK
;
6525 new_st
.op
= EXEC_WHERE
;
6526 new_st
.expr1
= expr
;
6530 m
= gfc_match_assignment ();
6532 gfc_syntax_error (ST_WHERE
);
6536 gfc_free_expr (expr
);
6540 /* We've got a simple WHERE statement. */
6542 c
= gfc_get_code (EXEC_WHERE
);
6545 /* Put in the assignment. It will not be processed by add_statement, so we
6546 need to copy the location here. */
6548 c
->next
= XCNEW (gfc_code
);
6550 c
->next
->loc
= gfc_current_locus
;
6551 gfc_clear_new_st ();
6553 new_st
.op
= EXEC_WHERE
;
6560 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
6561 new_st if successful. */
6564 gfc_match_elsewhere (void)
6566 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6570 if (gfc_current_state () != COMP_WHERE
)
6572 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
6578 if (gfc_match_char ('(') == MATCH_YES
)
6580 m
= gfc_match_expr (&expr
);
6583 if (m
== MATCH_ERROR
)
6586 if (gfc_match_char (')') != MATCH_YES
)
6590 if (gfc_match_eos () != MATCH_YES
)
6592 /* Only makes sense if we have a where-construct-name. */
6593 if (!gfc_current_block ())
6598 /* Better be a name at this point. */
6599 m
= gfc_match_name (name
);
6602 if (m
== MATCH_ERROR
)
6605 if (gfc_match_eos () != MATCH_YES
)
6608 if (strcmp (name
, gfc_current_block ()->name
) != 0)
6610 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
6611 name
, gfc_current_block ()->name
);
6616 new_st
.op
= EXEC_WHERE
;
6617 new_st
.expr1
= expr
;
6621 gfc_syntax_error (ST_ELSEWHERE
);
6624 gfc_free_expr (expr
);