1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000-2017 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
);
1246 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1247 expect an upper case character here! */
1248 gcc_assert (TOLOWER (c
) == c
);
1250 if (c
== gfc_next_ascii_char ())
1260 /* Clean up after a failed match. */
1261 gfc_current_locus
= old_loc
;
1262 va_start (argp
, target
);
1265 for (; matches
> 0; matches
--)
1267 while (*p
++ != '%');
1275 /* Matches that don't have to be undone */
1280 (void) va_arg (argp
, void **);
1285 vp
= va_arg (argp
, void **);
1286 gfc_free_expr ((struct gfc_expr
*)*vp
);
1299 /*********************** Statement level matching **********************/
1301 /* Matches the start of a program unit, which is the program keyword
1302 followed by an obligatory symbol. */
1305 gfc_match_program (void)
1310 m
= gfc_match ("% %s%t", &sym
);
1314 gfc_error ("Invalid form of PROGRAM statement at %C");
1318 if (m
== MATCH_ERROR
)
1321 if (!gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
))
1324 gfc_new_block
= sym
;
1330 /* Match a simple assignment statement. */
1333 gfc_match_assignment (void)
1335 gfc_expr
*lvalue
, *rvalue
;
1339 old_loc
= gfc_current_locus
;
1342 m
= gfc_match (" %v =", &lvalue
);
1345 gfc_current_locus
= old_loc
;
1346 gfc_free_expr (lvalue
);
1351 m
= gfc_match (" %e%t", &rvalue
);
1354 gfc_current_locus
= old_loc
;
1355 gfc_free_expr (lvalue
);
1356 gfc_free_expr (rvalue
);
1360 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1362 new_st
.op
= EXEC_ASSIGN
;
1363 new_st
.expr1
= lvalue
;
1364 new_st
.expr2
= rvalue
;
1366 gfc_check_do_variable (lvalue
->symtree
);
1372 /* Match a pointer assignment statement. */
1375 gfc_match_pointer_assignment (void)
1377 gfc_expr
*lvalue
, *rvalue
;
1381 old_loc
= gfc_current_locus
;
1383 lvalue
= rvalue
= NULL
;
1384 gfc_matching_ptr_assignment
= 0;
1385 gfc_matching_procptr_assignment
= 0;
1387 m
= gfc_match (" %v =>", &lvalue
);
1394 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1395 || gfc_is_proc_ptr_comp (lvalue
))
1396 gfc_matching_procptr_assignment
= 1;
1398 gfc_matching_ptr_assignment
= 1;
1400 m
= gfc_match (" %e%t", &rvalue
);
1401 gfc_matching_ptr_assignment
= 0;
1402 gfc_matching_procptr_assignment
= 0;
1406 new_st
.op
= EXEC_POINTER_ASSIGN
;
1407 new_st
.expr1
= lvalue
;
1408 new_st
.expr2
= rvalue
;
1413 gfc_current_locus
= old_loc
;
1414 gfc_free_expr (lvalue
);
1415 gfc_free_expr (rvalue
);
1420 /* We try to match an easy arithmetic IF statement. This only happens
1421 when just after having encountered a simple IF statement. This code
1422 is really duplicate with parts of the gfc_match_if code, but this is
1426 match_arithmetic_if (void)
1428 gfc_st_label
*l1
, *l2
, *l3
;
1432 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1436 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1437 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1438 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1440 gfc_free_expr (expr
);
1444 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Arithmetic IF statement at %C"))
1447 new_st
.op
= EXEC_ARITHMETIC_IF
;
1448 new_st
.expr1
= expr
;
1457 /* The IF statement is a bit of a pain. First of all, there are three
1458 forms of it, the simple IF, the IF that starts a block and the
1461 There is a problem with the simple IF and that is the fact that we
1462 only have a single level of undo information on symbols. What this
1463 means is for a simple IF, we must re-match the whole IF statement
1464 multiple times in order to guarantee that the symbol table ends up
1465 in the proper state. */
1467 static match
match_simple_forall (void);
1468 static match
match_simple_where (void);
1471 gfc_match_if (gfc_statement
*if_type
)
1474 gfc_st_label
*l1
, *l2
, *l3
;
1475 locus old_loc
, old_loc2
;
1479 n
= gfc_match_label ();
1480 if (n
== MATCH_ERROR
)
1483 old_loc
= gfc_current_locus
;
1485 m
= gfc_match (" if ( %e", &expr
);
1489 old_loc2
= gfc_current_locus
;
1490 gfc_current_locus
= old_loc
;
1492 if (gfc_match_parens () == MATCH_ERROR
)
1495 gfc_current_locus
= old_loc2
;
1497 if (gfc_match_char (')') != MATCH_YES
)
1499 gfc_error ("Syntax error in IF-expression at %C");
1500 gfc_free_expr (expr
);
1504 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1510 gfc_error ("Block label not appropriate for arithmetic IF "
1512 gfc_free_expr (expr
);
1516 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1517 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1518 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1520 gfc_free_expr (expr
);
1524 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Arithmetic IF statement at %C"))
1527 new_st
.op
= EXEC_ARITHMETIC_IF
;
1528 new_st
.expr1
= expr
;
1533 *if_type
= ST_ARITHMETIC_IF
;
1537 if (gfc_match (" then%t") == MATCH_YES
)
1539 new_st
.op
= EXEC_IF
;
1540 new_st
.expr1
= expr
;
1541 *if_type
= ST_IF_BLOCK
;
1547 gfc_error ("Block label is not appropriate for IF statement at %C");
1548 gfc_free_expr (expr
);
1552 /* At this point the only thing left is a simple IF statement. At
1553 this point, n has to be MATCH_NO, so we don't have to worry about
1554 re-matching a block label. From what we've got so far, try
1555 matching an assignment. */
1557 *if_type
= ST_SIMPLE_IF
;
1559 m
= gfc_match_assignment ();
1563 gfc_free_expr (expr
);
1564 gfc_undo_symbols ();
1565 gfc_current_locus
= old_loc
;
1567 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1568 assignment was found. For MATCH_NO, continue to call the various
1570 if (m
== MATCH_ERROR
)
1573 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1575 m
= gfc_match_pointer_assignment ();
1579 gfc_free_expr (expr
);
1580 gfc_undo_symbols ();
1581 gfc_current_locus
= old_loc
;
1583 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1585 /* Look at the next keyword to see which matcher to call. Matching
1586 the keyword doesn't affect the symbol table, so we don't have to
1587 restore between tries. */
1589 #define match(string, subr, statement) \
1590 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1594 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1595 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1596 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1597 match ("call", gfc_match_call
, ST_CALL
)
1598 match ("close", gfc_match_close
, ST_CLOSE
)
1599 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1600 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1601 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1602 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1603 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
)
1604 match ("event post", gfc_match_event_post
, ST_EVENT_POST
)
1605 match ("event wait", gfc_match_event_wait
, ST_EVENT_WAIT
)
1606 match ("exit", gfc_match_exit
, ST_EXIT
)
1607 match ("fail image", gfc_match_fail_image
, ST_FAIL_IMAGE
)
1608 match ("flush", gfc_match_flush
, ST_FLUSH
)
1609 match ("forall", match_simple_forall
, ST_FORALL
)
1610 match ("go to", gfc_match_goto
, ST_GOTO
)
1611 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1612 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1613 match ("lock", gfc_match_lock
, ST_LOCK
)
1614 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1615 match ("open", gfc_match_open
, ST_OPEN
)
1616 match ("pause", gfc_match_pause
, ST_NONE
)
1617 match ("print", gfc_match_print
, ST_WRITE
)
1618 match ("read", gfc_match_read
, ST_READ
)
1619 match ("return", gfc_match_return
, ST_RETURN
)
1620 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1621 match ("stop", gfc_match_stop
, ST_STOP
)
1622 match ("wait", gfc_match_wait
, ST_WAIT
)
1623 match ("sync all", gfc_match_sync_all
, ST_SYNC_CALL
);
1624 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
1625 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
1626 match ("unlock", gfc_match_unlock
, ST_UNLOCK
)
1627 match ("where", match_simple_where
, ST_WHERE
)
1628 match ("write", gfc_match_write
, ST_WRITE
)
1631 match ("type", gfc_match_print
, ST_WRITE
)
1633 /* The gfc_match_assignment() above may have returned a MATCH_NO
1634 where the assignment was to a named constant. Check that
1635 special case here. */
1636 m
= gfc_match_assignment ();
1639 gfc_error ("Cannot assign to a named constant at %C");
1640 gfc_free_expr (expr
);
1641 gfc_undo_symbols ();
1642 gfc_current_locus
= old_loc
;
1646 /* All else has failed, so give up. See if any of the matchers has
1647 stored an error message of some sort. */
1648 if (!gfc_error_check ())
1649 gfc_error ("Unclassifiable statement in IF-clause at %C");
1651 gfc_free_expr (expr
);
1656 gfc_error ("Syntax error in IF-clause at %C");
1659 gfc_free_expr (expr
);
1663 /* At this point, we've matched the single IF and the action clause
1664 is in new_st. Rearrange things so that the IF statement appears
1667 p
= gfc_get_code (EXEC_IF
);
1668 p
->next
= XCNEW (gfc_code
);
1670 p
->next
->loc
= gfc_current_locus
;
1674 gfc_clear_new_st ();
1676 new_st
.op
= EXEC_IF
;
1685 /* Match an ELSE statement. */
1688 gfc_match_else (void)
1690 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1692 if (gfc_match_eos () == MATCH_YES
)
1695 if (gfc_match_name (name
) != MATCH_YES
1696 || gfc_current_block () == NULL
1697 || gfc_match_eos () != MATCH_YES
)
1699 gfc_error ("Unexpected junk after ELSE statement at %C");
1703 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1705 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1706 name
, gfc_current_block ()->name
);
1714 /* Match an ELSE IF statement. */
1717 gfc_match_elseif (void)
1719 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1723 m
= gfc_match (" ( %e ) then", &expr
);
1727 if (gfc_match_eos () == MATCH_YES
)
1730 if (gfc_match_name (name
) != MATCH_YES
1731 || gfc_current_block () == NULL
1732 || gfc_match_eos () != MATCH_YES
)
1734 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1738 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1740 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1741 name
, gfc_current_block ()->name
);
1746 new_st
.op
= EXEC_IF
;
1747 new_st
.expr1
= expr
;
1751 gfc_free_expr (expr
);
1756 /* Free a gfc_iterator structure. */
1759 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1765 gfc_free_expr (iter
->var
);
1766 gfc_free_expr (iter
->start
);
1767 gfc_free_expr (iter
->end
);
1768 gfc_free_expr (iter
->step
);
1775 /* Match a CRITICAL statement. */
1777 gfc_match_critical (void)
1779 gfc_st_label
*label
= NULL
;
1781 if (gfc_match_label () == MATCH_ERROR
)
1784 if (gfc_match (" critical") != MATCH_YES
)
1787 if (gfc_match_st_label (&label
) == MATCH_ERROR
)
1790 if (gfc_match_eos () != MATCH_YES
)
1792 gfc_syntax_error (ST_CRITICAL
);
1796 if (gfc_pure (NULL
))
1798 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1802 if (gfc_find_state (COMP_DO_CONCURRENT
))
1804 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1809 gfc_unset_implicit_pure (NULL
);
1811 if (!gfc_notify_std (GFC_STD_F2008
, "CRITICAL statement at %C"))
1814 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1816 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1821 if (gfc_find_state (COMP_CRITICAL
))
1823 gfc_error ("Nested CRITICAL block at %C");
1827 new_st
.op
= EXEC_CRITICAL
;
1830 && !gfc_reference_st_label (label
, ST_LABEL_TARGET
))
1837 /* Match a BLOCK statement. */
1840 gfc_match_block (void)
1844 if (gfc_match_label () == MATCH_ERROR
)
1847 if (gfc_match (" block") != MATCH_YES
)
1850 /* For this to be a correct BLOCK statement, the line must end now. */
1851 m
= gfc_match_eos ();
1852 if (m
== MATCH_ERROR
)
1861 /* Match an ASSOCIATE statement. */
1864 gfc_match_associate (void)
1866 if (gfc_match_label () == MATCH_ERROR
)
1869 if (gfc_match (" associate") != MATCH_YES
)
1872 /* Match the association list. */
1873 if (gfc_match_char ('(') != MATCH_YES
)
1875 gfc_error ("Expected association list at %C");
1878 new_st
.ext
.block
.assoc
= NULL
;
1881 gfc_association_list
* newAssoc
= gfc_get_association_list ();
1882 gfc_association_list
* a
;
1884 /* Match the next association. */
1885 if (gfc_match (" %n => %e", newAssoc
->name
, &newAssoc
->target
)
1888 /* Have another go, allowing for procedure pointer selectors. */
1889 gfc_matching_procptr_assignment
= 1;
1890 if (gfc_match (" %n => %e", newAssoc
->name
, &newAssoc
->target
)
1893 gfc_error ("Expected association at %C");
1894 goto assocListError
;
1896 gfc_matching_procptr_assignment
= 0;
1898 newAssoc
->where
= gfc_current_locus
;
1900 /* Check that the current name is not yet in the list. */
1901 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
1902 if (!strcmp (a
->name
, newAssoc
->name
))
1904 gfc_error ("Duplicate name %qs in association at %C",
1906 goto assocListError
;
1909 /* The target expression must not be coindexed. */
1910 if (gfc_is_coindexed (newAssoc
->target
))
1912 gfc_error ("Association target at %C must not be coindexed");
1913 goto assocListError
;
1916 /* The `variable' field is left blank for now; because the target is not
1917 yet resolved, we can't use gfc_has_vector_subscript to determine it
1918 for now. This is set during resolution. */
1920 /* Put it into the list. */
1921 newAssoc
->next
= new_st
.ext
.block
.assoc
;
1922 new_st
.ext
.block
.assoc
= newAssoc
;
1924 /* Try next one or end if closing parenthesis is found. */
1925 gfc_gobble_whitespace ();
1926 if (gfc_peek_char () == ')')
1928 if (gfc_match_char (',') != MATCH_YES
)
1930 gfc_error ("Expected %<)%> or %<,%> at %C");
1940 if (gfc_match_char (')') != MATCH_YES
)
1942 /* This should never happen as we peek above. */
1946 if (gfc_match_eos () != MATCH_YES
)
1948 gfc_error ("Junk after ASSOCIATE statement at %C");
1955 gfc_free_association_list (new_st
.ext
.block
.assoc
);
1960 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1961 an accessible derived type. */
1964 match_derived_type_spec (gfc_typespec
*ts
)
1966 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1968 gfc_symbol
*derived
, *der_type
;
1969 match m
= MATCH_YES
;
1970 gfc_actual_arglist
*decl_type_param_list
= NULL
;
1971 bool is_pdt_template
= false;
1973 old_locus
= gfc_current_locus
;
1975 if (gfc_match ("%n", name
) != MATCH_YES
)
1977 gfc_current_locus
= old_locus
;
1981 gfc_find_symbol (name
, NULL
, 1, &derived
);
1983 /* Match the PDT spec list, if there. */
1984 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
)
1986 gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &der_type
);
1987 is_pdt_template
= der_type
1988 && der_type
->attr
.flavor
== FL_DERIVED
1989 && der_type
->attr
.pdt_template
;
1992 if (is_pdt_template
)
1993 m
= gfc_match_actual_arglist (1, &decl_type_param_list
, true);
1995 if (m
== MATCH_ERROR
)
1997 gfc_free_actual_arglist (decl_type_param_list
);
2001 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
&& derived
->attr
.generic
)
2002 derived
= gfc_find_dt_in_generic (derived
);
2004 /* If this is a PDT, find the specific instance. */
2005 if (m
== MATCH_YES
&& is_pdt_template
)
2007 gfc_namespace
*old_ns
;
2009 old_ns
= gfc_current_ns
;
2010 while (gfc_current_ns
&& gfc_current_ns
->parent
)
2011 gfc_current_ns
= gfc_current_ns
->parent
;
2013 if (type_param_spec_list
)
2014 gfc_free_actual_arglist (type_param_spec_list
);
2015 m
= gfc_get_pdt_instance (decl_type_param_list
, &der_type
,
2016 &type_param_spec_list
);
2017 gfc_free_actual_arglist (decl_type_param_list
);
2022 gcc_assert (!derived
->attr
.pdt_template
&& derived
->attr
.pdt_type
);
2023 gfc_set_sym_referenced (derived
);
2025 gfc_current_ns
= old_ns
;
2028 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
2030 ts
->type
= BT_DERIVED
;
2031 ts
->u
.derived
= derived
;
2035 gfc_current_locus
= old_locus
;
2040 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2041 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2042 It only includes the intrinsic types from the Fortran 2003 standard
2043 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2044 the implicit_flag is not needed, so it was removed. Derived types are
2045 identified by their name alone. */
2048 gfc_match_type_spec (gfc_typespec
*ts
)
2052 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2055 gfc_gobble_whitespace ();
2056 old_locus
= gfc_current_locus
;
2057 type_param_spec_list
= NULL
;
2059 if (match_derived_type_spec (ts
) == MATCH_YES
)
2061 /* Enforce F03:C401. */
2062 if (ts
->u
.derived
->attr
.abstract
)
2064 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
2065 ts
->u
.derived
->name
, &old_locus
);
2071 if (gfc_match ("integer") == MATCH_YES
)
2073 ts
->type
= BT_INTEGER
;
2074 ts
->kind
= gfc_default_integer_kind
;
2078 if (gfc_match ("double precision") == MATCH_YES
)
2081 ts
->kind
= gfc_default_double_kind
;
2085 if (gfc_match ("complex") == MATCH_YES
)
2087 ts
->type
= BT_COMPLEX
;
2088 ts
->kind
= gfc_default_complex_kind
;
2092 if (gfc_match ("character") == MATCH_YES
)
2094 ts
->type
= BT_CHARACTER
;
2096 m
= gfc_match_char_spec (ts
);
2104 if (gfc_match ("logical") == MATCH_YES
)
2106 ts
->type
= BT_LOGICAL
;
2107 ts
->kind
= gfc_default_logical_kind
;
2111 /* REAL is a real pain because it can be a type, intrinsic subprogram,
2112 or list item in a type-list of an OpenMP reduction clause. Need to
2113 differentiate REAL([KIND]=scalar-int-initialization-expr) from
2114 REAL(A,[KIND]) and REAL(KIND,A). */
2116 m
= gfc_match (" %n", name
);
2117 if (m
== MATCH_YES
&& strcmp (name
, "real") == 0)
2124 ts
->kind
= gfc_default_real_kind
;
2126 gfc_gobble_whitespace ();
2128 /* Prevent REAL*4, etc. */
2129 c
= gfc_peek_ascii_char ();
2132 gfc_error ("Invalid type-spec at %C");
2136 /* Found leading colon in REAL::, a trailing ')' in for example
2137 TYPE IS (REAL), or REAL, for an OpenMP list-item. */
2138 if (c
== ':' || c
== ')' || (flag_openmp
&& c
== ','))
2141 /* Found something other than the opening '(' in REAL(... */
2145 gfc_next_char (); /* Burn the '('. */
2147 /* Look for the optional KIND=. */
2148 where
= gfc_current_locus
;
2149 m
= gfc_match ("%n", name
);
2152 gfc_gobble_whitespace ();
2153 c
= gfc_next_char ();
2156 if (strcmp(name
, "a") == 0)
2158 else if (strcmp(name
, "kind") == 0)
2164 gfc_current_locus
= where
;
2167 gfc_current_locus
= where
;
2171 m
= gfc_match_init_expr (&e
);
2172 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
2175 /* If a comma appears, it is an intrinsic subprogram. */
2176 gfc_gobble_whitespace ();
2177 c
= gfc_peek_ascii_char ();
2184 /* If ')' appears, we have REAL(initialization-expr), here check for
2185 a scalar integer initialization-expr and valid kind parameter. */
2188 if (e
->ts
.type
!= BT_INTEGER
|| e
->rank
> 0)
2194 gfc_next_char (); /* Burn the ')'. */
2195 ts
->kind
= (int) mpz_get_si (e
->value
.integer
);
2196 if (gfc_validate_kind (BT_REAL
, ts
->kind
, true) == -1)
2198 gfc_error ("Invalid type-spec at %C");
2208 /* If a type is not matched, simply return MATCH_NO. */
2209 gfc_current_locus
= old_locus
;
2214 gfc_gobble_whitespace ();
2216 /* This prevents INTEGER*4, etc. */
2217 if (gfc_peek_ascii_char () == '*')
2219 gfc_error ("Invalid type-spec at %C");
2223 m
= gfc_match_kind_spec (ts
, false);
2225 /* No kind specifier found. */
2233 /******************** FORALL subroutines ********************/
2235 /* Free a list of FORALL iterators. */
2238 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
2240 gfc_forall_iterator
*next
;
2245 gfc_free_expr (iter
->var
);
2246 gfc_free_expr (iter
->start
);
2247 gfc_free_expr (iter
->end
);
2248 gfc_free_expr (iter
->stride
);
2255 /* Match an iterator as part of a FORALL statement. The format is:
2257 <var> = <start>:<end>[:<stride>]
2259 On MATCH_NO, the caller tests for the possibility that there is a
2260 scalar mask expression. */
2263 match_forall_iterator (gfc_forall_iterator
**result
)
2265 gfc_forall_iterator
*iter
;
2269 where
= gfc_current_locus
;
2270 iter
= XCNEW (gfc_forall_iterator
);
2272 m
= gfc_match_expr (&iter
->var
);
2276 if (gfc_match_char ('=') != MATCH_YES
2277 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
2283 m
= gfc_match_expr (&iter
->start
);
2287 if (gfc_match_char (':') != MATCH_YES
)
2290 m
= gfc_match_expr (&iter
->end
);
2293 if (m
== MATCH_ERROR
)
2296 if (gfc_match_char (':') == MATCH_NO
)
2297 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2300 m
= gfc_match_expr (&iter
->stride
);
2303 if (m
== MATCH_ERROR
)
2307 /* Mark the iteration variable's symbol as used as a FORALL index. */
2308 iter
->var
->symtree
->n
.sym
->forall_index
= true;
2314 gfc_error ("Syntax error in FORALL iterator at %C");
2319 gfc_current_locus
= where
;
2320 gfc_free_forall_iterator (iter
);
2325 /* Match the header of a FORALL statement. */
2328 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
2330 gfc_forall_iterator
*head
, *tail
, *new_iter
;
2334 gfc_gobble_whitespace ();
2339 if (gfc_match_char ('(') != MATCH_YES
)
2342 m
= match_forall_iterator (&new_iter
);
2343 if (m
== MATCH_ERROR
)
2348 head
= tail
= new_iter
;
2352 if (gfc_match_char (',') != MATCH_YES
)
2355 m
= match_forall_iterator (&new_iter
);
2356 if (m
== MATCH_ERROR
)
2361 tail
->next
= new_iter
;
2366 /* Have to have a mask expression. */
2368 m
= gfc_match_expr (&msk
);
2371 if (m
== MATCH_ERROR
)
2377 if (gfc_match_char (')') == MATCH_NO
)
2385 gfc_syntax_error (ST_FORALL
);
2388 gfc_free_expr (msk
);
2389 gfc_free_forall_iterator (head
);
2394 /* Match the rest of a simple FORALL statement that follows an
2398 match_simple_forall (void)
2400 gfc_forall_iterator
*head
;
2409 m
= match_forall_header (&head
, &mask
);
2416 m
= gfc_match_assignment ();
2418 if (m
== MATCH_ERROR
)
2422 m
= gfc_match_pointer_assignment ();
2423 if (m
== MATCH_ERROR
)
2429 c
= XCNEW (gfc_code
);
2431 c
->loc
= gfc_current_locus
;
2433 if (gfc_match_eos () != MATCH_YES
)
2436 gfc_clear_new_st ();
2437 new_st
.op
= EXEC_FORALL
;
2438 new_st
.expr1
= mask
;
2439 new_st
.ext
.forall_iterator
= head
;
2440 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2441 new_st
.block
->next
= c
;
2446 gfc_syntax_error (ST_FORALL
);
2449 gfc_free_forall_iterator (head
);
2450 gfc_free_expr (mask
);
2456 /* Match a FORALL statement. */
2459 gfc_match_forall (gfc_statement
*st
)
2461 gfc_forall_iterator
*head
;
2470 m0
= gfc_match_label ();
2471 if (m0
== MATCH_ERROR
)
2474 m
= gfc_match (" forall");
2478 m
= match_forall_header (&head
, &mask
);
2479 if (m
== MATCH_ERROR
)
2484 if (gfc_match_eos () == MATCH_YES
)
2486 *st
= ST_FORALL_BLOCK
;
2487 new_st
.op
= EXEC_FORALL
;
2488 new_st
.expr1
= mask
;
2489 new_st
.ext
.forall_iterator
= head
;
2493 m
= gfc_match_assignment ();
2494 if (m
== MATCH_ERROR
)
2498 m
= gfc_match_pointer_assignment ();
2499 if (m
== MATCH_ERROR
)
2505 c
= XCNEW (gfc_code
);
2507 c
->loc
= gfc_current_locus
;
2509 gfc_clear_new_st ();
2510 new_st
.op
= EXEC_FORALL
;
2511 new_st
.expr1
= mask
;
2512 new_st
.ext
.forall_iterator
= head
;
2513 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2514 new_st
.block
->next
= c
;
2520 gfc_syntax_error (ST_FORALL
);
2523 gfc_free_forall_iterator (head
);
2524 gfc_free_expr (mask
);
2525 gfc_free_statements (c
);
2530 /* Match a DO statement. */
2535 gfc_iterator iter
, *ip
;
2537 gfc_st_label
*label
;
2540 old_loc
= gfc_current_locus
;
2543 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
2545 m
= gfc_match_label ();
2546 if (m
== MATCH_ERROR
)
2549 if (gfc_match (" do") != MATCH_YES
)
2552 m
= gfc_match_st_label (&label
);
2553 if (m
== MATCH_ERROR
)
2556 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2558 if (gfc_match_eos () == MATCH_YES
)
2560 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
2561 new_st
.op
= EXEC_DO_WHILE
;
2565 /* Match an optional comma, if no comma is found, a space is obligatory. */
2566 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
2569 /* Check for balanced parens. */
2571 if (gfc_match_parens () == MATCH_ERROR
)
2574 if (gfc_match (" concurrent") == MATCH_YES
)
2576 gfc_forall_iterator
*head
;
2579 if (!gfc_notify_std (GFC_STD_F2008
, "DO CONCURRENT construct at %C"))
2585 m
= match_forall_header (&head
, &mask
);
2589 if (m
== MATCH_ERROR
)
2590 goto concurr_cleanup
;
2592 if (gfc_match_eos () != MATCH_YES
)
2593 goto concurr_cleanup
;
2596 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2597 goto concurr_cleanup
;
2599 new_st
.label1
= label
;
2600 new_st
.op
= EXEC_DO_CONCURRENT
;
2601 new_st
.expr1
= mask
;
2602 new_st
.ext
.forall_iterator
= head
;
2607 gfc_syntax_error (ST_DO
);
2608 gfc_free_expr (mask
);
2609 gfc_free_forall_iterator (head
);
2613 /* See if we have a DO WHILE. */
2614 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
2616 new_st
.op
= EXEC_DO_WHILE
;
2620 /* The abortive DO WHILE may have done something to the symbol
2621 table, so we start over. */
2622 gfc_undo_symbols ();
2623 gfc_current_locus
= old_loc
;
2625 gfc_match_label (); /* This won't error. */
2626 gfc_match (" do "); /* This will work. */
2628 gfc_match_st_label (&label
); /* Can't error out. */
2629 gfc_match_char (','); /* Optional comma. */
2631 m
= gfc_match_iterator (&iter
, 0);
2634 if (m
== MATCH_ERROR
)
2637 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
2638 gfc_check_do_variable (iter
.var
->symtree
);
2640 if (gfc_match_eos () != MATCH_YES
)
2642 gfc_syntax_error (ST_DO
);
2646 new_st
.op
= EXEC_DO
;
2650 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2653 new_st
.label1
= label
;
2655 if (new_st
.op
== EXEC_DO_WHILE
)
2656 new_st
.expr1
= iter
.end
;
2659 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
2666 gfc_free_iterator (&iter
, 0);
2672 /* Match an EXIT or CYCLE statement. */
2675 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2677 gfc_state_data
*p
, *o
;
2682 if (gfc_match_eos () == MATCH_YES
)
2686 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2689 m
= gfc_match ("% %n%t", name
);
2690 if (m
== MATCH_ERROR
)
2694 gfc_syntax_error (st
);
2698 /* Find the corresponding symbol. If there's a BLOCK statement
2699 between here and the label, it is not in gfc_current_ns but a parent
2701 stree
= gfc_find_symtree_in_proc (name
, gfc_current_ns
);
2704 gfc_error ("Name %qs in %s statement at %C is unknown",
2705 name
, gfc_ascii_statement (st
));
2710 if (sym
->attr
.flavor
!= FL_LABEL
)
2712 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2713 name
, gfc_ascii_statement (st
));
2718 /* Find the loop specified by the label (or lack of a label). */
2719 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2720 if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2722 else if (p
->state
== COMP_CRITICAL
)
2724 gfc_error("%s statement at %C leaves CRITICAL construct",
2725 gfc_ascii_statement (st
));
2728 else if (p
->state
== COMP_DO_CONCURRENT
2729 && (op
== EXEC_EXIT
|| (sym
&& sym
!= p
->sym
)))
2731 /* F2008, C821 & C845. */
2732 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2733 gfc_ascii_statement (st
));
2736 else if ((sym
&& sym
== p
->sym
)
2737 || (!sym
&& (p
->state
== COMP_DO
2738 || p
->state
== COMP_DO_CONCURRENT
)))
2744 gfc_error ("%s statement at %C is not within a construct",
2745 gfc_ascii_statement (st
));
2747 gfc_error ("%s statement at %C is not within construct %qs",
2748 gfc_ascii_statement (st
), sym
->name
);
2753 /* Special checks for EXIT from non-loop constructs. */
2757 case COMP_DO_CONCURRENT
:
2761 /* This is already handled above. */
2764 case COMP_ASSOCIATE
:
2768 case COMP_SELECT_TYPE
:
2770 if (op
== EXEC_CYCLE
)
2772 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2773 " construct %qs", sym
->name
);
2776 gcc_assert (op
== EXEC_EXIT
);
2777 if (!gfc_notify_std (GFC_STD_F2008
, "EXIT statement with no"
2778 " do-construct-name at %C"))
2783 gfc_error ("%s statement at %C is not applicable to construct %qs",
2784 gfc_ascii_statement (st
), sym
->name
);
2790 gfc_error (is_oacc (p
)
2791 ? G_("%s statement at %C leaving OpenACC structured block")
2792 : G_("%s statement at %C leaving OpenMP structured block"),
2793 gfc_ascii_statement (st
));
2797 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2801 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
2802 && (o
->head
->op
== EXEC_OACC_LOOP
2803 || o
->head
->op
== EXEC_OACC_PARALLEL_LOOP
))
2806 gcc_assert (o
->head
->next
!= NULL
2807 && (o
->head
->next
->op
== EXEC_DO
2808 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2809 && o
->previous
!= NULL
2810 && o
->previous
->tail
->op
== o
->head
->op
);
2811 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2812 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2813 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2814 if (st
== ST_EXIT
&& cnt
<= collapse
)
2816 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2819 if (st
== ST_CYCLE
&& cnt
< collapse
)
2821 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2822 " !$ACC LOOP loop");
2828 && (o
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2829 && (o
->head
->op
== EXEC_OMP_DO
2830 || o
->head
->op
== EXEC_OMP_PARALLEL_DO
2831 || o
->head
->op
== EXEC_OMP_SIMD
2832 || o
->head
->op
== EXEC_OMP_DO_SIMD
2833 || o
->head
->op
== EXEC_OMP_PARALLEL_DO_SIMD
))
2836 gcc_assert (o
->head
->next
!= NULL
2837 && (o
->head
->next
->op
== EXEC_DO
2838 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2839 && o
->previous
!= NULL
2840 && o
->previous
->tail
->op
== o
->head
->op
);
2841 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
)
2843 if (o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2844 count
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2845 if (o
->previous
->tail
->ext
.omp_clauses
->orderedc
)
2846 count
= o
->previous
->tail
->ext
.omp_clauses
->orderedc
;
2848 if (st
== ST_EXIT
&& cnt
<= count
)
2850 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2853 if (st
== ST_CYCLE
&& cnt
< count
)
2855 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2861 /* Save the first statement in the construct - needed by the backend. */
2862 new_st
.ext
.which_construct
= p
->construct
;
2870 /* Match the EXIT statement. */
2873 gfc_match_exit (void)
2875 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2879 /* Match the CYCLE statement. */
2882 gfc_match_cycle (void)
2884 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2888 /* Match a stop-code after an (ERROR) STOP or PAUSE statement. The
2889 requirements for a stop-code differ in the standards.
2893 R840 stop-stmt is STOP [ stop-code ]
2894 R841 stop-code is scalar-char-constant
2895 or digit [ digit [ digit [ digit [ digit ] ] ] ]
2897 Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
2900 R855 stop-stmt is STOP [ stop-code ]
2901 R856 allstop-stmt is ALL STOP [ stop-code ]
2902 R857 stop-code is scalar-default-char-constant-expr
2903 or scalar-int-constant-expr
2905 For free-form source code, all standards contain a statement of the form:
2907 A blank shall be used to separate names, constants, or labels from
2908 adjacent keywords, names, constants, or labels.
2910 A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003,
2914 is valid, but it is invalid Fortran 2008. */
2917 gfc_match_stopcode (gfc_statement st
)
2923 /* Set f95 for -std=f95. */
2924 f95
= gfc_option
.allow_std
== (GFC_STD_F95_OBS
| GFC_STD_F95
| GFC_STD_F77
2925 | GFC_STD_F2008_OBS
);
2927 /* Set f03 for -std=f2003. */
2928 f03
= gfc_option
.allow_std
== (GFC_STD_F95_OBS
| GFC_STD_F95
| GFC_STD_F77
2929 | GFC_STD_F2008_OBS
| GFC_STD_F2003
);
2931 /* Look for a blank between STOP and the stop-code for F2008 or later. */
2932 if (gfc_current_form
!= FORM_FIXED
&& !(f95
|| f03
))
2934 char c
= gfc_peek_ascii_char ();
2936 /* Look for end-of-statement. There is no stop-code. */
2937 if (c
== '\n' || c
== '!' || c
== ';')
2942 gfc_error ("Blank required in %s statement near %C",
2943 gfc_ascii_statement (st
));
2948 if (gfc_match_eos () != MATCH_YES
)
2953 /* First look for the F95 or F2003 digit [...] construct. */
2954 old_locus
= gfc_current_locus
;
2955 m
= gfc_match_small_int (&stopcode
);
2956 if (m
== MATCH_YES
&& (f95
|| f03
))
2960 gfc_error ("STOP code at %C cannot be negative");
2964 if (stopcode
> 99999)
2966 gfc_error ("STOP code at %C contains too many digits");
2971 /* Reset the locus and now load gfc_expr. */
2972 gfc_current_locus
= old_locus
;
2973 m
= gfc_match_expr (&e
);
2974 if (m
== MATCH_ERROR
)
2979 if (gfc_match_eos () != MATCH_YES
)
2983 if (gfc_pure (NULL
))
2985 if (st
== ST_ERROR_STOP
)
2987 if (!gfc_notify_std (GFC_STD_F2015
, "%s statement at %C in PURE "
2988 "procedure", gfc_ascii_statement (st
)))
2993 gfc_error ("%s statement not allowed in PURE procedure at %C",
2994 gfc_ascii_statement (st
));
2999 gfc_unset_implicit_pure (NULL
);
3001 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
))
3003 gfc_error ("Image control statement STOP at %C in CRITICAL block");
3006 if (st
== ST_STOP
&& gfc_find_state (COMP_DO_CONCURRENT
))
3008 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
3014 gfc_simplify_expr (e
, 0);
3016 /* Test for F95 and F2003 style STOP stop-code. */
3017 if (e
->expr_type
!= EXPR_CONSTANT
&& (f95
|| f03
))
3019 gfc_error ("STOP code at %L must be a scalar CHARACTER constant or "
3020 "digit[digit[digit[digit[digit]]]]", &e
->where
);
3024 /* Use the machinery for an initialization expression to reduce the
3025 stop-code to a constant. */
3026 gfc_init_expr_flag
= true;
3027 gfc_reduce_init_expr (e
);
3028 gfc_init_expr_flag
= false;
3030 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
3032 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
3039 gfc_error ("STOP code at %L must be scalar", &e
->where
);
3043 if (e
->ts
.type
== BT_CHARACTER
3044 && e
->ts
.kind
!= gfc_default_character_kind
)
3046 gfc_error ("STOP code at %L must be default character KIND=%d",
3047 &e
->where
, (int) gfc_default_character_kind
);
3051 if (e
->ts
.type
== BT_INTEGER
&& e
->ts
.kind
!= gfc_default_integer_kind
)
3053 gfc_error ("STOP code at %L must be default integer KIND=%d",
3054 &e
->where
, (int) gfc_default_integer_kind
);
3064 new_st
.op
= EXEC_STOP
;
3067 new_st
.op
= EXEC_ERROR_STOP
;
3070 new_st
.op
= EXEC_PAUSE
;
3077 new_st
.ext
.stop_code
= -1;
3082 gfc_syntax_error (st
);
3091 /* Match the (deprecated) PAUSE statement. */
3094 gfc_match_pause (void)
3098 m
= gfc_match_stopcode (ST_PAUSE
);
3101 if (!gfc_notify_std (GFC_STD_F95_DEL
, "PAUSE statement at %C"))
3108 /* Match the STOP statement. */
3111 gfc_match_stop (void)
3113 return gfc_match_stopcode (ST_STOP
);
3117 /* Match the ERROR STOP statement. */
3120 gfc_match_error_stop (void)
3122 if (!gfc_notify_std (GFC_STD_F2008
, "ERROR STOP statement at %C"))
3125 return gfc_match_stopcode (ST_ERROR_STOP
);
3128 /* Match EVENT POST/WAIT statement. Syntax:
3129 EVENT POST ( event-variable [, sync-stat-list] )
3130 EVENT WAIT ( event-variable [, wait-spec-list] )
3132 wait-spec-list is sync-stat-list or until-spec
3133 until-spec is UNTIL_COUNT = scalar-int-expr
3134 sync-stat is STAT= or ERRMSG=. */
3137 event_statement (gfc_statement st
)
3140 gfc_expr
*tmp
, *eventvar
, *until_count
, *stat
, *errmsg
;
3141 bool saw_until_count
, saw_stat
, saw_errmsg
;
3143 tmp
= eventvar
= until_count
= stat
= errmsg
= NULL
;
3144 saw_until_count
= saw_stat
= saw_errmsg
= false;
3146 if (gfc_pure (NULL
))
3148 gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
3149 st
== ST_EVENT_POST
? "POST" : "WAIT");
3153 gfc_unset_implicit_pure (NULL
);
3155 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3157 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3161 if (gfc_find_state (COMP_CRITICAL
))
3163 gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
3164 st
== ST_EVENT_POST
? "POST" : "WAIT");
3168 if (gfc_find_state (COMP_DO_CONCURRENT
))
3170 gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
3171 "block", st
== ST_EVENT_POST
? "POST" : "WAIT");
3175 if (gfc_match_char ('(') != MATCH_YES
)
3178 if (gfc_match ("%e", &eventvar
) != MATCH_YES
)
3180 m
= gfc_match_char (',');
3181 if (m
== MATCH_ERROR
)
3185 m
= gfc_match_char (')');
3193 m
= gfc_match (" stat = %v", &tmp
);
3194 if (m
== MATCH_ERROR
)
3200 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3206 m
= gfc_match_char (',');
3214 m
= gfc_match (" errmsg = %v", &tmp
);
3215 if (m
== MATCH_ERROR
)
3221 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3227 m
= gfc_match_char (',');
3235 m
= gfc_match (" until_count = %e", &tmp
);
3236 if (m
== MATCH_ERROR
|| st
== ST_EVENT_POST
)
3240 if (saw_until_count
)
3242 gfc_error ("Redundant UNTIL_COUNT tag found at %L",
3247 saw_until_count
= true;
3249 m
= gfc_match_char (',');
3260 if (m
== MATCH_ERROR
)
3263 if (gfc_match (" )%t") != MATCH_YES
)
3270 new_st
.op
= EXEC_EVENT_POST
;
3273 new_st
.op
= EXEC_EVENT_WAIT
;
3279 new_st
.expr1
= eventvar
;
3280 new_st
.expr2
= stat
;
3281 new_st
.expr3
= errmsg
;
3282 new_st
.expr4
= until_count
;
3287 gfc_syntax_error (st
);
3290 if (until_count
!= tmp
)
3291 gfc_free_expr (until_count
);
3293 gfc_free_expr (errmsg
);
3295 gfc_free_expr (stat
);
3297 gfc_free_expr (tmp
);
3298 gfc_free_expr (eventvar
);
3306 gfc_match_event_post (void)
3308 if (!gfc_notify_std (GFC_STD_F2008_TS
, "EVENT POST statement at %C"))
3311 return event_statement (ST_EVENT_POST
);
3316 gfc_match_event_wait (void)
3318 if (!gfc_notify_std (GFC_STD_F2008_TS
, "EVENT WAIT statement at %C"))
3321 return event_statement (ST_EVENT_WAIT
);
3325 /* Match a FAIL IMAGE statement. */
3328 gfc_match_fail_image (void)
3330 if (!gfc_notify_std (GFC_STD_F2008_TS
, "FAIL IMAGE statement at %C"))
3333 if (gfc_match_char ('(') == MATCH_YES
)
3336 new_st
.op
= EXEC_FAIL_IMAGE
;
3341 gfc_syntax_error (ST_FAIL_IMAGE
);
3347 /* Match LOCK/UNLOCK statement. Syntax:
3348 LOCK ( lock-variable [ , lock-stat-list ] )
3349 UNLOCK ( lock-variable [ , sync-stat-list ] )
3350 where lock-stat is ACQUIRED_LOCK or sync-stat
3351 and sync-stat is STAT= or ERRMSG=. */
3354 lock_unlock_statement (gfc_statement st
)
3357 gfc_expr
*tmp
, *lockvar
, *acq_lock
, *stat
, *errmsg
;
3358 bool saw_acq_lock
, saw_stat
, saw_errmsg
;
3360 tmp
= lockvar
= acq_lock
= stat
= errmsg
= NULL
;
3361 saw_acq_lock
= saw_stat
= saw_errmsg
= false;
3363 if (gfc_pure (NULL
))
3365 gfc_error ("Image control statement %s at %C in PURE procedure",
3366 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3370 gfc_unset_implicit_pure (NULL
);
3372 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3374 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3378 if (gfc_find_state (COMP_CRITICAL
))
3380 gfc_error ("Image control statement %s at %C in CRITICAL block",
3381 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3385 if (gfc_find_state (COMP_DO_CONCURRENT
))
3387 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
3388 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3392 if (gfc_match_char ('(') != MATCH_YES
)
3395 if (gfc_match ("%e", &lockvar
) != MATCH_YES
)
3397 m
= gfc_match_char (',');
3398 if (m
== MATCH_ERROR
)
3402 m
= gfc_match_char (')');
3410 m
= gfc_match (" stat = %v", &tmp
);
3411 if (m
== MATCH_ERROR
)
3417 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3423 m
= gfc_match_char (',');
3431 m
= gfc_match (" errmsg = %v", &tmp
);
3432 if (m
== MATCH_ERROR
)
3438 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3444 m
= gfc_match_char (',');
3452 m
= gfc_match (" acquired_lock = %v", &tmp
);
3453 if (m
== MATCH_ERROR
|| st
== ST_UNLOCK
)
3459 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L",
3464 saw_acq_lock
= true;
3466 m
= gfc_match_char (',');
3477 if (m
== MATCH_ERROR
)
3480 if (gfc_match (" )%t") != MATCH_YES
)
3487 new_st
.op
= EXEC_LOCK
;
3490 new_st
.op
= EXEC_UNLOCK
;
3496 new_st
.expr1
= lockvar
;
3497 new_st
.expr2
= stat
;
3498 new_st
.expr3
= errmsg
;
3499 new_st
.expr4
= acq_lock
;
3504 gfc_syntax_error (st
);
3507 if (acq_lock
!= tmp
)
3508 gfc_free_expr (acq_lock
);
3510 gfc_free_expr (errmsg
);
3512 gfc_free_expr (stat
);
3514 gfc_free_expr (tmp
);
3515 gfc_free_expr (lockvar
);
3522 gfc_match_lock (void)
3524 if (!gfc_notify_std (GFC_STD_F2008
, "LOCK statement at %C"))
3527 return lock_unlock_statement (ST_LOCK
);
3532 gfc_match_unlock (void)
3534 if (!gfc_notify_std (GFC_STD_F2008
, "UNLOCK statement at %C"))
3537 return lock_unlock_statement (ST_UNLOCK
);
3541 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
3542 SYNC ALL [(sync-stat-list)]
3543 SYNC MEMORY [(sync-stat-list)]
3544 SYNC IMAGES (image-set [, sync-stat-list] )
3545 with sync-stat is int-expr or *. */
3548 sync_statement (gfc_statement st
)
3551 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
3552 bool saw_stat
, saw_errmsg
;
3554 tmp
= imageset
= stat
= errmsg
= NULL
;
3555 saw_stat
= saw_errmsg
= false;
3557 if (gfc_pure (NULL
))
3559 gfc_error ("Image control statement SYNC at %C in PURE procedure");
3563 gfc_unset_implicit_pure (NULL
);
3565 if (!gfc_notify_std (GFC_STD_F2008
, "SYNC statement at %C"))
3568 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3570 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
3575 if (gfc_find_state (COMP_CRITICAL
))
3577 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3581 if (gfc_find_state (COMP_DO_CONCURRENT
))
3583 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3587 if (gfc_match_eos () == MATCH_YES
)
3589 if (st
== ST_SYNC_IMAGES
)
3594 if (gfc_match_char ('(') != MATCH_YES
)
3597 if (st
== ST_SYNC_IMAGES
)
3599 /* Denote '*' as imageset == NULL. */
3600 m
= gfc_match_char ('*');
3601 if (m
== MATCH_ERROR
)
3605 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
3608 m
= gfc_match_char (',');
3609 if (m
== MATCH_ERROR
)
3613 m
= gfc_match_char (')');
3622 m
= gfc_match (" stat = %v", &tmp
);
3623 if (m
== MATCH_ERROR
)
3629 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
3635 if (gfc_match_char (',') == MATCH_YES
)
3642 m
= gfc_match (" errmsg = %v", &tmp
);
3643 if (m
== MATCH_ERROR
)
3649 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
3655 if (gfc_match_char (',') == MATCH_YES
)
3665 if (gfc_match (" )%t") != MATCH_YES
)
3672 new_st
.op
= EXEC_SYNC_ALL
;
3674 case ST_SYNC_IMAGES
:
3675 new_st
.op
= EXEC_SYNC_IMAGES
;
3677 case ST_SYNC_MEMORY
:
3678 new_st
.op
= EXEC_SYNC_MEMORY
;
3684 new_st
.expr1
= imageset
;
3685 new_st
.expr2
= stat
;
3686 new_st
.expr3
= errmsg
;
3691 gfc_syntax_error (st
);
3695 gfc_free_expr (stat
);
3697 gfc_free_expr (errmsg
);
3699 gfc_free_expr (tmp
);
3700 gfc_free_expr (imageset
);
3706 /* Match SYNC ALL statement. */
3709 gfc_match_sync_all (void)
3711 return sync_statement (ST_SYNC_ALL
);
3715 /* Match SYNC IMAGES statement. */
3718 gfc_match_sync_images (void)
3720 return sync_statement (ST_SYNC_IMAGES
);
3724 /* Match SYNC MEMORY statement. */
3727 gfc_match_sync_memory (void)
3729 return sync_statement (ST_SYNC_MEMORY
);
3733 /* Match a CONTINUE statement. */
3736 gfc_match_continue (void)
3738 if (gfc_match_eos () != MATCH_YES
)
3740 gfc_syntax_error (ST_CONTINUE
);
3744 new_st
.op
= EXEC_CONTINUE
;
3749 /* Match the (deprecated) ASSIGN statement. */
3752 gfc_match_assign (void)
3755 gfc_st_label
*label
;
3757 if (gfc_match (" %l", &label
) == MATCH_YES
)
3759 if (!gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
))
3761 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
3763 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGN statement at %C"))
3766 expr
->symtree
->n
.sym
->attr
.assign
= 1;
3768 new_st
.op
= EXEC_LABEL_ASSIGN
;
3769 new_st
.label1
= label
;
3770 new_st
.expr1
= expr
;
3778 /* Match the GO TO statement. As a computed GOTO statement is
3779 matched, it is transformed into an equivalent SELECT block. No
3780 tree is necessary, and the resulting jumps-to-jumps are
3781 specifically optimized away by the back end. */
3784 gfc_match_goto (void)
3786 gfc_code
*head
, *tail
;
3789 gfc_st_label
*label
;
3793 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
3795 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3798 new_st
.op
= EXEC_GOTO
;
3799 new_st
.label1
= label
;
3803 /* The assigned GO TO statement. */
3805 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
3807 if (!gfc_notify_std (GFC_STD_F95_DEL
, "Assigned GOTO statement at %C"))
3810 new_st
.op
= EXEC_GOTO
;
3811 new_st
.expr1
= expr
;
3813 if (gfc_match_eos () == MATCH_YES
)
3816 /* Match label list. */
3817 gfc_match_char (',');
3818 if (gfc_match_char ('(') != MATCH_YES
)
3820 gfc_syntax_error (ST_GOTO
);
3827 m
= gfc_match_st_label (&label
);
3831 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3835 head
= tail
= gfc_get_code (EXEC_GOTO
);
3838 tail
->block
= gfc_get_code (EXEC_GOTO
);
3842 tail
->label1
= label
;
3844 while (gfc_match_char (',') == MATCH_YES
);
3846 if (gfc_match (")%t") != MATCH_YES
)
3851 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3854 new_st
.block
= head
;
3859 /* Last chance is a computed GO TO statement. */
3860 if (gfc_match_char ('(') != MATCH_YES
)
3862 gfc_syntax_error (ST_GOTO
);
3871 m
= gfc_match_st_label (&label
);
3875 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3879 head
= tail
= gfc_get_code (EXEC_SELECT
);
3882 tail
->block
= gfc_get_code (EXEC_SELECT
);
3886 cp
= gfc_get_case ();
3887 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
3890 tail
->ext
.block
.case_list
= cp
;
3892 tail
->next
= gfc_get_code (EXEC_GOTO
);
3893 tail
->next
->label1
= label
;
3895 while (gfc_match_char (',') == MATCH_YES
);
3897 if (gfc_match_char (')') != MATCH_YES
)
3902 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3906 /* Get the rest of the statement. */
3907 gfc_match_char (',');
3909 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
3912 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Computed GOTO at %C"))
3915 /* At this point, a computed GOTO has been fully matched and an
3916 equivalent SELECT statement constructed. */
3918 new_st
.op
= EXEC_SELECT
;
3919 new_st
.expr1
= NULL
;
3921 /* Hack: For a "real" SELECT, the expression is in expr. We put
3922 it in expr2 so we can distinguish then and produce the correct
3924 new_st
.expr2
= expr
;
3925 new_st
.block
= head
;
3929 gfc_syntax_error (ST_GOTO
);
3931 gfc_free_statements (head
);
3936 /* Frees a list of gfc_alloc structures. */
3939 gfc_free_alloc_list (gfc_alloc
*p
)
3946 gfc_free_expr (p
->expr
);
3952 /* Match an ALLOCATE statement. */
3955 gfc_match_allocate (void)
3957 gfc_alloc
*head
, *tail
;
3958 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
3962 locus old_locus
, deferred_locus
;
3963 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, saw_deferred
, b1
, b2
, b3
;
3964 bool saw_unlimited
= false;
3967 stat
= errmsg
= source
= mold
= tmp
= NULL
;
3968 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= saw_deferred
= false;
3970 if (gfc_match_char ('(') != MATCH_YES
)
3972 gfc_syntax_error (ST_ALLOCATE
);
3976 /* Match an optional type-spec. */
3977 old_locus
= gfc_current_locus
;
3978 m
= gfc_match_type_spec (&ts
);
3979 if (m
== MATCH_ERROR
)
3981 else if (m
== MATCH_NO
)
3983 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
3985 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
3987 gfc_error ("Error in type-spec at %L", &old_locus
);
3991 ts
.type
= BT_UNKNOWN
;
3995 if (gfc_match (" :: ") == MATCH_YES
)
3997 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
4003 gfc_error ("Type-spec at %L cannot contain a deferred "
4004 "type parameter", &old_locus
);
4008 if (ts
.type
== BT_CHARACTER
)
4009 ts
.u
.cl
->length_from_typespec
= true;
4011 /* TODO understand why this error does not appear but, instead,
4012 the derived type is caught as a variable in primary.c. */
4013 if (gfc_spec_list_type (type_param_spec_list
, NULL
) != SPEC_EXPLICIT
)
4015 gfc_error ("The type parameter spec list in the type-spec at "
4016 "%L cannot contain ASSUMED or DEFERRED parameters",
4023 ts
.type
= BT_UNKNOWN
;
4024 gfc_current_locus
= old_locus
;
4031 head
= tail
= gfc_get_alloc ();
4034 tail
->next
= gfc_get_alloc ();
4038 m
= gfc_match_variable (&tail
->expr
, 0);
4041 if (m
== MATCH_ERROR
)
4044 if (gfc_check_do_variable (tail
->expr
->symtree
))
4047 bool impure
= gfc_impure_variable (tail
->expr
->symtree
->n
.sym
);
4048 if (impure
&& gfc_pure (NULL
))
4050 gfc_error ("Bad allocate-object at %C for a PURE procedure");
4055 gfc_unset_implicit_pure (NULL
);
4057 if (tail
->expr
->ts
.deferred
)
4059 saw_deferred
= true;
4060 deferred_locus
= tail
->expr
->where
;
4063 if (gfc_find_state (COMP_DO_CONCURRENT
)
4064 || gfc_find_state (COMP_CRITICAL
))
4067 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
4068 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
4069 if (ref
->type
== REF_COMPONENT
)
4070 coarray
= ref
->u
.c
.component
->attr
.codimension
;
4072 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
4074 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
4077 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
4079 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
4084 /* Check for F08:C628. */
4085 sym
= tail
->expr
->symtree
->n
.sym
;
4086 b1
= !(tail
->expr
->ref
4087 && (tail
->expr
->ref
->type
== REF_COMPONENT
4088 || tail
->expr
->ref
->type
== REF_ARRAY
));
4089 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4090 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
4091 || CLASS_DATA (sym
)->attr
.class_pointer
);
4093 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4094 || sym
->attr
.proc_pointer
);
4095 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
4096 && (sym
->ns
->proc_name
->attr
.allocatable
4097 || sym
->ns
->proc_name
->attr
.pointer
4098 || sym
->ns
->proc_name
->attr
.proc_pointer
);
4099 if (b1
&& b2
&& !b3
)
4101 gfc_error ("Allocate-object at %L is neither a data pointer "
4102 "nor an allocatable variable", &tail
->expr
->where
);
4106 /* The ALLOCATE statement had an optional typespec. Check the
4108 if (ts
.type
!= BT_UNKNOWN
)
4110 /* Enforce F03:C624. */
4111 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
4113 gfc_error ("Type of entity at %L is type incompatible with "
4114 "typespec", &tail
->expr
->where
);
4118 /* Enforce F03:C627. */
4119 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
4121 gfc_error ("Kind type parameter for entity at %L differs from "
4122 "the kind type parameter of the typespec",
4123 &tail
->expr
->where
);
4128 if (tail
->expr
->ts
.type
== BT_DERIVED
)
4129 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
4131 if (type_param_spec_list
)
4132 tail
->expr
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
4134 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
4136 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
4138 gfc_error ("Shape specification for allocatable scalar at %C");
4142 if (gfc_match_char (',') != MATCH_YES
)
4147 m
= gfc_match (" stat = %v", &tmp
);
4148 if (m
== MATCH_ERROR
)
4155 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4163 if (gfc_check_do_variable (stat
->symtree
))
4166 if (gfc_match_char (',') == MATCH_YES
)
4167 goto alloc_opt_list
;
4170 m
= gfc_match (" errmsg = %v", &tmp
);
4171 if (m
== MATCH_ERROR
)
4175 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
4181 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4189 if (gfc_match_char (',') == MATCH_YES
)
4190 goto alloc_opt_list
;
4193 m
= gfc_match (" source = %e", &tmp
);
4194 if (m
== MATCH_ERROR
)
4198 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
4204 gfc_error ("Redundant SOURCE tag found at %L", &tmp
->where
);
4208 /* The next 2 conditionals check C631. */
4209 if (ts
.type
!= BT_UNKNOWN
)
4211 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
4212 &tmp
->where
, &old_locus
);
4217 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
4218 " with more than a single allocate object",
4226 if (gfc_match_char (',') == MATCH_YES
)
4227 goto alloc_opt_list
;
4230 m
= gfc_match (" mold = %e", &tmp
);
4231 if (m
== MATCH_ERROR
)
4235 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
4238 /* Check F08:C636. */
4241 gfc_error ("Redundant MOLD tag found at %L", &tmp
->where
);
4245 /* Check F08:C637. */
4246 if (ts
.type
!= BT_UNKNOWN
)
4248 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
4249 &tmp
->where
, &old_locus
);
4258 if (gfc_match_char (',') == MATCH_YES
)
4259 goto alloc_opt_list
;
4262 gfc_gobble_whitespace ();
4264 if (gfc_peek_char () == ')')
4268 if (gfc_match (" )%t") != MATCH_YES
)
4271 /* Check F08:C637. */
4274 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
4275 &mold
->where
, &source
->where
);
4279 /* Check F03:C623, */
4280 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4282 gfc_error ("Allocate-object at %L with a deferred type parameter "
4283 "requires either a type-spec or SOURCE tag or a MOLD tag",
4288 /* Check F03:C625, */
4289 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4291 for (tail
= head
; tail
; tail
= tail
->next
)
4293 if (UNLIMITED_POLY (tail
->expr
))
4294 gfc_error ("Unlimited polymorphic allocate-object at %L "
4295 "requires either a type-spec or SOURCE tag "
4296 "or a MOLD tag", &tail
->expr
->where
);
4301 new_st
.op
= EXEC_ALLOCATE
;
4302 new_st
.expr1
= stat
;
4303 new_st
.expr2
= errmsg
;
4305 new_st
.expr3
= source
;
4307 new_st
.expr3
= mold
;
4308 new_st
.ext
.alloc
.list
= head
;
4309 new_st
.ext
.alloc
.ts
= ts
;
4311 if (type_param_spec_list
)
4312 gfc_free_actual_arglist (type_param_spec_list
);
4317 gfc_syntax_error (ST_ALLOCATE
);
4320 gfc_free_expr (errmsg
);
4321 gfc_free_expr (source
);
4322 gfc_free_expr (stat
);
4323 gfc_free_expr (mold
);
4324 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
4325 gfc_free_alloc_list (head
);
4326 if (type_param_spec_list
)
4327 gfc_free_actual_arglist (type_param_spec_list
);
4332 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
4333 a set of pointer assignments to intrinsic NULL(). */
4336 gfc_match_nullify (void)
4344 if (gfc_match_char ('(') != MATCH_YES
)
4349 m
= gfc_match_variable (&p
, 0);
4350 if (m
== MATCH_ERROR
)
4355 if (gfc_check_do_variable (p
->symtree
))
4359 if (gfc_is_coindexed (p
))
4361 gfc_error ("Pointer object at %C shall not be coindexed");
4365 /* build ' => NULL() '. */
4366 e
= gfc_get_null_expr (&gfc_current_locus
);
4368 /* Chain to list. */
4372 tail
->op
= EXEC_POINTER_ASSIGN
;
4376 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
4383 if (gfc_match (" )%t") == MATCH_YES
)
4385 if (gfc_match_char (',') != MATCH_YES
)
4392 gfc_syntax_error (ST_NULLIFY
);
4395 gfc_free_statements (new_st
.next
);
4397 gfc_free_expr (new_st
.expr1
);
4398 new_st
.expr1
= NULL
;
4399 gfc_free_expr (new_st
.expr2
);
4400 new_st
.expr2
= NULL
;
4405 /* Match a DEALLOCATE statement. */
4408 gfc_match_deallocate (void)
4410 gfc_alloc
*head
, *tail
;
4411 gfc_expr
*stat
, *errmsg
, *tmp
;
4414 bool saw_stat
, saw_errmsg
, b1
, b2
;
4417 stat
= errmsg
= tmp
= NULL
;
4418 saw_stat
= saw_errmsg
= false;
4420 if (gfc_match_char ('(') != MATCH_YES
)
4426 head
= tail
= gfc_get_alloc ();
4429 tail
->next
= gfc_get_alloc ();
4433 m
= gfc_match_variable (&tail
->expr
, 0);
4434 if (m
== MATCH_ERROR
)
4439 if (gfc_check_do_variable (tail
->expr
->symtree
))
4442 sym
= tail
->expr
->symtree
->n
.sym
;
4444 bool impure
= gfc_impure_variable (sym
);
4445 if (impure
&& gfc_pure (NULL
))
4447 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
4452 gfc_unset_implicit_pure (NULL
);
4454 if (gfc_is_coarray (tail
->expr
)
4455 && gfc_find_state (COMP_DO_CONCURRENT
))
4457 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
4461 if (gfc_is_coarray (tail
->expr
)
4462 && gfc_find_state (COMP_CRITICAL
))
4464 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
4468 /* FIXME: disable the checking on derived types. */
4469 b1
= !(tail
->expr
->ref
4470 && (tail
->expr
->ref
->type
== REF_COMPONENT
4471 || tail
->expr
->ref
->type
== REF_ARRAY
));
4472 if (sym
&& sym
->ts
.type
== BT_CLASS
)
4473 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
4474 || CLASS_DATA (sym
)->attr
.class_pointer
);
4476 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4477 || sym
->attr
.proc_pointer
);
4480 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
4481 "nor an allocatable variable");
4485 if (gfc_match_char (',') != MATCH_YES
)
4490 m
= gfc_match (" stat = %v", &tmp
);
4491 if (m
== MATCH_ERROR
)
4497 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4498 gfc_free_expr (tmp
);
4505 if (gfc_check_do_variable (stat
->symtree
))
4508 if (gfc_match_char (',') == MATCH_YES
)
4509 goto dealloc_opt_list
;
4512 m
= gfc_match (" errmsg = %v", &tmp
);
4513 if (m
== MATCH_ERROR
)
4517 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
4522 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4523 gfc_free_expr (tmp
);
4530 if (gfc_match_char (',') == MATCH_YES
)
4531 goto dealloc_opt_list
;
4534 gfc_gobble_whitespace ();
4536 if (gfc_peek_char () == ')')
4540 if (gfc_match (" )%t") != MATCH_YES
)
4543 new_st
.op
= EXEC_DEALLOCATE
;
4544 new_st
.expr1
= stat
;
4545 new_st
.expr2
= errmsg
;
4546 new_st
.ext
.alloc
.list
= head
;
4551 gfc_syntax_error (ST_DEALLOCATE
);
4554 gfc_free_expr (errmsg
);
4555 gfc_free_expr (stat
);
4556 gfc_free_alloc_list (head
);
4561 /* Match a RETURN statement. */
4564 gfc_match_return (void)
4568 gfc_compile_state s
;
4572 if (gfc_find_state (COMP_CRITICAL
))
4574 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4578 if (gfc_find_state (COMP_DO_CONCURRENT
))
4580 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4584 if (gfc_match_eos () == MATCH_YES
)
4587 if (!gfc_find_state (COMP_SUBROUTINE
))
4589 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4594 if (gfc_current_form
== FORM_FREE
)
4596 /* The following are valid, so we can't require a blank after the
4600 char c
= gfc_peek_ascii_char ();
4601 if (ISALPHA (c
) || ISDIGIT (c
))
4605 m
= gfc_match (" %e%t", &e
);
4608 if (m
== MATCH_ERROR
)
4611 gfc_syntax_error (ST_RETURN
);
4618 gfc_enclosing_unit (&s
);
4619 if (s
== COMP_PROGRAM
4620 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
4621 "main program at %C"))
4624 new_st
.op
= EXEC_RETURN
;
4631 /* Match the call of a type-bound procedure, if CALL%var has already been
4632 matched and var found to be a derived-type variable. */
4635 match_typebound_call (gfc_symtree
* varst
)
4640 base
= gfc_get_expr ();
4641 base
->expr_type
= EXPR_VARIABLE
;
4642 base
->symtree
= varst
;
4643 base
->where
= gfc_current_locus
;
4644 gfc_set_sym_referenced (varst
->n
.sym
);
4646 m
= gfc_match_varspec (base
, 0, true, true);
4648 gfc_error ("Expected component reference at %C");
4651 gfc_free_expr (base
);
4655 if (gfc_match_eos () != MATCH_YES
)
4657 gfc_error ("Junk after CALL at %C");
4658 gfc_free_expr (base
);
4662 if (base
->expr_type
== EXPR_COMPCALL
)
4663 new_st
.op
= EXEC_COMPCALL
;
4664 else if (base
->expr_type
== EXPR_PPC
)
4665 new_st
.op
= EXEC_CALL_PPC
;
4668 gfc_error ("Expected type-bound procedure or procedure pointer component "
4670 gfc_free_expr (base
);
4673 new_st
.expr1
= base
;
4679 /* Match a CALL statement. The tricky part here are possible
4680 alternate return specifiers. We handle these by having all
4681 "subroutines" actually return an integer via a register that gives
4682 the return number. If the call specifies alternate returns, we
4683 generate code for a SELECT statement whose case clauses contain
4684 GOTOs to the various labels. */
4687 gfc_match_call (void)
4689 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4690 gfc_actual_arglist
*a
, *arglist
;
4700 m
= gfc_match ("% %n", name
);
4706 if (gfc_get_ha_sym_tree (name
, &st
))
4711 /* If this is a variable of derived-type, it probably starts a type-bound
4713 if ((sym
->attr
.flavor
!= FL_PROCEDURE
4714 || gfc_is_function_return_value (sym
, gfc_current_ns
))
4715 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
4716 return match_typebound_call (st
);
4718 /* If it does not seem to be callable (include functions so that the
4719 right association is made. They are thrown out in resolution.)
4721 if (!sym
->attr
.generic
4722 && !sym
->attr
.subroutine
4723 && !sym
->attr
.function
)
4725 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
4727 /* ...create a symbol in this scope... */
4728 if (sym
->ns
!= gfc_current_ns
4729 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
4732 if (sym
!= st
->n
.sym
)
4736 /* ...and then to try to make the symbol into a subroutine. */
4737 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
4741 gfc_set_sym_referenced (sym
);
4743 if (gfc_match_eos () != MATCH_YES
)
4745 m
= gfc_match_actual_arglist (1, &arglist
);
4748 if (m
== MATCH_ERROR
)
4751 if (gfc_match_eos () != MATCH_YES
)
4755 /* If any alternate return labels were found, construct a SELECT
4756 statement that will jump to the right place. */
4759 for (a
= arglist
; a
; a
= a
->next
)
4760 if (a
->expr
== NULL
)
4768 gfc_symtree
*select_st
;
4769 gfc_symbol
*select_sym
;
4770 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4772 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
4773 sprintf (name
, "_result_%s", sym
->name
);
4774 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
4776 select_sym
= select_st
->n
.sym
;
4777 select_sym
->ts
.type
= BT_INTEGER
;
4778 select_sym
->ts
.kind
= gfc_default_integer_kind
;
4779 gfc_set_sym_referenced (select_sym
);
4780 c
->expr1
= gfc_get_expr ();
4781 c
->expr1
->expr_type
= EXPR_VARIABLE
;
4782 c
->expr1
->symtree
= select_st
;
4783 c
->expr1
->ts
= select_sym
->ts
;
4784 c
->expr1
->where
= gfc_current_locus
;
4787 for (a
= arglist
; a
; a
= a
->next
)
4789 if (a
->expr
!= NULL
)
4792 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
4797 c
->block
= gfc_get_code (EXEC_SELECT
);
4800 new_case
= gfc_get_case ();
4801 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
4802 new_case
->low
= new_case
->high
;
4803 c
->ext
.block
.case_list
= new_case
;
4805 c
->next
= gfc_get_code (EXEC_GOTO
);
4806 c
->next
->label1
= a
->label
;
4810 new_st
.op
= EXEC_CALL
;
4811 new_st
.symtree
= st
;
4812 new_st
.ext
.actual
= arglist
;
4817 gfc_syntax_error (ST_CALL
);
4820 gfc_free_actual_arglist (arglist
);
4825 /* Given a name, return a pointer to the common head structure,
4826 creating it if it does not exist. If FROM_MODULE is nonzero, we
4827 mangle the name so that it doesn't interfere with commons defined
4828 in the using namespace.
4829 TODO: Add to global symbol tree. */
4832 gfc_get_common (const char *name
, int from_module
)
4835 static int serial
= 0;
4836 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
4840 /* A use associated common block is only needed to correctly layout
4841 the variables it contains. */
4842 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
4843 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
4847 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
4850 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
4853 if (st
->n
.common
== NULL
)
4855 st
->n
.common
= gfc_get_common_head ();
4856 st
->n
.common
->where
= gfc_current_locus
;
4857 strcpy (st
->n
.common
->name
, name
);
4860 return st
->n
.common
;
4864 /* Match a common block name. */
4866 match
match_common_name (char *name
)
4870 if (gfc_match_char ('/') == MATCH_NO
)
4876 if (gfc_match_char ('/') == MATCH_YES
)
4882 m
= gfc_match_name (name
);
4884 if (m
== MATCH_ERROR
)
4886 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
4889 gfc_error ("Syntax error in common block name at %C");
4894 /* Match a COMMON statement. */
4897 gfc_match_common (void)
4899 gfc_symbol
*sym
, **head
, *tail
, *other
;
4900 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4910 m
= match_common_name (name
);
4911 if (m
== MATCH_ERROR
)
4914 if (name
[0] == '\0')
4916 t
= &gfc_current_ns
->blank_common
;
4917 if (t
->head
== NULL
)
4918 t
->where
= gfc_current_locus
;
4922 t
= gfc_get_common (name
, 0);
4931 while (tail
->common_next
)
4932 tail
= tail
->common_next
;
4935 /* Grab the list of symbols. */
4938 m
= gfc_match_symbol (&sym
, 0);
4939 if (m
== MATCH_ERROR
)
4944 /* See if we know the current common block is bind(c), and if
4945 so, then see if we can check if the symbol is (which it'll
4946 need to be). This can happen if the bind(c) attr stmt was
4947 applied to the common block, and the variable(s) already
4948 defined, before declaring the common block. */
4949 if (t
->is_bind_c
== 1)
4951 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
4953 /* If we find an error, just print it and continue,
4954 cause it's just semantic, and we can see if there
4956 gfc_error_now ("Variable %qs at %L in common block %qs "
4957 "at %C must be declared with a C "
4958 "interoperable kind since common block "
4960 sym
->name
, &(sym
->declared_at
), t
->name
,
4964 if (sym
->attr
.is_bind_c
== 1)
4965 gfc_error_now ("Variable %qs in common block %qs at %C can not "
4966 "be bind(c) since it is not global", sym
->name
,
4970 if (sym
->attr
.in_common
)
4972 gfc_error ("Symbol %qs at %C is already in a COMMON block",
4977 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
4978 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
4980 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol %qs at "
4981 "%C can only be COMMON in BLOCK DATA",
4986 /* Deal with an optional array specification after the
4988 m
= gfc_match_array_spec (&as
, true, true);
4989 if (m
== MATCH_ERROR
)
4994 if (as
->type
!= AS_EXPLICIT
)
4996 gfc_error ("Array specification for symbol %qs in COMMON "
4997 "at %C must be explicit", sym
->name
);
5001 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
5004 if (sym
->attr
.pointer
)
5006 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
5007 "POINTER array", sym
->name
);
5016 /* Add the in_common attribute, but ignore the reported errors
5017 if any, and continue matching. */
5018 gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
);
5020 sym
->common_block
= t
;
5021 sym
->common_block
->refs
++;
5024 tail
->common_next
= sym
;
5030 sym
->common_head
= t
;
5032 /* Check to see if the symbol is already in an equivalence group.
5033 If it is, set the other members as being in common. */
5034 if (sym
->attr
.in_equivalence
)
5036 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
5038 for (e2
= e1
; e2
; e2
= e2
->eq
)
5039 if (e2
->expr
->symtree
->n
.sym
== sym
)
5046 for (e2
= e1
; e2
; e2
= e2
->eq
)
5048 other
= e2
->expr
->symtree
->n
.sym
;
5049 if (other
->common_head
5050 && other
->common_head
!= sym
->common_head
)
5052 gfc_error ("Symbol %qs, in COMMON block %qs at "
5053 "%C is being indirectly equivalenced to "
5054 "another COMMON block %qs",
5055 sym
->name
, sym
->common_head
->name
,
5056 other
->common_head
->name
);
5059 other
->attr
.in_common
= 1;
5060 other
->common_head
= t
;
5066 gfc_gobble_whitespace ();
5067 if (gfc_match_eos () == MATCH_YES
)
5069 if (gfc_peek_ascii_char () == '/')
5071 if (gfc_match_char (',') != MATCH_YES
)
5073 gfc_gobble_whitespace ();
5074 if (gfc_peek_ascii_char () == '/')
5083 gfc_syntax_error (ST_COMMON
);
5086 gfc_free_array_spec (as
);
5091 /* Match a BLOCK DATA program unit. */
5094 gfc_match_block_data (void)
5096 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5100 if (gfc_match_eos () == MATCH_YES
)
5102 gfc_new_block
= NULL
;
5106 m
= gfc_match ("% %n%t", name
);
5110 if (gfc_get_symbol (name
, NULL
, &sym
))
5113 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
5116 gfc_new_block
= sym
;
5122 /* Free a namelist structure. */
5125 gfc_free_namelist (gfc_namelist
*name
)
5129 for (; name
; name
= n
)
5137 /* Free an OpenMP namelist structure. */
5140 gfc_free_omp_namelist (gfc_omp_namelist
*name
)
5142 gfc_omp_namelist
*n
;
5144 for (; name
; name
= n
)
5146 gfc_free_expr (name
->expr
);
5149 if (name
->udr
->combiner
)
5150 gfc_free_statement (name
->udr
->combiner
);
5151 if (name
->udr
->initializer
)
5152 gfc_free_statement (name
->udr
->initializer
);
5161 /* Match a NAMELIST statement. */
5164 gfc_match_namelist (void)
5166 gfc_symbol
*group_name
, *sym
;
5170 m
= gfc_match (" / %s /", &group_name
);
5173 if (m
== MATCH_ERROR
)
5178 if (group_name
->ts
.type
!= BT_UNKNOWN
)
5180 gfc_error ("Namelist group name %qs at %C already has a basic "
5181 "type of %s", group_name
->name
,
5182 gfc_typename (&group_name
->ts
));
5186 if (group_name
->attr
.flavor
== FL_NAMELIST
5187 && group_name
->attr
.use_assoc
5188 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name %qs "
5189 "at %C already is USE associated and can"
5190 "not be respecified.", group_name
->name
))
5193 if (group_name
->attr
.flavor
!= FL_NAMELIST
5194 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
5195 group_name
->name
, NULL
))
5200 m
= gfc_match_symbol (&sym
, 1);
5203 if (m
== MATCH_ERROR
)
5206 if (sym
->attr
.in_namelist
== 0
5207 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
5210 /* Use gfc_error_check here, rather than goto error, so that
5211 these are the only errors for the next two lines. */
5212 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
5214 gfc_error ("Assumed size array %qs in namelist %qs at "
5215 "%C is not allowed", sym
->name
, group_name
->name
);
5219 nl
= gfc_get_namelist ();
5223 if (group_name
->namelist
== NULL
)
5224 group_name
->namelist
= group_name
->namelist_tail
= nl
;
5227 group_name
->namelist_tail
->next
= nl
;
5228 group_name
->namelist_tail
= nl
;
5231 if (gfc_match_eos () == MATCH_YES
)
5234 m
= gfc_match_char (',');
5236 if (gfc_match_char ('/') == MATCH_YES
)
5238 m2
= gfc_match (" %s /", &group_name
);
5239 if (m2
== MATCH_YES
)
5241 if (m2
== MATCH_ERROR
)
5255 gfc_syntax_error (ST_NAMELIST
);
5262 /* Match a MODULE statement. */
5265 gfc_match_module (void)
5269 m
= gfc_match (" %s%t", &gfc_new_block
);
5273 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
5274 gfc_new_block
->name
, NULL
))
5281 /* Free equivalence sets and lists. Recursively is the easiest way to
5285 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
5290 gfc_free_equiv (eq
->eq
);
5291 gfc_free_equiv_until (eq
->next
, stop
);
5292 gfc_free_expr (eq
->expr
);
5298 gfc_free_equiv (gfc_equiv
*eq
)
5300 gfc_free_equiv_until (eq
, NULL
);
5304 /* Match an EQUIVALENCE statement. */
5307 gfc_match_equivalence (void)
5309 gfc_equiv
*eq
, *set
, *tail
;
5313 gfc_common_head
*common_head
= NULL
;
5321 eq
= gfc_get_equiv ();
5325 eq
->next
= gfc_current_ns
->equiv
;
5326 gfc_current_ns
->equiv
= eq
;
5328 if (gfc_match_char ('(') != MATCH_YES
)
5332 common_flag
= FALSE
;
5337 m
= gfc_match_equiv_variable (&set
->expr
);
5338 if (m
== MATCH_ERROR
)
5343 /* count the number of objects. */
5346 if (gfc_match_char ('%') == MATCH_YES
)
5348 gfc_error ("Derived type component %C is not a "
5349 "permitted EQUIVALENCE member");
5353 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
5354 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5356 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
5357 "be an array section");
5361 sym
= set
->expr
->symtree
->n
.sym
;
5363 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
5366 if (sym
->attr
.in_common
)
5369 common_head
= sym
->common_head
;
5372 if (gfc_match_char (')') == MATCH_YES
)
5375 if (gfc_match_char (',') != MATCH_YES
)
5378 set
->eq
= gfc_get_equiv ();
5384 gfc_error ("EQUIVALENCE at %C requires two or more objects");
5388 /* If one of the members of an equivalence is in common, then
5389 mark them all as being in common. Before doing this, check
5390 that members of the equivalence group are not in different
5393 for (set
= eq
; set
; set
= set
->eq
)
5395 sym
= set
->expr
->symtree
->n
.sym
;
5396 if (sym
->common_head
&& sym
->common_head
!= common_head
)
5398 gfc_error ("Attempt to indirectly overlap COMMON "
5399 "blocks %s and %s by EQUIVALENCE at %C",
5400 sym
->common_head
->name
, common_head
->name
);
5403 sym
->attr
.in_common
= 1;
5404 sym
->common_head
= common_head
;
5407 if (gfc_match_eos () == MATCH_YES
)
5409 if (gfc_match_char (',') != MATCH_YES
)
5411 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
5419 gfc_syntax_error (ST_EQUIVALENCE
);
5425 gfc_free_equiv (gfc_current_ns
->equiv
);
5426 gfc_current_ns
->equiv
= eq
;
5432 /* Check that a statement function is not recursive. This is done by looking
5433 for the statement function symbol(sym) by looking recursively through its
5434 expression(e). If a reference to sym is found, true is returned.
5435 12.5.4 requires that any variable of function that is implicitly typed
5436 shall have that type confirmed by any subsequent type declaration. The
5437 implicit typing is conveniently done here. */
5439 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
5442 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
5448 switch (e
->expr_type
)
5451 if (e
->symtree
== NULL
)
5454 /* Check the name before testing for nested recursion! */
5455 if (sym
->name
== e
->symtree
->n
.sym
->name
)
5458 /* Catch recursion via other statement functions. */
5459 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
5460 && e
->symtree
->n
.sym
->value
5461 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
5464 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5465 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5470 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
5473 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5474 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5486 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
5488 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
5492 /* Match a statement function declaration. It is so easy to match
5493 non-statement function statements with a MATCH_ERROR as opposed to
5494 MATCH_NO that we suppress error message in most cases. */
5497 gfc_match_st_function (void)
5499 gfc_error_buffer old_error
;
5504 m
= gfc_match_symbol (&sym
, 0);
5508 gfc_push_error (&old_error
);
5510 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
5513 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
5516 m
= gfc_match (" = %e%t", &expr
);
5520 gfc_free_error (&old_error
);
5522 if (m
== MATCH_ERROR
)
5525 if (recursive_stmt_fcn (expr
, sym
))
5527 gfc_error ("Statement function at %L is recursive", &expr
->where
);
5533 if ((gfc_current_state () == COMP_FUNCTION
5534 || gfc_current_state () == COMP_SUBROUTINE
)
5535 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
5537 gfc_error ("Statement function at %L cannot appear within an INTERFACE",
5542 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
5548 gfc_pop_error (&old_error
);
5553 /* Match an assignment to a pointer function (F2008). This could, in
5554 general be ambiguous with a statement function. In this implementation
5555 it remains so if it is the first statement after the specification
5559 gfc_match_ptr_fcn_assign (void)
5561 gfc_error_buffer old_error
;
5566 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5568 old_loc
= gfc_current_locus
;
5569 m
= gfc_match_name (name
);
5573 gfc_find_symbol (name
, NULL
, 1, &sym
);
5574 if (sym
&& sym
->attr
.flavor
!= FL_PROCEDURE
)
5577 gfc_push_error (&old_error
);
5579 if (sym
&& sym
->attr
.function
)
5580 goto match_actual_arglist
;
5582 gfc_current_locus
= old_loc
;
5583 m
= gfc_match_symbol (&sym
, 0);
5587 if (!gfc_add_procedure (&sym
->attr
, PROC_UNKNOWN
, sym
->name
, NULL
))
5590 match_actual_arglist
:
5591 gfc_current_locus
= old_loc
;
5592 m
= gfc_match (" %e", &expr
);
5596 new_st
.op
= EXEC_ASSIGN
;
5597 new_st
.expr1
= expr
;
5600 m
= gfc_match (" = %e%t", &expr
);
5604 new_st
.expr2
= expr
;
5608 gfc_pop_error (&old_error
);
5613 /***************** SELECT CASE subroutines ******************/
5615 /* Free a single case structure. */
5618 free_case (gfc_case
*p
)
5620 if (p
->low
== p
->high
)
5622 gfc_free_expr (p
->low
);
5623 gfc_free_expr (p
->high
);
5628 /* Free a list of case structures. */
5631 gfc_free_case_list (gfc_case
*p
)
5643 /* Match a single case selector. Combining the requirements of F08:C830
5644 and F08:C832 (R838) means that the case-value must have either CHARACTER,
5645 INTEGER, or LOGICAL type. */
5648 match_case_selector (gfc_case
**cp
)
5653 c
= gfc_get_case ();
5654 c
->where
= gfc_current_locus
;
5656 if (gfc_match_char (':') == MATCH_YES
)
5658 m
= gfc_match_init_expr (&c
->high
);
5661 if (m
== MATCH_ERROR
)
5664 if (c
->high
->ts
.type
!= BT_LOGICAL
&& c
->high
->ts
.type
!= BT_INTEGER
5665 && c
->high
->ts
.type
!= BT_CHARACTER
)
5667 gfc_error ("Expression in CASE selector at %L cannot be %s",
5668 &c
->high
->where
, gfc_typename (&c
->high
->ts
));
5674 m
= gfc_match_init_expr (&c
->low
);
5675 if (m
== MATCH_ERROR
)
5680 if (c
->low
->ts
.type
!= BT_LOGICAL
&& c
->low
->ts
.type
!= BT_INTEGER
5681 && c
->low
->ts
.type
!= BT_CHARACTER
)
5683 gfc_error ("Expression in CASE selector at %L cannot be %s",
5684 &c
->low
->where
, gfc_typename (&c
->low
->ts
));
5688 /* If we're not looking at a ':' now, make a range out of a single
5689 target. Else get the upper bound for the case range. */
5690 if (gfc_match_char (':') != MATCH_YES
)
5694 m
= gfc_match_init_expr (&c
->high
);
5695 if (m
== MATCH_ERROR
)
5697 /* MATCH_NO is fine. It's OK if nothing is there! */
5705 gfc_error ("Expected initialization expression in CASE at %C");
5713 /* Match the end of a case statement. */
5716 match_case_eos (void)
5718 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5721 if (gfc_match_eos () == MATCH_YES
)
5724 /* If the case construct doesn't have a case-construct-name, we
5725 should have matched the EOS. */
5726 if (!gfc_current_block ())
5729 gfc_gobble_whitespace ();
5731 m
= gfc_match_name (name
);
5735 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5737 gfc_error ("Expected block name %qs of SELECT construct at %C",
5738 gfc_current_block ()->name
);
5742 return gfc_match_eos ();
5746 /* Match a SELECT statement. */
5749 gfc_match_select (void)
5754 m
= gfc_match_label ();
5755 if (m
== MATCH_ERROR
)
5758 m
= gfc_match (" select case ( %e )%t", &expr
);
5762 new_st
.op
= EXEC_SELECT
;
5763 new_st
.expr1
= expr
;
5769 /* Transfer the selector typespec to the associate name. */
5772 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
)
5775 gfc_symbol
*assoc_sym
;
5777 assoc_sym
= associate
->symtree
->n
.sym
;
5779 /* At this stage the expression rank and arrayspec dimensions have
5780 not been completely sorted out. We must get the expr2->rank
5781 right here, so that the correct class container is obtained. */
5782 ref
= selector
->ref
;
5783 while (ref
&& ref
->next
)
5786 if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
5787 && ref
&& ref
->type
== REF_ARRAY
)
5789 /* Ensure that the array reference type is set. We cannot use
5790 gfc_resolve_expr at this point, so the usable parts of
5791 resolve.c(resolve_array_ref) are employed to do it. */
5792 if (ref
->u
.ar
.type
== AR_UNKNOWN
)
5794 ref
->u
.ar
.type
= AR_ELEMENT
;
5795 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
5796 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5797 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
5798 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
5799 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
5801 ref
->u
.ar
.type
= AR_SECTION
;
5806 if (ref
->u
.ar
.type
== AR_FULL
)
5807 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
5808 else if (ref
->u
.ar
.type
== AR_SECTION
)
5809 selector
->rank
= ref
->u
.ar
.dimen
;
5816 assoc_sym
->attr
.dimension
= 1;
5817 assoc_sym
->as
= gfc_get_array_spec ();
5818 assoc_sym
->as
->rank
= selector
->rank
;
5819 assoc_sym
->as
->type
= AS_DEFERRED
;
5822 assoc_sym
->as
= NULL
;
5824 if (selector
->ts
.type
== BT_CLASS
)
5826 /* The correct class container has to be available. */
5827 assoc_sym
->ts
.type
= BT_CLASS
;
5828 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
5829 assoc_sym
->attr
.pointer
= 1;
5830 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
5835 /* Push the current selector onto the SELECT TYPE stack. */
5838 select_type_push (gfc_symbol
*sel
)
5840 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
5841 top
->selector
= sel
;
5843 top
->prev
= select_type_stack
;
5845 select_type_stack
= top
;
5849 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
5851 static gfc_symtree
*
5852 select_intrinsic_set_tmp (gfc_typespec
*ts
)
5854 char name
[GFC_MAX_SYMBOL_LEN
];
5858 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
5861 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5862 && !select_type_stack
->selector
->attr
.class_ok
)
5865 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
5866 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5867 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
5869 if (ts
->type
!= BT_CHARACTER
)
5870 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
5873 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (ts
->type
),
5876 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5877 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5879 /* Copy across the array spec to the selector. */
5880 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5881 && (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5882 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
))
5884 tmp
->n
.sym
->attr
.pointer
= 1;
5885 tmp
->n
.sym
->attr
.dimension
5886 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5887 tmp
->n
.sym
->attr
.codimension
5888 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5890 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5893 gfc_set_sym_referenced (tmp
->n
.sym
);
5894 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5895 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5901 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
5904 select_type_set_tmp (gfc_typespec
*ts
)
5906 char name
[GFC_MAX_SYMBOL_LEN
];
5907 gfc_symtree
*tmp
= NULL
;
5911 select_type_stack
->tmp
= NULL
;
5915 tmp
= select_intrinsic_set_tmp (ts
);
5922 if (ts
->type
== BT_CLASS
)
5923 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
5925 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
5926 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5927 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5929 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5930 && select_type_stack
->selector
->attr
.class_ok
)
5932 tmp
->n
.sym
->attr
.pointer
5933 = CLASS_DATA (select_type_stack
->selector
)->attr
.class_pointer
;
5935 /* Copy across the array spec to the selector. */
5936 if (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5937 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
)
5939 tmp
->n
.sym
->attr
.dimension
5940 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5941 tmp
->n
.sym
->attr
.codimension
5942 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5944 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5948 gfc_set_sym_referenced (tmp
->n
.sym
);
5949 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5950 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5952 if (ts
->type
== BT_CLASS
)
5953 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
5957 /* Add an association for it, so the rest of the parser knows it is
5958 an associate-name. The target will be set during resolution. */
5959 tmp
->n
.sym
->assoc
= gfc_get_association_list ();
5960 tmp
->n
.sym
->assoc
->dangling
= 1;
5961 tmp
->n
.sym
->assoc
->st
= tmp
;
5963 select_type_stack
->tmp
= tmp
;
5967 /* Match a SELECT TYPE statement. */
5970 gfc_match_select_type (void)
5972 gfc_expr
*expr1
, *expr2
= NULL
;
5974 char name
[GFC_MAX_SYMBOL_LEN
];
5977 gfc_namespace
*ns
= gfc_current_ns
;
5979 m
= gfc_match_label ();
5980 if (m
== MATCH_ERROR
)
5983 m
= gfc_match (" select type ( ");
5987 gfc_current_ns
= gfc_build_block_ns (ns
);
5988 m
= gfc_match (" %n => %e", name
, &expr2
);
5991 expr1
= gfc_get_expr ();
5992 expr1
->expr_type
= EXPR_VARIABLE
;
5993 expr1
->where
= expr2
->where
;
5994 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
6000 sym
= expr1
->symtree
->n
.sym
;
6001 if (expr2
->ts
.type
== BT_UNKNOWN
)
6002 sym
->attr
.untyped
= 1;
6004 copy_ts_from_selector_to_associate (expr1
, expr2
);
6006 sym
->attr
.flavor
= FL_VARIABLE
;
6007 sym
->attr
.referenced
= 1;
6008 sym
->attr
.class_ok
= 1;
6012 m
= gfc_match (" %e ", &expr1
);
6015 std::swap (ns
, gfc_current_ns
);
6016 gfc_free_namespace (ns
);
6021 m
= gfc_match (" )%t");
6024 gfc_error ("parse error in SELECT TYPE statement at %C");
6028 /* This ghastly expression seems to be needed to distinguish a CLASS
6029 array, which can have a reference, from other expressions that
6030 have references, such as derived type components, and are not
6031 allowed by the standard.
6032 TODO: see if it is sufficient to exclude component and substring
6034 class_array
= (expr1
->expr_type
== EXPR_VARIABLE
6035 && expr1
->ts
.type
== BT_CLASS
6036 && CLASS_DATA (expr1
)
6037 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
6038 && (CLASS_DATA (expr1
)->attr
.dimension
6039 || CLASS_DATA (expr1
)->attr
.codimension
)
6041 && expr1
->ref
->type
== REF_ARRAY
6042 && expr1
->ref
->next
== NULL
);
6044 /* Check for F03:C811. */
6045 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
6046 || (!class_array
&& expr1
->ref
!= NULL
)))
6048 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
6049 "use associate-name=>");
6054 new_st
.op
= EXEC_SELECT_TYPE
;
6055 new_st
.expr1
= expr1
;
6056 new_st
.expr2
= expr2
;
6057 new_st
.ext
.block
.ns
= gfc_current_ns
;
6059 select_type_push (expr1
->symtree
->n
.sym
);
6060 gfc_current_ns
= ns
;
6065 gfc_free_expr (expr1
);
6066 gfc_free_expr (expr2
);
6067 gfc_undo_symbols ();
6068 std::swap (ns
, gfc_current_ns
);
6069 gfc_free_namespace (ns
);
6074 /* Match a CASE statement. */
6077 gfc_match_case (void)
6079 gfc_case
*c
, *head
, *tail
;
6084 if (gfc_current_state () != COMP_SELECT
)
6086 gfc_error ("Unexpected CASE statement at %C");
6090 if (gfc_match ("% default") == MATCH_YES
)
6092 m
= match_case_eos ();
6095 if (m
== MATCH_ERROR
)
6098 new_st
.op
= EXEC_SELECT
;
6099 c
= gfc_get_case ();
6100 c
->where
= gfc_current_locus
;
6101 new_st
.ext
.block
.case_list
= c
;
6105 if (gfc_match_char ('(') != MATCH_YES
)
6110 if (match_case_selector (&c
) == MATCH_ERROR
)
6120 if (gfc_match_char (')') == MATCH_YES
)
6122 if (gfc_match_char (',') != MATCH_YES
)
6126 m
= match_case_eos ();
6129 if (m
== MATCH_ERROR
)
6132 new_st
.op
= EXEC_SELECT
;
6133 new_st
.ext
.block
.case_list
= head
;
6138 gfc_error ("Syntax error in CASE specification at %C");
6141 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
6146 /* Match a TYPE IS statement. */
6149 gfc_match_type_is (void)
6154 if (gfc_current_state () != COMP_SELECT_TYPE
)
6156 gfc_error ("Unexpected TYPE IS statement at %C");
6160 if (gfc_match_char ('(') != MATCH_YES
)
6163 c
= gfc_get_case ();
6164 c
->where
= gfc_current_locus
;
6166 m
= gfc_match_type_spec (&c
->ts
);
6169 if (m
== MATCH_ERROR
)
6172 if (gfc_match_char (')') != MATCH_YES
)
6175 m
= match_case_eos ();
6178 if (m
== MATCH_ERROR
)
6181 new_st
.op
= EXEC_SELECT_TYPE
;
6182 new_st
.ext
.block
.case_list
= c
;
6184 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
6185 && (c
->ts
.u
.derived
->attr
.sequence
6186 || c
->ts
.u
.derived
->attr
.is_bind_c
))
6188 gfc_error ("The type-spec shall not specify a sequence derived "
6189 "type or a type with the BIND attribute in SELECT "
6190 "TYPE at %C [F2003:C815]");
6194 if (c
->ts
.type
== BT_DERIVED
6195 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
6196 && gfc_spec_list_type (type_param_spec_list
, c
->ts
.u
.derived
)
6199 gfc_error ("All the LEN type parameters in the TYPE IS statement "
6200 "at %C must be ASSUMED");
6204 /* Create temporary variable. */
6205 select_type_set_tmp (&c
->ts
);
6210 gfc_error ("Syntax error in TYPE IS specification at %C");
6214 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6219 /* Match a CLASS IS or CLASS DEFAULT statement. */
6222 gfc_match_class_is (void)
6227 if (gfc_current_state () != COMP_SELECT_TYPE
)
6230 if (gfc_match ("% default") == MATCH_YES
)
6232 m
= match_case_eos ();
6235 if (m
== MATCH_ERROR
)
6238 new_st
.op
= EXEC_SELECT_TYPE
;
6239 c
= gfc_get_case ();
6240 c
->where
= gfc_current_locus
;
6241 c
->ts
.type
= BT_UNKNOWN
;
6242 new_st
.ext
.block
.case_list
= c
;
6243 select_type_set_tmp (NULL
);
6247 m
= gfc_match ("% is");
6250 if (m
== MATCH_ERROR
)
6253 if (gfc_match_char ('(') != MATCH_YES
)
6256 c
= gfc_get_case ();
6257 c
->where
= gfc_current_locus
;
6259 m
= match_derived_type_spec (&c
->ts
);
6262 if (m
== MATCH_ERROR
)
6265 if (c
->ts
.type
== BT_DERIVED
)
6266 c
->ts
.type
= BT_CLASS
;
6268 if (gfc_match_char (')') != MATCH_YES
)
6271 m
= match_case_eos ();
6274 if (m
== MATCH_ERROR
)
6277 new_st
.op
= EXEC_SELECT_TYPE
;
6278 new_st
.ext
.block
.case_list
= c
;
6280 /* Create temporary variable. */
6281 select_type_set_tmp (&c
->ts
);
6286 gfc_error ("Syntax error in CLASS IS specification at %C");
6290 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6295 /********************* WHERE subroutines ********************/
6297 /* Match the rest of a simple WHERE statement that follows an IF statement.
6301 match_simple_where (void)
6307 m
= gfc_match (" ( %e )", &expr
);
6311 m
= gfc_match_assignment ();
6314 if (m
== MATCH_ERROR
)
6317 if (gfc_match_eos () != MATCH_YES
)
6320 c
= gfc_get_code (EXEC_WHERE
);
6323 c
->next
= XCNEW (gfc_code
);
6325 c
->next
->loc
= gfc_current_locus
;
6326 gfc_clear_new_st ();
6328 new_st
.op
= EXEC_WHERE
;
6334 gfc_syntax_error (ST_WHERE
);
6337 gfc_free_expr (expr
);
6342 /* Match a WHERE statement. */
6345 gfc_match_where (gfc_statement
*st
)
6351 m0
= gfc_match_label ();
6352 if (m0
== MATCH_ERROR
)
6355 m
= gfc_match (" where ( %e )", &expr
);
6359 if (gfc_match_eos () == MATCH_YES
)
6361 *st
= ST_WHERE_BLOCK
;
6362 new_st
.op
= EXEC_WHERE
;
6363 new_st
.expr1
= expr
;
6367 m
= gfc_match_assignment ();
6369 gfc_syntax_error (ST_WHERE
);
6373 gfc_free_expr (expr
);
6377 /* We've got a simple WHERE statement. */
6379 c
= gfc_get_code (EXEC_WHERE
);
6382 /* Put in the assignment. It will not be processed by add_statement, so we
6383 need to copy the location here. */
6385 c
->next
= XCNEW (gfc_code
);
6387 c
->next
->loc
= gfc_current_locus
;
6388 gfc_clear_new_st ();
6390 new_st
.op
= EXEC_WHERE
;
6397 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
6398 new_st if successful. */
6401 gfc_match_elsewhere (void)
6403 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6407 if (gfc_current_state () != COMP_WHERE
)
6409 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
6415 if (gfc_match_char ('(') == MATCH_YES
)
6417 m
= gfc_match_expr (&expr
);
6420 if (m
== MATCH_ERROR
)
6423 if (gfc_match_char (')') != MATCH_YES
)
6427 if (gfc_match_eos () != MATCH_YES
)
6429 /* Only makes sense if we have a where-construct-name. */
6430 if (!gfc_current_block ())
6435 /* Better be a name at this point. */
6436 m
= gfc_match_name (name
);
6439 if (m
== MATCH_ERROR
)
6442 if (gfc_match_eos () != MATCH_YES
)
6445 if (strcmp (name
, gfc_current_block ()->name
) != 0)
6447 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
6448 name
, gfc_current_block ()->name
);
6453 new_st
.op
= EXEC_WHERE
;
6454 new_st
.expr1
= expr
;
6458 gfc_syntax_error (ST_ELSEWHERE
);
6461 gfc_free_expr (expr
);