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 name
[GFC_MAX_SYMBOL_LEN
+ 1];
2060 gfc_gobble_whitespace ();
2061 old_locus
= gfc_current_locus
;
2062 type_param_spec_list
= NULL
;
2064 if (match_derived_type_spec (ts
) == MATCH_YES
)
2066 /* Enforce F03:C401. */
2067 if (ts
->u
.derived
->attr
.abstract
)
2069 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
2070 ts
->u
.derived
->name
, &old_locus
);
2076 if (gfc_match ("integer") == MATCH_YES
)
2078 ts
->type
= BT_INTEGER
;
2079 ts
->kind
= gfc_default_integer_kind
;
2083 if (gfc_match ("double precision") == MATCH_YES
)
2086 ts
->kind
= gfc_default_double_kind
;
2090 if (gfc_match ("complex") == MATCH_YES
)
2092 ts
->type
= BT_COMPLEX
;
2093 ts
->kind
= gfc_default_complex_kind
;
2097 if (gfc_match ("character") == MATCH_YES
)
2099 ts
->type
= BT_CHARACTER
;
2101 m
= gfc_match_char_spec (ts
);
2109 /* REAL is a real pain because it can be a type, intrinsic subprogram,
2110 or list item in a type-list of an OpenMP reduction clause. Need to
2111 differentiate REAL([KIND]=scalar-int-initialization-expr) from
2112 REAL(A,[KIND]) and REAL(KIND,A). Logically, when this code was
2113 written the use of LOGICAL as a type-spec or intrinsic subprogram
2116 m
= gfc_match (" %n", name
);
2118 && (strcmp (name
, "real") == 0 || strcmp (name
, "logical") == 0))
2127 ts
->kind
= gfc_default_real_kind
;
2131 ts
->type
= BT_LOGICAL
;
2132 ts
->kind
= gfc_default_logical_kind
;
2135 gfc_gobble_whitespace ();
2137 /* Prevent REAL*4, etc. */
2138 c
= gfc_peek_ascii_char ();
2141 gfc_error ("Invalid type-spec at %C");
2145 /* Found leading colon in REAL::, a trailing ')' in for example
2146 TYPE IS (REAL), or REAL, for an OpenMP list-item. */
2147 if (c
== ':' || c
== ')' || (flag_openmp
&& c
== ','))
2150 /* Found something other than the opening '(' in REAL(... */
2154 gfc_next_char (); /* Burn the '('. */
2156 /* Look for the optional KIND=. */
2157 where
= gfc_current_locus
;
2158 m
= gfc_match ("%n", name
);
2161 gfc_gobble_whitespace ();
2162 c
= gfc_next_char ();
2165 if (strcmp(name
, "a") == 0 || strcmp(name
, "l") == 0)
2167 else if (strcmp(name
, "kind") == 0)
2173 gfc_current_locus
= where
;
2176 gfc_current_locus
= where
;
2180 m
= gfc_match_init_expr (&e
);
2181 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
2184 /* If a comma appears, it is an intrinsic subprogram. */
2185 gfc_gobble_whitespace ();
2186 c
= gfc_peek_ascii_char ();
2193 /* If ')' appears, we have REAL(initialization-expr), here check for
2194 a scalar integer initialization-expr and valid kind parameter. */
2197 if (e
->ts
.type
!= BT_INTEGER
|| e
->rank
> 0)
2203 gfc_next_char (); /* Burn the ')'. */
2204 ts
->kind
= (int) mpz_get_si (e
->value
.integer
);
2205 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
2207 gfc_error ("Invalid type-spec at %C");
2217 /* If a type is not matched, simply return MATCH_NO. */
2218 gfc_current_locus
= old_locus
;
2223 gfc_gobble_whitespace ();
2225 /* This prevents INTEGER*4, etc. */
2226 if (gfc_peek_ascii_char () == '*')
2228 gfc_error ("Invalid type-spec at %C");
2232 m
= gfc_match_kind_spec (ts
, false);
2234 /* No kind specifier found. */
2242 /******************** FORALL subroutines ********************/
2244 /* Free a list of FORALL iterators. */
2247 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
2249 gfc_forall_iterator
*next
;
2254 gfc_free_expr (iter
->var
);
2255 gfc_free_expr (iter
->start
);
2256 gfc_free_expr (iter
->end
);
2257 gfc_free_expr (iter
->stride
);
2264 /* Match an iterator as part of a FORALL statement. The format is:
2266 <var> = <start>:<end>[:<stride>]
2268 On MATCH_NO, the caller tests for the possibility that there is a
2269 scalar mask expression. */
2272 match_forall_iterator (gfc_forall_iterator
**result
)
2274 gfc_forall_iterator
*iter
;
2278 where
= gfc_current_locus
;
2279 iter
= XCNEW (gfc_forall_iterator
);
2281 m
= gfc_match_expr (&iter
->var
);
2285 if (gfc_match_char ('=') != MATCH_YES
2286 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
2292 m
= gfc_match_expr (&iter
->start
);
2296 if (gfc_match_char (':') != MATCH_YES
)
2299 m
= gfc_match_expr (&iter
->end
);
2302 if (m
== MATCH_ERROR
)
2305 if (gfc_match_char (':') == MATCH_NO
)
2306 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2309 m
= gfc_match_expr (&iter
->stride
);
2312 if (m
== MATCH_ERROR
)
2316 /* Mark the iteration variable's symbol as used as a FORALL index. */
2317 iter
->var
->symtree
->n
.sym
->forall_index
= true;
2323 gfc_error ("Syntax error in FORALL iterator at %C");
2328 gfc_current_locus
= where
;
2329 gfc_free_forall_iterator (iter
);
2334 /* Match the header of a FORALL statement. */
2337 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
2339 gfc_forall_iterator
*head
, *tail
, *new_iter
;
2343 gfc_gobble_whitespace ();
2348 if (gfc_match_char ('(') != MATCH_YES
)
2351 m
= match_forall_iterator (&new_iter
);
2352 if (m
== MATCH_ERROR
)
2357 head
= tail
= new_iter
;
2361 if (gfc_match_char (',') != MATCH_YES
)
2364 m
= match_forall_iterator (&new_iter
);
2365 if (m
== MATCH_ERROR
)
2370 tail
->next
= new_iter
;
2375 /* Have to have a mask expression. */
2377 m
= gfc_match_expr (&msk
);
2380 if (m
== MATCH_ERROR
)
2386 if (gfc_match_char (')') == MATCH_NO
)
2394 gfc_syntax_error (ST_FORALL
);
2397 gfc_free_expr (msk
);
2398 gfc_free_forall_iterator (head
);
2403 /* Match the rest of a simple FORALL statement that follows an
2407 match_simple_forall (void)
2409 gfc_forall_iterator
*head
;
2418 m
= match_forall_header (&head
, &mask
);
2425 m
= gfc_match_assignment ();
2427 if (m
== MATCH_ERROR
)
2431 m
= gfc_match_pointer_assignment ();
2432 if (m
== MATCH_ERROR
)
2438 c
= XCNEW (gfc_code
);
2440 c
->loc
= gfc_current_locus
;
2442 if (gfc_match_eos () != MATCH_YES
)
2445 gfc_clear_new_st ();
2446 new_st
.op
= EXEC_FORALL
;
2447 new_st
.expr1
= mask
;
2448 new_st
.ext
.forall_iterator
= head
;
2449 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2450 new_st
.block
->next
= c
;
2455 gfc_syntax_error (ST_FORALL
);
2458 gfc_free_forall_iterator (head
);
2459 gfc_free_expr (mask
);
2465 /* Match a FORALL statement. */
2468 gfc_match_forall (gfc_statement
*st
)
2470 gfc_forall_iterator
*head
;
2479 m0
= gfc_match_label ();
2480 if (m0
== MATCH_ERROR
)
2483 m
= gfc_match (" forall");
2487 m
= match_forall_header (&head
, &mask
);
2488 if (m
== MATCH_ERROR
)
2493 if (gfc_match_eos () == MATCH_YES
)
2495 *st
= ST_FORALL_BLOCK
;
2496 new_st
.op
= EXEC_FORALL
;
2497 new_st
.expr1
= mask
;
2498 new_st
.ext
.forall_iterator
= head
;
2502 m
= gfc_match_assignment ();
2503 if (m
== MATCH_ERROR
)
2507 m
= gfc_match_pointer_assignment ();
2508 if (m
== MATCH_ERROR
)
2514 c
= XCNEW (gfc_code
);
2516 c
->loc
= gfc_current_locus
;
2518 gfc_clear_new_st ();
2519 new_st
.op
= EXEC_FORALL
;
2520 new_st
.expr1
= mask
;
2521 new_st
.ext
.forall_iterator
= head
;
2522 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2523 new_st
.block
->next
= c
;
2529 gfc_syntax_error (ST_FORALL
);
2532 gfc_free_forall_iterator (head
);
2533 gfc_free_expr (mask
);
2534 gfc_free_statements (c
);
2539 /* Match a DO statement. */
2544 gfc_iterator iter
, *ip
;
2546 gfc_st_label
*label
;
2549 old_loc
= gfc_current_locus
;
2551 memset (&iter
, '\0', sizeof (gfc_iterator
));
2554 m
= gfc_match_label ();
2555 if (m
== MATCH_ERROR
)
2558 if (gfc_match (" do") != MATCH_YES
)
2561 m
= gfc_match_st_label (&label
);
2562 if (m
== MATCH_ERROR
)
2565 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2567 if (gfc_match_eos () == MATCH_YES
)
2569 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
2570 new_st
.op
= EXEC_DO_WHILE
;
2574 /* Match an optional comma, if no comma is found, a space is obligatory. */
2575 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
2578 /* Check for balanced parens. */
2580 if (gfc_match_parens () == MATCH_ERROR
)
2583 if (gfc_match (" concurrent") == MATCH_YES
)
2585 gfc_forall_iterator
*head
;
2588 if (!gfc_notify_std (GFC_STD_F2008
, "DO CONCURRENT construct at %C"))
2594 m
= match_forall_header (&head
, &mask
);
2598 if (m
== MATCH_ERROR
)
2599 goto concurr_cleanup
;
2601 if (gfc_match_eos () != MATCH_YES
)
2602 goto concurr_cleanup
;
2605 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2606 goto concurr_cleanup
;
2608 new_st
.label1
= label
;
2609 new_st
.op
= EXEC_DO_CONCURRENT
;
2610 new_st
.expr1
= mask
;
2611 new_st
.ext
.forall_iterator
= head
;
2616 gfc_syntax_error (ST_DO
);
2617 gfc_free_expr (mask
);
2618 gfc_free_forall_iterator (head
);
2622 /* See if we have a DO WHILE. */
2623 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
2625 new_st
.op
= EXEC_DO_WHILE
;
2629 /* The abortive DO WHILE may have done something to the symbol
2630 table, so we start over. */
2631 gfc_undo_symbols ();
2632 gfc_current_locus
= old_loc
;
2634 gfc_match_label (); /* This won't error. */
2635 gfc_match (" do "); /* This will work. */
2637 gfc_match_st_label (&label
); /* Can't error out. */
2638 gfc_match_char (','); /* Optional comma. */
2640 m
= gfc_match_iterator (&iter
, 0);
2643 if (m
== MATCH_ERROR
)
2646 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
2647 gfc_check_do_variable (iter
.var
->symtree
);
2649 if (gfc_match_eos () != MATCH_YES
)
2651 gfc_syntax_error (ST_DO
);
2655 new_st
.op
= EXEC_DO
;
2659 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2662 new_st
.label1
= label
;
2664 if (new_st
.op
== EXEC_DO_WHILE
)
2665 new_st
.expr1
= iter
.end
;
2668 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
2675 gfc_free_iterator (&iter
, 0);
2681 /* Match an EXIT or CYCLE statement. */
2684 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2686 gfc_state_data
*p
, *o
;
2691 if (gfc_match_eos () == MATCH_YES
)
2695 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2698 m
= gfc_match ("% %n%t", name
);
2699 if (m
== MATCH_ERROR
)
2703 gfc_syntax_error (st
);
2707 /* Find the corresponding symbol. If there's a BLOCK statement
2708 between here and the label, it is not in gfc_current_ns but a parent
2710 stree
= gfc_find_symtree_in_proc (name
, gfc_current_ns
);
2713 gfc_error ("Name %qs in %s statement at %C is unknown",
2714 name
, gfc_ascii_statement (st
));
2719 if (sym
->attr
.flavor
!= FL_LABEL
)
2721 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2722 name
, gfc_ascii_statement (st
));
2727 /* Find the loop specified by the label (or lack of a label). */
2728 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2729 if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2731 else if (p
->state
== COMP_CRITICAL
)
2733 gfc_error("%s statement at %C leaves CRITICAL construct",
2734 gfc_ascii_statement (st
));
2737 else if (p
->state
== COMP_DO_CONCURRENT
2738 && (op
== EXEC_EXIT
|| (sym
&& sym
!= p
->sym
)))
2740 /* F2008, C821 & C845. */
2741 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2742 gfc_ascii_statement (st
));
2745 else if ((sym
&& sym
== p
->sym
)
2746 || (!sym
&& (p
->state
== COMP_DO
2747 || p
->state
== COMP_DO_CONCURRENT
)))
2753 gfc_error ("%s statement at %C is not within a construct",
2754 gfc_ascii_statement (st
));
2756 gfc_error ("%s statement at %C is not within construct %qs",
2757 gfc_ascii_statement (st
), sym
->name
);
2762 /* Special checks for EXIT from non-loop constructs. */
2766 case COMP_DO_CONCURRENT
:
2770 /* This is already handled above. */
2773 case COMP_ASSOCIATE
:
2777 case COMP_SELECT_TYPE
:
2779 if (op
== EXEC_CYCLE
)
2781 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2782 " construct %qs", sym
->name
);
2785 gcc_assert (op
== EXEC_EXIT
);
2786 if (!gfc_notify_std (GFC_STD_F2008
, "EXIT statement with no"
2787 " do-construct-name at %C"))
2792 gfc_error ("%s statement at %C is not applicable to construct %qs",
2793 gfc_ascii_statement (st
), sym
->name
);
2799 gfc_error (is_oacc (p
)
2800 ? G_("%s statement at %C leaving OpenACC structured block")
2801 : G_("%s statement at %C leaving OpenMP structured block"),
2802 gfc_ascii_statement (st
));
2806 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2810 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
2811 && (o
->head
->op
== EXEC_OACC_LOOP
2812 || o
->head
->op
== EXEC_OACC_PARALLEL_LOOP
))
2815 gcc_assert (o
->head
->next
!= NULL
2816 && (o
->head
->next
->op
== EXEC_DO
2817 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2818 && o
->previous
!= NULL
2819 && o
->previous
->tail
->op
== o
->head
->op
);
2820 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2821 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2822 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2823 if (st
== ST_EXIT
&& cnt
<= collapse
)
2825 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2828 if (st
== ST_CYCLE
&& cnt
< collapse
)
2830 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2831 " !$ACC LOOP loop");
2837 && (o
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2838 && (o
->head
->op
== EXEC_OMP_DO
2839 || o
->head
->op
== EXEC_OMP_PARALLEL_DO
2840 || o
->head
->op
== EXEC_OMP_SIMD
2841 || o
->head
->op
== EXEC_OMP_DO_SIMD
2842 || o
->head
->op
== EXEC_OMP_PARALLEL_DO_SIMD
))
2845 gcc_assert (o
->head
->next
!= NULL
2846 && (o
->head
->next
->op
== EXEC_DO
2847 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2848 && o
->previous
!= NULL
2849 && o
->previous
->tail
->op
== o
->head
->op
);
2850 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
)
2852 if (o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2853 count
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2854 if (o
->previous
->tail
->ext
.omp_clauses
->orderedc
)
2855 count
= o
->previous
->tail
->ext
.omp_clauses
->orderedc
;
2857 if (st
== ST_EXIT
&& cnt
<= count
)
2859 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2862 if (st
== ST_CYCLE
&& cnt
< count
)
2864 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2870 /* Save the first statement in the construct - needed by the backend. */
2871 new_st
.ext
.which_construct
= p
->construct
;
2879 /* Match the EXIT statement. */
2882 gfc_match_exit (void)
2884 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2888 /* Match the CYCLE statement. */
2891 gfc_match_cycle (void)
2893 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2897 /* Match a stop-code after an (ERROR) STOP or PAUSE statement. The
2898 requirements for a stop-code differ in the standards.
2902 R840 stop-stmt is STOP [ stop-code ]
2903 R841 stop-code is scalar-char-constant
2904 or digit [ digit [ digit [ digit [ digit ] ] ] ]
2906 Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
2909 R855 stop-stmt is STOP [ stop-code ]
2910 R856 allstop-stmt is ALL STOP [ stop-code ]
2911 R857 stop-code is scalar-default-char-constant-expr
2912 or scalar-int-constant-expr
2914 For free-form source code, all standards contain a statement of the form:
2916 A blank shall be used to separate names, constants, or labels from
2917 adjacent keywords, names, constants, or labels.
2919 A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003,
2923 is valid, but it is invalid Fortran 2008. */
2926 gfc_match_stopcode (gfc_statement st
)
2932 /* Set f95 for -std=f95. */
2933 f95
= gfc_option
.allow_std
== (GFC_STD_F95_OBS
| GFC_STD_F95
| GFC_STD_F77
2934 | GFC_STD_F2008_OBS
);
2936 /* Set f03 for -std=f2003. */
2937 f03
= gfc_option
.allow_std
== (GFC_STD_F95_OBS
| GFC_STD_F95
| GFC_STD_F77
2938 | GFC_STD_F2008_OBS
| GFC_STD_F2003
);
2940 /* Look for a blank between STOP and the stop-code for F2008 or later. */
2941 if (gfc_current_form
!= FORM_FIXED
&& !(f95
|| f03
))
2943 char c
= gfc_peek_ascii_char ();
2945 /* Look for end-of-statement. There is no stop-code. */
2946 if (c
== '\n' || c
== '!' || c
== ';')
2951 gfc_error ("Blank required in %s statement near %C",
2952 gfc_ascii_statement (st
));
2957 if (gfc_match_eos () != MATCH_YES
)
2962 /* First look for the F95 or F2003 digit [...] construct. */
2963 old_locus
= gfc_current_locus
;
2964 m
= gfc_match_small_int (&stopcode
);
2965 if (m
== MATCH_YES
&& (f95
|| f03
))
2969 gfc_error ("STOP code at %C cannot be negative");
2973 if (stopcode
> 99999)
2975 gfc_error ("STOP code at %C contains too many digits");
2980 /* Reset the locus and now load gfc_expr. */
2981 gfc_current_locus
= old_locus
;
2982 m
= gfc_match_expr (&e
);
2983 if (m
== MATCH_ERROR
)
2988 if (gfc_match_eos () != MATCH_YES
)
2992 if (gfc_pure (NULL
))
2994 if (st
== ST_ERROR_STOP
)
2996 if (!gfc_notify_std (GFC_STD_F2018
, "%s statement at %C in PURE "
2997 "procedure", gfc_ascii_statement (st
)))
3002 gfc_error ("%s statement not allowed in PURE procedure at %C",
3003 gfc_ascii_statement (st
));
3008 gfc_unset_implicit_pure (NULL
);
3010 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
))
3012 gfc_error ("Image control statement STOP at %C in CRITICAL block");
3015 if (st
== ST_STOP
&& gfc_find_state (COMP_DO_CONCURRENT
))
3017 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
3023 gfc_simplify_expr (e
, 0);
3025 /* Test for F95 and F2003 style STOP stop-code. */
3026 if (e
->expr_type
!= EXPR_CONSTANT
&& (f95
|| f03
))
3028 gfc_error ("STOP code at %L must be a scalar CHARACTER constant or "
3029 "digit[digit[digit[digit[digit]]]]", &e
->where
);
3033 /* Use the machinery for an initialization expression to reduce the
3034 stop-code to a constant. */
3035 gfc_init_expr_flag
= true;
3036 gfc_reduce_init_expr (e
);
3037 gfc_init_expr_flag
= false;
3039 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
3041 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
3048 gfc_error ("STOP code at %L must be scalar", &e
->where
);
3052 if (e
->ts
.type
== BT_CHARACTER
3053 && e
->ts
.kind
!= gfc_default_character_kind
)
3055 gfc_error ("STOP code at %L must be default character KIND=%d",
3056 &e
->where
, (int) gfc_default_character_kind
);
3060 if (e
->ts
.type
== BT_INTEGER
&& e
->ts
.kind
!= gfc_default_integer_kind
)
3062 gfc_error ("STOP code at %L must be default integer KIND=%d",
3063 &e
->where
, (int) gfc_default_integer_kind
);
3073 new_st
.op
= EXEC_STOP
;
3076 new_st
.op
= EXEC_ERROR_STOP
;
3079 new_st
.op
= EXEC_PAUSE
;
3086 new_st
.ext
.stop_code
= -1;
3091 gfc_syntax_error (st
);
3100 /* Match the (deprecated) PAUSE statement. */
3103 gfc_match_pause (void)
3107 m
= gfc_match_stopcode (ST_PAUSE
);
3110 if (!gfc_notify_std (GFC_STD_F95_DEL
, "PAUSE statement at %C"))
3117 /* Match the STOP statement. */
3120 gfc_match_stop (void)
3122 return gfc_match_stopcode (ST_STOP
);
3126 /* Match the ERROR STOP statement. */
3129 gfc_match_error_stop (void)
3131 if (!gfc_notify_std (GFC_STD_F2008
, "ERROR STOP statement at %C"))
3134 return gfc_match_stopcode (ST_ERROR_STOP
);
3137 /* Match EVENT POST/WAIT statement. Syntax:
3138 EVENT POST ( event-variable [, sync-stat-list] )
3139 EVENT WAIT ( event-variable [, wait-spec-list] )
3141 wait-spec-list is sync-stat-list or until-spec
3142 until-spec is UNTIL_COUNT = scalar-int-expr
3143 sync-stat is STAT= or ERRMSG=. */
3146 event_statement (gfc_statement st
)
3149 gfc_expr
*tmp
, *eventvar
, *until_count
, *stat
, *errmsg
;
3150 bool saw_until_count
, saw_stat
, saw_errmsg
;
3152 tmp
= eventvar
= until_count
= stat
= errmsg
= NULL
;
3153 saw_until_count
= saw_stat
= saw_errmsg
= false;
3155 if (gfc_pure (NULL
))
3157 gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
3158 st
== ST_EVENT_POST
? "POST" : "WAIT");
3162 gfc_unset_implicit_pure (NULL
);
3164 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3166 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3170 if (gfc_find_state (COMP_CRITICAL
))
3172 gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
3173 st
== ST_EVENT_POST
? "POST" : "WAIT");
3177 if (gfc_find_state (COMP_DO_CONCURRENT
))
3179 gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
3180 "block", st
== ST_EVENT_POST
? "POST" : "WAIT");
3184 if (gfc_match_char ('(') != MATCH_YES
)
3187 if (gfc_match ("%e", &eventvar
) != MATCH_YES
)
3189 m
= gfc_match_char (',');
3190 if (m
== MATCH_ERROR
)
3194 m
= gfc_match_char (')');
3202 m
= gfc_match (" stat = %v", &tmp
);
3203 if (m
== MATCH_ERROR
)
3209 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3215 m
= gfc_match_char (',');
3223 m
= gfc_match (" errmsg = %v", &tmp
);
3224 if (m
== MATCH_ERROR
)
3230 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3236 m
= gfc_match_char (',');
3244 m
= gfc_match (" until_count = %e", &tmp
);
3245 if (m
== MATCH_ERROR
|| st
== ST_EVENT_POST
)
3249 if (saw_until_count
)
3251 gfc_error ("Redundant UNTIL_COUNT tag found at %L",
3256 saw_until_count
= true;
3258 m
= gfc_match_char (',');
3269 if (m
== MATCH_ERROR
)
3272 if (gfc_match (" )%t") != MATCH_YES
)
3279 new_st
.op
= EXEC_EVENT_POST
;
3282 new_st
.op
= EXEC_EVENT_WAIT
;
3288 new_st
.expr1
= eventvar
;
3289 new_st
.expr2
= stat
;
3290 new_st
.expr3
= errmsg
;
3291 new_st
.expr4
= until_count
;
3296 gfc_syntax_error (st
);
3299 if (until_count
!= tmp
)
3300 gfc_free_expr (until_count
);
3302 gfc_free_expr (errmsg
);
3304 gfc_free_expr (stat
);
3306 gfc_free_expr (tmp
);
3307 gfc_free_expr (eventvar
);
3315 gfc_match_event_post (void)
3317 if (!gfc_notify_std (GFC_STD_F2008_TS
, "EVENT POST statement at %C"))
3320 return event_statement (ST_EVENT_POST
);
3325 gfc_match_event_wait (void)
3327 if (!gfc_notify_std (GFC_STD_F2008_TS
, "EVENT WAIT statement at %C"))
3330 return event_statement (ST_EVENT_WAIT
);
3334 /* Match a FAIL IMAGE statement. */
3337 gfc_match_fail_image (void)
3339 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FAIL IMAGE statement at %C"))
3342 if (gfc_match_char ('(') == MATCH_YES
)
3345 new_st
.op
= EXEC_FAIL_IMAGE
;
3350 gfc_syntax_error (ST_FAIL_IMAGE
);
3355 /* Match a FORM TEAM statement. */
3358 gfc_match_form_team (void)
3361 gfc_expr
*teamid
,*team
;
3363 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FORM TEAM statement at %C"))
3366 if (gfc_match_char ('(') == MATCH_NO
)
3369 new_st
.op
= EXEC_FORM_TEAM
;
3371 if (gfc_match ("%e", &teamid
) != MATCH_YES
)
3373 m
= gfc_match_char (',');
3374 if (m
== MATCH_ERROR
)
3376 if (gfc_match ("%e", &team
) != MATCH_YES
)
3379 m
= gfc_match_char (')');
3383 new_st
.expr1
= teamid
;
3384 new_st
.expr2
= team
;
3389 gfc_syntax_error (ST_FORM_TEAM
);
3394 /* Match a CHANGE TEAM statement. */
3397 gfc_match_change_team (void)
3402 if (!gfc_notify_std (GFC_STD_F2008_TS
, "CHANGE TEAM statement at %C"))
3405 if (gfc_match_char ('(') == MATCH_NO
)
3408 new_st
.op
= EXEC_CHANGE_TEAM
;
3410 if (gfc_match ("%e", &team
) != MATCH_YES
)
3413 m
= gfc_match_char (')');
3417 new_st
.expr1
= team
;
3422 gfc_syntax_error (ST_CHANGE_TEAM
);
3427 /* Match a END TEAM statement. */
3430 gfc_match_end_team (void)
3432 if (!gfc_notify_std (GFC_STD_F2008_TS
, "END TEAM statement at %C"))
3435 if (gfc_match_char ('(') == MATCH_YES
)
3438 new_st
.op
= EXEC_END_TEAM
;
3443 gfc_syntax_error (ST_END_TEAM
);
3448 /* Match a SYNC TEAM statement. */
3451 gfc_match_sync_team (void)
3456 if (!gfc_notify_std (GFC_STD_F2008_TS
, "SYNC TEAM statement at %C"))
3459 if (gfc_match_char ('(') == MATCH_NO
)
3462 new_st
.op
= EXEC_SYNC_TEAM
;
3464 if (gfc_match ("%e", &team
) != MATCH_YES
)
3467 m
= gfc_match_char (')');
3471 new_st
.expr1
= team
;
3476 gfc_syntax_error (ST_SYNC_TEAM
);
3481 /* Match LOCK/UNLOCK statement. Syntax:
3482 LOCK ( lock-variable [ , lock-stat-list ] )
3483 UNLOCK ( lock-variable [ , sync-stat-list ] )
3484 where lock-stat is ACQUIRED_LOCK or sync-stat
3485 and sync-stat is STAT= or ERRMSG=. */
3488 lock_unlock_statement (gfc_statement st
)
3491 gfc_expr
*tmp
, *lockvar
, *acq_lock
, *stat
, *errmsg
;
3492 bool saw_acq_lock
, saw_stat
, saw_errmsg
;
3494 tmp
= lockvar
= acq_lock
= stat
= errmsg
= NULL
;
3495 saw_acq_lock
= saw_stat
= saw_errmsg
= false;
3497 if (gfc_pure (NULL
))
3499 gfc_error ("Image control statement %s at %C in PURE procedure",
3500 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3504 gfc_unset_implicit_pure (NULL
);
3506 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3508 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3512 if (gfc_find_state (COMP_CRITICAL
))
3514 gfc_error ("Image control statement %s at %C in CRITICAL block",
3515 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3519 if (gfc_find_state (COMP_DO_CONCURRENT
))
3521 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
3522 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3526 if (gfc_match_char ('(') != MATCH_YES
)
3529 if (gfc_match ("%e", &lockvar
) != MATCH_YES
)
3531 m
= gfc_match_char (',');
3532 if (m
== MATCH_ERROR
)
3536 m
= gfc_match_char (')');
3544 m
= gfc_match (" stat = %v", &tmp
);
3545 if (m
== MATCH_ERROR
)
3551 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3557 m
= gfc_match_char (',');
3565 m
= gfc_match (" errmsg = %v", &tmp
);
3566 if (m
== MATCH_ERROR
)
3572 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3578 m
= gfc_match_char (',');
3586 m
= gfc_match (" acquired_lock = %v", &tmp
);
3587 if (m
== MATCH_ERROR
|| st
== ST_UNLOCK
)
3593 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L",
3598 saw_acq_lock
= true;
3600 m
= gfc_match_char (',');
3611 if (m
== MATCH_ERROR
)
3614 if (gfc_match (" )%t") != MATCH_YES
)
3621 new_st
.op
= EXEC_LOCK
;
3624 new_st
.op
= EXEC_UNLOCK
;
3630 new_st
.expr1
= lockvar
;
3631 new_st
.expr2
= stat
;
3632 new_st
.expr3
= errmsg
;
3633 new_st
.expr4
= acq_lock
;
3638 gfc_syntax_error (st
);
3641 if (acq_lock
!= tmp
)
3642 gfc_free_expr (acq_lock
);
3644 gfc_free_expr (errmsg
);
3646 gfc_free_expr (stat
);
3648 gfc_free_expr (tmp
);
3649 gfc_free_expr (lockvar
);
3656 gfc_match_lock (void)
3658 if (!gfc_notify_std (GFC_STD_F2008
, "LOCK statement at %C"))
3661 return lock_unlock_statement (ST_LOCK
);
3666 gfc_match_unlock (void)
3668 if (!gfc_notify_std (GFC_STD_F2008
, "UNLOCK statement at %C"))
3671 return lock_unlock_statement (ST_UNLOCK
);
3675 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
3676 SYNC ALL [(sync-stat-list)]
3677 SYNC MEMORY [(sync-stat-list)]
3678 SYNC IMAGES (image-set [, sync-stat-list] )
3679 with sync-stat is int-expr or *. */
3682 sync_statement (gfc_statement st
)
3685 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
3686 bool saw_stat
, saw_errmsg
;
3688 tmp
= imageset
= stat
= errmsg
= NULL
;
3689 saw_stat
= saw_errmsg
= false;
3691 if (gfc_pure (NULL
))
3693 gfc_error ("Image control statement SYNC at %C in PURE procedure");
3697 gfc_unset_implicit_pure (NULL
);
3699 if (!gfc_notify_std (GFC_STD_F2008
, "SYNC statement at %C"))
3702 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3704 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
3709 if (gfc_find_state (COMP_CRITICAL
))
3711 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3715 if (gfc_find_state (COMP_DO_CONCURRENT
))
3717 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3721 if (gfc_match_eos () == MATCH_YES
)
3723 if (st
== ST_SYNC_IMAGES
)
3728 if (gfc_match_char ('(') != MATCH_YES
)
3731 if (st
== ST_SYNC_IMAGES
)
3733 /* Denote '*' as imageset == NULL. */
3734 m
= gfc_match_char ('*');
3735 if (m
== MATCH_ERROR
)
3739 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
3742 m
= gfc_match_char (',');
3743 if (m
== MATCH_ERROR
)
3747 m
= gfc_match_char (')');
3756 m
= gfc_match (" stat = %v", &tmp
);
3757 if (m
== MATCH_ERROR
)
3763 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3769 if (gfc_match_char (',') == MATCH_YES
)
3776 m
= gfc_match (" errmsg = %v", &tmp
);
3777 if (m
== MATCH_ERROR
)
3783 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3789 if (gfc_match_char (',') == MATCH_YES
)
3799 if (gfc_match (" )%t") != MATCH_YES
)
3806 new_st
.op
= EXEC_SYNC_ALL
;
3808 case ST_SYNC_IMAGES
:
3809 new_st
.op
= EXEC_SYNC_IMAGES
;
3811 case ST_SYNC_MEMORY
:
3812 new_st
.op
= EXEC_SYNC_MEMORY
;
3818 new_st
.expr1
= imageset
;
3819 new_st
.expr2
= stat
;
3820 new_st
.expr3
= errmsg
;
3825 gfc_syntax_error (st
);
3829 gfc_free_expr (stat
);
3831 gfc_free_expr (errmsg
);
3833 gfc_free_expr (tmp
);
3834 gfc_free_expr (imageset
);
3840 /* Match SYNC ALL statement. */
3843 gfc_match_sync_all (void)
3845 return sync_statement (ST_SYNC_ALL
);
3849 /* Match SYNC IMAGES statement. */
3852 gfc_match_sync_images (void)
3854 return sync_statement (ST_SYNC_IMAGES
);
3858 /* Match SYNC MEMORY statement. */
3861 gfc_match_sync_memory (void)
3863 return sync_statement (ST_SYNC_MEMORY
);
3867 /* Match a CONTINUE statement. */
3870 gfc_match_continue (void)
3872 if (gfc_match_eos () != MATCH_YES
)
3874 gfc_syntax_error (ST_CONTINUE
);
3878 new_st
.op
= EXEC_CONTINUE
;
3883 /* Match the (deprecated) ASSIGN statement. */
3886 gfc_match_assign (void)
3889 gfc_st_label
*label
;
3891 if (gfc_match (" %l", &label
) == MATCH_YES
)
3893 if (!gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
))
3895 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
3897 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGN statement at %C"))
3900 expr
->symtree
->n
.sym
->attr
.assign
= 1;
3902 new_st
.op
= EXEC_LABEL_ASSIGN
;
3903 new_st
.label1
= label
;
3904 new_st
.expr1
= expr
;
3912 /* Match the GO TO statement. As a computed GOTO statement is
3913 matched, it is transformed into an equivalent SELECT block. No
3914 tree is necessary, and the resulting jumps-to-jumps are
3915 specifically optimized away by the back end. */
3918 gfc_match_goto (void)
3920 gfc_code
*head
, *tail
;
3923 gfc_st_label
*label
;
3927 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
3929 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3932 new_st
.op
= EXEC_GOTO
;
3933 new_st
.label1
= label
;
3937 /* The assigned GO TO statement. */
3939 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
3941 if (!gfc_notify_std (GFC_STD_F95_DEL
, "Assigned GOTO statement at %C"))
3944 new_st
.op
= EXEC_GOTO
;
3945 new_st
.expr1
= expr
;
3947 if (gfc_match_eos () == MATCH_YES
)
3950 /* Match label list. */
3951 gfc_match_char (',');
3952 if (gfc_match_char ('(') != MATCH_YES
)
3954 gfc_syntax_error (ST_GOTO
);
3961 m
= gfc_match_st_label (&label
);
3965 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3969 head
= tail
= gfc_get_code (EXEC_GOTO
);
3972 tail
->block
= gfc_get_code (EXEC_GOTO
);
3976 tail
->label1
= label
;
3978 while (gfc_match_char (',') == MATCH_YES
);
3980 if (gfc_match (")%t") != MATCH_YES
)
3985 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3988 new_st
.block
= head
;
3993 /* Last chance is a computed GO TO statement. */
3994 if (gfc_match_char ('(') != MATCH_YES
)
3996 gfc_syntax_error (ST_GOTO
);
4005 m
= gfc_match_st_label (&label
);
4009 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
4013 head
= tail
= gfc_get_code (EXEC_SELECT
);
4016 tail
->block
= gfc_get_code (EXEC_SELECT
);
4020 cp
= gfc_get_case ();
4021 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
4024 tail
->ext
.block
.case_list
= cp
;
4026 tail
->next
= gfc_get_code (EXEC_GOTO
);
4027 tail
->next
->label1
= label
;
4029 while (gfc_match_char (',') == MATCH_YES
);
4031 if (gfc_match_char (')') != MATCH_YES
)
4036 gfc_error ("Statement label list in GOTO at %C cannot be empty");
4040 /* Get the rest of the statement. */
4041 gfc_match_char (',');
4043 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
4046 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Computed GOTO at %C"))
4049 /* At this point, a computed GOTO has been fully matched and an
4050 equivalent SELECT statement constructed. */
4052 new_st
.op
= EXEC_SELECT
;
4053 new_st
.expr1
= NULL
;
4055 /* Hack: For a "real" SELECT, the expression is in expr. We put
4056 it in expr2 so we can distinguish then and produce the correct
4058 new_st
.expr2
= expr
;
4059 new_st
.block
= head
;
4063 gfc_syntax_error (ST_GOTO
);
4065 gfc_free_statements (head
);
4070 /* Frees a list of gfc_alloc structures. */
4073 gfc_free_alloc_list (gfc_alloc
*p
)
4080 gfc_free_expr (p
->expr
);
4086 /* Match an ALLOCATE statement. */
4089 gfc_match_allocate (void)
4091 gfc_alloc
*head
, *tail
;
4092 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
4096 locus old_locus
, deferred_locus
, assumed_locus
;
4097 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, saw_deferred
, b1
, b2
, b3
;
4098 bool saw_unlimited
= false, saw_assumed
= false;
4101 stat
= errmsg
= source
= mold
= tmp
= NULL
;
4102 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= saw_deferred
= false;
4104 if (gfc_match_char ('(') != MATCH_YES
)
4106 gfc_syntax_error (ST_ALLOCATE
);
4110 /* Match an optional type-spec. */
4111 old_locus
= gfc_current_locus
;
4112 m
= gfc_match_type_spec (&ts
);
4113 if (m
== MATCH_ERROR
)
4115 else if (m
== MATCH_NO
)
4117 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
4119 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
4121 gfc_error ("Error in type-spec at %L", &old_locus
);
4125 ts
.type
= BT_UNKNOWN
;
4129 /* Needed for the F2008:C631 check below. */
4130 assumed_locus
= gfc_current_locus
;
4132 if (gfc_match (" :: ") == MATCH_YES
)
4134 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
4140 gfc_error ("Type-spec at %L cannot contain a deferred "
4141 "type parameter", &old_locus
);
4145 if (ts
.type
== BT_CHARACTER
)
4147 if (!ts
.u
.cl
->length
)
4150 ts
.u
.cl
->length_from_typespec
= true;
4153 if (type_param_spec_list
4154 && gfc_spec_list_type (type_param_spec_list
, NULL
)
4157 gfc_error ("The type parameter spec list in the type-spec at "
4158 "%L cannot contain DEFERRED parameters", &old_locus
);
4164 ts
.type
= BT_UNKNOWN
;
4165 gfc_current_locus
= old_locus
;
4172 head
= tail
= gfc_get_alloc ();
4175 tail
->next
= gfc_get_alloc ();
4179 m
= gfc_match_variable (&tail
->expr
, 0);
4182 if (m
== MATCH_ERROR
)
4185 if (gfc_check_do_variable (tail
->expr
->symtree
))
4188 bool impure
= gfc_impure_variable (tail
->expr
->symtree
->n
.sym
);
4189 if (impure
&& gfc_pure (NULL
))
4191 gfc_error ("Bad allocate-object at %C for a PURE procedure");
4196 gfc_unset_implicit_pure (NULL
);
4198 /* F2008:C631 (R626) A type-param-value in a type-spec shall be an
4199 asterisk if and only if each allocate-object is a dummy argument
4200 for which the corresponding type parameter is assumed. */
4202 && (tail
->expr
->ts
.deferred
4203 || (tail
->expr
->ts
.u
.cl
&& tail
->expr
->ts
.u
.cl
->length
)
4204 || tail
->expr
->symtree
->n
.sym
->attr
.dummy
== 0))
4206 gfc_error ("Incompatible allocate-object at %C for CHARACTER "
4207 "type-spec at %L", &assumed_locus
);
4211 if (tail
->expr
->ts
.deferred
)
4213 saw_deferred
= true;
4214 deferred_locus
= tail
->expr
->where
;
4217 if (gfc_find_state (COMP_DO_CONCURRENT
)
4218 || gfc_find_state (COMP_CRITICAL
))
4221 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
4222 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
4223 if (ref
->type
== REF_COMPONENT
)
4224 coarray
= ref
->u
.c
.component
->attr
.codimension
;
4226 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
4228 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
4231 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
4233 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
4238 /* Check for F08:C628. */
4239 sym
= tail
->expr
->symtree
->n
.sym
;
4240 b1
= !(tail
->expr
->ref
4241 && (tail
->expr
->ref
->type
== REF_COMPONENT
4242 || tail
->expr
->ref
->type
== REF_ARRAY
));
4243 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4244 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
4245 || CLASS_DATA (sym
)->attr
.class_pointer
);
4247 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4248 || sym
->attr
.proc_pointer
);
4249 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
4250 && (sym
->ns
->proc_name
->attr
.allocatable
4251 || sym
->ns
->proc_name
->attr
.pointer
4252 || sym
->ns
->proc_name
->attr
.proc_pointer
);
4253 if (b1
&& b2
&& !b3
)
4255 gfc_error ("Allocate-object at %L is neither a data pointer "
4256 "nor an allocatable variable", &tail
->expr
->where
);
4260 /* The ALLOCATE statement had an optional typespec. Check the
4262 if (ts
.type
!= BT_UNKNOWN
)
4264 /* Enforce F03:C624. */
4265 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
4267 gfc_error ("Type of entity at %L is type incompatible with "
4268 "typespec", &tail
->expr
->where
);
4272 /* Enforce F03:C627. */
4273 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
4275 gfc_error ("Kind type parameter for entity at %L differs from "
4276 "the kind type parameter of the typespec",
4277 &tail
->expr
->where
);
4282 if (tail
->expr
->ts
.type
== BT_DERIVED
)
4283 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
4285 if (type_param_spec_list
)
4286 tail
->expr
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
4288 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
4290 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
4292 gfc_error ("Shape specification for allocatable scalar at %C");
4296 if (gfc_match_char (',') != MATCH_YES
)
4301 m
= gfc_match (" stat = %v", &tmp
);
4302 if (m
== MATCH_ERROR
)
4309 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4317 if (gfc_check_do_variable (stat
->symtree
))
4320 if (gfc_match_char (',') == MATCH_YES
)
4321 goto alloc_opt_list
;
4324 m
= gfc_match (" errmsg = %v", &tmp
);
4325 if (m
== MATCH_ERROR
)
4329 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
4335 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4343 if (gfc_match_char (',') == MATCH_YES
)
4344 goto alloc_opt_list
;
4347 m
= gfc_match (" source = %e", &tmp
);
4348 if (m
== MATCH_ERROR
)
4352 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
4358 gfc_error ("Redundant SOURCE tag found at %L", &tmp
->where
);
4362 /* The next 2 conditionals check C631. */
4363 if (ts
.type
!= BT_UNKNOWN
)
4365 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
4366 &tmp
->where
, &old_locus
);
4371 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
4372 " with more than a single allocate object",
4380 if (gfc_match_char (',') == MATCH_YES
)
4381 goto alloc_opt_list
;
4384 m
= gfc_match (" mold = %e", &tmp
);
4385 if (m
== MATCH_ERROR
)
4389 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
4392 /* Check F08:C636. */
4395 gfc_error ("Redundant MOLD tag found at %L", &tmp
->where
);
4399 /* Check F08:C637. */
4400 if (ts
.type
!= BT_UNKNOWN
)
4402 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
4403 &tmp
->where
, &old_locus
);
4412 if (gfc_match_char (',') == MATCH_YES
)
4413 goto alloc_opt_list
;
4416 gfc_gobble_whitespace ();
4418 if (gfc_peek_char () == ')')
4422 if (gfc_match (" )%t") != MATCH_YES
)
4425 /* Check F08:C637. */
4428 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
4429 &mold
->where
, &source
->where
);
4433 /* Check F03:C623, */
4434 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4436 gfc_error ("Allocate-object at %L with a deferred type parameter "
4437 "requires either a type-spec or SOURCE tag or a MOLD tag",
4442 /* Check F03:C625, */
4443 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4445 for (tail
= head
; tail
; tail
= tail
->next
)
4447 if (UNLIMITED_POLY (tail
->expr
))
4448 gfc_error ("Unlimited polymorphic allocate-object at %L "
4449 "requires either a type-spec or SOURCE tag "
4450 "or a MOLD tag", &tail
->expr
->where
);
4455 new_st
.op
= EXEC_ALLOCATE
;
4456 new_st
.expr1
= stat
;
4457 new_st
.expr2
= errmsg
;
4459 new_st
.expr3
= source
;
4461 new_st
.expr3
= mold
;
4462 new_st
.ext
.alloc
.list
= head
;
4463 new_st
.ext
.alloc
.ts
= ts
;
4465 if (type_param_spec_list
)
4466 gfc_free_actual_arglist (type_param_spec_list
);
4471 gfc_syntax_error (ST_ALLOCATE
);
4474 gfc_free_expr (errmsg
);
4475 gfc_free_expr (source
);
4476 gfc_free_expr (stat
);
4477 gfc_free_expr (mold
);
4478 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
4479 gfc_free_alloc_list (head
);
4480 if (type_param_spec_list
)
4481 gfc_free_actual_arglist (type_param_spec_list
);
4486 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
4487 a set of pointer assignments to intrinsic NULL(). */
4490 gfc_match_nullify (void)
4498 if (gfc_match_char ('(') != MATCH_YES
)
4503 m
= gfc_match_variable (&p
, 0);
4504 if (m
== MATCH_ERROR
)
4509 if (gfc_check_do_variable (p
->symtree
))
4513 if (gfc_is_coindexed (p
))
4515 gfc_error ("Pointer object at %C shall not be coindexed");
4519 /* build ' => NULL() '. */
4520 e
= gfc_get_null_expr (&gfc_current_locus
);
4522 /* Chain to list. */
4526 tail
->op
= EXEC_POINTER_ASSIGN
;
4530 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
4537 if (gfc_match (" )%t") == MATCH_YES
)
4539 if (gfc_match_char (',') != MATCH_YES
)
4546 gfc_syntax_error (ST_NULLIFY
);
4549 gfc_free_statements (new_st
.next
);
4551 gfc_free_expr (new_st
.expr1
);
4552 new_st
.expr1
= NULL
;
4553 gfc_free_expr (new_st
.expr2
);
4554 new_st
.expr2
= NULL
;
4559 /* Match a DEALLOCATE statement. */
4562 gfc_match_deallocate (void)
4564 gfc_alloc
*head
, *tail
;
4565 gfc_expr
*stat
, *errmsg
, *tmp
;
4568 bool saw_stat
, saw_errmsg
, b1
, b2
;
4571 stat
= errmsg
= tmp
= NULL
;
4572 saw_stat
= saw_errmsg
= false;
4574 if (gfc_match_char ('(') != MATCH_YES
)
4580 head
= tail
= gfc_get_alloc ();
4583 tail
->next
= gfc_get_alloc ();
4587 m
= gfc_match_variable (&tail
->expr
, 0);
4588 if (m
== MATCH_ERROR
)
4593 if (gfc_check_do_variable (tail
->expr
->symtree
))
4596 sym
= tail
->expr
->symtree
->n
.sym
;
4598 bool impure
= gfc_impure_variable (sym
);
4599 if (impure
&& gfc_pure (NULL
))
4601 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
4606 gfc_unset_implicit_pure (NULL
);
4608 if (gfc_is_coarray (tail
->expr
)
4609 && gfc_find_state (COMP_DO_CONCURRENT
))
4611 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
4615 if (gfc_is_coarray (tail
->expr
)
4616 && gfc_find_state (COMP_CRITICAL
))
4618 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
4622 /* FIXME: disable the checking on derived types. */
4623 b1
= !(tail
->expr
->ref
4624 && (tail
->expr
->ref
->type
== REF_COMPONENT
4625 || tail
->expr
->ref
->type
== REF_ARRAY
));
4626 if (sym
&& sym
->ts
.type
== BT_CLASS
)
4627 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
4628 || CLASS_DATA (sym
)->attr
.class_pointer
);
4630 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4631 || sym
->attr
.proc_pointer
);
4634 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
4635 "nor an allocatable variable");
4639 if (gfc_match_char (',') != MATCH_YES
)
4644 m
= gfc_match (" stat = %v", &tmp
);
4645 if (m
== MATCH_ERROR
)
4651 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4652 gfc_free_expr (tmp
);
4659 if (gfc_check_do_variable (stat
->symtree
))
4662 if (gfc_match_char (',') == MATCH_YES
)
4663 goto dealloc_opt_list
;
4666 m
= gfc_match (" errmsg = %v", &tmp
);
4667 if (m
== MATCH_ERROR
)
4671 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
4676 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4677 gfc_free_expr (tmp
);
4684 if (gfc_match_char (',') == MATCH_YES
)
4685 goto dealloc_opt_list
;
4688 gfc_gobble_whitespace ();
4690 if (gfc_peek_char () == ')')
4694 if (gfc_match (" )%t") != MATCH_YES
)
4697 new_st
.op
= EXEC_DEALLOCATE
;
4698 new_st
.expr1
= stat
;
4699 new_st
.expr2
= errmsg
;
4700 new_st
.ext
.alloc
.list
= head
;
4705 gfc_syntax_error (ST_DEALLOCATE
);
4708 gfc_free_expr (errmsg
);
4709 gfc_free_expr (stat
);
4710 gfc_free_alloc_list (head
);
4715 /* Match a RETURN statement. */
4718 gfc_match_return (void)
4722 gfc_compile_state s
;
4726 if (gfc_find_state (COMP_CRITICAL
))
4728 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4732 if (gfc_find_state (COMP_DO_CONCURRENT
))
4734 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4738 if (gfc_match_eos () == MATCH_YES
)
4741 if (!gfc_find_state (COMP_SUBROUTINE
))
4743 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4748 if (gfc_current_form
== FORM_FREE
)
4750 /* The following are valid, so we can't require a blank after the
4754 char c
= gfc_peek_ascii_char ();
4755 if (ISALPHA (c
) || ISDIGIT (c
))
4759 m
= gfc_match (" %e%t", &e
);
4762 if (m
== MATCH_ERROR
)
4765 gfc_syntax_error (ST_RETURN
);
4772 gfc_enclosing_unit (&s
);
4773 if (s
== COMP_PROGRAM
4774 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
4775 "main program at %C"))
4778 new_st
.op
= EXEC_RETURN
;
4785 /* Match the call of a type-bound procedure, if CALL%var has already been
4786 matched and var found to be a derived-type variable. */
4789 match_typebound_call (gfc_symtree
* varst
)
4794 base
= gfc_get_expr ();
4795 base
->expr_type
= EXPR_VARIABLE
;
4796 base
->symtree
= varst
;
4797 base
->where
= gfc_current_locus
;
4798 gfc_set_sym_referenced (varst
->n
.sym
);
4800 m
= gfc_match_varspec (base
, 0, true, true);
4802 gfc_error ("Expected component reference at %C");
4805 gfc_free_expr (base
);
4809 if (gfc_match_eos () != MATCH_YES
)
4811 gfc_error ("Junk after CALL at %C");
4812 gfc_free_expr (base
);
4816 if (base
->expr_type
== EXPR_COMPCALL
)
4817 new_st
.op
= EXEC_COMPCALL
;
4818 else if (base
->expr_type
== EXPR_PPC
)
4819 new_st
.op
= EXEC_CALL_PPC
;
4822 gfc_error ("Expected type-bound procedure or procedure pointer component "
4824 gfc_free_expr (base
);
4827 new_st
.expr1
= base
;
4833 /* Match a CALL statement. The tricky part here are possible
4834 alternate return specifiers. We handle these by having all
4835 "subroutines" actually return an integer via a register that gives
4836 the return number. If the call specifies alternate returns, we
4837 generate code for a SELECT statement whose case clauses contain
4838 GOTOs to the various labels. */
4841 gfc_match_call (void)
4843 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4844 gfc_actual_arglist
*a
, *arglist
;
4854 m
= gfc_match ("% %n", name
);
4860 if (gfc_get_ha_sym_tree (name
, &st
))
4865 /* If this is a variable of derived-type, it probably starts a type-bound
4867 if ((sym
->attr
.flavor
!= FL_PROCEDURE
4868 || gfc_is_function_return_value (sym
, gfc_current_ns
))
4869 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
4870 return match_typebound_call (st
);
4872 /* If it does not seem to be callable (include functions so that the
4873 right association is made. They are thrown out in resolution.)
4875 if (!sym
->attr
.generic
4876 && !sym
->attr
.subroutine
4877 && !sym
->attr
.function
)
4879 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
4881 /* ...create a symbol in this scope... */
4882 if (sym
->ns
!= gfc_current_ns
4883 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
4886 if (sym
!= st
->n
.sym
)
4890 /* ...and then to try to make the symbol into a subroutine. */
4891 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
4895 gfc_set_sym_referenced (sym
);
4897 if (gfc_match_eos () != MATCH_YES
)
4899 m
= gfc_match_actual_arglist (1, &arglist
);
4902 if (m
== MATCH_ERROR
)
4905 if (gfc_match_eos () != MATCH_YES
)
4909 /* If any alternate return labels were found, construct a SELECT
4910 statement that will jump to the right place. */
4913 for (a
= arglist
; a
; a
= a
->next
)
4914 if (a
->expr
== NULL
)
4922 gfc_symtree
*select_st
;
4923 gfc_symbol
*select_sym
;
4924 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4926 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
4927 sprintf (name
, "_result_%s", sym
->name
);
4928 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
4930 select_sym
= select_st
->n
.sym
;
4931 select_sym
->ts
.type
= BT_INTEGER
;
4932 select_sym
->ts
.kind
= gfc_default_integer_kind
;
4933 gfc_set_sym_referenced (select_sym
);
4934 c
->expr1
= gfc_get_expr ();
4935 c
->expr1
->expr_type
= EXPR_VARIABLE
;
4936 c
->expr1
->symtree
= select_st
;
4937 c
->expr1
->ts
= select_sym
->ts
;
4938 c
->expr1
->where
= gfc_current_locus
;
4941 for (a
= arglist
; a
; a
= a
->next
)
4943 if (a
->expr
!= NULL
)
4946 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
4951 c
->block
= gfc_get_code (EXEC_SELECT
);
4954 new_case
= gfc_get_case ();
4955 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
4956 new_case
->low
= new_case
->high
;
4957 c
->ext
.block
.case_list
= new_case
;
4959 c
->next
= gfc_get_code (EXEC_GOTO
);
4960 c
->next
->label1
= a
->label
;
4964 new_st
.op
= EXEC_CALL
;
4965 new_st
.symtree
= st
;
4966 new_st
.ext
.actual
= arglist
;
4971 gfc_syntax_error (ST_CALL
);
4974 gfc_free_actual_arglist (arglist
);
4979 /* Given a name, return a pointer to the common head structure,
4980 creating it if it does not exist. If FROM_MODULE is nonzero, we
4981 mangle the name so that it doesn't interfere with commons defined
4982 in the using namespace.
4983 TODO: Add to global symbol tree. */
4986 gfc_get_common (const char *name
, int from_module
)
4989 static int serial
= 0;
4990 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
4994 /* A use associated common block is only needed to correctly layout
4995 the variables it contains. */
4996 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
4997 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
5001 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
5004 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
5007 if (st
->n
.common
== NULL
)
5009 st
->n
.common
= gfc_get_common_head ();
5010 st
->n
.common
->where
= gfc_current_locus
;
5011 strcpy (st
->n
.common
->name
, name
);
5014 return st
->n
.common
;
5018 /* Match a common block name. */
5020 match
match_common_name (char *name
)
5024 if (gfc_match_char ('/') == MATCH_NO
)
5030 if (gfc_match_char ('/') == MATCH_YES
)
5036 m
= gfc_match_name (name
);
5038 if (m
== MATCH_ERROR
)
5040 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
5043 gfc_error ("Syntax error in common block name at %C");
5048 /* Match a COMMON statement. */
5051 gfc_match_common (void)
5053 gfc_symbol
*sym
, **head
, *tail
, *other
;
5054 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5064 m
= match_common_name (name
);
5065 if (m
== MATCH_ERROR
)
5068 if (name
[0] == '\0')
5070 t
= &gfc_current_ns
->blank_common
;
5071 if (t
->head
== NULL
)
5072 t
->where
= gfc_current_locus
;
5076 t
= gfc_get_common (name
, 0);
5085 while (tail
->common_next
)
5086 tail
= tail
->common_next
;
5089 /* Grab the list of symbols. */
5092 m
= gfc_match_symbol (&sym
, 0);
5093 if (m
== MATCH_ERROR
)
5098 /* See if we know the current common block is bind(c), and if
5099 so, then see if we can check if the symbol is (which it'll
5100 need to be). This can happen if the bind(c) attr stmt was
5101 applied to the common block, and the variable(s) already
5102 defined, before declaring the common block. */
5103 if (t
->is_bind_c
== 1)
5105 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
5107 /* If we find an error, just print it and continue,
5108 cause it's just semantic, and we can see if there
5110 gfc_error_now ("Variable %qs at %L in common block %qs "
5111 "at %C must be declared with a C "
5112 "interoperable kind since common block "
5114 sym
->name
, &(sym
->declared_at
), t
->name
,
5118 if (sym
->attr
.is_bind_c
== 1)
5119 gfc_error_now ("Variable %qs in common block %qs at %C can not "
5120 "be bind(c) since it is not global", sym
->name
,
5124 if (sym
->attr
.in_common
)
5126 gfc_error ("Symbol %qs at %C is already in a COMMON block",
5131 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
5132 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
5134 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol %qs at "
5135 "%C can only be COMMON in BLOCK DATA",
5140 /* Deal with an optional array specification after the
5142 m
= gfc_match_array_spec (&as
, true, true);
5143 if (m
== MATCH_ERROR
)
5148 if (as
->type
!= AS_EXPLICIT
)
5150 gfc_error ("Array specification for symbol %qs in COMMON "
5151 "at %C must be explicit", sym
->name
);
5155 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
5158 if (sym
->attr
.pointer
)
5160 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
5161 "POINTER array", sym
->name
);
5170 /* Add the in_common attribute, but ignore the reported errors
5171 if any, and continue matching. */
5172 gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
);
5174 sym
->common_block
= t
;
5175 sym
->common_block
->refs
++;
5178 tail
->common_next
= sym
;
5184 sym
->common_head
= t
;
5186 /* Check to see if the symbol is already in an equivalence group.
5187 If it is, set the other members as being in common. */
5188 if (sym
->attr
.in_equivalence
)
5190 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
5192 for (e2
= e1
; e2
; e2
= e2
->eq
)
5193 if (e2
->expr
->symtree
->n
.sym
== sym
)
5200 for (e2
= e1
; e2
; e2
= e2
->eq
)
5202 other
= e2
->expr
->symtree
->n
.sym
;
5203 if (other
->common_head
5204 && other
->common_head
!= sym
->common_head
)
5206 gfc_error ("Symbol %qs, in COMMON block %qs at "
5207 "%C is being indirectly equivalenced to "
5208 "another COMMON block %qs",
5209 sym
->name
, sym
->common_head
->name
,
5210 other
->common_head
->name
);
5213 other
->attr
.in_common
= 1;
5214 other
->common_head
= t
;
5220 gfc_gobble_whitespace ();
5221 if (gfc_match_eos () == MATCH_YES
)
5223 if (gfc_peek_ascii_char () == '/')
5225 if (gfc_match_char (',') != MATCH_YES
)
5227 gfc_gobble_whitespace ();
5228 if (gfc_peek_ascii_char () == '/')
5237 gfc_syntax_error (ST_COMMON
);
5240 gfc_free_array_spec (as
);
5245 /* Match a BLOCK DATA program unit. */
5248 gfc_match_block_data (void)
5250 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5254 if (gfc_match_eos () == MATCH_YES
)
5256 gfc_new_block
= NULL
;
5260 m
= gfc_match ("% %n%t", name
);
5264 if (gfc_get_symbol (name
, NULL
, &sym
))
5267 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
5270 gfc_new_block
= sym
;
5276 /* Free a namelist structure. */
5279 gfc_free_namelist (gfc_namelist
*name
)
5283 for (; name
; name
= n
)
5291 /* Free an OpenMP namelist structure. */
5294 gfc_free_omp_namelist (gfc_omp_namelist
*name
)
5296 gfc_omp_namelist
*n
;
5298 for (; name
; name
= n
)
5300 gfc_free_expr (name
->expr
);
5303 if (name
->udr
->combiner
)
5304 gfc_free_statement (name
->udr
->combiner
);
5305 if (name
->udr
->initializer
)
5306 gfc_free_statement (name
->udr
->initializer
);
5315 /* Match a NAMELIST statement. */
5318 gfc_match_namelist (void)
5320 gfc_symbol
*group_name
, *sym
;
5324 m
= gfc_match (" / %s /", &group_name
);
5327 if (m
== MATCH_ERROR
)
5332 if (group_name
->ts
.type
!= BT_UNKNOWN
)
5334 gfc_error ("Namelist group name %qs at %C already has a basic "
5335 "type of %s", group_name
->name
,
5336 gfc_typename (&group_name
->ts
));
5340 if (group_name
->attr
.flavor
== FL_NAMELIST
5341 && group_name
->attr
.use_assoc
5342 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name %qs "
5343 "at %C already is USE associated and can"
5344 "not be respecified.", group_name
->name
))
5347 if (group_name
->attr
.flavor
!= FL_NAMELIST
5348 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
5349 group_name
->name
, NULL
))
5354 m
= gfc_match_symbol (&sym
, 1);
5357 if (m
== MATCH_ERROR
)
5360 if (sym
->attr
.in_namelist
== 0
5361 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
5364 /* Use gfc_error_check here, rather than goto error, so that
5365 these are the only errors for the next two lines. */
5366 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
5368 gfc_error ("Assumed size array %qs in namelist %qs at "
5369 "%C is not allowed", sym
->name
, group_name
->name
);
5373 nl
= gfc_get_namelist ();
5377 if (group_name
->namelist
== NULL
)
5378 group_name
->namelist
= group_name
->namelist_tail
= nl
;
5381 group_name
->namelist_tail
->next
= nl
;
5382 group_name
->namelist_tail
= nl
;
5385 if (gfc_match_eos () == MATCH_YES
)
5388 m
= gfc_match_char (',');
5390 if (gfc_match_char ('/') == MATCH_YES
)
5392 m2
= gfc_match (" %s /", &group_name
);
5393 if (m2
== MATCH_YES
)
5395 if (m2
== MATCH_ERROR
)
5409 gfc_syntax_error (ST_NAMELIST
);
5416 /* Match a MODULE statement. */
5419 gfc_match_module (void)
5423 m
= gfc_match (" %s%t", &gfc_new_block
);
5427 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
5428 gfc_new_block
->name
, NULL
))
5435 /* Free equivalence sets and lists. Recursively is the easiest way to
5439 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
5444 gfc_free_equiv (eq
->eq
);
5445 gfc_free_equiv_until (eq
->next
, stop
);
5446 gfc_free_expr (eq
->expr
);
5452 gfc_free_equiv (gfc_equiv
*eq
)
5454 gfc_free_equiv_until (eq
, NULL
);
5458 /* Match an EQUIVALENCE statement. */
5461 gfc_match_equivalence (void)
5463 gfc_equiv
*eq
, *set
, *tail
;
5467 gfc_common_head
*common_head
= NULL
;
5475 eq
= gfc_get_equiv ();
5479 eq
->next
= gfc_current_ns
->equiv
;
5480 gfc_current_ns
->equiv
= eq
;
5482 if (gfc_match_char ('(') != MATCH_YES
)
5486 common_flag
= FALSE
;
5491 m
= gfc_match_equiv_variable (&set
->expr
);
5492 if (m
== MATCH_ERROR
)
5497 /* count the number of objects. */
5500 if (gfc_match_char ('%') == MATCH_YES
)
5502 gfc_error ("Derived type component %C is not a "
5503 "permitted EQUIVALENCE member");
5507 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
5508 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5510 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
5511 "be an array section");
5515 sym
= set
->expr
->symtree
->n
.sym
;
5517 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
5520 if (sym
->attr
.in_common
)
5523 common_head
= sym
->common_head
;
5526 if (gfc_match_char (')') == MATCH_YES
)
5529 if (gfc_match_char (',') != MATCH_YES
)
5532 set
->eq
= gfc_get_equiv ();
5538 gfc_error ("EQUIVALENCE at %C requires two or more objects");
5542 /* If one of the members of an equivalence is in common, then
5543 mark them all as being in common. Before doing this, check
5544 that members of the equivalence group are not in different
5547 for (set
= eq
; set
; set
= set
->eq
)
5549 sym
= set
->expr
->symtree
->n
.sym
;
5550 if (sym
->common_head
&& sym
->common_head
!= common_head
)
5552 gfc_error ("Attempt to indirectly overlap COMMON "
5553 "blocks %s and %s by EQUIVALENCE at %C",
5554 sym
->common_head
->name
, common_head
->name
);
5557 sym
->attr
.in_common
= 1;
5558 sym
->common_head
= common_head
;
5561 if (gfc_match_eos () == MATCH_YES
)
5563 if (gfc_match_char (',') != MATCH_YES
)
5565 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
5573 gfc_syntax_error (ST_EQUIVALENCE
);
5579 gfc_free_equiv (gfc_current_ns
->equiv
);
5580 gfc_current_ns
->equiv
= eq
;
5586 /* Check that a statement function is not recursive. This is done by looking
5587 for the statement function symbol(sym) by looking recursively through its
5588 expression(e). If a reference to sym is found, true is returned.
5589 12.5.4 requires that any variable of function that is implicitly typed
5590 shall have that type confirmed by any subsequent type declaration. The
5591 implicit typing is conveniently done here. */
5593 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
5596 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
5602 switch (e
->expr_type
)
5605 if (e
->symtree
== NULL
)
5608 /* Check the name before testing for nested recursion! */
5609 if (sym
->name
== e
->symtree
->n
.sym
->name
)
5612 /* Catch recursion via other statement functions. */
5613 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
5614 && e
->symtree
->n
.sym
->value
5615 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
5618 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5619 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5624 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
5627 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5628 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5640 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
5642 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
5646 /* Match a statement function declaration. It is so easy to match
5647 non-statement function statements with a MATCH_ERROR as opposed to
5648 MATCH_NO that we suppress error message in most cases. */
5651 gfc_match_st_function (void)
5653 gfc_error_buffer old_error
;
5658 m
= gfc_match_symbol (&sym
, 0);
5662 gfc_push_error (&old_error
);
5664 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
5667 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
5670 m
= gfc_match (" = %e%t", &expr
);
5674 gfc_free_error (&old_error
);
5676 if (m
== MATCH_ERROR
)
5679 if (recursive_stmt_fcn (expr
, sym
))
5681 gfc_error ("Statement function at %L is recursive", &expr
->where
);
5687 if ((gfc_current_state () == COMP_FUNCTION
5688 || gfc_current_state () == COMP_SUBROUTINE
)
5689 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
5691 gfc_error ("Statement function at %L cannot appear within an INTERFACE",
5696 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
5702 gfc_pop_error (&old_error
);
5707 /* Match an assignment to a pointer function (F2008). This could, in
5708 general be ambiguous with a statement function. In this implementation
5709 it remains so if it is the first statement after the specification
5713 gfc_match_ptr_fcn_assign (void)
5715 gfc_error_buffer old_error
;
5720 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5722 old_loc
= gfc_current_locus
;
5723 m
= gfc_match_name (name
);
5727 gfc_find_symbol (name
, NULL
, 1, &sym
);
5728 if (sym
&& sym
->attr
.flavor
!= FL_PROCEDURE
)
5731 gfc_push_error (&old_error
);
5733 if (sym
&& sym
->attr
.function
)
5734 goto match_actual_arglist
;
5736 gfc_current_locus
= old_loc
;
5737 m
= gfc_match_symbol (&sym
, 0);
5741 if (!gfc_add_procedure (&sym
->attr
, PROC_UNKNOWN
, sym
->name
, NULL
))
5744 match_actual_arglist
:
5745 gfc_current_locus
= old_loc
;
5746 m
= gfc_match (" %e", &expr
);
5750 new_st
.op
= EXEC_ASSIGN
;
5751 new_st
.expr1
= expr
;
5754 m
= gfc_match (" = %e%t", &expr
);
5758 new_st
.expr2
= expr
;
5762 gfc_pop_error (&old_error
);
5767 /***************** SELECT CASE subroutines ******************/
5769 /* Free a single case structure. */
5772 free_case (gfc_case
*p
)
5774 if (p
->low
== p
->high
)
5776 gfc_free_expr (p
->low
);
5777 gfc_free_expr (p
->high
);
5782 /* Free a list of case structures. */
5785 gfc_free_case_list (gfc_case
*p
)
5797 /* Match a single case selector. Combining the requirements of F08:C830
5798 and F08:C832 (R838) means that the case-value must have either CHARACTER,
5799 INTEGER, or LOGICAL type. */
5802 match_case_selector (gfc_case
**cp
)
5807 c
= gfc_get_case ();
5808 c
->where
= gfc_current_locus
;
5810 if (gfc_match_char (':') == MATCH_YES
)
5812 m
= gfc_match_init_expr (&c
->high
);
5815 if (m
== MATCH_ERROR
)
5818 if (c
->high
->ts
.type
!= BT_LOGICAL
&& c
->high
->ts
.type
!= BT_INTEGER
5819 && c
->high
->ts
.type
!= BT_CHARACTER
)
5821 gfc_error ("Expression in CASE selector at %L cannot be %s",
5822 &c
->high
->where
, gfc_typename (&c
->high
->ts
));
5828 m
= gfc_match_init_expr (&c
->low
);
5829 if (m
== MATCH_ERROR
)
5834 if (c
->low
->ts
.type
!= BT_LOGICAL
&& c
->low
->ts
.type
!= BT_INTEGER
5835 && c
->low
->ts
.type
!= BT_CHARACTER
)
5837 gfc_error ("Expression in CASE selector at %L cannot be %s",
5838 &c
->low
->where
, gfc_typename (&c
->low
->ts
));
5842 /* If we're not looking at a ':' now, make a range out of a single
5843 target. Else get the upper bound for the case range. */
5844 if (gfc_match_char (':') != MATCH_YES
)
5848 m
= gfc_match_init_expr (&c
->high
);
5849 if (m
== MATCH_ERROR
)
5851 /* MATCH_NO is fine. It's OK if nothing is there! */
5859 gfc_error ("Expected initialization expression in CASE at %C");
5867 /* Match the end of a case statement. */
5870 match_case_eos (void)
5872 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5875 if (gfc_match_eos () == MATCH_YES
)
5878 /* If the case construct doesn't have a case-construct-name, we
5879 should have matched the EOS. */
5880 if (!gfc_current_block ())
5883 gfc_gobble_whitespace ();
5885 m
= gfc_match_name (name
);
5889 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5891 gfc_error ("Expected block name %qs of SELECT construct at %C",
5892 gfc_current_block ()->name
);
5896 return gfc_match_eos ();
5900 /* Match a SELECT statement. */
5903 gfc_match_select (void)
5908 m
= gfc_match_label ();
5909 if (m
== MATCH_ERROR
)
5912 m
= gfc_match (" select case ( %e )%t", &expr
);
5916 new_st
.op
= EXEC_SELECT
;
5917 new_st
.expr1
= expr
;
5923 /* Transfer the selector typespec to the associate name. */
5926 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
)
5929 gfc_symbol
*assoc_sym
;
5931 assoc_sym
= associate
->symtree
->n
.sym
;
5933 /* At this stage the expression rank and arrayspec dimensions have
5934 not been completely sorted out. We must get the expr2->rank
5935 right here, so that the correct class container is obtained. */
5936 ref
= selector
->ref
;
5937 while (ref
&& ref
->next
)
5940 if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
5941 && ref
&& ref
->type
== REF_ARRAY
)
5943 /* Ensure that the array reference type is set. We cannot use
5944 gfc_resolve_expr at this point, so the usable parts of
5945 resolve.c(resolve_array_ref) are employed to do it. */
5946 if (ref
->u
.ar
.type
== AR_UNKNOWN
)
5948 ref
->u
.ar
.type
= AR_ELEMENT
;
5949 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
5950 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5951 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
5952 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
5953 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
5955 ref
->u
.ar
.type
= AR_SECTION
;
5960 if (ref
->u
.ar
.type
== AR_FULL
)
5961 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
5962 else if (ref
->u
.ar
.type
== AR_SECTION
)
5963 selector
->rank
= ref
->u
.ar
.dimen
;
5970 assoc_sym
->attr
.dimension
= 1;
5971 assoc_sym
->as
= gfc_get_array_spec ();
5972 assoc_sym
->as
->rank
= selector
->rank
;
5973 assoc_sym
->as
->type
= AS_DEFERRED
;
5976 assoc_sym
->as
= NULL
;
5978 if (selector
->ts
.type
== BT_CLASS
)
5980 /* The correct class container has to be available. */
5981 assoc_sym
->ts
.type
= BT_CLASS
;
5982 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
5983 assoc_sym
->attr
.pointer
= 1;
5984 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
5989 /* Push the current selector onto the SELECT TYPE stack. */
5992 select_type_push (gfc_symbol
*sel
)
5994 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
5995 top
->selector
= sel
;
5997 top
->prev
= select_type_stack
;
5999 select_type_stack
= top
;
6003 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
6005 static gfc_symtree
*
6006 select_intrinsic_set_tmp (gfc_typespec
*ts
)
6008 char name
[GFC_MAX_SYMBOL_LEN
];
6010 HOST_WIDE_INT charlen
= 0;
6012 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
6015 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
6016 && !select_type_stack
->selector
->attr
.class_ok
)
6019 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
6020 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6021 charlen
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
6023 if (ts
->type
!= BT_CHARACTER
)
6024 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
6027 snprintf (name
, sizeof (name
), "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC
"_%d",
6028 gfc_basic_typename (ts
->type
), charlen
, ts
->kind
);
6030 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6031 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
6033 /* Copy across the array spec to the selector. */
6034 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
6035 && (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
6036 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
))
6038 tmp
->n
.sym
->attr
.pointer
= 1;
6039 tmp
->n
.sym
->attr
.dimension
6040 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
6041 tmp
->n
.sym
->attr
.codimension
6042 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
6044 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
6047 gfc_set_sym_referenced (tmp
->n
.sym
);
6048 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
6049 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
6055 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
6058 select_type_set_tmp (gfc_typespec
*ts
)
6060 char name
[GFC_MAX_SYMBOL_LEN
];
6061 gfc_symtree
*tmp
= NULL
;
6065 select_type_stack
->tmp
= NULL
;
6069 tmp
= select_intrinsic_set_tmp (ts
);
6076 if (ts
->type
== BT_CLASS
)
6077 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
6079 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
6080 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
6081 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
6083 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
6084 && select_type_stack
->selector
->attr
.class_ok
)
6086 tmp
->n
.sym
->attr
.pointer
6087 = CLASS_DATA (select_type_stack
->selector
)->attr
.class_pointer
;
6089 /* Copy across the array spec to the selector. */
6090 if (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
6091 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
)
6093 tmp
->n
.sym
->attr
.dimension
6094 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
6095 tmp
->n
.sym
->attr
.codimension
6096 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
6098 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
6102 gfc_set_sym_referenced (tmp
->n
.sym
);
6103 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
6104 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
6106 if (ts
->type
== BT_CLASS
)
6107 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
6111 /* Add an association for it, so the rest of the parser knows it is
6112 an associate-name. The target will be set during resolution. */
6113 tmp
->n
.sym
->assoc
= gfc_get_association_list ();
6114 tmp
->n
.sym
->assoc
->dangling
= 1;
6115 tmp
->n
.sym
->assoc
->st
= tmp
;
6117 select_type_stack
->tmp
= tmp
;
6121 /* Match a SELECT TYPE statement. */
6124 gfc_match_select_type (void)
6126 gfc_expr
*expr1
, *expr2
= NULL
;
6128 char name
[GFC_MAX_SYMBOL_LEN
];
6131 gfc_namespace
*ns
= gfc_current_ns
;
6133 m
= gfc_match_label ();
6134 if (m
== MATCH_ERROR
)
6137 m
= gfc_match (" select type ( ");
6141 gfc_current_ns
= gfc_build_block_ns (ns
);
6142 m
= gfc_match (" %n => %e", name
, &expr2
);
6145 expr1
= gfc_get_expr ();
6146 expr1
->expr_type
= EXPR_VARIABLE
;
6147 expr1
->where
= expr2
->where
;
6148 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
6154 sym
= expr1
->symtree
->n
.sym
;
6155 if (expr2
->ts
.type
== BT_UNKNOWN
)
6156 sym
->attr
.untyped
= 1;
6158 copy_ts_from_selector_to_associate (expr1
, expr2
);
6160 sym
->attr
.flavor
= FL_VARIABLE
;
6161 sym
->attr
.referenced
= 1;
6162 sym
->attr
.class_ok
= 1;
6166 m
= gfc_match (" %e ", &expr1
);
6169 std::swap (ns
, gfc_current_ns
);
6170 gfc_free_namespace (ns
);
6175 m
= gfc_match (" )%t");
6178 gfc_error ("parse error in SELECT TYPE statement at %C");
6182 /* This ghastly expression seems to be needed to distinguish a CLASS
6183 array, which can have a reference, from other expressions that
6184 have references, such as derived type components, and are not
6185 allowed by the standard.
6186 TODO: see if it is sufficient to exclude component and substring
6188 class_array
= (expr1
->expr_type
== EXPR_VARIABLE
6189 && expr1
->ts
.type
== BT_CLASS
6190 && CLASS_DATA (expr1
)
6191 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
6192 && (CLASS_DATA (expr1
)->attr
.dimension
6193 || CLASS_DATA (expr1
)->attr
.codimension
)
6195 && expr1
->ref
->type
== REF_ARRAY
6196 && expr1
->ref
->next
== NULL
);
6198 /* Check for F03:C811. */
6199 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
6200 || (!class_array
&& expr1
->ref
!= NULL
)))
6202 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
6203 "use associate-name=>");
6208 new_st
.op
= EXEC_SELECT_TYPE
;
6209 new_st
.expr1
= expr1
;
6210 new_st
.expr2
= expr2
;
6211 new_st
.ext
.block
.ns
= gfc_current_ns
;
6213 select_type_push (expr1
->symtree
->n
.sym
);
6214 gfc_current_ns
= ns
;
6219 gfc_free_expr (expr1
);
6220 gfc_free_expr (expr2
);
6221 gfc_undo_symbols ();
6222 std::swap (ns
, gfc_current_ns
);
6223 gfc_free_namespace (ns
);
6228 /* Match a CASE statement. */
6231 gfc_match_case (void)
6233 gfc_case
*c
, *head
, *tail
;
6238 if (gfc_current_state () != COMP_SELECT
)
6240 gfc_error ("Unexpected CASE statement at %C");
6244 if (gfc_match ("% default") == MATCH_YES
)
6246 m
= match_case_eos ();
6249 if (m
== MATCH_ERROR
)
6252 new_st
.op
= EXEC_SELECT
;
6253 c
= gfc_get_case ();
6254 c
->where
= gfc_current_locus
;
6255 new_st
.ext
.block
.case_list
= c
;
6259 if (gfc_match_char ('(') != MATCH_YES
)
6264 if (match_case_selector (&c
) == MATCH_ERROR
)
6274 if (gfc_match_char (')') == MATCH_YES
)
6276 if (gfc_match_char (',') != MATCH_YES
)
6280 m
= match_case_eos ();
6283 if (m
== MATCH_ERROR
)
6286 new_st
.op
= EXEC_SELECT
;
6287 new_st
.ext
.block
.case_list
= head
;
6292 gfc_error ("Syntax error in CASE specification at %C");
6295 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
6300 /* Match a TYPE IS statement. */
6303 gfc_match_type_is (void)
6308 if (gfc_current_state () != COMP_SELECT_TYPE
)
6310 gfc_error ("Unexpected TYPE IS statement at %C");
6314 if (gfc_match_char ('(') != MATCH_YES
)
6317 c
= gfc_get_case ();
6318 c
->where
= gfc_current_locus
;
6320 m
= gfc_match_type_spec (&c
->ts
);
6323 if (m
== MATCH_ERROR
)
6326 if (gfc_match_char (')') != MATCH_YES
)
6329 m
= match_case_eos ();
6332 if (m
== MATCH_ERROR
)
6335 new_st
.op
= EXEC_SELECT_TYPE
;
6336 new_st
.ext
.block
.case_list
= c
;
6338 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
6339 && (c
->ts
.u
.derived
->attr
.sequence
6340 || c
->ts
.u
.derived
->attr
.is_bind_c
))
6342 gfc_error ("The type-spec shall not specify a sequence derived "
6343 "type or a type with the BIND attribute in SELECT "
6344 "TYPE at %C [F2003:C815]");
6348 if (c
->ts
.type
== BT_DERIVED
6349 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
6350 && gfc_spec_list_type (type_param_spec_list
, c
->ts
.u
.derived
)
6353 gfc_error ("All the LEN type parameters in the TYPE IS statement "
6354 "at %C must be ASSUMED");
6358 /* Create temporary variable. */
6359 select_type_set_tmp (&c
->ts
);
6364 gfc_error ("Syntax error in TYPE IS specification at %C");
6368 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6373 /* Match a CLASS IS or CLASS DEFAULT statement. */
6376 gfc_match_class_is (void)
6381 if (gfc_current_state () != COMP_SELECT_TYPE
)
6384 if (gfc_match ("% default") == MATCH_YES
)
6386 m
= match_case_eos ();
6389 if (m
== MATCH_ERROR
)
6392 new_st
.op
= EXEC_SELECT_TYPE
;
6393 c
= gfc_get_case ();
6394 c
->where
= gfc_current_locus
;
6395 c
->ts
.type
= BT_UNKNOWN
;
6396 new_st
.ext
.block
.case_list
= c
;
6397 select_type_set_tmp (NULL
);
6401 m
= gfc_match ("% is");
6404 if (m
== MATCH_ERROR
)
6407 if (gfc_match_char ('(') != MATCH_YES
)
6410 c
= gfc_get_case ();
6411 c
->where
= gfc_current_locus
;
6413 m
= match_derived_type_spec (&c
->ts
);
6416 if (m
== MATCH_ERROR
)
6419 if (c
->ts
.type
== BT_DERIVED
)
6420 c
->ts
.type
= BT_CLASS
;
6422 if (gfc_match_char (')') != MATCH_YES
)
6425 m
= match_case_eos ();
6428 if (m
== MATCH_ERROR
)
6431 new_st
.op
= EXEC_SELECT_TYPE
;
6432 new_st
.ext
.block
.case_list
= c
;
6434 /* Create temporary variable. */
6435 select_type_set_tmp (&c
->ts
);
6440 gfc_error ("Syntax error in CLASS IS specification at %C");
6444 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6449 /********************* WHERE subroutines ********************/
6451 /* Match the rest of a simple WHERE statement that follows an IF statement.
6455 match_simple_where (void)
6461 m
= gfc_match (" ( %e )", &expr
);
6465 m
= gfc_match_assignment ();
6468 if (m
== MATCH_ERROR
)
6471 if (gfc_match_eos () != MATCH_YES
)
6474 c
= gfc_get_code (EXEC_WHERE
);
6477 c
->next
= XCNEW (gfc_code
);
6479 c
->next
->loc
= gfc_current_locus
;
6480 gfc_clear_new_st ();
6482 new_st
.op
= EXEC_WHERE
;
6488 gfc_syntax_error (ST_WHERE
);
6491 gfc_free_expr (expr
);
6496 /* Match a WHERE statement. */
6499 gfc_match_where (gfc_statement
*st
)
6505 m0
= gfc_match_label ();
6506 if (m0
== MATCH_ERROR
)
6509 m
= gfc_match (" where ( %e )", &expr
);
6513 if (gfc_match_eos () == MATCH_YES
)
6515 *st
= ST_WHERE_BLOCK
;
6516 new_st
.op
= EXEC_WHERE
;
6517 new_st
.expr1
= expr
;
6521 m
= gfc_match_assignment ();
6523 gfc_syntax_error (ST_WHERE
);
6527 gfc_free_expr (expr
);
6531 /* We've got a simple WHERE statement. */
6533 c
= gfc_get_code (EXEC_WHERE
);
6536 /* Put in the assignment. It will not be processed by add_statement, so we
6537 need to copy the location here. */
6539 c
->next
= XCNEW (gfc_code
);
6541 c
->next
->loc
= gfc_current_locus
;
6542 gfc_clear_new_st ();
6544 new_st
.op
= EXEC_WHERE
;
6551 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
6552 new_st if successful. */
6555 gfc_match_elsewhere (void)
6557 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6561 if (gfc_current_state () != COMP_WHERE
)
6563 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
6569 if (gfc_match_char ('(') == MATCH_YES
)
6571 m
= gfc_match_expr (&expr
);
6574 if (m
== MATCH_ERROR
)
6577 if (gfc_match_char (')') != MATCH_YES
)
6581 if (gfc_match_eos () != MATCH_YES
)
6583 /* Only makes sense if we have a where-construct-name. */
6584 if (!gfc_current_block ())
6589 /* Better be a name at this point. */
6590 m
= gfc_match_name (name
);
6593 if (m
== MATCH_ERROR
)
6596 if (gfc_match_eos () != MATCH_YES
)
6599 if (strcmp (name
, gfc_current_block ()->name
) != 0)
6601 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
6602 name
, gfc_current_block ()->name
);
6607 new_st
.op
= EXEC_WHERE
;
6608 new_st
.expr1
= expr
;
6612 gfc_syntax_error (ST_ELSEWHERE
);
6615 gfc_free_expr (expr
);