1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000-2015 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"
31 #include "stringpool.h"
33 int gfc_matching_ptr_assignment
= 0;
34 int gfc_matching_procptr_assignment
= 0;
35 bool gfc_matching_prefix
= false;
37 /* Stack of SELECT TYPE statements. */
38 gfc_select_type_stack
*select_type_stack
= NULL
;
40 /* For debugging and diagnostic purposes. Return the textual representation
41 of the intrinsic operator OP. */
43 gfc_op2string (gfc_intrinsic_op op
)
51 case INTRINSIC_UMINUS
:
57 case INTRINSIC_CONCAT
:
61 case INTRINSIC_DIVIDE
:
100 case INTRINSIC_ASSIGN
:
103 case INTRINSIC_PARENTHESES
:
113 gfc_internal_error ("gfc_op2string(): Bad code");
118 /******************** Generic matching subroutines ************************/
120 /* This function scans the current statement counting the opened and closed
121 parenthesis to make sure they are balanced. */
124 gfc_match_parens (void)
126 locus old_loc
, where
;
128 gfc_instring instring
;
131 old_loc
= gfc_current_locus
;
133 instring
= NONSTRING
;
138 c
= gfc_next_char_literal (instring
);
141 if (quote
== ' ' && ((c
== '\'') || (c
== '"')))
144 instring
= INSTRING_WARN
;
147 if (quote
!= ' ' && c
== quote
)
150 instring
= NONSTRING
;
154 if (c
== '(' && quote
== ' ')
157 where
= gfc_current_locus
;
159 if (c
== ')' && quote
== ' ')
162 where
= gfc_current_locus
;
166 gfc_current_locus
= old_loc
;
170 gfc_error ("Missing %<)%> in statement at or before %L", &where
);
175 gfc_error ("Missing %<(%> in statement at or before %L", &where
);
183 /* See if the next character is a special character that has
184 escaped by a \ via the -fbackslash option. */
187 gfc_match_special_char (gfc_char_t
*res
)
195 switch ((c
= gfc_next_char_literal (INSTRING_WARN
)))
228 /* Hexadecimal form of wide characters. */
229 len
= (c
== 'x' ? 2 : (c
== 'u' ? 4 : 8));
231 for (i
= 0; i
< len
; i
++)
233 char buf
[2] = { '\0', '\0' };
235 c
= gfc_next_char_literal (INSTRING_WARN
);
236 if (!gfc_wide_fits_in_byte (c
)
237 || !gfc_check_digit ((unsigned char) c
, 16))
240 buf
[0] = (unsigned char) c
;
242 n
+= strtol (buf
, NULL
, 16);
248 /* Unknown backslash codes are simply not expanded. */
257 /* In free form, match at least one space. Always matches in fixed
261 gfc_match_space (void)
266 if (gfc_current_form
== FORM_FIXED
)
269 old_loc
= gfc_current_locus
;
271 c
= gfc_next_ascii_char ();
272 if (!gfc_is_whitespace (c
))
274 gfc_current_locus
= old_loc
;
278 gfc_gobble_whitespace ();
284 /* Match an end of statement. End of statement is optional
285 whitespace, followed by a ';' or '\n' or comment '!'. If a
286 semicolon is found, we continue to eat whitespace and semicolons. */
299 old_loc
= gfc_current_locus
;
300 gfc_gobble_whitespace ();
302 c
= gfc_next_ascii_char ();
308 c
= gfc_next_ascii_char ();
325 gfc_current_locus
= old_loc
;
326 return (flag
) ? MATCH_YES
: MATCH_NO
;
330 /* Match a literal integer on the input, setting the value on
331 MATCH_YES. Literal ints occur in kind-parameters as well as
332 old-style character length specifications. If cnt is non-NULL it
333 will be set to the number of digits. */
336 gfc_match_small_literal_int (int *value
, int *cnt
)
342 old_loc
= gfc_current_locus
;
345 gfc_gobble_whitespace ();
346 c
= gfc_next_ascii_char ();
352 gfc_current_locus
= old_loc
;
361 old_loc
= gfc_current_locus
;
362 c
= gfc_next_ascii_char ();
367 i
= 10 * i
+ c
- '0';
372 gfc_error ("Integer too large at %C");
377 gfc_current_locus
= old_loc
;
386 /* Match a small, constant integer expression, like in a kind
387 statement. On MATCH_YES, 'value' is set. */
390 gfc_match_small_int (int *value
)
397 m
= gfc_match_expr (&expr
);
401 p
= gfc_extract_int (expr
, &i
);
402 gfc_free_expr (expr
);
415 /* This function is the same as the gfc_match_small_int, except that
416 we're keeping the pointer to the expr. This function could just be
417 removed and the previously mentioned one modified, though all calls
418 to it would have to be modified then (and there were a number of
419 them). Return MATCH_ERROR if fail to extract the int; otherwise,
420 return the result of gfc_match_expr(). The expr (if any) that was
421 matched is returned in the parameter expr. */
424 gfc_match_small_int_expr (int *value
, gfc_expr
**expr
)
430 m
= gfc_match_expr (expr
);
434 p
= gfc_extract_int (*expr
, &i
);
447 /* Matches a statement label. Uses gfc_match_small_literal_int() to
448 do most of the work. */
451 gfc_match_st_label (gfc_st_label
**label
)
457 old_loc
= gfc_current_locus
;
459 m
= gfc_match_small_literal_int (&i
, &cnt
);
465 gfc_error ("Too many digits in statement label at %C");
471 gfc_error ("Statement label at %C is zero");
475 *label
= gfc_get_st_label (i
);
480 gfc_current_locus
= old_loc
;
485 /* Match and validate a label associated with a named IF, DO or SELECT
486 statement. If the symbol does not have the label attribute, we add
487 it. We also make sure the symbol does not refer to another
488 (active) block. A matched label is pointed to by gfc_new_block. */
491 gfc_match_label (void)
493 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
496 gfc_new_block
= NULL
;
498 m
= gfc_match (" %n :", name
);
502 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
504 gfc_error ("Label name %qs at %C is ambiguous", name
);
508 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
510 gfc_error ("Duplicate construct label %qs at %C", name
);
514 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
515 gfc_new_block
->name
, NULL
))
522 /* See if the current input looks like a name of some sort. Modifies
523 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
524 Note that options.c restricts max_identifier_length to not more
525 than GFC_MAX_SYMBOL_LEN. */
528 gfc_match_name (char *buffer
)
534 old_loc
= gfc_current_locus
;
535 gfc_gobble_whitespace ();
537 c
= gfc_next_ascii_char ();
538 if (!(ISALPHA (c
) || (c
== '_' && flag_allow_leading_underscore
)))
540 if (!gfc_error_flag_test () && c
!= '(')
541 gfc_error ("Invalid character in name at %C");
542 gfc_current_locus
= old_loc
;
552 if (i
> gfc_option
.max_identifier_length
)
554 gfc_error ("Name at %C is too long");
558 old_loc
= gfc_current_locus
;
559 c
= gfc_next_ascii_char ();
561 while (ISALNUM (c
) || c
== '_' || (flag_dollar_ok
&& c
== '$'));
563 if (c
== '$' && !flag_dollar_ok
)
565 gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to "
566 "allow it as an extension", &old_loc
);
571 gfc_current_locus
= old_loc
;
577 /* Match a symbol on the input. Modifies the pointer to the symbol
578 pointer if successful. */
581 gfc_match_sym_tree (gfc_symtree
**matched_symbol
, int host_assoc
)
583 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
586 m
= gfc_match_name (buffer
);
591 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
592 ? MATCH_ERROR
: MATCH_YES
;
594 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
, false))
602 gfc_match_symbol (gfc_symbol
**matched_symbol
, int host_assoc
)
607 m
= gfc_match_sym_tree (&st
, host_assoc
);
612 *matched_symbol
= st
->n
.sym
;
614 *matched_symbol
= NULL
;
617 *matched_symbol
= NULL
;
622 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
623 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
627 gfc_match_intrinsic_op (gfc_intrinsic_op
*result
)
629 locus orig_loc
= gfc_current_locus
;
632 gfc_gobble_whitespace ();
633 ch
= gfc_next_ascii_char ();
638 *result
= INTRINSIC_PLUS
;
643 *result
= INTRINSIC_MINUS
;
647 if (gfc_next_ascii_char () == '=')
650 *result
= INTRINSIC_EQ
;
656 if (gfc_peek_ascii_char () == '=')
659 gfc_next_ascii_char ();
660 *result
= INTRINSIC_LE
;
664 *result
= INTRINSIC_LT
;
668 if (gfc_peek_ascii_char () == '=')
671 gfc_next_ascii_char ();
672 *result
= INTRINSIC_GE
;
676 *result
= INTRINSIC_GT
;
680 if (gfc_peek_ascii_char () == '*')
683 gfc_next_ascii_char ();
684 *result
= INTRINSIC_POWER
;
688 *result
= INTRINSIC_TIMES
;
692 ch
= gfc_peek_ascii_char ();
696 gfc_next_ascii_char ();
697 *result
= INTRINSIC_NE
;
703 gfc_next_ascii_char ();
704 *result
= INTRINSIC_CONCAT
;
708 *result
= INTRINSIC_DIVIDE
;
712 ch
= gfc_next_ascii_char ();
716 if (gfc_next_ascii_char () == 'n'
717 && gfc_next_ascii_char () == 'd'
718 && gfc_next_ascii_char () == '.')
720 /* Matched ".and.". */
721 *result
= INTRINSIC_AND
;
727 if (gfc_next_ascii_char () == 'q')
729 ch
= gfc_next_ascii_char ();
732 /* Matched ".eq.". */
733 *result
= INTRINSIC_EQ_OS
;
738 if (gfc_next_ascii_char () == '.')
740 /* Matched ".eqv.". */
741 *result
= INTRINSIC_EQV
;
749 ch
= gfc_next_ascii_char ();
752 if (gfc_next_ascii_char () == '.')
754 /* Matched ".ge.". */
755 *result
= INTRINSIC_GE_OS
;
761 if (gfc_next_ascii_char () == '.')
763 /* Matched ".gt.". */
764 *result
= INTRINSIC_GT_OS
;
771 ch
= gfc_next_ascii_char ();
774 if (gfc_next_ascii_char () == '.')
776 /* Matched ".le.". */
777 *result
= INTRINSIC_LE_OS
;
783 if (gfc_next_ascii_char () == '.')
785 /* Matched ".lt.". */
786 *result
= INTRINSIC_LT_OS
;
793 ch
= gfc_next_ascii_char ();
796 ch
= gfc_next_ascii_char ();
799 /* Matched ".ne.". */
800 *result
= INTRINSIC_NE_OS
;
805 if (gfc_next_ascii_char () == 'v'
806 && gfc_next_ascii_char () == '.')
808 /* Matched ".neqv.". */
809 *result
= INTRINSIC_NEQV
;
816 if (gfc_next_ascii_char () == 't'
817 && gfc_next_ascii_char () == '.')
819 /* Matched ".not.". */
820 *result
= INTRINSIC_NOT
;
827 if (gfc_next_ascii_char () == 'r'
828 && gfc_next_ascii_char () == '.')
830 /* Matched ".or.". */
831 *result
= INTRINSIC_OR
;
845 gfc_current_locus
= orig_loc
;
850 /* Match a loop control phrase:
852 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
854 If the final integer expression is not present, a constant unity
855 expression is returned. We don't return MATCH_ERROR until after
856 the equals sign is seen. */
859 gfc_match_iterator (gfc_iterator
*iter
, int init_flag
)
861 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
862 gfc_expr
*var
, *e1
, *e2
, *e3
;
868 /* Match the start of an iterator without affecting the symbol table. */
870 start
= gfc_current_locus
;
871 m
= gfc_match (" %n =", name
);
872 gfc_current_locus
= start
;
877 m
= gfc_match_variable (&var
, 0);
881 /* F2008, C617 & C565. */
882 if (var
->symtree
->n
.sym
->attr
.codimension
)
884 gfc_error ("Loop variable at %C cannot be a coarray");
888 if (var
->ref
!= NULL
)
890 gfc_error ("Loop variable at %C cannot be a sub-component");
894 gfc_match_char ('=');
896 var
->symtree
->n
.sym
->attr
.implied_index
= 1;
898 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
901 if (m
== MATCH_ERROR
)
904 if (gfc_match_char (',') != MATCH_YES
)
907 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
910 if (m
== MATCH_ERROR
)
913 if (gfc_match_char (',') != MATCH_YES
)
915 e3
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
919 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
920 if (m
== MATCH_ERROR
)
924 gfc_error ("Expected a step value in iterator at %C");
936 gfc_error ("Syntax error in iterator at %C");
947 /* Tries to match the next non-whitespace character on the input.
948 This subroutine does not return MATCH_ERROR. */
951 gfc_match_char (char c
)
955 where
= gfc_current_locus
;
956 gfc_gobble_whitespace ();
958 if (gfc_next_ascii_char () == c
)
961 gfc_current_locus
= where
;
966 /* General purpose matching subroutine. The target string is a
967 scanf-like format string in which spaces correspond to arbitrary
968 whitespace (including no whitespace), characters correspond to
969 themselves. The %-codes are:
971 %% Literal percent sign
972 %e Expression, pointer to a pointer is set
973 %s Symbol, pointer to the symbol is set
974 %n Name, character buffer is set to name
975 %t Matches end of statement.
976 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
977 %l Matches a statement label
978 %v Matches a variable expression (an lvalue)
979 % Matches a required space (in free form) and optional spaces. */
982 gfc_match (const char *target
, ...)
984 gfc_st_label
**label
;
993 old_loc
= gfc_current_locus
;
994 va_start (argp
, target
);
1004 gfc_gobble_whitespace ();
1015 vp
= va_arg (argp
, void **);
1016 n
= gfc_match_expr ((gfc_expr
**) vp
);
1027 vp
= va_arg (argp
, void **);
1028 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
1039 vp
= va_arg (argp
, void **);
1040 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
1051 np
= va_arg (argp
, char *);
1052 n
= gfc_match_name (np
);
1063 label
= va_arg (argp
, gfc_st_label
**);
1064 n
= gfc_match_st_label (label
);
1075 ip
= va_arg (argp
, int *);
1076 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
1087 if (gfc_match_eos () != MATCH_YES
)
1095 if (gfc_match_space () == MATCH_YES
)
1101 break; /* Fall through to character matcher. */
1104 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
1109 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1110 expect an upper case character here! */
1111 gcc_assert (TOLOWER (c
) == c
);
1113 if (c
== gfc_next_ascii_char ())
1123 /* Clean up after a failed match. */
1124 gfc_current_locus
= old_loc
;
1125 va_start (argp
, target
);
1128 for (; matches
> 0; matches
--)
1130 while (*p
++ != '%');
1138 /* Matches that don't have to be undone */
1143 (void) va_arg (argp
, void **);
1148 vp
= va_arg (argp
, void **);
1149 gfc_free_expr ((struct gfc_expr
*)*vp
);
1162 /*********************** Statement level matching **********************/
1164 /* Matches the start of a program unit, which is the program keyword
1165 followed by an obligatory symbol. */
1168 gfc_match_program (void)
1173 m
= gfc_match ("% %s%t", &sym
);
1177 gfc_error ("Invalid form of PROGRAM statement at %C");
1181 if (m
== MATCH_ERROR
)
1184 if (!gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
))
1187 gfc_new_block
= sym
;
1193 /* Match a simple assignment statement. */
1196 gfc_match_assignment (void)
1198 gfc_expr
*lvalue
, *rvalue
;
1202 old_loc
= gfc_current_locus
;
1205 m
= gfc_match (" %v =", &lvalue
);
1208 gfc_current_locus
= old_loc
;
1209 gfc_free_expr (lvalue
);
1214 m
= gfc_match (" %e%t", &rvalue
);
1217 gfc_current_locus
= old_loc
;
1218 gfc_free_expr (lvalue
);
1219 gfc_free_expr (rvalue
);
1223 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1225 new_st
.op
= EXEC_ASSIGN
;
1226 new_st
.expr1
= lvalue
;
1227 new_st
.expr2
= rvalue
;
1229 gfc_check_do_variable (lvalue
->symtree
);
1235 /* Match a pointer assignment statement. */
1238 gfc_match_pointer_assignment (void)
1240 gfc_expr
*lvalue
, *rvalue
;
1244 old_loc
= gfc_current_locus
;
1246 lvalue
= rvalue
= NULL
;
1247 gfc_matching_ptr_assignment
= 0;
1248 gfc_matching_procptr_assignment
= 0;
1250 m
= gfc_match (" %v =>", &lvalue
);
1257 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1258 || gfc_is_proc_ptr_comp (lvalue
))
1259 gfc_matching_procptr_assignment
= 1;
1261 gfc_matching_ptr_assignment
= 1;
1263 m
= gfc_match (" %e%t", &rvalue
);
1264 gfc_matching_ptr_assignment
= 0;
1265 gfc_matching_procptr_assignment
= 0;
1269 new_st
.op
= EXEC_POINTER_ASSIGN
;
1270 new_st
.expr1
= lvalue
;
1271 new_st
.expr2
= rvalue
;
1276 gfc_current_locus
= old_loc
;
1277 gfc_free_expr (lvalue
);
1278 gfc_free_expr (rvalue
);
1283 /* We try to match an easy arithmetic IF statement. This only happens
1284 when just after having encountered a simple IF statement. This code
1285 is really duplicate with parts of the gfc_match_if code, but this is
1289 match_arithmetic_if (void)
1291 gfc_st_label
*l1
, *l2
, *l3
;
1295 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1299 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1300 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1301 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1303 gfc_free_expr (expr
);
1307 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Arithmetic IF statement at %C"))
1310 new_st
.op
= EXEC_ARITHMETIC_IF
;
1311 new_st
.expr1
= expr
;
1320 /* The IF statement is a bit of a pain. First of all, there are three
1321 forms of it, the simple IF, the IF that starts a block and the
1324 There is a problem with the simple IF and that is the fact that we
1325 only have a single level of undo information on symbols. What this
1326 means is for a simple IF, we must re-match the whole IF statement
1327 multiple times in order to guarantee that the symbol table ends up
1328 in the proper state. */
1330 static match
match_simple_forall (void);
1331 static match
match_simple_where (void);
1334 gfc_match_if (gfc_statement
*if_type
)
1337 gfc_st_label
*l1
, *l2
, *l3
;
1338 locus old_loc
, old_loc2
;
1342 n
= gfc_match_label ();
1343 if (n
== MATCH_ERROR
)
1346 old_loc
= gfc_current_locus
;
1348 m
= gfc_match (" if ( %e", &expr
);
1352 old_loc2
= gfc_current_locus
;
1353 gfc_current_locus
= old_loc
;
1355 if (gfc_match_parens () == MATCH_ERROR
)
1358 gfc_current_locus
= old_loc2
;
1360 if (gfc_match_char (')') != MATCH_YES
)
1362 gfc_error ("Syntax error in IF-expression at %C");
1363 gfc_free_expr (expr
);
1367 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1373 gfc_error ("Block label not appropriate for arithmetic IF "
1375 gfc_free_expr (expr
);
1379 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1380 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1381 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1383 gfc_free_expr (expr
);
1387 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Arithmetic IF statement at %C"))
1390 new_st
.op
= EXEC_ARITHMETIC_IF
;
1391 new_st
.expr1
= expr
;
1396 *if_type
= ST_ARITHMETIC_IF
;
1400 if (gfc_match (" then%t") == MATCH_YES
)
1402 new_st
.op
= EXEC_IF
;
1403 new_st
.expr1
= expr
;
1404 *if_type
= ST_IF_BLOCK
;
1410 gfc_error ("Block label is not appropriate for IF statement at %C");
1411 gfc_free_expr (expr
);
1415 /* At this point the only thing left is a simple IF statement. At
1416 this point, n has to be MATCH_NO, so we don't have to worry about
1417 re-matching a block label. From what we've got so far, try
1418 matching an assignment. */
1420 *if_type
= ST_SIMPLE_IF
;
1422 m
= gfc_match_assignment ();
1426 gfc_free_expr (expr
);
1427 gfc_undo_symbols ();
1428 gfc_current_locus
= old_loc
;
1430 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1431 assignment was found. For MATCH_NO, continue to call the various
1433 if (m
== MATCH_ERROR
)
1436 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1438 m
= gfc_match_pointer_assignment ();
1442 gfc_free_expr (expr
);
1443 gfc_undo_symbols ();
1444 gfc_current_locus
= old_loc
;
1446 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1448 /* Look at the next keyword to see which matcher to call. Matching
1449 the keyword doesn't affect the symbol table, so we don't have to
1450 restore between tries. */
1452 #define match(string, subr, statement) \
1453 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1457 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1458 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1459 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1460 match ("call", gfc_match_call
, ST_CALL
)
1461 match ("close", gfc_match_close
, ST_CLOSE
)
1462 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1463 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1464 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1465 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1466 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
)
1467 match ("exit", gfc_match_exit
, ST_EXIT
)
1468 match ("flush", gfc_match_flush
, ST_FLUSH
)
1469 match ("forall", match_simple_forall
, ST_FORALL
)
1470 match ("go to", gfc_match_goto
, ST_GOTO
)
1471 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1472 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1473 match ("lock", gfc_match_lock
, ST_LOCK
)
1474 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1475 match ("open", gfc_match_open
, ST_OPEN
)
1476 match ("pause", gfc_match_pause
, ST_NONE
)
1477 match ("print", gfc_match_print
, ST_WRITE
)
1478 match ("read", gfc_match_read
, ST_READ
)
1479 match ("return", gfc_match_return
, ST_RETURN
)
1480 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1481 match ("stop", gfc_match_stop
, ST_STOP
)
1482 match ("wait", gfc_match_wait
, ST_WAIT
)
1483 match ("sync all", gfc_match_sync_all
, ST_SYNC_CALL
);
1484 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
1485 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
1486 match ("unlock", gfc_match_unlock
, ST_UNLOCK
)
1487 match ("where", match_simple_where
, ST_WHERE
)
1488 match ("write", gfc_match_write
, ST_WRITE
)
1490 /* The gfc_match_assignment() above may have returned a MATCH_NO
1491 where the assignment was to a named constant. Check that
1492 special case here. */
1493 m
= gfc_match_assignment ();
1496 gfc_error ("Cannot assign to a named constant at %C");
1497 gfc_free_expr (expr
);
1498 gfc_undo_symbols ();
1499 gfc_current_locus
= old_loc
;
1503 /* All else has failed, so give up. See if any of the matchers has
1504 stored an error message of some sort. */
1505 if (!gfc_error_check ())
1506 gfc_error ("Unclassifiable statement in IF-clause at %C");
1508 gfc_free_expr (expr
);
1513 gfc_error ("Syntax error in IF-clause at %C");
1516 gfc_free_expr (expr
);
1520 /* At this point, we've matched the single IF and the action clause
1521 is in new_st. Rearrange things so that the IF statement appears
1524 p
= gfc_get_code (EXEC_IF
);
1525 p
->next
= XCNEW (gfc_code
);
1527 p
->next
->loc
= gfc_current_locus
;
1531 gfc_clear_new_st ();
1533 new_st
.op
= EXEC_IF
;
1542 /* Match an ELSE statement. */
1545 gfc_match_else (void)
1547 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1549 if (gfc_match_eos () == MATCH_YES
)
1552 if (gfc_match_name (name
) != MATCH_YES
1553 || gfc_current_block () == NULL
1554 || gfc_match_eos () != MATCH_YES
)
1556 gfc_error ("Unexpected junk after ELSE statement at %C");
1560 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1562 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1563 name
, gfc_current_block ()->name
);
1571 /* Match an ELSE IF statement. */
1574 gfc_match_elseif (void)
1576 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1580 m
= gfc_match (" ( %e ) then", &expr
);
1584 if (gfc_match_eos () == MATCH_YES
)
1587 if (gfc_match_name (name
) != MATCH_YES
1588 || gfc_current_block () == NULL
1589 || gfc_match_eos () != MATCH_YES
)
1591 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1595 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1597 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1598 name
, gfc_current_block ()->name
);
1603 new_st
.op
= EXEC_IF
;
1604 new_st
.expr1
= expr
;
1608 gfc_free_expr (expr
);
1613 /* Free a gfc_iterator structure. */
1616 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1622 gfc_free_expr (iter
->var
);
1623 gfc_free_expr (iter
->start
);
1624 gfc_free_expr (iter
->end
);
1625 gfc_free_expr (iter
->step
);
1632 /* Match a CRITICAL statement. */
1634 gfc_match_critical (void)
1636 gfc_st_label
*label
= NULL
;
1638 if (gfc_match_label () == MATCH_ERROR
)
1641 if (gfc_match (" critical") != MATCH_YES
)
1644 if (gfc_match_st_label (&label
) == MATCH_ERROR
)
1647 if (gfc_match_eos () != MATCH_YES
)
1649 gfc_syntax_error (ST_CRITICAL
);
1653 if (gfc_pure (NULL
))
1655 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1659 if (gfc_find_state (COMP_DO_CONCURRENT
))
1661 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1666 gfc_unset_implicit_pure (NULL
);
1668 if (!gfc_notify_std (GFC_STD_F2008
, "CRITICAL statement at %C"))
1671 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1673 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1678 if (gfc_find_state (COMP_CRITICAL
))
1680 gfc_error ("Nested CRITICAL block at %C");
1684 new_st
.op
= EXEC_CRITICAL
;
1687 && !gfc_reference_st_label (label
, ST_LABEL_TARGET
))
1694 /* Match a BLOCK statement. */
1697 gfc_match_block (void)
1701 if (gfc_match_label () == MATCH_ERROR
)
1704 if (gfc_match (" block") != MATCH_YES
)
1707 /* For this to be a correct BLOCK statement, the line must end now. */
1708 m
= gfc_match_eos ();
1709 if (m
== MATCH_ERROR
)
1718 /* Match an ASSOCIATE statement. */
1721 gfc_match_associate (void)
1723 if (gfc_match_label () == MATCH_ERROR
)
1726 if (gfc_match (" associate") != MATCH_YES
)
1729 /* Match the association list. */
1730 if (gfc_match_char ('(') != MATCH_YES
)
1732 gfc_error ("Expected association list at %C");
1735 new_st
.ext
.block
.assoc
= NULL
;
1738 gfc_association_list
* newAssoc
= gfc_get_association_list ();
1739 gfc_association_list
* a
;
1741 /* Match the next association. */
1742 if (gfc_match (" %n => %e", newAssoc
->name
, &newAssoc
->target
)
1745 gfc_error ("Expected association at %C");
1746 goto assocListError
;
1748 newAssoc
->where
= gfc_current_locus
;
1750 /* Check that the current name is not yet in the list. */
1751 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
1752 if (!strcmp (a
->name
, newAssoc
->name
))
1754 gfc_error ("Duplicate name %qs in association at %C",
1756 goto assocListError
;
1759 /* The target expression must not be coindexed. */
1760 if (gfc_is_coindexed (newAssoc
->target
))
1762 gfc_error ("Association target at %C must not be coindexed");
1763 goto assocListError
;
1766 /* The `variable' field is left blank for now; because the target is not
1767 yet resolved, we can't use gfc_has_vector_subscript to determine it
1768 for now. This is set during resolution. */
1770 /* Put it into the list. */
1771 newAssoc
->next
= new_st
.ext
.block
.assoc
;
1772 new_st
.ext
.block
.assoc
= newAssoc
;
1774 /* Try next one or end if closing parenthesis is found. */
1775 gfc_gobble_whitespace ();
1776 if (gfc_peek_char () == ')')
1778 if (gfc_match_char (',') != MATCH_YES
)
1780 gfc_error ("Expected %<)%> or %<,%> at %C");
1790 if (gfc_match_char (')') != MATCH_YES
)
1792 /* This should never happen as we peek above. */
1796 if (gfc_match_eos () != MATCH_YES
)
1798 gfc_error ("Junk after ASSOCIATE statement at %C");
1805 gfc_free_association_list (new_st
.ext
.block
.assoc
);
1810 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1811 an accessible derived type. */
1814 match_derived_type_spec (gfc_typespec
*ts
)
1816 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1818 gfc_symbol
*derived
;
1820 old_locus
= gfc_current_locus
;
1822 if (gfc_match ("%n", name
) != MATCH_YES
)
1824 gfc_current_locus
= old_locus
;
1828 gfc_find_symbol (name
, NULL
, 1, &derived
);
1830 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
&& derived
->attr
.generic
)
1831 derived
= gfc_find_dt_in_generic (derived
);
1833 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
1835 ts
->type
= BT_DERIVED
;
1836 ts
->u
.derived
= derived
;
1840 gfc_current_locus
= old_locus
;
1845 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
1846 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
1847 It only includes the intrinsic types from the Fortran 2003 standard
1848 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
1849 the implicit_flag is not needed, so it was removed. Derived types are
1850 identified by their name alone. */
1853 gfc_match_type_spec (gfc_typespec
*ts
)
1859 gfc_gobble_whitespace ();
1860 old_locus
= gfc_current_locus
;
1862 if (match_derived_type_spec (ts
) == MATCH_YES
)
1864 /* Enforce F03:C401. */
1865 if (ts
->u
.derived
->attr
.abstract
)
1867 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
1868 ts
->u
.derived
->name
, &old_locus
);
1874 if (gfc_match ("integer") == MATCH_YES
)
1876 ts
->type
= BT_INTEGER
;
1877 ts
->kind
= gfc_default_integer_kind
;
1881 if (gfc_match ("real") == MATCH_YES
)
1884 ts
->kind
= gfc_default_real_kind
;
1888 if (gfc_match ("double precision") == MATCH_YES
)
1891 ts
->kind
= gfc_default_double_kind
;
1895 if (gfc_match ("complex") == MATCH_YES
)
1897 ts
->type
= BT_COMPLEX
;
1898 ts
->kind
= gfc_default_complex_kind
;
1902 if (gfc_match ("character") == MATCH_YES
)
1904 ts
->type
= BT_CHARACTER
;
1906 m
= gfc_match_char_spec (ts
);
1914 if (gfc_match ("logical") == MATCH_YES
)
1916 ts
->type
= BT_LOGICAL
;
1917 ts
->kind
= gfc_default_logical_kind
;
1921 /* If a type is not matched, simply return MATCH_NO. */
1922 gfc_current_locus
= old_locus
;
1927 gfc_gobble_whitespace ();
1928 if (gfc_peek_ascii_char () == '*')
1930 gfc_error ("Invalid type-spec at %C");
1934 m
= gfc_match_kind_spec (ts
, false);
1937 m
= MATCH_YES
; /* No kind specifier found. */
1943 /******************** FORALL subroutines ********************/
1945 /* Free a list of FORALL iterators. */
1948 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
1950 gfc_forall_iterator
*next
;
1955 gfc_free_expr (iter
->var
);
1956 gfc_free_expr (iter
->start
);
1957 gfc_free_expr (iter
->end
);
1958 gfc_free_expr (iter
->stride
);
1965 /* Match an iterator as part of a FORALL statement. The format is:
1967 <var> = <start>:<end>[:<stride>]
1969 On MATCH_NO, the caller tests for the possibility that there is a
1970 scalar mask expression. */
1973 match_forall_iterator (gfc_forall_iterator
**result
)
1975 gfc_forall_iterator
*iter
;
1979 where
= gfc_current_locus
;
1980 iter
= XCNEW (gfc_forall_iterator
);
1982 m
= gfc_match_expr (&iter
->var
);
1986 if (gfc_match_char ('=') != MATCH_YES
1987 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
1993 m
= gfc_match_expr (&iter
->start
);
1997 if (gfc_match_char (':') != MATCH_YES
)
2000 m
= gfc_match_expr (&iter
->end
);
2003 if (m
== MATCH_ERROR
)
2006 if (gfc_match_char (':') == MATCH_NO
)
2007 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2010 m
= gfc_match_expr (&iter
->stride
);
2013 if (m
== MATCH_ERROR
)
2017 /* Mark the iteration variable's symbol as used as a FORALL index. */
2018 iter
->var
->symtree
->n
.sym
->forall_index
= true;
2024 gfc_error ("Syntax error in FORALL iterator at %C");
2029 gfc_current_locus
= where
;
2030 gfc_free_forall_iterator (iter
);
2035 /* Match the header of a FORALL statement. */
2038 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
2040 gfc_forall_iterator
*head
, *tail
, *new_iter
;
2044 gfc_gobble_whitespace ();
2049 if (gfc_match_char ('(') != MATCH_YES
)
2052 m
= match_forall_iterator (&new_iter
);
2053 if (m
== MATCH_ERROR
)
2058 head
= tail
= new_iter
;
2062 if (gfc_match_char (',') != MATCH_YES
)
2065 m
= match_forall_iterator (&new_iter
);
2066 if (m
== MATCH_ERROR
)
2071 tail
->next
= new_iter
;
2076 /* Have to have a mask expression. */
2078 m
= gfc_match_expr (&msk
);
2081 if (m
== MATCH_ERROR
)
2087 if (gfc_match_char (')') == MATCH_NO
)
2095 gfc_syntax_error (ST_FORALL
);
2098 gfc_free_expr (msk
);
2099 gfc_free_forall_iterator (head
);
2104 /* Match the rest of a simple FORALL statement that follows an
2108 match_simple_forall (void)
2110 gfc_forall_iterator
*head
;
2119 m
= match_forall_header (&head
, &mask
);
2126 m
= gfc_match_assignment ();
2128 if (m
== MATCH_ERROR
)
2132 m
= gfc_match_pointer_assignment ();
2133 if (m
== MATCH_ERROR
)
2139 c
= XCNEW (gfc_code
);
2141 c
->loc
= gfc_current_locus
;
2143 if (gfc_match_eos () != MATCH_YES
)
2146 gfc_clear_new_st ();
2147 new_st
.op
= EXEC_FORALL
;
2148 new_st
.expr1
= mask
;
2149 new_st
.ext
.forall_iterator
= head
;
2150 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2151 new_st
.block
->next
= c
;
2156 gfc_syntax_error (ST_FORALL
);
2159 gfc_free_forall_iterator (head
);
2160 gfc_free_expr (mask
);
2166 /* Match a FORALL statement. */
2169 gfc_match_forall (gfc_statement
*st
)
2171 gfc_forall_iterator
*head
;
2180 m0
= gfc_match_label ();
2181 if (m0
== MATCH_ERROR
)
2184 m
= gfc_match (" forall");
2188 m
= match_forall_header (&head
, &mask
);
2189 if (m
== MATCH_ERROR
)
2194 if (gfc_match_eos () == MATCH_YES
)
2196 *st
= ST_FORALL_BLOCK
;
2197 new_st
.op
= EXEC_FORALL
;
2198 new_st
.expr1
= mask
;
2199 new_st
.ext
.forall_iterator
= head
;
2203 m
= gfc_match_assignment ();
2204 if (m
== MATCH_ERROR
)
2208 m
= gfc_match_pointer_assignment ();
2209 if (m
== MATCH_ERROR
)
2215 c
= XCNEW (gfc_code
);
2217 c
->loc
= gfc_current_locus
;
2219 gfc_clear_new_st ();
2220 new_st
.op
= EXEC_FORALL
;
2221 new_st
.expr1
= mask
;
2222 new_st
.ext
.forall_iterator
= head
;
2223 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2224 new_st
.block
->next
= c
;
2230 gfc_syntax_error (ST_FORALL
);
2233 gfc_free_forall_iterator (head
);
2234 gfc_free_expr (mask
);
2235 gfc_free_statements (c
);
2240 /* Match a DO statement. */
2245 gfc_iterator iter
, *ip
;
2247 gfc_st_label
*label
;
2250 old_loc
= gfc_current_locus
;
2253 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
2255 m
= gfc_match_label ();
2256 if (m
== MATCH_ERROR
)
2259 if (gfc_match (" do") != MATCH_YES
)
2262 m
= gfc_match_st_label (&label
);
2263 if (m
== MATCH_ERROR
)
2266 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2268 if (gfc_match_eos () == MATCH_YES
)
2270 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
2271 new_st
.op
= EXEC_DO_WHILE
;
2275 /* Match an optional comma, if no comma is found, a space is obligatory. */
2276 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
2279 /* Check for balanced parens. */
2281 if (gfc_match_parens () == MATCH_ERROR
)
2284 if (gfc_match (" concurrent") == MATCH_YES
)
2286 gfc_forall_iterator
*head
;
2289 if (!gfc_notify_std (GFC_STD_F2008
, "DO CONCURRENT construct at %C"))
2295 m
= match_forall_header (&head
, &mask
);
2299 if (m
== MATCH_ERROR
)
2300 goto concurr_cleanup
;
2302 if (gfc_match_eos () != MATCH_YES
)
2303 goto concurr_cleanup
;
2306 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2307 goto concurr_cleanup
;
2309 new_st
.label1
= label
;
2310 new_st
.op
= EXEC_DO_CONCURRENT
;
2311 new_st
.expr1
= mask
;
2312 new_st
.ext
.forall_iterator
= head
;
2317 gfc_syntax_error (ST_DO
);
2318 gfc_free_expr (mask
);
2319 gfc_free_forall_iterator (head
);
2323 /* See if we have a DO WHILE. */
2324 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
2326 new_st
.op
= EXEC_DO_WHILE
;
2330 /* The abortive DO WHILE may have done something to the symbol
2331 table, so we start over. */
2332 gfc_undo_symbols ();
2333 gfc_current_locus
= old_loc
;
2335 gfc_match_label (); /* This won't error. */
2336 gfc_match (" do "); /* This will work. */
2338 gfc_match_st_label (&label
); /* Can't error out. */
2339 gfc_match_char (','); /* Optional comma. */
2341 m
= gfc_match_iterator (&iter
, 0);
2344 if (m
== MATCH_ERROR
)
2347 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
2348 gfc_check_do_variable (iter
.var
->symtree
);
2350 if (gfc_match_eos () != MATCH_YES
)
2352 gfc_syntax_error (ST_DO
);
2356 new_st
.op
= EXEC_DO
;
2360 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2363 new_st
.label1
= label
;
2365 if (new_st
.op
== EXEC_DO_WHILE
)
2366 new_st
.expr1
= iter
.end
;
2369 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
2376 gfc_free_iterator (&iter
, 0);
2382 /* Match an EXIT or CYCLE statement. */
2385 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2387 gfc_state_data
*p
, *o
;
2392 if (gfc_match_eos () == MATCH_YES
)
2396 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2399 m
= gfc_match ("% %n%t", name
);
2400 if (m
== MATCH_ERROR
)
2404 gfc_syntax_error (st
);
2408 /* Find the corresponding symbol. If there's a BLOCK statement
2409 between here and the label, it is not in gfc_current_ns but a parent
2411 stree
= gfc_find_symtree_in_proc (name
, gfc_current_ns
);
2414 gfc_error ("Name %qs in %s statement at %C is unknown",
2415 name
, gfc_ascii_statement (st
));
2420 if (sym
->attr
.flavor
!= FL_LABEL
)
2422 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2423 name
, gfc_ascii_statement (st
));
2428 /* Find the loop specified by the label (or lack of a label). */
2429 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2430 if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2432 else if (p
->state
== COMP_CRITICAL
)
2434 gfc_error("%s statement at %C leaves CRITICAL construct",
2435 gfc_ascii_statement (st
));
2438 else if (p
->state
== COMP_DO_CONCURRENT
2439 && (op
== EXEC_EXIT
|| (sym
&& sym
!= p
->sym
)))
2441 /* F2008, C821 & C845. */
2442 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2443 gfc_ascii_statement (st
));
2446 else if ((sym
&& sym
== p
->sym
)
2447 || (!sym
&& (p
->state
== COMP_DO
2448 || p
->state
== COMP_DO_CONCURRENT
)))
2454 gfc_error ("%s statement at %C is not within a construct",
2455 gfc_ascii_statement (st
));
2457 gfc_error ("%s statement at %C is not within construct %qs",
2458 gfc_ascii_statement (st
), sym
->name
);
2463 /* Special checks for EXIT from non-loop constructs. */
2467 case COMP_DO_CONCURRENT
:
2471 /* This is already handled above. */
2474 case COMP_ASSOCIATE
:
2478 case COMP_SELECT_TYPE
:
2480 if (op
== EXEC_CYCLE
)
2482 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2483 " construct %qs", sym
->name
);
2486 gcc_assert (op
== EXEC_EXIT
);
2487 if (!gfc_notify_std (GFC_STD_F2008
, "EXIT statement with no"
2488 " do-construct-name at %C"))
2493 gfc_error ("%s statement at %C is not applicable to construct %qs",
2494 gfc_ascii_statement (st
), sym
->name
);
2500 gfc_error (is_oacc (p
)
2501 ? "%s statement at %C leaving OpenACC structured block"
2502 : "%s statement at %C leaving OpenMP structured block",
2503 gfc_ascii_statement (st
));
2507 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2511 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
2512 && (o
->head
->op
== EXEC_OACC_LOOP
2513 || o
->head
->op
== EXEC_OACC_PARALLEL_LOOP
))
2516 gcc_assert (o
->head
->next
!= NULL
2517 && (o
->head
->next
->op
== EXEC_DO
2518 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2519 && o
->previous
!= NULL
2520 && o
->previous
->tail
->op
== o
->head
->op
);
2521 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2522 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2523 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2524 if (st
== ST_EXIT
&& cnt
<= collapse
)
2526 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2529 if (st
== ST_CYCLE
&& cnt
< collapse
)
2531 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2532 " !$ACC LOOP loop");
2538 && (o
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2539 && (o
->head
->op
== EXEC_OMP_DO
2540 || o
->head
->op
== EXEC_OMP_PARALLEL_DO
2541 || o
->head
->op
== EXEC_OMP_SIMD
2542 || o
->head
->op
== EXEC_OMP_DO_SIMD
2543 || o
->head
->op
== EXEC_OMP_PARALLEL_DO_SIMD
))
2546 gcc_assert (o
->head
->next
!= NULL
2547 && (o
->head
->next
->op
== EXEC_DO
2548 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2549 && o
->previous
!= NULL
2550 && o
->previous
->tail
->op
== o
->head
->op
);
2551 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2552 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2553 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2554 if (st
== ST_EXIT
&& cnt
<= collapse
)
2556 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2559 if (st
== ST_CYCLE
&& cnt
< collapse
)
2561 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2567 /* Save the first statement in the construct - needed by the backend. */
2568 new_st
.ext
.which_construct
= p
->construct
;
2576 /* Match the EXIT statement. */
2579 gfc_match_exit (void)
2581 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2585 /* Match the CYCLE statement. */
2588 gfc_match_cycle (void)
2590 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2594 /* Match a number or character constant after an (ERROR) STOP or PAUSE
2598 gfc_match_stopcode (gfc_statement st
)
2605 if (gfc_match_eos () != MATCH_YES
)
2607 m
= gfc_match_init_expr (&e
);
2608 if (m
== MATCH_ERROR
)
2613 if (gfc_match_eos () != MATCH_YES
)
2617 if (gfc_pure (NULL
))
2619 if (st
== ST_ERROR_STOP
)
2621 if (!gfc_notify_std (GFC_STD_F2015
, "%s statement at %C in PURE "
2622 "procedure", gfc_ascii_statement (st
)))
2627 gfc_error ("%s statement not allowed in PURE procedure at %C",
2628 gfc_ascii_statement (st
));
2633 gfc_unset_implicit_pure (NULL
);
2635 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
))
2637 gfc_error ("Image control statement STOP at %C in CRITICAL block");
2640 if (st
== ST_STOP
&& gfc_find_state (COMP_DO_CONCURRENT
))
2642 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
2648 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
2650 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2657 gfc_error ("STOP code at %L must be scalar",
2662 if (e
->ts
.type
== BT_CHARACTER
2663 && e
->ts
.kind
!= gfc_default_character_kind
)
2665 gfc_error ("STOP code at %L must be default character KIND=%d",
2666 &e
->where
, (int) gfc_default_character_kind
);
2670 if (e
->ts
.type
== BT_INTEGER
2671 && e
->ts
.kind
!= gfc_default_integer_kind
)
2673 gfc_error ("STOP code at %L must be default integer KIND=%d",
2674 &e
->where
, (int) gfc_default_integer_kind
);
2682 new_st
.op
= EXEC_STOP
;
2685 new_st
.op
= EXEC_ERROR_STOP
;
2688 new_st
.op
= EXEC_PAUSE
;
2695 new_st
.ext
.stop_code
= -1;
2700 gfc_syntax_error (st
);
2709 /* Match the (deprecated) PAUSE statement. */
2712 gfc_match_pause (void)
2716 m
= gfc_match_stopcode (ST_PAUSE
);
2719 if (!gfc_notify_std (GFC_STD_F95_DEL
, "PAUSE statement at %C"))
2726 /* Match the STOP statement. */
2729 gfc_match_stop (void)
2731 return gfc_match_stopcode (ST_STOP
);
2735 /* Match the ERROR STOP statement. */
2738 gfc_match_error_stop (void)
2740 if (!gfc_notify_std (GFC_STD_F2008
, "ERROR STOP statement at %C"))
2743 return gfc_match_stopcode (ST_ERROR_STOP
);
2747 /* Match LOCK/UNLOCK statement. Syntax:
2748 LOCK ( lock-variable [ , lock-stat-list ] )
2749 UNLOCK ( lock-variable [ , sync-stat-list ] )
2750 where lock-stat is ACQUIRED_LOCK or sync-stat
2751 and sync-stat is STAT= or ERRMSG=. */
2754 lock_unlock_statement (gfc_statement st
)
2757 gfc_expr
*tmp
, *lockvar
, *acq_lock
, *stat
, *errmsg
;
2758 bool saw_acq_lock
, saw_stat
, saw_errmsg
;
2760 tmp
= lockvar
= acq_lock
= stat
= errmsg
= NULL
;
2761 saw_acq_lock
= saw_stat
= saw_errmsg
= false;
2763 if (gfc_pure (NULL
))
2765 gfc_error ("Image control statement %s at %C in PURE procedure",
2766 st
== ST_LOCK
? "LOCK" : "UNLOCK");
2770 gfc_unset_implicit_pure (NULL
);
2772 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2774 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2778 if (gfc_find_state (COMP_CRITICAL
))
2780 gfc_error ("Image control statement %s at %C in CRITICAL block",
2781 st
== ST_LOCK
? "LOCK" : "UNLOCK");
2785 if (gfc_find_state (COMP_DO_CONCURRENT
))
2787 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
2788 st
== ST_LOCK
? "LOCK" : "UNLOCK");
2792 if (gfc_match_char ('(') != MATCH_YES
)
2795 if (gfc_match ("%e", &lockvar
) != MATCH_YES
)
2797 m
= gfc_match_char (',');
2798 if (m
== MATCH_ERROR
)
2802 m
= gfc_match_char (')');
2810 m
= gfc_match (" stat = %v", &tmp
);
2811 if (m
== MATCH_ERROR
)
2817 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
2823 m
= gfc_match_char (',');
2831 m
= gfc_match (" errmsg = %v", &tmp
);
2832 if (m
== MATCH_ERROR
)
2838 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
2844 m
= gfc_match_char (',');
2852 m
= gfc_match (" acquired_lock = %v", &tmp
);
2853 if (m
== MATCH_ERROR
|| st
== ST_UNLOCK
)
2859 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
2864 saw_acq_lock
= true;
2866 m
= gfc_match_char (',');
2877 if (m
== MATCH_ERROR
)
2880 if (gfc_match (" )%t") != MATCH_YES
)
2887 new_st
.op
= EXEC_LOCK
;
2890 new_st
.op
= EXEC_UNLOCK
;
2896 new_st
.expr1
= lockvar
;
2897 new_st
.expr2
= stat
;
2898 new_st
.expr3
= errmsg
;
2899 new_st
.expr4
= acq_lock
;
2904 gfc_syntax_error (st
);
2907 if (acq_lock
!= tmp
)
2908 gfc_free_expr (acq_lock
);
2910 gfc_free_expr (errmsg
);
2912 gfc_free_expr (stat
);
2914 gfc_free_expr (tmp
);
2915 gfc_free_expr (lockvar
);
2922 gfc_match_lock (void)
2924 if (!gfc_notify_std (GFC_STD_F2008
, "LOCK statement at %C"))
2927 return lock_unlock_statement (ST_LOCK
);
2932 gfc_match_unlock (void)
2934 if (!gfc_notify_std (GFC_STD_F2008
, "UNLOCK statement at %C"))
2937 return lock_unlock_statement (ST_UNLOCK
);
2941 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
2942 SYNC ALL [(sync-stat-list)]
2943 SYNC MEMORY [(sync-stat-list)]
2944 SYNC IMAGES (image-set [, sync-stat-list] )
2945 with sync-stat is int-expr or *. */
2948 sync_statement (gfc_statement st
)
2951 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
2952 bool saw_stat
, saw_errmsg
;
2954 tmp
= imageset
= stat
= errmsg
= NULL
;
2955 saw_stat
= saw_errmsg
= false;
2957 if (gfc_pure (NULL
))
2959 gfc_error ("Image control statement SYNC at %C in PURE procedure");
2963 gfc_unset_implicit_pure (NULL
);
2965 if (!gfc_notify_std (GFC_STD_F2008
, "SYNC statement at %C"))
2968 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2970 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
2975 if (gfc_find_state (COMP_CRITICAL
))
2977 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
2981 if (gfc_find_state (COMP_DO_CONCURRENT
))
2983 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
2987 if (gfc_match_eos () == MATCH_YES
)
2989 if (st
== ST_SYNC_IMAGES
)
2994 if (gfc_match_char ('(') != MATCH_YES
)
2997 if (st
== ST_SYNC_IMAGES
)
2999 /* Denote '*' as imageset == NULL. */
3000 m
= gfc_match_char ('*');
3001 if (m
== MATCH_ERROR
)
3005 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
3008 m
= gfc_match_char (',');
3009 if (m
== MATCH_ERROR
)
3013 m
= gfc_match_char (')');
3022 m
= gfc_match (" stat = %v", &tmp
);
3023 if (m
== MATCH_ERROR
)
3029 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3035 if (gfc_match_char (',') == MATCH_YES
)
3042 m
= gfc_match (" errmsg = %v", &tmp
);
3043 if (m
== MATCH_ERROR
)
3049 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3055 if (gfc_match_char (',') == MATCH_YES
)
3065 if (gfc_match (" )%t") != MATCH_YES
)
3072 new_st
.op
= EXEC_SYNC_ALL
;
3074 case ST_SYNC_IMAGES
:
3075 new_st
.op
= EXEC_SYNC_IMAGES
;
3077 case ST_SYNC_MEMORY
:
3078 new_st
.op
= EXEC_SYNC_MEMORY
;
3084 new_st
.expr1
= imageset
;
3085 new_st
.expr2
= stat
;
3086 new_st
.expr3
= errmsg
;
3091 gfc_syntax_error (st
);
3095 gfc_free_expr (stat
);
3097 gfc_free_expr (errmsg
);
3099 gfc_free_expr (tmp
);
3100 gfc_free_expr (imageset
);
3106 /* Match SYNC ALL statement. */
3109 gfc_match_sync_all (void)
3111 return sync_statement (ST_SYNC_ALL
);
3115 /* Match SYNC IMAGES statement. */
3118 gfc_match_sync_images (void)
3120 return sync_statement (ST_SYNC_IMAGES
);
3124 /* Match SYNC MEMORY statement. */
3127 gfc_match_sync_memory (void)
3129 return sync_statement (ST_SYNC_MEMORY
);
3133 /* Match a CONTINUE statement. */
3136 gfc_match_continue (void)
3138 if (gfc_match_eos () != MATCH_YES
)
3140 gfc_syntax_error (ST_CONTINUE
);
3144 new_st
.op
= EXEC_CONTINUE
;
3149 /* Match the (deprecated) ASSIGN statement. */
3152 gfc_match_assign (void)
3155 gfc_st_label
*label
;
3157 if (gfc_match (" %l", &label
) == MATCH_YES
)
3159 if (!gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
))
3161 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
3163 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGN statement at %C"))
3166 expr
->symtree
->n
.sym
->attr
.assign
= 1;
3168 new_st
.op
= EXEC_LABEL_ASSIGN
;
3169 new_st
.label1
= label
;
3170 new_st
.expr1
= expr
;
3178 /* Match the GO TO statement. As a computed GOTO statement is
3179 matched, it is transformed into an equivalent SELECT block. No
3180 tree is necessary, and the resulting jumps-to-jumps are
3181 specifically optimized away by the back end. */
3184 gfc_match_goto (void)
3186 gfc_code
*head
, *tail
;
3189 gfc_st_label
*label
;
3193 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
3195 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3198 new_st
.op
= EXEC_GOTO
;
3199 new_st
.label1
= label
;
3203 /* The assigned GO TO statement. */
3205 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
3207 if (!gfc_notify_std (GFC_STD_F95_DEL
, "Assigned GOTO statement at %C"))
3210 new_st
.op
= EXEC_GOTO
;
3211 new_st
.expr1
= expr
;
3213 if (gfc_match_eos () == MATCH_YES
)
3216 /* Match label list. */
3217 gfc_match_char (',');
3218 if (gfc_match_char ('(') != MATCH_YES
)
3220 gfc_syntax_error (ST_GOTO
);
3227 m
= gfc_match_st_label (&label
);
3231 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3235 head
= tail
= gfc_get_code (EXEC_GOTO
);
3238 tail
->block
= gfc_get_code (EXEC_GOTO
);
3242 tail
->label1
= label
;
3244 while (gfc_match_char (',') == MATCH_YES
);
3246 if (gfc_match (")%t") != MATCH_YES
)
3251 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3254 new_st
.block
= head
;
3259 /* Last chance is a computed GO TO statement. */
3260 if (gfc_match_char ('(') != MATCH_YES
)
3262 gfc_syntax_error (ST_GOTO
);
3271 m
= gfc_match_st_label (&label
);
3275 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3279 head
= tail
= gfc_get_code (EXEC_SELECT
);
3282 tail
->block
= gfc_get_code (EXEC_SELECT
);
3286 cp
= gfc_get_case ();
3287 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
3290 tail
->ext
.block
.case_list
= cp
;
3292 tail
->next
= gfc_get_code (EXEC_GOTO
);
3293 tail
->next
->label1
= label
;
3295 while (gfc_match_char (',') == MATCH_YES
);
3297 if (gfc_match_char (')') != MATCH_YES
)
3302 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3306 /* Get the rest of the statement. */
3307 gfc_match_char (',');
3309 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
3312 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Computed GOTO at %C"))
3315 /* At this point, a computed GOTO has been fully matched and an
3316 equivalent SELECT statement constructed. */
3318 new_st
.op
= EXEC_SELECT
;
3319 new_st
.expr1
= NULL
;
3321 /* Hack: For a "real" SELECT, the expression is in expr. We put
3322 it in expr2 so we can distinguish then and produce the correct
3324 new_st
.expr2
= expr
;
3325 new_st
.block
= head
;
3329 gfc_syntax_error (ST_GOTO
);
3331 gfc_free_statements (head
);
3336 /* Frees a list of gfc_alloc structures. */
3339 gfc_free_alloc_list (gfc_alloc
*p
)
3346 gfc_free_expr (p
->expr
);
3352 /* Match an ALLOCATE statement. */
3355 gfc_match_allocate (void)
3357 gfc_alloc
*head
, *tail
;
3358 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
3362 locus old_locus
, deferred_locus
;
3363 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, saw_deferred
, b1
, b2
, b3
;
3364 bool saw_unlimited
= false;
3367 stat
= errmsg
= source
= mold
= tmp
= NULL
;
3368 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= saw_deferred
= false;
3370 if (gfc_match_char ('(') != MATCH_YES
)
3373 /* Match an optional type-spec. */
3374 old_locus
= gfc_current_locus
;
3375 m
= gfc_match_type_spec (&ts
);
3376 if (m
== MATCH_ERROR
)
3378 else if (m
== MATCH_NO
)
3380 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
3382 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
3384 gfc_error ("Error in type-spec at %L", &old_locus
);
3388 ts
.type
= BT_UNKNOWN
;
3392 if (gfc_match (" :: ") == MATCH_YES
)
3394 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
3400 gfc_error ("Type-spec at %L cannot contain a deferred "
3401 "type parameter", &old_locus
);
3405 if (ts
.type
== BT_CHARACTER
)
3406 ts
.u
.cl
->length_from_typespec
= true;
3410 ts
.type
= BT_UNKNOWN
;
3411 gfc_current_locus
= old_locus
;
3418 head
= tail
= gfc_get_alloc ();
3421 tail
->next
= gfc_get_alloc ();
3425 m
= gfc_match_variable (&tail
->expr
, 0);
3428 if (m
== MATCH_ERROR
)
3431 if (gfc_check_do_variable (tail
->expr
->symtree
))
3434 bool impure
= gfc_impure_variable (tail
->expr
->symtree
->n
.sym
);
3435 if (impure
&& gfc_pure (NULL
))
3437 gfc_error ("Bad allocate-object at %C for a PURE procedure");
3442 gfc_unset_implicit_pure (NULL
);
3444 if (tail
->expr
->ts
.deferred
)
3446 saw_deferred
= true;
3447 deferred_locus
= tail
->expr
->where
;
3450 if (gfc_find_state (COMP_DO_CONCURRENT
)
3451 || gfc_find_state (COMP_CRITICAL
))
3454 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
3455 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
3456 if (ref
->type
== REF_COMPONENT
)
3457 coarray
= ref
->u
.c
.component
->attr
.codimension
;
3459 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
3461 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
3464 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
3466 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
3471 /* Check for F08:C628. */
3472 sym
= tail
->expr
->symtree
->n
.sym
;
3473 b1
= !(tail
->expr
->ref
3474 && (tail
->expr
->ref
->type
== REF_COMPONENT
3475 || tail
->expr
->ref
->type
== REF_ARRAY
));
3476 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
3477 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
3478 || CLASS_DATA (sym
)->attr
.class_pointer
);
3480 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
3481 || sym
->attr
.proc_pointer
);
3482 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
3483 && (sym
->ns
->proc_name
->attr
.allocatable
3484 || sym
->ns
->proc_name
->attr
.pointer
3485 || sym
->ns
->proc_name
->attr
.proc_pointer
);
3486 if (b1
&& b2
&& !b3
)
3488 gfc_error ("Allocate-object at %L is neither a data pointer "
3489 "nor an allocatable variable", &tail
->expr
->where
);
3493 /* The ALLOCATE statement had an optional typespec. Check the
3495 if (ts
.type
!= BT_UNKNOWN
)
3497 /* Enforce F03:C624. */
3498 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
3500 gfc_error ("Type of entity at %L is type incompatible with "
3501 "typespec", &tail
->expr
->where
);
3505 /* Enforce F03:C627. */
3506 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
3508 gfc_error ("Kind type parameter for entity at %L differs from "
3509 "the kind type parameter of the typespec",
3510 &tail
->expr
->where
);
3515 if (tail
->expr
->ts
.type
== BT_DERIVED
)
3516 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
3518 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
3520 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
3522 gfc_error ("Shape specification for allocatable scalar at %C");
3526 if (gfc_match_char (',') != MATCH_YES
)
3531 m
= gfc_match (" stat = %v", &tmp
);
3532 if (m
== MATCH_ERROR
)
3539 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3547 if (gfc_check_do_variable (stat
->symtree
))
3550 if (gfc_match_char (',') == MATCH_YES
)
3551 goto alloc_opt_list
;
3554 m
= gfc_match (" errmsg = %v", &tmp
);
3555 if (m
== MATCH_ERROR
)
3559 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
3565 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3573 if (gfc_match_char (',') == MATCH_YES
)
3574 goto alloc_opt_list
;
3577 m
= gfc_match (" source = %e", &tmp
);
3578 if (m
== MATCH_ERROR
)
3582 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
3588 gfc_error ("Redundant SOURCE tag found at %L ", &tmp
->where
);
3592 /* The next 2 conditionals check C631. */
3593 if (ts
.type
!= BT_UNKNOWN
)
3595 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
3596 &tmp
->where
, &old_locus
);
3601 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
3602 " with more than a single allocate object",
3610 if (gfc_match_char (',') == MATCH_YES
)
3611 goto alloc_opt_list
;
3614 m
= gfc_match (" mold = %e", &tmp
);
3615 if (m
== MATCH_ERROR
)
3619 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
3622 /* Check F08:C636. */
3625 gfc_error ("Redundant MOLD tag found at %L ", &tmp
->where
);
3629 /* Check F08:C637. */
3630 if (ts
.type
!= BT_UNKNOWN
)
3632 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
3633 &tmp
->where
, &old_locus
);
3642 if (gfc_match_char (',') == MATCH_YES
)
3643 goto alloc_opt_list
;
3646 gfc_gobble_whitespace ();
3648 if (gfc_peek_char () == ')')
3652 if (gfc_match (" )%t") != MATCH_YES
)
3655 /* Check F08:C637. */
3658 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
3659 &mold
->where
, &source
->where
);
3663 /* Check F03:C623, */
3664 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
3666 gfc_error ("Allocate-object at %L with a deferred type parameter "
3667 "requires either a type-spec or SOURCE tag or a MOLD tag",
3672 /* Check F03:C625, */
3673 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
3675 for (tail
= head
; tail
; tail
= tail
->next
)
3677 if (UNLIMITED_POLY (tail
->expr
))
3678 gfc_error ("Unlimited polymorphic allocate-object at %L "
3679 "requires either a type-spec or SOURCE tag "
3680 "or a MOLD tag", &tail
->expr
->where
);
3685 new_st
.op
= EXEC_ALLOCATE
;
3686 new_st
.expr1
= stat
;
3687 new_st
.expr2
= errmsg
;
3689 new_st
.expr3
= source
;
3691 new_st
.expr3
= mold
;
3692 new_st
.ext
.alloc
.list
= head
;
3693 new_st
.ext
.alloc
.ts
= ts
;
3698 gfc_syntax_error (ST_ALLOCATE
);
3701 gfc_free_expr (errmsg
);
3702 gfc_free_expr (source
);
3703 gfc_free_expr (stat
);
3704 gfc_free_expr (mold
);
3705 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
3706 gfc_free_alloc_list (head
);
3711 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
3712 a set of pointer assignments to intrinsic NULL(). */
3715 gfc_match_nullify (void)
3723 if (gfc_match_char ('(') != MATCH_YES
)
3728 m
= gfc_match_variable (&p
, 0);
3729 if (m
== MATCH_ERROR
)
3734 if (gfc_check_do_variable (p
->symtree
))
3738 if (gfc_is_coindexed (p
))
3740 gfc_error ("Pointer object at %C shall not be coindexed");
3744 /* build ' => NULL() '. */
3745 e
= gfc_get_null_expr (&gfc_current_locus
);
3747 /* Chain to list. */
3751 tail
->op
= EXEC_POINTER_ASSIGN
;
3755 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
3762 if (gfc_match (" )%t") == MATCH_YES
)
3764 if (gfc_match_char (',') != MATCH_YES
)
3771 gfc_syntax_error (ST_NULLIFY
);
3774 gfc_free_statements (new_st
.next
);
3776 gfc_free_expr (new_st
.expr1
);
3777 new_st
.expr1
= NULL
;
3778 gfc_free_expr (new_st
.expr2
);
3779 new_st
.expr2
= NULL
;
3784 /* Match a DEALLOCATE statement. */
3787 gfc_match_deallocate (void)
3789 gfc_alloc
*head
, *tail
;
3790 gfc_expr
*stat
, *errmsg
, *tmp
;
3793 bool saw_stat
, saw_errmsg
, b1
, b2
;
3796 stat
= errmsg
= tmp
= NULL
;
3797 saw_stat
= saw_errmsg
= false;
3799 if (gfc_match_char ('(') != MATCH_YES
)
3805 head
= tail
= gfc_get_alloc ();
3808 tail
->next
= gfc_get_alloc ();
3812 m
= gfc_match_variable (&tail
->expr
, 0);
3813 if (m
== MATCH_ERROR
)
3818 if (gfc_check_do_variable (tail
->expr
->symtree
))
3821 sym
= tail
->expr
->symtree
->n
.sym
;
3823 bool impure
= gfc_impure_variable (sym
);
3824 if (impure
&& gfc_pure (NULL
))
3826 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3831 gfc_unset_implicit_pure (NULL
);
3833 if (gfc_is_coarray (tail
->expr
)
3834 && gfc_find_state (COMP_DO_CONCURRENT
))
3836 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
3840 if (gfc_is_coarray (tail
->expr
)
3841 && gfc_find_state (COMP_CRITICAL
))
3843 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
3847 /* FIXME: disable the checking on derived types. */
3848 b1
= !(tail
->expr
->ref
3849 && (tail
->expr
->ref
->type
== REF_COMPONENT
3850 || tail
->expr
->ref
->type
== REF_ARRAY
));
3851 if (sym
&& sym
->ts
.type
== BT_CLASS
)
3852 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
3853 || CLASS_DATA (sym
)->attr
.class_pointer
);
3855 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
3856 || sym
->attr
.proc_pointer
);
3859 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3860 "nor an allocatable variable");
3864 if (gfc_match_char (',') != MATCH_YES
)
3869 m
= gfc_match (" stat = %v", &tmp
);
3870 if (m
== MATCH_ERROR
)
3876 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3877 gfc_free_expr (tmp
);
3884 if (gfc_check_do_variable (stat
->symtree
))
3887 if (gfc_match_char (',') == MATCH_YES
)
3888 goto dealloc_opt_list
;
3891 m
= gfc_match (" errmsg = %v", &tmp
);
3892 if (m
== MATCH_ERROR
)
3896 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
3901 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3902 gfc_free_expr (tmp
);
3909 if (gfc_match_char (',') == MATCH_YES
)
3910 goto dealloc_opt_list
;
3913 gfc_gobble_whitespace ();
3915 if (gfc_peek_char () == ')')
3919 if (gfc_match (" )%t") != MATCH_YES
)
3922 new_st
.op
= EXEC_DEALLOCATE
;
3923 new_st
.expr1
= stat
;
3924 new_st
.expr2
= errmsg
;
3925 new_st
.ext
.alloc
.list
= head
;
3930 gfc_syntax_error (ST_DEALLOCATE
);
3933 gfc_free_expr (errmsg
);
3934 gfc_free_expr (stat
);
3935 gfc_free_alloc_list (head
);
3940 /* Match a RETURN statement. */
3943 gfc_match_return (void)
3947 gfc_compile_state s
;
3951 if (gfc_find_state (COMP_CRITICAL
))
3953 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
3957 if (gfc_find_state (COMP_DO_CONCURRENT
))
3959 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
3963 if (gfc_match_eos () == MATCH_YES
)
3966 if (!gfc_find_state (COMP_SUBROUTINE
))
3968 gfc_error ("Alternate RETURN statement at %C is only allowed within "
3973 if (gfc_current_form
== FORM_FREE
)
3975 /* The following are valid, so we can't require a blank after the
3979 char c
= gfc_peek_ascii_char ();
3980 if (ISALPHA (c
) || ISDIGIT (c
))
3984 m
= gfc_match (" %e%t", &e
);
3987 if (m
== MATCH_ERROR
)
3990 gfc_syntax_error (ST_RETURN
);
3997 gfc_enclosing_unit (&s
);
3998 if (s
== COMP_PROGRAM
3999 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
4000 "main program at %C"))
4003 new_st
.op
= EXEC_RETURN
;
4010 /* Match the call of a type-bound procedure, if CALL%var has already been
4011 matched and var found to be a derived-type variable. */
4014 match_typebound_call (gfc_symtree
* varst
)
4019 base
= gfc_get_expr ();
4020 base
->expr_type
= EXPR_VARIABLE
;
4021 base
->symtree
= varst
;
4022 base
->where
= gfc_current_locus
;
4023 gfc_set_sym_referenced (varst
->n
.sym
);
4025 m
= gfc_match_varspec (base
, 0, true, true);
4027 gfc_error ("Expected component reference at %C");
4030 gfc_free_expr (base
);
4034 if (gfc_match_eos () != MATCH_YES
)
4036 gfc_error ("Junk after CALL at %C");
4037 gfc_free_expr (base
);
4041 if (base
->expr_type
== EXPR_COMPCALL
)
4042 new_st
.op
= EXEC_COMPCALL
;
4043 else if (base
->expr_type
== EXPR_PPC
)
4044 new_st
.op
= EXEC_CALL_PPC
;
4047 gfc_error ("Expected type-bound procedure or procedure pointer component "
4049 gfc_free_expr (base
);
4052 new_st
.expr1
= base
;
4058 /* Match a CALL statement. The tricky part here are possible
4059 alternate return specifiers. We handle these by having all
4060 "subroutines" actually return an integer via a register that gives
4061 the return number. If the call specifies alternate returns, we
4062 generate code for a SELECT statement whose case clauses contain
4063 GOTOs to the various labels. */
4066 gfc_match_call (void)
4068 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4069 gfc_actual_arglist
*a
, *arglist
;
4079 m
= gfc_match ("% %n", name
);
4085 if (gfc_get_ha_sym_tree (name
, &st
))
4090 /* If this is a variable of derived-type, it probably starts a type-bound
4092 if ((sym
->attr
.flavor
!= FL_PROCEDURE
4093 || gfc_is_function_return_value (sym
, gfc_current_ns
))
4094 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
4095 return match_typebound_call (st
);
4097 /* If it does not seem to be callable (include functions so that the
4098 right association is made. They are thrown out in resolution.)
4100 if (!sym
->attr
.generic
4101 && !sym
->attr
.subroutine
4102 && !sym
->attr
.function
)
4104 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
4106 /* ...create a symbol in this scope... */
4107 if (sym
->ns
!= gfc_current_ns
4108 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
4111 if (sym
!= st
->n
.sym
)
4115 /* ...and then to try to make the symbol into a subroutine. */
4116 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
4120 gfc_set_sym_referenced (sym
);
4122 if (gfc_match_eos () != MATCH_YES
)
4124 m
= gfc_match_actual_arglist (1, &arglist
);
4127 if (m
== MATCH_ERROR
)
4130 if (gfc_match_eos () != MATCH_YES
)
4134 /* If any alternate return labels were found, construct a SELECT
4135 statement that will jump to the right place. */
4138 for (a
= arglist
; a
; a
= a
->next
)
4139 if (a
->expr
== NULL
)
4147 gfc_symtree
*select_st
;
4148 gfc_symbol
*select_sym
;
4149 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4151 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
4152 sprintf (name
, "_result_%s", sym
->name
);
4153 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
4155 select_sym
= select_st
->n
.sym
;
4156 select_sym
->ts
.type
= BT_INTEGER
;
4157 select_sym
->ts
.kind
= gfc_default_integer_kind
;
4158 gfc_set_sym_referenced (select_sym
);
4159 c
->expr1
= gfc_get_expr ();
4160 c
->expr1
->expr_type
= EXPR_VARIABLE
;
4161 c
->expr1
->symtree
= select_st
;
4162 c
->expr1
->ts
= select_sym
->ts
;
4163 c
->expr1
->where
= gfc_current_locus
;
4166 for (a
= arglist
; a
; a
= a
->next
)
4168 if (a
->expr
!= NULL
)
4171 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
4176 c
->block
= gfc_get_code (EXEC_SELECT
);
4179 new_case
= gfc_get_case ();
4180 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
4181 new_case
->low
= new_case
->high
;
4182 c
->ext
.block
.case_list
= new_case
;
4184 c
->next
= gfc_get_code (EXEC_GOTO
);
4185 c
->next
->label1
= a
->label
;
4189 new_st
.op
= EXEC_CALL
;
4190 new_st
.symtree
= st
;
4191 new_st
.ext
.actual
= arglist
;
4196 gfc_syntax_error (ST_CALL
);
4199 gfc_free_actual_arglist (arglist
);
4204 /* Given a name, return a pointer to the common head structure,
4205 creating it if it does not exist. If FROM_MODULE is nonzero, we
4206 mangle the name so that it doesn't interfere with commons defined
4207 in the using namespace.
4208 TODO: Add to global symbol tree. */
4211 gfc_get_common (const char *name
, int from_module
)
4214 static int serial
= 0;
4215 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
4219 /* A use associated common block is only needed to correctly layout
4220 the variables it contains. */
4221 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
4222 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
4226 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
4229 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
4232 if (st
->n
.common
== NULL
)
4234 st
->n
.common
= gfc_get_common_head ();
4235 st
->n
.common
->where
= gfc_current_locus
;
4236 strcpy (st
->n
.common
->name
, name
);
4239 return st
->n
.common
;
4243 /* Match a common block name. */
4245 match
match_common_name (char *name
)
4249 if (gfc_match_char ('/') == MATCH_NO
)
4255 if (gfc_match_char ('/') == MATCH_YES
)
4261 m
= gfc_match_name (name
);
4263 if (m
== MATCH_ERROR
)
4265 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
4268 gfc_error ("Syntax error in common block name at %C");
4273 /* Match a COMMON statement. */
4276 gfc_match_common (void)
4278 gfc_symbol
*sym
, **head
, *tail
, *other
, *old_blank_common
;
4279 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4285 old_blank_common
= gfc_current_ns
->blank_common
.head
;
4286 if (old_blank_common
)
4288 while (old_blank_common
->common_next
)
4289 old_blank_common
= old_blank_common
->common_next
;
4296 m
= match_common_name (name
);
4297 if (m
== MATCH_ERROR
)
4300 if (name
[0] == '\0')
4302 t
= &gfc_current_ns
->blank_common
;
4303 if (t
->head
== NULL
)
4304 t
->where
= gfc_current_locus
;
4308 t
= gfc_get_common (name
, 0);
4317 while (tail
->common_next
)
4318 tail
= tail
->common_next
;
4321 /* Grab the list of symbols. */
4324 m
= gfc_match_symbol (&sym
, 0);
4325 if (m
== MATCH_ERROR
)
4330 /* Store a ref to the common block for error checking. */
4331 sym
->common_block
= t
;
4332 sym
->common_block
->refs
++;
4334 /* See if we know the current common block is bind(c), and if
4335 so, then see if we can check if the symbol is (which it'll
4336 need to be). This can happen if the bind(c) attr stmt was
4337 applied to the common block, and the variable(s) already
4338 defined, before declaring the common block. */
4339 if (t
->is_bind_c
== 1)
4341 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
4343 /* If we find an error, just print it and continue,
4344 cause it's just semantic, and we can see if there
4346 gfc_error_now ("Variable %qs at %L in common block %qs "
4347 "at %C must be declared with a C "
4348 "interoperable kind since common block "
4350 sym
->name
, &(sym
->declared_at
), t
->name
,
4354 if (sym
->attr
.is_bind_c
== 1)
4355 gfc_error_now ("Variable %qs in common block %qs at %C can not "
4356 "be bind(c) since it is not global", sym
->name
,
4360 if (sym
->attr
.in_common
)
4362 gfc_error ("Symbol %qs at %C is already in a COMMON block",
4367 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
4368 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
4370 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol %qs at "
4371 "%C can only be COMMON in BLOCK DATA",
4376 if (!gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
))
4380 tail
->common_next
= sym
;
4386 /* Deal with an optional array specification after the
4388 m
= gfc_match_array_spec (&as
, true, true);
4389 if (m
== MATCH_ERROR
)
4394 if (as
->type
!= AS_EXPLICIT
)
4396 gfc_error ("Array specification for symbol %qs in COMMON "
4397 "at %C must be explicit", sym
->name
);
4401 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
4404 if (sym
->attr
.pointer
)
4406 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
4407 "POINTER array", sym
->name
);
4416 sym
->common_head
= t
;
4418 /* Check to see if the symbol is already in an equivalence group.
4419 If it is, set the other members as being in common. */
4420 if (sym
->attr
.in_equivalence
)
4422 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
4424 for (e2
= e1
; e2
; e2
= e2
->eq
)
4425 if (e2
->expr
->symtree
->n
.sym
== sym
)
4432 for (e2
= e1
; e2
; e2
= e2
->eq
)
4434 other
= e2
->expr
->symtree
->n
.sym
;
4435 if (other
->common_head
4436 && other
->common_head
!= sym
->common_head
)
4438 gfc_error ("Symbol %qs, in COMMON block %qs at "
4439 "%C is being indirectly equivalenced to "
4440 "another COMMON block %qs",
4441 sym
->name
, sym
->common_head
->name
,
4442 other
->common_head
->name
);
4445 other
->attr
.in_common
= 1;
4446 other
->common_head
= t
;
4452 gfc_gobble_whitespace ();
4453 if (gfc_match_eos () == MATCH_YES
)
4455 if (gfc_peek_ascii_char () == '/')
4457 if (gfc_match_char (',') != MATCH_YES
)
4459 gfc_gobble_whitespace ();
4460 if (gfc_peek_ascii_char () == '/')
4469 gfc_syntax_error (ST_COMMON
);
4472 gfc_free_array_spec (as
);
4477 /* Match a BLOCK DATA program unit. */
4480 gfc_match_block_data (void)
4482 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4486 if (gfc_match_eos () == MATCH_YES
)
4488 gfc_new_block
= NULL
;
4492 m
= gfc_match ("% %n%t", name
);
4496 if (gfc_get_symbol (name
, NULL
, &sym
))
4499 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
4502 gfc_new_block
= sym
;
4508 /* Free a namelist structure. */
4511 gfc_free_namelist (gfc_namelist
*name
)
4515 for (; name
; name
= n
)
4523 /* Free an OpenMP namelist structure. */
4526 gfc_free_omp_namelist (gfc_omp_namelist
*name
)
4528 gfc_omp_namelist
*n
;
4530 for (; name
; name
= n
)
4532 gfc_free_expr (name
->expr
);
4535 if (name
->udr
->combiner
)
4536 gfc_free_statement (name
->udr
->combiner
);
4537 if (name
->udr
->initializer
)
4538 gfc_free_statement (name
->udr
->initializer
);
4547 /* Match a NAMELIST statement. */
4550 gfc_match_namelist (void)
4552 gfc_symbol
*group_name
, *sym
;
4556 m
= gfc_match (" / %s /", &group_name
);
4559 if (m
== MATCH_ERROR
)
4564 if (group_name
->ts
.type
!= BT_UNKNOWN
)
4566 gfc_error ("Namelist group name %qs at %C already has a basic "
4567 "type of %s", group_name
->name
,
4568 gfc_typename (&group_name
->ts
));
4572 if (group_name
->attr
.flavor
== FL_NAMELIST
4573 && group_name
->attr
.use_assoc
4574 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name %qs "
4575 "at %C already is USE associated and can"
4576 "not be respecified.", group_name
->name
))
4579 if (group_name
->attr
.flavor
!= FL_NAMELIST
4580 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
4581 group_name
->name
, NULL
))
4586 m
= gfc_match_symbol (&sym
, 1);
4589 if (m
== MATCH_ERROR
)
4592 if (sym
->attr
.in_namelist
== 0
4593 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
4596 /* Use gfc_error_check here, rather than goto error, so that
4597 these are the only errors for the next two lines. */
4598 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
4600 gfc_error ("Assumed size array %qs in namelist %qs at "
4601 "%C is not allowed", sym
->name
, group_name
->name
);
4605 nl
= gfc_get_namelist ();
4609 if (group_name
->namelist
== NULL
)
4610 group_name
->namelist
= group_name
->namelist_tail
= nl
;
4613 group_name
->namelist_tail
->next
= nl
;
4614 group_name
->namelist_tail
= nl
;
4617 if (gfc_match_eos () == MATCH_YES
)
4620 m
= gfc_match_char (',');
4622 if (gfc_match_char ('/') == MATCH_YES
)
4624 m2
= gfc_match (" %s /", &group_name
);
4625 if (m2
== MATCH_YES
)
4627 if (m2
== MATCH_ERROR
)
4641 gfc_syntax_error (ST_NAMELIST
);
4648 /* Match a MODULE statement. */
4651 gfc_match_module (void)
4655 m
= gfc_match (" %s%t", &gfc_new_block
);
4659 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
4660 gfc_new_block
->name
, NULL
))
4667 /* Free equivalence sets and lists. Recursively is the easiest way to
4671 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
4676 gfc_free_equiv (eq
->eq
);
4677 gfc_free_equiv_until (eq
->next
, stop
);
4678 gfc_free_expr (eq
->expr
);
4684 gfc_free_equiv (gfc_equiv
*eq
)
4686 gfc_free_equiv_until (eq
, NULL
);
4690 /* Match an EQUIVALENCE statement. */
4693 gfc_match_equivalence (void)
4695 gfc_equiv
*eq
, *set
, *tail
;
4699 gfc_common_head
*common_head
= NULL
;
4707 eq
= gfc_get_equiv ();
4711 eq
->next
= gfc_current_ns
->equiv
;
4712 gfc_current_ns
->equiv
= eq
;
4714 if (gfc_match_char ('(') != MATCH_YES
)
4718 common_flag
= FALSE
;
4723 m
= gfc_match_equiv_variable (&set
->expr
);
4724 if (m
== MATCH_ERROR
)
4729 /* count the number of objects. */
4732 if (gfc_match_char ('%') == MATCH_YES
)
4734 gfc_error ("Derived type component %C is not a "
4735 "permitted EQUIVALENCE member");
4739 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
4740 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
4742 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
4743 "be an array section");
4747 sym
= set
->expr
->symtree
->n
.sym
;
4749 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
4752 if (sym
->attr
.in_common
)
4755 common_head
= sym
->common_head
;
4758 if (gfc_match_char (')') == MATCH_YES
)
4761 if (gfc_match_char (',') != MATCH_YES
)
4764 set
->eq
= gfc_get_equiv ();
4770 gfc_error ("EQUIVALENCE at %C requires two or more objects");
4774 /* If one of the members of an equivalence is in common, then
4775 mark them all as being in common. Before doing this, check
4776 that members of the equivalence group are not in different
4779 for (set
= eq
; set
; set
= set
->eq
)
4781 sym
= set
->expr
->symtree
->n
.sym
;
4782 if (sym
->common_head
&& sym
->common_head
!= common_head
)
4784 gfc_error ("Attempt to indirectly overlap COMMON "
4785 "blocks %s and %s by EQUIVALENCE at %C",
4786 sym
->common_head
->name
, common_head
->name
);
4789 sym
->attr
.in_common
= 1;
4790 sym
->common_head
= common_head
;
4793 if (gfc_match_eos () == MATCH_YES
)
4795 if (gfc_match_char (',') != MATCH_YES
)
4797 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
4805 gfc_syntax_error (ST_EQUIVALENCE
);
4811 gfc_free_equiv (gfc_current_ns
->equiv
);
4812 gfc_current_ns
->equiv
= eq
;
4818 /* Check that a statement function is not recursive. This is done by looking
4819 for the statement function symbol(sym) by looking recursively through its
4820 expression(e). If a reference to sym is found, true is returned.
4821 12.5.4 requires that any variable of function that is implicitly typed
4822 shall have that type confirmed by any subsequent type declaration. The
4823 implicit typing is conveniently done here. */
4825 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
4828 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
4834 switch (e
->expr_type
)
4837 if (e
->symtree
== NULL
)
4840 /* Check the name before testing for nested recursion! */
4841 if (sym
->name
== e
->symtree
->n
.sym
->name
)
4844 /* Catch recursion via other statement functions. */
4845 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
4846 && e
->symtree
->n
.sym
->value
4847 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
4850 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
4851 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
4856 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
4859 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
4860 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
4872 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
4874 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
4878 /* Match a statement function declaration. It is so easy to match
4879 non-statement function statements with a MATCH_ERROR as opposed to
4880 MATCH_NO that we suppress error message in most cases. */
4883 gfc_match_st_function (void)
4885 gfc_error_buffer old_error
;
4891 m
= gfc_match_symbol (&sym
, 0);
4895 gfc_push_error (&old_error
);
4897 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
4900 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
4903 m
= gfc_match (" = %e%t", &expr
);
4907 gfc_free_error (&old_error
);
4909 if (m
== MATCH_ERROR
)
4912 if (recursive_stmt_fcn (expr
, sym
))
4914 gfc_error ("Statement function at %L is recursive", &expr
->where
);
4920 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
4926 gfc_pop_error (&old_error
);
4931 /***************** SELECT CASE subroutines ******************/
4933 /* Free a single case structure. */
4936 free_case (gfc_case
*p
)
4938 if (p
->low
== p
->high
)
4940 gfc_free_expr (p
->low
);
4941 gfc_free_expr (p
->high
);
4946 /* Free a list of case structures. */
4949 gfc_free_case_list (gfc_case
*p
)
4961 /* Match a single case selector. */
4964 match_case_selector (gfc_case
**cp
)
4969 c
= gfc_get_case ();
4970 c
->where
= gfc_current_locus
;
4972 if (gfc_match_char (':') == MATCH_YES
)
4974 m
= gfc_match_init_expr (&c
->high
);
4977 if (m
== MATCH_ERROR
)
4982 m
= gfc_match_init_expr (&c
->low
);
4983 if (m
== MATCH_ERROR
)
4988 /* If we're not looking at a ':' now, make a range out of a single
4989 target. Else get the upper bound for the case range. */
4990 if (gfc_match_char (':') != MATCH_YES
)
4994 m
= gfc_match_init_expr (&c
->high
);
4995 if (m
== MATCH_ERROR
)
4997 /* MATCH_NO is fine. It's OK if nothing is there! */
5005 gfc_error ("Expected initialization expression in CASE at %C");
5013 /* Match the end of a case statement. */
5016 match_case_eos (void)
5018 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5021 if (gfc_match_eos () == MATCH_YES
)
5024 /* If the case construct doesn't have a case-construct-name, we
5025 should have matched the EOS. */
5026 if (!gfc_current_block ())
5029 gfc_gobble_whitespace ();
5031 m
= gfc_match_name (name
);
5035 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5037 gfc_error ("Expected block name %qs of SELECT construct at %C",
5038 gfc_current_block ()->name
);
5042 return gfc_match_eos ();
5046 /* Match a SELECT statement. */
5049 gfc_match_select (void)
5054 m
= gfc_match_label ();
5055 if (m
== MATCH_ERROR
)
5058 m
= gfc_match (" select case ( %e )%t", &expr
);
5062 new_st
.op
= EXEC_SELECT
;
5063 new_st
.expr1
= expr
;
5069 /* Transfer the selector typespec to the associate name. */
5072 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
)
5075 gfc_symbol
*assoc_sym
;
5077 assoc_sym
= associate
->symtree
->n
.sym
;
5079 /* At this stage the expression rank and arrayspec dimensions have
5080 not been completely sorted out. We must get the expr2->rank
5081 right here, so that the correct class container is obtained. */
5082 ref
= selector
->ref
;
5083 while (ref
&& ref
->next
)
5086 if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
5087 && ref
&& ref
->type
== REF_ARRAY
)
5089 /* Ensure that the array reference type is set. We cannot use
5090 gfc_resolve_expr at this point, so the usable parts of
5091 resolve.c(resolve_array_ref) are employed to do it. */
5092 if (ref
->u
.ar
.type
== AR_UNKNOWN
)
5094 ref
->u
.ar
.type
= AR_ELEMENT
;
5095 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
5096 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5097 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
5098 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
5099 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
5101 ref
->u
.ar
.type
= AR_SECTION
;
5106 if (ref
->u
.ar
.type
== AR_FULL
)
5107 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
5108 else if (ref
->u
.ar
.type
== AR_SECTION
)
5109 selector
->rank
= ref
->u
.ar
.dimen
;
5116 assoc_sym
->attr
.dimension
= 1;
5117 assoc_sym
->as
= gfc_get_array_spec ();
5118 assoc_sym
->as
->rank
= selector
->rank
;
5119 assoc_sym
->as
->type
= AS_DEFERRED
;
5122 assoc_sym
->as
= NULL
;
5124 if (selector
->ts
.type
== BT_CLASS
)
5126 /* The correct class container has to be available. */
5127 assoc_sym
->ts
.type
= BT_CLASS
;
5128 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
5129 assoc_sym
->attr
.pointer
= 1;
5130 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
5135 /* Push the current selector onto the SELECT TYPE stack. */
5138 select_type_push (gfc_symbol
*sel
)
5140 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
5141 top
->selector
= sel
;
5143 top
->prev
= select_type_stack
;
5145 select_type_stack
= top
;
5149 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
5151 static gfc_symtree
*
5152 select_intrinsic_set_tmp (gfc_typespec
*ts
)
5154 char name
[GFC_MAX_SYMBOL_LEN
];
5158 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
5161 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5162 && !select_type_stack
->selector
->attr
.class_ok
)
5165 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
5166 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5167 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
5169 if (ts
->type
!= BT_CHARACTER
)
5170 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
5173 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (ts
->type
),
5176 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5177 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5179 /* Copy across the array spec to the selector. */
5180 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5181 && (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5182 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
))
5184 tmp
->n
.sym
->attr
.pointer
= 1;
5185 tmp
->n
.sym
->attr
.dimension
5186 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5187 tmp
->n
.sym
->attr
.codimension
5188 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5190 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5193 gfc_set_sym_referenced (tmp
->n
.sym
);
5194 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5195 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5201 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
5204 select_type_set_tmp (gfc_typespec
*ts
)
5206 char name
[GFC_MAX_SYMBOL_LEN
];
5207 gfc_symtree
*tmp
= NULL
;
5211 select_type_stack
->tmp
= NULL
;
5215 tmp
= select_intrinsic_set_tmp (ts
);
5222 if (ts
->type
== BT_CLASS
)
5223 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
5225 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
5226 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5227 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5229 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5230 && select_type_stack
->selector
->attr
.class_ok
)
5232 tmp
->n
.sym
->attr
.pointer
5233 = CLASS_DATA (select_type_stack
->selector
)->attr
.class_pointer
;
5235 /* Copy across the array spec to the selector. */
5236 if (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5237 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
)
5239 tmp
->n
.sym
->attr
.dimension
5240 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5241 tmp
->n
.sym
->attr
.codimension
5242 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5244 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5248 gfc_set_sym_referenced (tmp
->n
.sym
);
5249 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5250 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5252 if (ts
->type
== BT_CLASS
)
5253 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
5257 /* Add an association for it, so the rest of the parser knows it is
5258 an associate-name. The target will be set during resolution. */
5259 tmp
->n
.sym
->assoc
= gfc_get_association_list ();
5260 tmp
->n
.sym
->assoc
->dangling
= 1;
5261 tmp
->n
.sym
->assoc
->st
= tmp
;
5263 select_type_stack
->tmp
= tmp
;
5267 /* Match a SELECT TYPE statement. */
5270 gfc_match_select_type (void)
5272 gfc_expr
*expr1
, *expr2
= NULL
;
5274 char name
[GFC_MAX_SYMBOL_LEN
];
5278 m
= gfc_match_label ();
5279 if (m
== MATCH_ERROR
)
5282 m
= gfc_match (" select type ( ");
5286 m
= gfc_match (" %n => %e", name
, &expr2
);
5289 expr1
= gfc_get_expr();
5290 expr1
->expr_type
= EXPR_VARIABLE
;
5291 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
5297 sym
= expr1
->symtree
->n
.sym
;
5298 if (expr2
->ts
.type
== BT_UNKNOWN
)
5299 sym
->attr
.untyped
= 1;
5301 copy_ts_from_selector_to_associate (expr1
, expr2
);
5303 sym
->attr
.flavor
= FL_VARIABLE
;
5304 sym
->attr
.referenced
= 1;
5305 sym
->attr
.class_ok
= 1;
5309 m
= gfc_match (" %e ", &expr1
);
5314 m
= gfc_match (" )%t");
5317 gfc_error ("parse error in SELECT TYPE statement at %C");
5321 /* This ghastly expression seems to be needed to distinguish a CLASS
5322 array, which can have a reference, from other expressions that
5323 have references, such as derived type components, and are not
5324 allowed by the standard.
5325 TODO: see if it is sufficient to exclude component and substring
5327 class_array
= expr1
->expr_type
== EXPR_VARIABLE
5328 && expr1
->ts
.type
== BT_CLASS
5329 && CLASS_DATA (expr1
)
5330 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
5331 && (CLASS_DATA (expr1
)->attr
.dimension
5332 || CLASS_DATA (expr1
)->attr
.codimension
)
5334 && expr1
->ref
->type
== REF_ARRAY
5335 && expr1
->ref
->next
== NULL
;
5337 /* Check for F03:C811. */
5338 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
5339 || (!class_array
&& expr1
->ref
!= NULL
)))
5341 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
5342 "use associate-name=>");
5347 new_st
.op
= EXEC_SELECT_TYPE
;
5348 new_st
.expr1
= expr1
;
5349 new_st
.expr2
= expr2
;
5350 new_st
.ext
.block
.ns
= gfc_current_ns
;
5352 select_type_push (expr1
->symtree
->n
.sym
);
5357 gfc_free_expr (expr1
);
5358 gfc_free_expr (expr2
);
5363 /* Match a CASE statement. */
5366 gfc_match_case (void)
5368 gfc_case
*c
, *head
, *tail
;
5373 if (gfc_current_state () != COMP_SELECT
)
5375 gfc_error ("Unexpected CASE statement at %C");
5379 if (gfc_match ("% default") == MATCH_YES
)
5381 m
= match_case_eos ();
5384 if (m
== MATCH_ERROR
)
5387 new_st
.op
= EXEC_SELECT
;
5388 c
= gfc_get_case ();
5389 c
->where
= gfc_current_locus
;
5390 new_st
.ext
.block
.case_list
= c
;
5394 if (gfc_match_char ('(') != MATCH_YES
)
5399 if (match_case_selector (&c
) == MATCH_ERROR
)
5409 if (gfc_match_char (')') == MATCH_YES
)
5411 if (gfc_match_char (',') != MATCH_YES
)
5415 m
= match_case_eos ();
5418 if (m
== MATCH_ERROR
)
5421 new_st
.op
= EXEC_SELECT
;
5422 new_st
.ext
.block
.case_list
= head
;
5427 gfc_error ("Syntax error in CASE specification at %C");
5430 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
5435 /* Match a TYPE IS statement. */
5438 gfc_match_type_is (void)
5443 if (gfc_current_state () != COMP_SELECT_TYPE
)
5445 gfc_error ("Unexpected TYPE IS statement at %C");
5449 if (gfc_match_char ('(') != MATCH_YES
)
5452 c
= gfc_get_case ();
5453 c
->where
= gfc_current_locus
;
5455 m
= gfc_match_type_spec (&c
->ts
);
5458 if (m
== MATCH_ERROR
)
5461 if (gfc_match_char (')') != MATCH_YES
)
5464 m
= match_case_eos ();
5467 if (m
== MATCH_ERROR
)
5470 new_st
.op
= EXEC_SELECT_TYPE
;
5471 new_st
.ext
.block
.case_list
= c
;
5473 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
5474 && (c
->ts
.u
.derived
->attr
.sequence
5475 || c
->ts
.u
.derived
->attr
.is_bind_c
))
5477 gfc_error ("The type-spec shall not specify a sequence derived "
5478 "type or a type with the BIND attribute in SELECT "
5479 "TYPE at %C [F2003:C815]");
5483 /* Create temporary variable. */
5484 select_type_set_tmp (&c
->ts
);
5489 gfc_error ("Syntax error in TYPE IS specification at %C");
5493 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
5498 /* Match a CLASS IS or CLASS DEFAULT statement. */
5501 gfc_match_class_is (void)
5506 if (gfc_current_state () != COMP_SELECT_TYPE
)
5509 if (gfc_match ("% default") == MATCH_YES
)
5511 m
= match_case_eos ();
5514 if (m
== MATCH_ERROR
)
5517 new_st
.op
= EXEC_SELECT_TYPE
;
5518 c
= gfc_get_case ();
5519 c
->where
= gfc_current_locus
;
5520 c
->ts
.type
= BT_UNKNOWN
;
5521 new_st
.ext
.block
.case_list
= c
;
5522 select_type_set_tmp (NULL
);
5526 m
= gfc_match ("% is");
5529 if (m
== MATCH_ERROR
)
5532 if (gfc_match_char ('(') != MATCH_YES
)
5535 c
= gfc_get_case ();
5536 c
->where
= gfc_current_locus
;
5538 m
= match_derived_type_spec (&c
->ts
);
5541 if (m
== MATCH_ERROR
)
5544 if (c
->ts
.type
== BT_DERIVED
)
5545 c
->ts
.type
= BT_CLASS
;
5547 if (gfc_match_char (')') != MATCH_YES
)
5550 m
= match_case_eos ();
5553 if (m
== MATCH_ERROR
)
5556 new_st
.op
= EXEC_SELECT_TYPE
;
5557 new_st
.ext
.block
.case_list
= c
;
5559 /* Create temporary variable. */
5560 select_type_set_tmp (&c
->ts
);
5565 gfc_error ("Syntax error in CLASS IS specification at %C");
5569 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
5574 /********************* WHERE subroutines ********************/
5576 /* Match the rest of a simple WHERE statement that follows an IF statement.
5580 match_simple_where (void)
5586 m
= gfc_match (" ( %e )", &expr
);
5590 m
= gfc_match_assignment ();
5593 if (m
== MATCH_ERROR
)
5596 if (gfc_match_eos () != MATCH_YES
)
5599 c
= gfc_get_code (EXEC_WHERE
);
5602 c
->next
= XCNEW (gfc_code
);
5604 gfc_clear_new_st ();
5606 new_st
.op
= EXEC_WHERE
;
5612 gfc_syntax_error (ST_WHERE
);
5615 gfc_free_expr (expr
);
5620 /* Match a WHERE statement. */
5623 gfc_match_where (gfc_statement
*st
)
5629 m0
= gfc_match_label ();
5630 if (m0
== MATCH_ERROR
)
5633 m
= gfc_match (" where ( %e )", &expr
);
5637 if (gfc_match_eos () == MATCH_YES
)
5639 *st
= ST_WHERE_BLOCK
;
5640 new_st
.op
= EXEC_WHERE
;
5641 new_st
.expr1
= expr
;
5645 m
= gfc_match_assignment ();
5647 gfc_syntax_error (ST_WHERE
);
5651 gfc_free_expr (expr
);
5655 /* We've got a simple WHERE statement. */
5657 c
= gfc_get_code (EXEC_WHERE
);
5660 c
->next
= XCNEW (gfc_code
);
5662 gfc_clear_new_st ();
5664 new_st
.op
= EXEC_WHERE
;
5671 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
5672 new_st if successful. */
5675 gfc_match_elsewhere (void)
5677 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5681 if (gfc_current_state () != COMP_WHERE
)
5683 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
5689 if (gfc_match_char ('(') == MATCH_YES
)
5691 m
= gfc_match_expr (&expr
);
5694 if (m
== MATCH_ERROR
)
5697 if (gfc_match_char (')') != MATCH_YES
)
5701 if (gfc_match_eos () != MATCH_YES
)
5703 /* Only makes sense if we have a where-construct-name. */
5704 if (!gfc_current_block ())
5709 /* Better be a name at this point. */
5710 m
= gfc_match_name (name
);
5713 if (m
== MATCH_ERROR
)
5716 if (gfc_match_eos () != MATCH_YES
)
5719 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5721 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
5722 name
, gfc_current_block ()->name
);
5727 new_st
.op
= EXEC_WHERE
;
5728 new_st
.expr1
= expr
;
5732 gfc_syntax_error (ST_ELSEWHERE
);
5735 gfc_free_expr (expr
);