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
)
3973 /* Match an optional type-spec. */
3974 old_locus
= gfc_current_locus
;
3975 m
= gfc_match_type_spec (&ts
);
3976 if (m
== MATCH_ERROR
)
3978 else if (m
== MATCH_NO
)
3980 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
3982 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
3984 gfc_error ("Error in type-spec at %L", &old_locus
);
3988 ts
.type
= BT_UNKNOWN
;
3992 if (gfc_match (" :: ") == MATCH_YES
)
3994 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
4000 gfc_error ("Type-spec at %L cannot contain a deferred "
4001 "type parameter", &old_locus
);
4005 if (ts
.type
== BT_CHARACTER
)
4006 ts
.u
.cl
->length_from_typespec
= true;
4008 /* TODO understand why this error does not appear but, instead,
4009 the derived type is caught as a variable in primary.c. */
4010 if (gfc_spec_list_type (type_param_spec_list
, NULL
) != SPEC_EXPLICIT
)
4012 gfc_error ("The type parameter spec list in the type-spec at "
4013 "%L cannot contain ASSUMED or DEFERRED parameters",
4020 ts
.type
= BT_UNKNOWN
;
4021 gfc_current_locus
= old_locus
;
4028 head
= tail
= gfc_get_alloc ();
4031 tail
->next
= gfc_get_alloc ();
4035 m
= gfc_match_variable (&tail
->expr
, 0);
4038 if (m
== MATCH_ERROR
)
4041 if (gfc_check_do_variable (tail
->expr
->symtree
))
4044 bool impure
= gfc_impure_variable (tail
->expr
->symtree
->n
.sym
);
4045 if (impure
&& gfc_pure (NULL
))
4047 gfc_error ("Bad allocate-object at %C for a PURE procedure");
4052 gfc_unset_implicit_pure (NULL
);
4054 if (tail
->expr
->ts
.deferred
)
4056 saw_deferred
= true;
4057 deferred_locus
= tail
->expr
->where
;
4060 if (gfc_find_state (COMP_DO_CONCURRENT
)
4061 || gfc_find_state (COMP_CRITICAL
))
4064 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
4065 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
4066 if (ref
->type
== REF_COMPONENT
)
4067 coarray
= ref
->u
.c
.component
->attr
.codimension
;
4069 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
4071 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
4074 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
4076 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
4081 /* Check for F08:C628. */
4082 sym
= tail
->expr
->symtree
->n
.sym
;
4083 b1
= !(tail
->expr
->ref
4084 && (tail
->expr
->ref
->type
== REF_COMPONENT
4085 || tail
->expr
->ref
->type
== REF_ARRAY
));
4086 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4087 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
4088 || CLASS_DATA (sym
)->attr
.class_pointer
);
4090 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4091 || sym
->attr
.proc_pointer
);
4092 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
4093 && (sym
->ns
->proc_name
->attr
.allocatable
4094 || sym
->ns
->proc_name
->attr
.pointer
4095 || sym
->ns
->proc_name
->attr
.proc_pointer
);
4096 if (b1
&& b2
&& !b3
)
4098 gfc_error ("Allocate-object at %L is neither a data pointer "
4099 "nor an allocatable variable", &tail
->expr
->where
);
4103 /* The ALLOCATE statement had an optional typespec. Check the
4105 if (ts
.type
!= BT_UNKNOWN
)
4107 /* Enforce F03:C624. */
4108 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
4110 gfc_error ("Type of entity at %L is type incompatible with "
4111 "typespec", &tail
->expr
->where
);
4115 /* Enforce F03:C627. */
4116 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
4118 gfc_error ("Kind type parameter for entity at %L differs from "
4119 "the kind type parameter of the typespec",
4120 &tail
->expr
->where
);
4125 if (tail
->expr
->ts
.type
== BT_DERIVED
)
4126 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
4128 if (type_param_spec_list
)
4129 tail
->expr
->param_list
= gfc_copy_actual_arglist (type_param_spec_list
);
4131 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
4133 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
4135 gfc_error ("Shape specification for allocatable scalar at %C");
4139 if (gfc_match_char (',') != MATCH_YES
)
4144 m
= gfc_match (" stat = %v", &tmp
);
4145 if (m
== MATCH_ERROR
)
4152 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4160 if (gfc_check_do_variable (stat
->symtree
))
4163 if (gfc_match_char (',') == MATCH_YES
)
4164 goto alloc_opt_list
;
4167 m
= gfc_match (" errmsg = %v", &tmp
);
4168 if (m
== MATCH_ERROR
)
4172 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
4178 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4186 if (gfc_match_char (',') == MATCH_YES
)
4187 goto alloc_opt_list
;
4190 m
= gfc_match (" source = %e", &tmp
);
4191 if (m
== MATCH_ERROR
)
4195 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
4201 gfc_error ("Redundant SOURCE tag found at %L", &tmp
->where
);
4205 /* The next 2 conditionals check C631. */
4206 if (ts
.type
!= BT_UNKNOWN
)
4208 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
4209 &tmp
->where
, &old_locus
);
4214 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
4215 " with more than a single allocate object",
4223 if (gfc_match_char (',') == MATCH_YES
)
4224 goto alloc_opt_list
;
4227 m
= gfc_match (" mold = %e", &tmp
);
4228 if (m
== MATCH_ERROR
)
4232 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
4235 /* Check F08:C636. */
4238 gfc_error ("Redundant MOLD tag found at %L", &tmp
->where
);
4242 /* Check F08:C637. */
4243 if (ts
.type
!= BT_UNKNOWN
)
4245 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
4246 &tmp
->where
, &old_locus
);
4255 if (gfc_match_char (',') == MATCH_YES
)
4256 goto alloc_opt_list
;
4259 gfc_gobble_whitespace ();
4261 if (gfc_peek_char () == ')')
4265 if (gfc_match (" )%t") != MATCH_YES
)
4268 /* Check F08:C637. */
4271 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
4272 &mold
->where
, &source
->where
);
4276 /* Check F03:C623, */
4277 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4279 gfc_error ("Allocate-object at %L with a deferred type parameter "
4280 "requires either a type-spec or SOURCE tag or a MOLD tag",
4285 /* Check F03:C625, */
4286 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4288 for (tail
= head
; tail
; tail
= tail
->next
)
4290 if (UNLIMITED_POLY (tail
->expr
))
4291 gfc_error ("Unlimited polymorphic allocate-object at %L "
4292 "requires either a type-spec or SOURCE tag "
4293 "or a MOLD tag", &tail
->expr
->where
);
4298 new_st
.op
= EXEC_ALLOCATE
;
4299 new_st
.expr1
= stat
;
4300 new_st
.expr2
= errmsg
;
4302 new_st
.expr3
= source
;
4304 new_st
.expr3
= mold
;
4305 new_st
.ext
.alloc
.list
= head
;
4306 new_st
.ext
.alloc
.ts
= ts
;
4308 if (type_param_spec_list
)
4309 gfc_free_actual_arglist (type_param_spec_list
);
4314 gfc_syntax_error (ST_ALLOCATE
);
4317 gfc_free_expr (errmsg
);
4318 gfc_free_expr (source
);
4319 gfc_free_expr (stat
);
4320 gfc_free_expr (mold
);
4321 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
4322 gfc_free_alloc_list (head
);
4323 if (type_param_spec_list
)
4324 gfc_free_actual_arglist (type_param_spec_list
);
4329 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
4330 a set of pointer assignments to intrinsic NULL(). */
4333 gfc_match_nullify (void)
4341 if (gfc_match_char ('(') != MATCH_YES
)
4346 m
= gfc_match_variable (&p
, 0);
4347 if (m
== MATCH_ERROR
)
4352 if (gfc_check_do_variable (p
->symtree
))
4356 if (gfc_is_coindexed (p
))
4358 gfc_error ("Pointer object at %C shall not be coindexed");
4362 /* build ' => NULL() '. */
4363 e
= gfc_get_null_expr (&gfc_current_locus
);
4365 /* Chain to list. */
4369 tail
->op
= EXEC_POINTER_ASSIGN
;
4373 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
4380 if (gfc_match (" )%t") == MATCH_YES
)
4382 if (gfc_match_char (',') != MATCH_YES
)
4389 gfc_syntax_error (ST_NULLIFY
);
4392 gfc_free_statements (new_st
.next
);
4394 gfc_free_expr (new_st
.expr1
);
4395 new_st
.expr1
= NULL
;
4396 gfc_free_expr (new_st
.expr2
);
4397 new_st
.expr2
= NULL
;
4402 /* Match a DEALLOCATE statement. */
4405 gfc_match_deallocate (void)
4407 gfc_alloc
*head
, *tail
;
4408 gfc_expr
*stat
, *errmsg
, *tmp
;
4411 bool saw_stat
, saw_errmsg
, b1
, b2
;
4414 stat
= errmsg
= tmp
= NULL
;
4415 saw_stat
= saw_errmsg
= false;
4417 if (gfc_match_char ('(') != MATCH_YES
)
4423 head
= tail
= gfc_get_alloc ();
4426 tail
->next
= gfc_get_alloc ();
4430 m
= gfc_match_variable (&tail
->expr
, 0);
4431 if (m
== MATCH_ERROR
)
4436 if (gfc_check_do_variable (tail
->expr
->symtree
))
4439 sym
= tail
->expr
->symtree
->n
.sym
;
4441 bool impure
= gfc_impure_variable (sym
);
4442 if (impure
&& gfc_pure (NULL
))
4444 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
4449 gfc_unset_implicit_pure (NULL
);
4451 if (gfc_is_coarray (tail
->expr
)
4452 && gfc_find_state (COMP_DO_CONCURRENT
))
4454 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
4458 if (gfc_is_coarray (tail
->expr
)
4459 && gfc_find_state (COMP_CRITICAL
))
4461 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
4465 /* FIXME: disable the checking on derived types. */
4466 b1
= !(tail
->expr
->ref
4467 && (tail
->expr
->ref
->type
== REF_COMPONENT
4468 || tail
->expr
->ref
->type
== REF_ARRAY
));
4469 if (sym
&& sym
->ts
.type
== BT_CLASS
)
4470 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
4471 || CLASS_DATA (sym
)->attr
.class_pointer
);
4473 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4474 || sym
->attr
.proc_pointer
);
4477 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
4478 "nor an allocatable variable");
4482 if (gfc_match_char (',') != MATCH_YES
)
4487 m
= gfc_match (" stat = %v", &tmp
);
4488 if (m
== MATCH_ERROR
)
4494 gfc_error ("Redundant STAT tag found at %L", &tmp
->where
);
4495 gfc_free_expr (tmp
);
4502 if (gfc_check_do_variable (stat
->symtree
))
4505 if (gfc_match_char (',') == MATCH_YES
)
4506 goto dealloc_opt_list
;
4509 m
= gfc_match (" errmsg = %v", &tmp
);
4510 if (m
== MATCH_ERROR
)
4514 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
4519 gfc_error ("Redundant ERRMSG tag found at %L", &tmp
->where
);
4520 gfc_free_expr (tmp
);
4527 if (gfc_match_char (',') == MATCH_YES
)
4528 goto dealloc_opt_list
;
4531 gfc_gobble_whitespace ();
4533 if (gfc_peek_char () == ')')
4537 if (gfc_match (" )%t") != MATCH_YES
)
4540 new_st
.op
= EXEC_DEALLOCATE
;
4541 new_st
.expr1
= stat
;
4542 new_st
.expr2
= errmsg
;
4543 new_st
.ext
.alloc
.list
= head
;
4548 gfc_syntax_error (ST_DEALLOCATE
);
4551 gfc_free_expr (errmsg
);
4552 gfc_free_expr (stat
);
4553 gfc_free_alloc_list (head
);
4558 /* Match a RETURN statement. */
4561 gfc_match_return (void)
4565 gfc_compile_state s
;
4569 if (gfc_find_state (COMP_CRITICAL
))
4571 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4575 if (gfc_find_state (COMP_DO_CONCURRENT
))
4577 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4581 if (gfc_match_eos () == MATCH_YES
)
4584 if (!gfc_find_state (COMP_SUBROUTINE
))
4586 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4591 if (gfc_current_form
== FORM_FREE
)
4593 /* The following are valid, so we can't require a blank after the
4597 char c
= gfc_peek_ascii_char ();
4598 if (ISALPHA (c
) || ISDIGIT (c
))
4602 m
= gfc_match (" %e%t", &e
);
4605 if (m
== MATCH_ERROR
)
4608 gfc_syntax_error (ST_RETURN
);
4615 gfc_enclosing_unit (&s
);
4616 if (s
== COMP_PROGRAM
4617 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
4618 "main program at %C"))
4621 new_st
.op
= EXEC_RETURN
;
4628 /* Match the call of a type-bound procedure, if CALL%var has already been
4629 matched and var found to be a derived-type variable. */
4632 match_typebound_call (gfc_symtree
* varst
)
4637 base
= gfc_get_expr ();
4638 base
->expr_type
= EXPR_VARIABLE
;
4639 base
->symtree
= varst
;
4640 base
->where
= gfc_current_locus
;
4641 gfc_set_sym_referenced (varst
->n
.sym
);
4643 m
= gfc_match_varspec (base
, 0, true, true);
4645 gfc_error ("Expected component reference at %C");
4648 gfc_free_expr (base
);
4652 if (gfc_match_eos () != MATCH_YES
)
4654 gfc_error ("Junk after CALL at %C");
4655 gfc_free_expr (base
);
4659 if (base
->expr_type
== EXPR_COMPCALL
)
4660 new_st
.op
= EXEC_COMPCALL
;
4661 else if (base
->expr_type
== EXPR_PPC
)
4662 new_st
.op
= EXEC_CALL_PPC
;
4665 gfc_error ("Expected type-bound procedure or procedure pointer component "
4667 gfc_free_expr (base
);
4670 new_st
.expr1
= base
;
4676 /* Match a CALL statement. The tricky part here are possible
4677 alternate return specifiers. We handle these by having all
4678 "subroutines" actually return an integer via a register that gives
4679 the return number. If the call specifies alternate returns, we
4680 generate code for a SELECT statement whose case clauses contain
4681 GOTOs to the various labels. */
4684 gfc_match_call (void)
4686 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4687 gfc_actual_arglist
*a
, *arglist
;
4697 m
= gfc_match ("% %n", name
);
4703 if (gfc_get_ha_sym_tree (name
, &st
))
4708 /* If this is a variable of derived-type, it probably starts a type-bound
4710 if ((sym
->attr
.flavor
!= FL_PROCEDURE
4711 || gfc_is_function_return_value (sym
, gfc_current_ns
))
4712 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
4713 return match_typebound_call (st
);
4715 /* If it does not seem to be callable (include functions so that the
4716 right association is made. They are thrown out in resolution.)
4718 if (!sym
->attr
.generic
4719 && !sym
->attr
.subroutine
4720 && !sym
->attr
.function
)
4722 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
4724 /* ...create a symbol in this scope... */
4725 if (sym
->ns
!= gfc_current_ns
4726 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
4729 if (sym
!= st
->n
.sym
)
4733 /* ...and then to try to make the symbol into a subroutine. */
4734 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
4738 gfc_set_sym_referenced (sym
);
4740 if (gfc_match_eos () != MATCH_YES
)
4742 m
= gfc_match_actual_arglist (1, &arglist
);
4745 if (m
== MATCH_ERROR
)
4748 if (gfc_match_eos () != MATCH_YES
)
4752 /* If any alternate return labels were found, construct a SELECT
4753 statement that will jump to the right place. */
4756 for (a
= arglist
; a
; a
= a
->next
)
4757 if (a
->expr
== NULL
)
4765 gfc_symtree
*select_st
;
4766 gfc_symbol
*select_sym
;
4767 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4769 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
4770 sprintf (name
, "_result_%s", sym
->name
);
4771 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
4773 select_sym
= select_st
->n
.sym
;
4774 select_sym
->ts
.type
= BT_INTEGER
;
4775 select_sym
->ts
.kind
= gfc_default_integer_kind
;
4776 gfc_set_sym_referenced (select_sym
);
4777 c
->expr1
= gfc_get_expr ();
4778 c
->expr1
->expr_type
= EXPR_VARIABLE
;
4779 c
->expr1
->symtree
= select_st
;
4780 c
->expr1
->ts
= select_sym
->ts
;
4781 c
->expr1
->where
= gfc_current_locus
;
4784 for (a
= arglist
; a
; a
= a
->next
)
4786 if (a
->expr
!= NULL
)
4789 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
4794 c
->block
= gfc_get_code (EXEC_SELECT
);
4797 new_case
= gfc_get_case ();
4798 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
4799 new_case
->low
= new_case
->high
;
4800 c
->ext
.block
.case_list
= new_case
;
4802 c
->next
= gfc_get_code (EXEC_GOTO
);
4803 c
->next
->label1
= a
->label
;
4807 new_st
.op
= EXEC_CALL
;
4808 new_st
.symtree
= st
;
4809 new_st
.ext
.actual
= arglist
;
4814 gfc_syntax_error (ST_CALL
);
4817 gfc_free_actual_arglist (arglist
);
4822 /* Given a name, return a pointer to the common head structure,
4823 creating it if it does not exist. If FROM_MODULE is nonzero, we
4824 mangle the name so that it doesn't interfere with commons defined
4825 in the using namespace.
4826 TODO: Add to global symbol tree. */
4829 gfc_get_common (const char *name
, int from_module
)
4832 static int serial
= 0;
4833 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
4837 /* A use associated common block is only needed to correctly layout
4838 the variables it contains. */
4839 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
4840 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
4844 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
4847 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
4850 if (st
->n
.common
== NULL
)
4852 st
->n
.common
= gfc_get_common_head ();
4853 st
->n
.common
->where
= gfc_current_locus
;
4854 strcpy (st
->n
.common
->name
, name
);
4857 return st
->n
.common
;
4861 /* Match a common block name. */
4863 match
match_common_name (char *name
)
4867 if (gfc_match_char ('/') == MATCH_NO
)
4873 if (gfc_match_char ('/') == MATCH_YES
)
4879 m
= gfc_match_name (name
);
4881 if (m
== MATCH_ERROR
)
4883 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
4886 gfc_error ("Syntax error in common block name at %C");
4891 /* Match a COMMON statement. */
4894 gfc_match_common (void)
4896 gfc_symbol
*sym
, **head
, *tail
, *other
;
4897 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4907 m
= match_common_name (name
);
4908 if (m
== MATCH_ERROR
)
4911 if (name
[0] == '\0')
4913 t
= &gfc_current_ns
->blank_common
;
4914 if (t
->head
== NULL
)
4915 t
->where
= gfc_current_locus
;
4919 t
= gfc_get_common (name
, 0);
4928 while (tail
->common_next
)
4929 tail
= tail
->common_next
;
4932 /* Grab the list of symbols. */
4935 m
= gfc_match_symbol (&sym
, 0);
4936 if (m
== MATCH_ERROR
)
4941 /* See if we know the current common block is bind(c), and if
4942 so, then see if we can check if the symbol is (which it'll
4943 need to be). This can happen if the bind(c) attr stmt was
4944 applied to the common block, and the variable(s) already
4945 defined, before declaring the common block. */
4946 if (t
->is_bind_c
== 1)
4948 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
4950 /* If we find an error, just print it and continue,
4951 cause it's just semantic, and we can see if there
4953 gfc_error_now ("Variable %qs at %L in common block %qs "
4954 "at %C must be declared with a C "
4955 "interoperable kind since common block "
4957 sym
->name
, &(sym
->declared_at
), t
->name
,
4961 if (sym
->attr
.is_bind_c
== 1)
4962 gfc_error_now ("Variable %qs in common block %qs at %C can not "
4963 "be bind(c) since it is not global", sym
->name
,
4967 if (sym
->attr
.in_common
)
4969 gfc_error ("Symbol %qs at %C is already in a COMMON block",
4974 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
4975 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
4977 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol %qs at "
4978 "%C can only be COMMON in BLOCK DATA",
4983 /* Deal with an optional array specification after the
4985 m
= gfc_match_array_spec (&as
, true, true);
4986 if (m
== MATCH_ERROR
)
4991 if (as
->type
!= AS_EXPLICIT
)
4993 gfc_error ("Array specification for symbol %qs in COMMON "
4994 "at %C must be explicit", sym
->name
);
4998 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
5001 if (sym
->attr
.pointer
)
5003 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
5004 "POINTER array", sym
->name
);
5013 /* Add the in_common attribute, but ignore the reported errors
5014 if any, and continue matching. */
5015 gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
);
5017 sym
->common_block
= t
;
5018 sym
->common_block
->refs
++;
5021 tail
->common_next
= sym
;
5027 sym
->common_head
= t
;
5029 /* Check to see if the symbol is already in an equivalence group.
5030 If it is, set the other members as being in common. */
5031 if (sym
->attr
.in_equivalence
)
5033 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
5035 for (e2
= e1
; e2
; e2
= e2
->eq
)
5036 if (e2
->expr
->symtree
->n
.sym
== sym
)
5043 for (e2
= e1
; e2
; e2
= e2
->eq
)
5045 other
= e2
->expr
->symtree
->n
.sym
;
5046 if (other
->common_head
5047 && other
->common_head
!= sym
->common_head
)
5049 gfc_error ("Symbol %qs, in COMMON block %qs at "
5050 "%C is being indirectly equivalenced to "
5051 "another COMMON block %qs",
5052 sym
->name
, sym
->common_head
->name
,
5053 other
->common_head
->name
);
5056 other
->attr
.in_common
= 1;
5057 other
->common_head
= t
;
5063 gfc_gobble_whitespace ();
5064 if (gfc_match_eos () == MATCH_YES
)
5066 if (gfc_peek_ascii_char () == '/')
5068 if (gfc_match_char (',') != MATCH_YES
)
5070 gfc_gobble_whitespace ();
5071 if (gfc_peek_ascii_char () == '/')
5080 gfc_syntax_error (ST_COMMON
);
5083 gfc_free_array_spec (as
);
5088 /* Match a BLOCK DATA program unit. */
5091 gfc_match_block_data (void)
5093 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5097 if (gfc_match_eos () == MATCH_YES
)
5099 gfc_new_block
= NULL
;
5103 m
= gfc_match ("% %n%t", name
);
5107 if (gfc_get_symbol (name
, NULL
, &sym
))
5110 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
5113 gfc_new_block
= sym
;
5119 /* Free a namelist structure. */
5122 gfc_free_namelist (gfc_namelist
*name
)
5126 for (; name
; name
= n
)
5134 /* Free an OpenMP namelist structure. */
5137 gfc_free_omp_namelist (gfc_omp_namelist
*name
)
5139 gfc_omp_namelist
*n
;
5141 for (; name
; name
= n
)
5143 gfc_free_expr (name
->expr
);
5146 if (name
->udr
->combiner
)
5147 gfc_free_statement (name
->udr
->combiner
);
5148 if (name
->udr
->initializer
)
5149 gfc_free_statement (name
->udr
->initializer
);
5158 /* Match a NAMELIST statement. */
5161 gfc_match_namelist (void)
5163 gfc_symbol
*group_name
, *sym
;
5167 m
= gfc_match (" / %s /", &group_name
);
5170 if (m
== MATCH_ERROR
)
5175 if (group_name
->ts
.type
!= BT_UNKNOWN
)
5177 gfc_error ("Namelist group name %qs at %C already has a basic "
5178 "type of %s", group_name
->name
,
5179 gfc_typename (&group_name
->ts
));
5183 if (group_name
->attr
.flavor
== FL_NAMELIST
5184 && group_name
->attr
.use_assoc
5185 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name %qs "
5186 "at %C already is USE associated and can"
5187 "not be respecified.", group_name
->name
))
5190 if (group_name
->attr
.flavor
!= FL_NAMELIST
5191 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
5192 group_name
->name
, NULL
))
5197 m
= gfc_match_symbol (&sym
, 1);
5200 if (m
== MATCH_ERROR
)
5203 if (sym
->attr
.in_namelist
== 0
5204 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
5207 /* Use gfc_error_check here, rather than goto error, so that
5208 these are the only errors for the next two lines. */
5209 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
5211 gfc_error ("Assumed size array %qs in namelist %qs at "
5212 "%C is not allowed", sym
->name
, group_name
->name
);
5216 nl
= gfc_get_namelist ();
5220 if (group_name
->namelist
== NULL
)
5221 group_name
->namelist
= group_name
->namelist_tail
= nl
;
5224 group_name
->namelist_tail
->next
= nl
;
5225 group_name
->namelist_tail
= nl
;
5228 if (gfc_match_eos () == MATCH_YES
)
5231 m
= gfc_match_char (',');
5233 if (gfc_match_char ('/') == MATCH_YES
)
5235 m2
= gfc_match (" %s /", &group_name
);
5236 if (m2
== MATCH_YES
)
5238 if (m2
== MATCH_ERROR
)
5252 gfc_syntax_error (ST_NAMELIST
);
5259 /* Match a MODULE statement. */
5262 gfc_match_module (void)
5266 m
= gfc_match (" %s%t", &gfc_new_block
);
5270 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
5271 gfc_new_block
->name
, NULL
))
5278 /* Free equivalence sets and lists. Recursively is the easiest way to
5282 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
5287 gfc_free_equiv (eq
->eq
);
5288 gfc_free_equiv_until (eq
->next
, stop
);
5289 gfc_free_expr (eq
->expr
);
5295 gfc_free_equiv (gfc_equiv
*eq
)
5297 gfc_free_equiv_until (eq
, NULL
);
5301 /* Match an EQUIVALENCE statement. */
5304 gfc_match_equivalence (void)
5306 gfc_equiv
*eq
, *set
, *tail
;
5310 gfc_common_head
*common_head
= NULL
;
5318 eq
= gfc_get_equiv ();
5322 eq
->next
= gfc_current_ns
->equiv
;
5323 gfc_current_ns
->equiv
= eq
;
5325 if (gfc_match_char ('(') != MATCH_YES
)
5329 common_flag
= FALSE
;
5334 m
= gfc_match_equiv_variable (&set
->expr
);
5335 if (m
== MATCH_ERROR
)
5340 /* count the number of objects. */
5343 if (gfc_match_char ('%') == MATCH_YES
)
5345 gfc_error ("Derived type component %C is not a "
5346 "permitted EQUIVALENCE member");
5350 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
5351 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5353 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
5354 "be an array section");
5358 sym
= set
->expr
->symtree
->n
.sym
;
5360 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
5363 if (sym
->attr
.in_common
)
5366 common_head
= sym
->common_head
;
5369 if (gfc_match_char (')') == MATCH_YES
)
5372 if (gfc_match_char (',') != MATCH_YES
)
5375 set
->eq
= gfc_get_equiv ();
5381 gfc_error ("EQUIVALENCE at %C requires two or more objects");
5385 /* If one of the members of an equivalence is in common, then
5386 mark them all as being in common. Before doing this, check
5387 that members of the equivalence group are not in different
5390 for (set
= eq
; set
; set
= set
->eq
)
5392 sym
= set
->expr
->symtree
->n
.sym
;
5393 if (sym
->common_head
&& sym
->common_head
!= common_head
)
5395 gfc_error ("Attempt to indirectly overlap COMMON "
5396 "blocks %s and %s by EQUIVALENCE at %C",
5397 sym
->common_head
->name
, common_head
->name
);
5400 sym
->attr
.in_common
= 1;
5401 sym
->common_head
= common_head
;
5404 if (gfc_match_eos () == MATCH_YES
)
5406 if (gfc_match_char (',') != MATCH_YES
)
5408 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
5416 gfc_syntax_error (ST_EQUIVALENCE
);
5422 gfc_free_equiv (gfc_current_ns
->equiv
);
5423 gfc_current_ns
->equiv
= eq
;
5429 /* Check that a statement function is not recursive. This is done by looking
5430 for the statement function symbol(sym) by looking recursively through its
5431 expression(e). If a reference to sym is found, true is returned.
5432 12.5.4 requires that any variable of function that is implicitly typed
5433 shall have that type confirmed by any subsequent type declaration. The
5434 implicit typing is conveniently done here. */
5436 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
5439 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
5445 switch (e
->expr_type
)
5448 if (e
->symtree
== NULL
)
5451 /* Check the name before testing for nested recursion! */
5452 if (sym
->name
== e
->symtree
->n
.sym
->name
)
5455 /* Catch recursion via other statement functions. */
5456 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
5457 && e
->symtree
->n
.sym
->value
5458 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
5461 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5462 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5467 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
5470 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5471 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5483 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
5485 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
5489 /* Match a statement function declaration. It is so easy to match
5490 non-statement function statements with a MATCH_ERROR as opposed to
5491 MATCH_NO that we suppress error message in most cases. */
5494 gfc_match_st_function (void)
5496 gfc_error_buffer old_error
;
5501 m
= gfc_match_symbol (&sym
, 0);
5505 gfc_push_error (&old_error
);
5507 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
5510 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
5513 m
= gfc_match (" = %e%t", &expr
);
5517 gfc_free_error (&old_error
);
5519 if (m
== MATCH_ERROR
)
5522 if (recursive_stmt_fcn (expr
, sym
))
5524 gfc_error ("Statement function at %L is recursive", &expr
->where
);
5530 if ((gfc_current_state () == COMP_FUNCTION
5531 || gfc_current_state () == COMP_SUBROUTINE
)
5532 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
5534 gfc_error ("Statement function at %L cannot appear within an INTERFACE",
5539 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
5545 gfc_pop_error (&old_error
);
5550 /* Match an assignment to a pointer function (F2008). This could, in
5551 general be ambiguous with a statement function. In this implementation
5552 it remains so if it is the first statement after the specification
5556 gfc_match_ptr_fcn_assign (void)
5558 gfc_error_buffer old_error
;
5563 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5565 old_loc
= gfc_current_locus
;
5566 m
= gfc_match_name (name
);
5570 gfc_find_symbol (name
, NULL
, 1, &sym
);
5571 if (sym
&& sym
->attr
.flavor
!= FL_PROCEDURE
)
5574 gfc_push_error (&old_error
);
5576 if (sym
&& sym
->attr
.function
)
5577 goto match_actual_arglist
;
5579 gfc_current_locus
= old_loc
;
5580 m
= gfc_match_symbol (&sym
, 0);
5584 if (!gfc_add_procedure (&sym
->attr
, PROC_UNKNOWN
, sym
->name
, NULL
))
5587 match_actual_arglist
:
5588 gfc_current_locus
= old_loc
;
5589 m
= gfc_match (" %e", &expr
);
5593 new_st
.op
= EXEC_ASSIGN
;
5594 new_st
.expr1
= expr
;
5597 m
= gfc_match (" = %e%t", &expr
);
5601 new_st
.expr2
= expr
;
5605 gfc_pop_error (&old_error
);
5610 /***************** SELECT CASE subroutines ******************/
5612 /* Free a single case structure. */
5615 free_case (gfc_case
*p
)
5617 if (p
->low
== p
->high
)
5619 gfc_free_expr (p
->low
);
5620 gfc_free_expr (p
->high
);
5625 /* Free a list of case structures. */
5628 gfc_free_case_list (gfc_case
*p
)
5640 /* Match a single case selector. Combining the requirements of F08:C830
5641 and F08:C832 (R838) means that the case-value must have either CHARACTER,
5642 INTEGER, or LOGICAL type. */
5645 match_case_selector (gfc_case
**cp
)
5650 c
= gfc_get_case ();
5651 c
->where
= gfc_current_locus
;
5653 if (gfc_match_char (':') == MATCH_YES
)
5655 m
= gfc_match_init_expr (&c
->high
);
5658 if (m
== MATCH_ERROR
)
5661 if (c
->high
->ts
.type
!= BT_LOGICAL
&& c
->high
->ts
.type
!= BT_INTEGER
5662 && c
->high
->ts
.type
!= BT_CHARACTER
)
5664 gfc_error ("Expression in CASE selector at %L cannot be %s",
5665 &c
->high
->where
, gfc_typename (&c
->high
->ts
));
5671 m
= gfc_match_init_expr (&c
->low
);
5672 if (m
== MATCH_ERROR
)
5677 if (c
->low
->ts
.type
!= BT_LOGICAL
&& c
->low
->ts
.type
!= BT_INTEGER
5678 && c
->low
->ts
.type
!= BT_CHARACTER
)
5680 gfc_error ("Expression in CASE selector at %L cannot be %s",
5681 &c
->low
->where
, gfc_typename (&c
->low
->ts
));
5685 /* If we're not looking at a ':' now, make a range out of a single
5686 target. Else get the upper bound for the case range. */
5687 if (gfc_match_char (':') != MATCH_YES
)
5691 m
= gfc_match_init_expr (&c
->high
);
5692 if (m
== MATCH_ERROR
)
5694 /* MATCH_NO is fine. It's OK if nothing is there! */
5702 gfc_error ("Expected initialization expression in CASE at %C");
5710 /* Match the end of a case statement. */
5713 match_case_eos (void)
5715 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5718 if (gfc_match_eos () == MATCH_YES
)
5721 /* If the case construct doesn't have a case-construct-name, we
5722 should have matched the EOS. */
5723 if (!gfc_current_block ())
5726 gfc_gobble_whitespace ();
5728 m
= gfc_match_name (name
);
5732 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5734 gfc_error ("Expected block name %qs of SELECT construct at %C",
5735 gfc_current_block ()->name
);
5739 return gfc_match_eos ();
5743 /* Match a SELECT statement. */
5746 gfc_match_select (void)
5751 m
= gfc_match_label ();
5752 if (m
== MATCH_ERROR
)
5755 m
= gfc_match (" select case ( %e )%t", &expr
);
5759 new_st
.op
= EXEC_SELECT
;
5760 new_st
.expr1
= expr
;
5766 /* Transfer the selector typespec to the associate name. */
5769 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
)
5772 gfc_symbol
*assoc_sym
;
5774 assoc_sym
= associate
->symtree
->n
.sym
;
5776 /* At this stage the expression rank and arrayspec dimensions have
5777 not been completely sorted out. We must get the expr2->rank
5778 right here, so that the correct class container is obtained. */
5779 ref
= selector
->ref
;
5780 while (ref
&& ref
->next
)
5783 if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
5784 && ref
&& ref
->type
== REF_ARRAY
)
5786 /* Ensure that the array reference type is set. We cannot use
5787 gfc_resolve_expr at this point, so the usable parts of
5788 resolve.c(resolve_array_ref) are employed to do it. */
5789 if (ref
->u
.ar
.type
== AR_UNKNOWN
)
5791 ref
->u
.ar
.type
= AR_ELEMENT
;
5792 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
5793 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5794 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
5795 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
5796 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
5798 ref
->u
.ar
.type
= AR_SECTION
;
5803 if (ref
->u
.ar
.type
== AR_FULL
)
5804 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
5805 else if (ref
->u
.ar
.type
== AR_SECTION
)
5806 selector
->rank
= ref
->u
.ar
.dimen
;
5813 assoc_sym
->attr
.dimension
= 1;
5814 assoc_sym
->as
= gfc_get_array_spec ();
5815 assoc_sym
->as
->rank
= selector
->rank
;
5816 assoc_sym
->as
->type
= AS_DEFERRED
;
5819 assoc_sym
->as
= NULL
;
5821 if (selector
->ts
.type
== BT_CLASS
)
5823 /* The correct class container has to be available. */
5824 assoc_sym
->ts
.type
= BT_CLASS
;
5825 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
5826 assoc_sym
->attr
.pointer
= 1;
5827 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
5832 /* Push the current selector onto the SELECT TYPE stack. */
5835 select_type_push (gfc_symbol
*sel
)
5837 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
5838 top
->selector
= sel
;
5840 top
->prev
= select_type_stack
;
5842 select_type_stack
= top
;
5846 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
5848 static gfc_symtree
*
5849 select_intrinsic_set_tmp (gfc_typespec
*ts
)
5851 char name
[GFC_MAX_SYMBOL_LEN
];
5855 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
5858 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5859 && !select_type_stack
->selector
->attr
.class_ok
)
5862 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
5863 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5864 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
5866 if (ts
->type
!= BT_CHARACTER
)
5867 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
5870 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (ts
->type
),
5873 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5874 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5876 /* Copy across the array spec to the selector. */
5877 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5878 && (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5879 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
))
5881 tmp
->n
.sym
->attr
.pointer
= 1;
5882 tmp
->n
.sym
->attr
.dimension
5883 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5884 tmp
->n
.sym
->attr
.codimension
5885 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5887 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5890 gfc_set_sym_referenced (tmp
->n
.sym
);
5891 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5892 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5898 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
5901 select_type_set_tmp (gfc_typespec
*ts
)
5903 char name
[GFC_MAX_SYMBOL_LEN
];
5904 gfc_symtree
*tmp
= NULL
;
5908 select_type_stack
->tmp
= NULL
;
5912 tmp
= select_intrinsic_set_tmp (ts
);
5919 if (ts
->type
== BT_CLASS
)
5920 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
5922 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
5923 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5924 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5926 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5927 && select_type_stack
->selector
->attr
.class_ok
)
5929 tmp
->n
.sym
->attr
.pointer
5930 = CLASS_DATA (select_type_stack
->selector
)->attr
.class_pointer
;
5932 /* Copy across the array spec to the selector. */
5933 if (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5934 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
)
5936 tmp
->n
.sym
->attr
.dimension
5937 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5938 tmp
->n
.sym
->attr
.codimension
5939 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5941 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5945 gfc_set_sym_referenced (tmp
->n
.sym
);
5946 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5947 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5949 if (ts
->type
== BT_CLASS
)
5950 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
5954 /* Add an association for it, so the rest of the parser knows it is
5955 an associate-name. The target will be set during resolution. */
5956 tmp
->n
.sym
->assoc
= gfc_get_association_list ();
5957 tmp
->n
.sym
->assoc
->dangling
= 1;
5958 tmp
->n
.sym
->assoc
->st
= tmp
;
5960 select_type_stack
->tmp
= tmp
;
5964 /* Match a SELECT TYPE statement. */
5967 gfc_match_select_type (void)
5969 gfc_expr
*expr1
, *expr2
= NULL
;
5971 char name
[GFC_MAX_SYMBOL_LEN
];
5974 gfc_namespace
*ns
= gfc_current_ns
;
5976 m
= gfc_match_label ();
5977 if (m
== MATCH_ERROR
)
5980 m
= gfc_match (" select type ( ");
5984 gfc_current_ns
= gfc_build_block_ns (ns
);
5985 m
= gfc_match (" %n => %e", name
, &expr2
);
5988 expr1
= gfc_get_expr ();
5989 expr1
->expr_type
= EXPR_VARIABLE
;
5990 expr1
->where
= expr2
->where
;
5991 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
5997 sym
= expr1
->symtree
->n
.sym
;
5998 if (expr2
->ts
.type
== BT_UNKNOWN
)
5999 sym
->attr
.untyped
= 1;
6001 copy_ts_from_selector_to_associate (expr1
, expr2
);
6003 sym
->attr
.flavor
= FL_VARIABLE
;
6004 sym
->attr
.referenced
= 1;
6005 sym
->attr
.class_ok
= 1;
6009 m
= gfc_match (" %e ", &expr1
);
6012 std::swap (ns
, gfc_current_ns
);
6013 gfc_free_namespace (ns
);
6018 m
= gfc_match (" )%t");
6021 gfc_error ("parse error in SELECT TYPE statement at %C");
6025 /* This ghastly expression seems to be needed to distinguish a CLASS
6026 array, which can have a reference, from other expressions that
6027 have references, such as derived type components, and are not
6028 allowed by the standard.
6029 TODO: see if it is sufficient to exclude component and substring
6031 class_array
= (expr1
->expr_type
== EXPR_VARIABLE
6032 && expr1
->ts
.type
== BT_CLASS
6033 && CLASS_DATA (expr1
)
6034 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
6035 && (CLASS_DATA (expr1
)->attr
.dimension
6036 || CLASS_DATA (expr1
)->attr
.codimension
)
6038 && expr1
->ref
->type
== REF_ARRAY
6039 && expr1
->ref
->next
== NULL
);
6041 /* Check for F03:C811. */
6042 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
6043 || (!class_array
&& expr1
->ref
!= NULL
)))
6045 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
6046 "use associate-name=>");
6051 new_st
.op
= EXEC_SELECT_TYPE
;
6052 new_st
.expr1
= expr1
;
6053 new_st
.expr2
= expr2
;
6054 new_st
.ext
.block
.ns
= gfc_current_ns
;
6056 select_type_push (expr1
->symtree
->n
.sym
);
6057 gfc_current_ns
= ns
;
6062 gfc_free_expr (expr1
);
6063 gfc_free_expr (expr2
);
6064 gfc_undo_symbols ();
6065 std::swap (ns
, gfc_current_ns
);
6066 gfc_free_namespace (ns
);
6071 /* Match a CASE statement. */
6074 gfc_match_case (void)
6076 gfc_case
*c
, *head
, *tail
;
6081 if (gfc_current_state () != COMP_SELECT
)
6083 gfc_error ("Unexpected CASE statement at %C");
6087 if (gfc_match ("% default") == MATCH_YES
)
6089 m
= match_case_eos ();
6092 if (m
== MATCH_ERROR
)
6095 new_st
.op
= EXEC_SELECT
;
6096 c
= gfc_get_case ();
6097 c
->where
= gfc_current_locus
;
6098 new_st
.ext
.block
.case_list
= c
;
6102 if (gfc_match_char ('(') != MATCH_YES
)
6107 if (match_case_selector (&c
) == MATCH_ERROR
)
6117 if (gfc_match_char (')') == MATCH_YES
)
6119 if (gfc_match_char (',') != MATCH_YES
)
6123 m
= match_case_eos ();
6126 if (m
== MATCH_ERROR
)
6129 new_st
.op
= EXEC_SELECT
;
6130 new_st
.ext
.block
.case_list
= head
;
6135 gfc_error ("Syntax error in CASE specification at %C");
6138 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
6143 /* Match a TYPE IS statement. */
6146 gfc_match_type_is (void)
6151 if (gfc_current_state () != COMP_SELECT_TYPE
)
6153 gfc_error ("Unexpected TYPE IS statement at %C");
6157 if (gfc_match_char ('(') != MATCH_YES
)
6160 c
= gfc_get_case ();
6161 c
->where
= gfc_current_locus
;
6163 m
= gfc_match_type_spec (&c
->ts
);
6166 if (m
== MATCH_ERROR
)
6169 if (gfc_match_char (')') != MATCH_YES
)
6172 m
= match_case_eos ();
6175 if (m
== MATCH_ERROR
)
6178 new_st
.op
= EXEC_SELECT_TYPE
;
6179 new_st
.ext
.block
.case_list
= c
;
6181 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
6182 && (c
->ts
.u
.derived
->attr
.sequence
6183 || c
->ts
.u
.derived
->attr
.is_bind_c
))
6185 gfc_error ("The type-spec shall not specify a sequence derived "
6186 "type or a type with the BIND attribute in SELECT "
6187 "TYPE at %C [F2003:C815]");
6191 if (c
->ts
.type
== BT_DERIVED
6192 && c
->ts
.u
.derived
&& c
->ts
.u
.derived
->attr
.pdt_type
6193 && gfc_spec_list_type (type_param_spec_list
, c
->ts
.u
.derived
)
6196 gfc_error ("All the LEN type parameters in the TYPE IS statement "
6197 "at %C must be ASSUMED");
6201 /* Create temporary variable. */
6202 select_type_set_tmp (&c
->ts
);
6207 gfc_error ("Ssyntax error in TYPE IS specification at %C");
6211 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6216 /* Match a CLASS IS or CLASS DEFAULT statement. */
6219 gfc_match_class_is (void)
6224 if (gfc_current_state () != COMP_SELECT_TYPE
)
6227 if (gfc_match ("% default") == MATCH_YES
)
6229 m
= match_case_eos ();
6232 if (m
== MATCH_ERROR
)
6235 new_st
.op
= EXEC_SELECT_TYPE
;
6236 c
= gfc_get_case ();
6237 c
->where
= gfc_current_locus
;
6238 c
->ts
.type
= BT_UNKNOWN
;
6239 new_st
.ext
.block
.case_list
= c
;
6240 select_type_set_tmp (NULL
);
6244 m
= gfc_match ("% is");
6247 if (m
== MATCH_ERROR
)
6250 if (gfc_match_char ('(') != MATCH_YES
)
6253 c
= gfc_get_case ();
6254 c
->where
= gfc_current_locus
;
6256 m
= match_derived_type_spec (&c
->ts
);
6259 if (m
== MATCH_ERROR
)
6262 if (c
->ts
.type
== BT_DERIVED
)
6263 c
->ts
.type
= BT_CLASS
;
6265 if (gfc_match_char (')') != MATCH_YES
)
6268 m
= match_case_eos ();
6271 if (m
== MATCH_ERROR
)
6274 new_st
.op
= EXEC_SELECT_TYPE
;
6275 new_st
.ext
.block
.case_list
= c
;
6277 /* Create temporary variable. */
6278 select_type_set_tmp (&c
->ts
);
6283 gfc_error ("Syntax error in CLASS IS specification at %C");
6287 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6292 /********************* WHERE subroutines ********************/
6294 /* Match the rest of a simple WHERE statement that follows an IF statement.
6298 match_simple_where (void)
6304 m
= gfc_match (" ( %e )", &expr
);
6308 m
= gfc_match_assignment ();
6311 if (m
== MATCH_ERROR
)
6314 if (gfc_match_eos () != MATCH_YES
)
6317 c
= gfc_get_code (EXEC_WHERE
);
6320 c
->next
= XCNEW (gfc_code
);
6322 c
->next
->loc
= gfc_current_locus
;
6323 gfc_clear_new_st ();
6325 new_st
.op
= EXEC_WHERE
;
6331 gfc_syntax_error (ST_WHERE
);
6334 gfc_free_expr (expr
);
6339 /* Match a WHERE statement. */
6342 gfc_match_where (gfc_statement
*st
)
6348 m0
= gfc_match_label ();
6349 if (m0
== MATCH_ERROR
)
6352 m
= gfc_match (" where ( %e )", &expr
);
6356 if (gfc_match_eos () == MATCH_YES
)
6358 *st
= ST_WHERE_BLOCK
;
6359 new_st
.op
= EXEC_WHERE
;
6360 new_st
.expr1
= expr
;
6364 m
= gfc_match_assignment ();
6366 gfc_syntax_error (ST_WHERE
);
6370 gfc_free_expr (expr
);
6374 /* We've got a simple WHERE statement. */
6376 c
= gfc_get_code (EXEC_WHERE
);
6379 /* Put in the assignment. It will not be processed by add_statement, so we
6380 need to copy the location here. */
6382 c
->next
= XCNEW (gfc_code
);
6384 c
->next
->loc
= gfc_current_locus
;
6385 gfc_clear_new_st ();
6387 new_st
.op
= EXEC_WHERE
;
6394 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
6395 new_st if successful. */
6398 gfc_match_elsewhere (void)
6400 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6404 if (gfc_current_state () != COMP_WHERE
)
6406 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
6412 if (gfc_match_char ('(') == MATCH_YES
)
6414 m
= gfc_match_expr (&expr
);
6417 if (m
== MATCH_ERROR
)
6420 if (gfc_match_char (')') != MATCH_YES
)
6424 if (gfc_match_eos () != MATCH_YES
)
6426 /* Only makes sense if we have a where-construct-name. */
6427 if (!gfc_current_block ())
6432 /* Better be a name at this point. */
6433 m
= gfc_match_name (name
);
6436 if (m
== MATCH_ERROR
)
6439 if (gfc_match_eos () != MATCH_YES
)
6442 if (strcmp (name
, gfc_current_block ()->name
) != 0)
6444 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
6445 name
, gfc_current_block ()->name
);
6450 new_st
.op
= EXEC_WHERE
;
6451 new_st
.expr1
= expr
;
6455 gfc_syntax_error (ST_ELSEWHERE
);
6458 gfc_free_expr (expr
);