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 "double-int.h"
38 #include "stringpool.h"
40 int gfc_matching_ptr_assignment
= 0;
41 int gfc_matching_procptr_assignment
= 0;
42 bool gfc_matching_prefix
= false;
44 /* Stack of SELECT TYPE statements. */
45 gfc_select_type_stack
*select_type_stack
= NULL
;
47 /* For debugging and diagnostic purposes. Return the textual representation
48 of the intrinsic operator OP. */
50 gfc_op2string (gfc_intrinsic_op op
)
58 case INTRINSIC_UMINUS
:
64 case INTRINSIC_CONCAT
:
68 case INTRINSIC_DIVIDE
:
100 case INTRINSIC_GT_OS
:
107 case INTRINSIC_ASSIGN
:
110 case INTRINSIC_PARENTHESES
:
117 gfc_internal_error ("gfc_op2string(): Bad code");
122 /******************** Generic matching subroutines ************************/
124 /* This function scans the current statement counting the opened and closed
125 parenthesis to make sure they are balanced. */
128 gfc_match_parens (void)
130 locus old_loc
, where
;
132 gfc_instring instring
;
135 old_loc
= gfc_current_locus
;
137 instring
= NONSTRING
;
142 c
= gfc_next_char_literal (instring
);
145 if (quote
== ' ' && ((c
== '\'') || (c
== '"')))
148 instring
= INSTRING_WARN
;
151 if (quote
!= ' ' && c
== quote
)
154 instring
= NONSTRING
;
158 if (c
== '(' && quote
== ' ')
161 where
= gfc_current_locus
;
163 if (c
== ')' && quote
== ' ')
166 where
= gfc_current_locus
;
170 gfc_current_locus
= old_loc
;
174 gfc_error ("Missing %<)%> in statement at or before %L", &where
);
179 gfc_error ("Missing %<(%> in statement at or before %L", &where
);
187 /* See if the next character is a special character that has
188 escaped by a \ via the -fbackslash option. */
191 gfc_match_special_char (gfc_char_t
*res
)
199 switch ((c
= gfc_next_char_literal (INSTRING_WARN
)))
232 /* Hexadecimal form of wide characters. */
233 len
= (c
== 'x' ? 2 : (c
== 'u' ? 4 : 8));
235 for (i
= 0; i
< len
; i
++)
237 char buf
[2] = { '\0', '\0' };
239 c
= gfc_next_char_literal (INSTRING_WARN
);
240 if (!gfc_wide_fits_in_byte (c
)
241 || !gfc_check_digit ((unsigned char) c
, 16))
244 buf
[0] = (unsigned char) c
;
246 n
+= strtol (buf
, NULL
, 16);
252 /* Unknown backslash codes are simply not expanded. */
261 /* In free form, match at least one space. Always matches in fixed
265 gfc_match_space (void)
270 if (gfc_current_form
== FORM_FIXED
)
273 old_loc
= gfc_current_locus
;
275 c
= gfc_next_ascii_char ();
276 if (!gfc_is_whitespace (c
))
278 gfc_current_locus
= old_loc
;
282 gfc_gobble_whitespace ();
288 /* Match an end of statement. End of statement is optional
289 whitespace, followed by a ';' or '\n' or comment '!'. If a
290 semicolon is found, we continue to eat whitespace and semicolons. */
303 old_loc
= gfc_current_locus
;
304 gfc_gobble_whitespace ();
306 c
= gfc_next_ascii_char ();
312 c
= gfc_next_ascii_char ();
329 gfc_current_locus
= old_loc
;
330 return (flag
) ? MATCH_YES
: MATCH_NO
;
334 /* Match a literal integer on the input, setting the value on
335 MATCH_YES. Literal ints occur in kind-parameters as well as
336 old-style character length specifications. If cnt is non-NULL it
337 will be set to the number of digits. */
340 gfc_match_small_literal_int (int *value
, int *cnt
)
346 old_loc
= gfc_current_locus
;
349 gfc_gobble_whitespace ();
350 c
= gfc_next_ascii_char ();
356 gfc_current_locus
= old_loc
;
365 old_loc
= gfc_current_locus
;
366 c
= gfc_next_ascii_char ();
371 i
= 10 * i
+ c
- '0';
376 gfc_error ("Integer too large at %C");
381 gfc_current_locus
= old_loc
;
390 /* Match a small, constant integer expression, like in a kind
391 statement. On MATCH_YES, 'value' is set. */
394 gfc_match_small_int (int *value
)
401 m
= gfc_match_expr (&expr
);
405 p
= gfc_extract_int (expr
, &i
);
406 gfc_free_expr (expr
);
419 /* This function is the same as the gfc_match_small_int, except that
420 we're keeping the pointer to the expr. This function could just be
421 removed and the previously mentioned one modified, though all calls
422 to it would have to be modified then (and there were a number of
423 them). Return MATCH_ERROR if fail to extract the int; otherwise,
424 return the result of gfc_match_expr(). The expr (if any) that was
425 matched is returned in the parameter expr. */
428 gfc_match_small_int_expr (int *value
, gfc_expr
**expr
)
434 m
= gfc_match_expr (expr
);
438 p
= gfc_extract_int (*expr
, &i
);
451 /* Matches a statement label. Uses gfc_match_small_literal_int() to
452 do most of the work. */
455 gfc_match_st_label (gfc_st_label
**label
)
461 old_loc
= gfc_current_locus
;
463 m
= gfc_match_small_literal_int (&i
, &cnt
);
469 gfc_error ("Too many digits in statement label at %C");
475 gfc_error ("Statement label at %C is zero");
479 *label
= gfc_get_st_label (i
);
484 gfc_current_locus
= old_loc
;
489 /* Match and validate a label associated with a named IF, DO or SELECT
490 statement. If the symbol does not have the label attribute, we add
491 it. We also make sure the symbol does not refer to another
492 (active) block. A matched label is pointed to by gfc_new_block. */
495 gfc_match_label (void)
497 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
500 gfc_new_block
= NULL
;
502 m
= gfc_match (" %n :", name
);
506 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
508 gfc_error ("Label name %qs at %C is ambiguous", name
);
512 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
514 gfc_error ("Duplicate construct label %qs at %C", name
);
518 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
519 gfc_new_block
->name
, NULL
))
526 /* See if the current input looks like a name of some sort. Modifies
527 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
528 Note that options.c restricts max_identifier_length to not more
529 than GFC_MAX_SYMBOL_LEN. */
532 gfc_match_name (char *buffer
)
538 old_loc
= gfc_current_locus
;
539 gfc_gobble_whitespace ();
541 c
= gfc_next_ascii_char ();
542 if (!(ISALPHA (c
) || (c
== '_' && flag_allow_leading_underscore
)))
544 if (!gfc_error_flag_test () && c
!= '(')
545 gfc_error ("Invalid character in name at %C");
546 gfc_current_locus
= old_loc
;
556 if (i
> gfc_option
.max_identifier_length
)
558 gfc_error ("Name at %C is too long");
562 old_loc
= gfc_current_locus
;
563 c
= gfc_next_ascii_char ();
565 while (ISALNUM (c
) || c
== '_' || (flag_dollar_ok
&& c
== '$'));
567 if (c
== '$' && !flag_dollar_ok
)
569 gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to "
570 "allow it as an extension", &old_loc
);
575 gfc_current_locus
= old_loc
;
581 /* Match a symbol on the input. Modifies the pointer to the symbol
582 pointer if successful. */
585 gfc_match_sym_tree (gfc_symtree
**matched_symbol
, int host_assoc
)
587 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
590 m
= gfc_match_name (buffer
);
595 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
596 ? MATCH_ERROR
: MATCH_YES
;
598 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
, false))
606 gfc_match_symbol (gfc_symbol
**matched_symbol
, int host_assoc
)
611 m
= gfc_match_sym_tree (&st
, host_assoc
);
616 *matched_symbol
= st
->n
.sym
;
618 *matched_symbol
= NULL
;
621 *matched_symbol
= NULL
;
626 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
627 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
631 gfc_match_intrinsic_op (gfc_intrinsic_op
*result
)
633 locus orig_loc
= gfc_current_locus
;
636 gfc_gobble_whitespace ();
637 ch
= gfc_next_ascii_char ();
642 *result
= INTRINSIC_PLUS
;
647 *result
= INTRINSIC_MINUS
;
651 if (gfc_next_ascii_char () == '=')
654 *result
= INTRINSIC_EQ
;
660 if (gfc_peek_ascii_char () == '=')
663 gfc_next_ascii_char ();
664 *result
= INTRINSIC_LE
;
668 *result
= INTRINSIC_LT
;
672 if (gfc_peek_ascii_char () == '=')
675 gfc_next_ascii_char ();
676 *result
= INTRINSIC_GE
;
680 *result
= INTRINSIC_GT
;
684 if (gfc_peek_ascii_char () == '*')
687 gfc_next_ascii_char ();
688 *result
= INTRINSIC_POWER
;
692 *result
= INTRINSIC_TIMES
;
696 ch
= gfc_peek_ascii_char ();
700 gfc_next_ascii_char ();
701 *result
= INTRINSIC_NE
;
707 gfc_next_ascii_char ();
708 *result
= INTRINSIC_CONCAT
;
712 *result
= INTRINSIC_DIVIDE
;
716 ch
= gfc_next_ascii_char ();
720 if (gfc_next_ascii_char () == 'n'
721 && gfc_next_ascii_char () == 'd'
722 && gfc_next_ascii_char () == '.')
724 /* Matched ".and.". */
725 *result
= INTRINSIC_AND
;
731 if (gfc_next_ascii_char () == 'q')
733 ch
= gfc_next_ascii_char ();
736 /* Matched ".eq.". */
737 *result
= INTRINSIC_EQ_OS
;
742 if (gfc_next_ascii_char () == '.')
744 /* Matched ".eqv.". */
745 *result
= INTRINSIC_EQV
;
753 ch
= gfc_next_ascii_char ();
756 if (gfc_next_ascii_char () == '.')
758 /* Matched ".ge.". */
759 *result
= INTRINSIC_GE_OS
;
765 if (gfc_next_ascii_char () == '.')
767 /* Matched ".gt.". */
768 *result
= INTRINSIC_GT_OS
;
775 ch
= gfc_next_ascii_char ();
778 if (gfc_next_ascii_char () == '.')
780 /* Matched ".le.". */
781 *result
= INTRINSIC_LE_OS
;
787 if (gfc_next_ascii_char () == '.')
789 /* Matched ".lt.". */
790 *result
= INTRINSIC_LT_OS
;
797 ch
= gfc_next_ascii_char ();
800 ch
= gfc_next_ascii_char ();
803 /* Matched ".ne.". */
804 *result
= INTRINSIC_NE_OS
;
809 if (gfc_next_ascii_char () == 'v'
810 && gfc_next_ascii_char () == '.')
812 /* Matched ".neqv.". */
813 *result
= INTRINSIC_NEQV
;
820 if (gfc_next_ascii_char () == 't'
821 && gfc_next_ascii_char () == '.')
823 /* Matched ".not.". */
824 *result
= INTRINSIC_NOT
;
831 if (gfc_next_ascii_char () == 'r'
832 && gfc_next_ascii_char () == '.')
834 /* Matched ".or.". */
835 *result
= INTRINSIC_OR
;
849 gfc_current_locus
= orig_loc
;
854 /* Match a loop control phrase:
856 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
858 If the final integer expression is not present, a constant unity
859 expression is returned. We don't return MATCH_ERROR until after
860 the equals sign is seen. */
863 gfc_match_iterator (gfc_iterator
*iter
, int init_flag
)
865 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
866 gfc_expr
*var
, *e1
, *e2
, *e3
;
872 /* Match the start of an iterator without affecting the symbol table. */
874 start
= gfc_current_locus
;
875 m
= gfc_match (" %n =", name
);
876 gfc_current_locus
= start
;
881 m
= gfc_match_variable (&var
, 0);
885 /* F2008, C617 & C565. */
886 if (var
->symtree
->n
.sym
->attr
.codimension
)
888 gfc_error ("Loop variable at %C cannot be a coarray");
892 if (var
->ref
!= NULL
)
894 gfc_error ("Loop variable at %C cannot be a sub-component");
898 gfc_match_char ('=');
900 var
->symtree
->n
.sym
->attr
.implied_index
= 1;
902 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
905 if (m
== MATCH_ERROR
)
908 if (gfc_match_char (',') != MATCH_YES
)
911 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
914 if (m
== MATCH_ERROR
)
917 if (gfc_match_char (',') != MATCH_YES
)
919 e3
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
923 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
924 if (m
== MATCH_ERROR
)
928 gfc_error ("Expected a step value in iterator at %C");
940 gfc_error ("Syntax error in iterator at %C");
951 /* Tries to match the next non-whitespace character on the input.
952 This subroutine does not return MATCH_ERROR. */
955 gfc_match_char (char c
)
959 where
= gfc_current_locus
;
960 gfc_gobble_whitespace ();
962 if (gfc_next_ascii_char () == c
)
965 gfc_current_locus
= where
;
970 /* General purpose matching subroutine. The target string is a
971 scanf-like format string in which spaces correspond to arbitrary
972 whitespace (including no whitespace), characters correspond to
973 themselves. The %-codes are:
975 %% Literal percent sign
976 %e Expression, pointer to a pointer is set
977 %s Symbol, pointer to the symbol is set
978 %n Name, character buffer is set to name
979 %t Matches end of statement.
980 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
981 %l Matches a statement label
982 %v Matches a variable expression (an lvalue)
983 % Matches a required space (in free form) and optional spaces. */
986 gfc_match (const char *target
, ...)
988 gfc_st_label
**label
;
997 old_loc
= gfc_current_locus
;
998 va_start (argp
, target
);
1008 gfc_gobble_whitespace ();
1019 vp
= va_arg (argp
, void **);
1020 n
= gfc_match_expr ((gfc_expr
**) vp
);
1031 vp
= va_arg (argp
, void **);
1032 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
1043 vp
= va_arg (argp
, void **);
1044 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
1055 np
= va_arg (argp
, char *);
1056 n
= gfc_match_name (np
);
1067 label
= va_arg (argp
, gfc_st_label
**);
1068 n
= gfc_match_st_label (label
);
1079 ip
= va_arg (argp
, int *);
1080 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
1091 if (gfc_match_eos () != MATCH_YES
)
1099 if (gfc_match_space () == MATCH_YES
)
1105 break; /* Fall through to character matcher. */
1108 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
1113 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1114 expect an upper case character here! */
1115 gcc_assert (TOLOWER (c
) == c
);
1117 if (c
== gfc_next_ascii_char ())
1127 /* Clean up after a failed match. */
1128 gfc_current_locus
= old_loc
;
1129 va_start (argp
, target
);
1132 for (; matches
> 0; matches
--)
1134 while (*p
++ != '%');
1142 /* Matches that don't have to be undone */
1147 (void) va_arg (argp
, void **);
1152 vp
= va_arg (argp
, void **);
1153 gfc_free_expr ((struct gfc_expr
*)*vp
);
1166 /*********************** Statement level matching **********************/
1168 /* Matches the start of a program unit, which is the program keyword
1169 followed by an obligatory symbol. */
1172 gfc_match_program (void)
1177 m
= gfc_match ("% %s%t", &sym
);
1181 gfc_error ("Invalid form of PROGRAM statement at %C");
1185 if (m
== MATCH_ERROR
)
1188 if (!gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
))
1191 gfc_new_block
= sym
;
1197 /* Match a simple assignment statement. */
1200 gfc_match_assignment (void)
1202 gfc_expr
*lvalue
, *rvalue
;
1206 old_loc
= gfc_current_locus
;
1209 m
= gfc_match (" %v =", &lvalue
);
1212 gfc_current_locus
= old_loc
;
1213 gfc_free_expr (lvalue
);
1218 m
= gfc_match (" %e%t", &rvalue
);
1221 gfc_current_locus
= old_loc
;
1222 gfc_free_expr (lvalue
);
1223 gfc_free_expr (rvalue
);
1227 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1229 new_st
.op
= EXEC_ASSIGN
;
1230 new_st
.expr1
= lvalue
;
1231 new_st
.expr2
= rvalue
;
1233 gfc_check_do_variable (lvalue
->symtree
);
1239 /* Match a pointer assignment statement. */
1242 gfc_match_pointer_assignment (void)
1244 gfc_expr
*lvalue
, *rvalue
;
1248 old_loc
= gfc_current_locus
;
1250 lvalue
= rvalue
= NULL
;
1251 gfc_matching_ptr_assignment
= 0;
1252 gfc_matching_procptr_assignment
= 0;
1254 m
= gfc_match (" %v =>", &lvalue
);
1261 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1262 || gfc_is_proc_ptr_comp (lvalue
))
1263 gfc_matching_procptr_assignment
= 1;
1265 gfc_matching_ptr_assignment
= 1;
1267 m
= gfc_match (" %e%t", &rvalue
);
1268 gfc_matching_ptr_assignment
= 0;
1269 gfc_matching_procptr_assignment
= 0;
1273 new_st
.op
= EXEC_POINTER_ASSIGN
;
1274 new_st
.expr1
= lvalue
;
1275 new_st
.expr2
= rvalue
;
1280 gfc_current_locus
= old_loc
;
1281 gfc_free_expr (lvalue
);
1282 gfc_free_expr (rvalue
);
1287 /* We try to match an easy arithmetic IF statement. This only happens
1288 when just after having encountered a simple IF statement. This code
1289 is really duplicate with parts of the gfc_match_if code, but this is
1293 match_arithmetic_if (void)
1295 gfc_st_label
*l1
, *l2
, *l3
;
1299 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1303 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1304 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1305 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1307 gfc_free_expr (expr
);
1311 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Arithmetic IF statement at %C"))
1314 new_st
.op
= EXEC_ARITHMETIC_IF
;
1315 new_st
.expr1
= expr
;
1324 /* The IF statement is a bit of a pain. First of all, there are three
1325 forms of it, the simple IF, the IF that starts a block and the
1328 There is a problem with the simple IF and that is the fact that we
1329 only have a single level of undo information on symbols. What this
1330 means is for a simple IF, we must re-match the whole IF statement
1331 multiple times in order to guarantee that the symbol table ends up
1332 in the proper state. */
1334 static match
match_simple_forall (void);
1335 static match
match_simple_where (void);
1338 gfc_match_if (gfc_statement
*if_type
)
1341 gfc_st_label
*l1
, *l2
, *l3
;
1342 locus old_loc
, old_loc2
;
1346 n
= gfc_match_label ();
1347 if (n
== MATCH_ERROR
)
1350 old_loc
= gfc_current_locus
;
1352 m
= gfc_match (" if ( %e", &expr
);
1356 old_loc2
= gfc_current_locus
;
1357 gfc_current_locus
= old_loc
;
1359 if (gfc_match_parens () == MATCH_ERROR
)
1362 gfc_current_locus
= old_loc2
;
1364 if (gfc_match_char (')') != MATCH_YES
)
1366 gfc_error ("Syntax error in IF-expression at %C");
1367 gfc_free_expr (expr
);
1371 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1377 gfc_error ("Block label not appropriate for arithmetic IF "
1379 gfc_free_expr (expr
);
1383 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1384 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1385 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1387 gfc_free_expr (expr
);
1391 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Arithmetic IF statement at %C"))
1394 new_st
.op
= EXEC_ARITHMETIC_IF
;
1395 new_st
.expr1
= expr
;
1400 *if_type
= ST_ARITHMETIC_IF
;
1404 if (gfc_match (" then%t") == MATCH_YES
)
1406 new_st
.op
= EXEC_IF
;
1407 new_st
.expr1
= expr
;
1408 *if_type
= ST_IF_BLOCK
;
1414 gfc_error ("Block label is not appropriate for IF statement at %C");
1415 gfc_free_expr (expr
);
1419 /* At this point the only thing left is a simple IF statement. At
1420 this point, n has to be MATCH_NO, so we don't have to worry about
1421 re-matching a block label. From what we've got so far, try
1422 matching an assignment. */
1424 *if_type
= ST_SIMPLE_IF
;
1426 m
= gfc_match_assignment ();
1430 gfc_free_expr (expr
);
1431 gfc_undo_symbols ();
1432 gfc_current_locus
= old_loc
;
1434 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1435 assignment was found. For MATCH_NO, continue to call the various
1437 if (m
== MATCH_ERROR
)
1440 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1442 m
= gfc_match_pointer_assignment ();
1446 gfc_free_expr (expr
);
1447 gfc_undo_symbols ();
1448 gfc_current_locus
= old_loc
;
1450 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1452 /* Look at the next keyword to see which matcher to call. Matching
1453 the keyword doesn't affect the symbol table, so we don't have to
1454 restore between tries. */
1456 #define match(string, subr, statement) \
1457 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1461 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1462 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1463 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1464 match ("call", gfc_match_call
, ST_CALL
)
1465 match ("close", gfc_match_close
, ST_CLOSE
)
1466 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1467 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1468 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1469 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1470 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
)
1471 match ("exit", gfc_match_exit
, ST_EXIT
)
1472 match ("flush", gfc_match_flush
, ST_FLUSH
)
1473 match ("forall", match_simple_forall
, ST_FORALL
)
1474 match ("go to", gfc_match_goto
, ST_GOTO
)
1475 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1476 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1477 match ("lock", gfc_match_lock
, ST_LOCK
)
1478 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1479 match ("open", gfc_match_open
, ST_OPEN
)
1480 match ("pause", gfc_match_pause
, ST_NONE
)
1481 match ("print", gfc_match_print
, ST_WRITE
)
1482 match ("read", gfc_match_read
, ST_READ
)
1483 match ("return", gfc_match_return
, ST_RETURN
)
1484 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1485 match ("stop", gfc_match_stop
, ST_STOP
)
1486 match ("wait", gfc_match_wait
, ST_WAIT
)
1487 match ("sync all", gfc_match_sync_all
, ST_SYNC_CALL
);
1488 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
1489 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
1490 match ("unlock", gfc_match_unlock
, ST_UNLOCK
)
1491 match ("where", match_simple_where
, ST_WHERE
)
1492 match ("write", gfc_match_write
, ST_WRITE
)
1494 /* The gfc_match_assignment() above may have returned a MATCH_NO
1495 where the assignment was to a named constant. Check that
1496 special case here. */
1497 m
= gfc_match_assignment ();
1500 gfc_error ("Cannot assign to a named constant at %C");
1501 gfc_free_expr (expr
);
1502 gfc_undo_symbols ();
1503 gfc_current_locus
= old_loc
;
1507 /* All else has failed, so give up. See if any of the matchers has
1508 stored an error message of some sort. */
1509 if (!gfc_error_check ())
1510 gfc_error ("Unclassifiable statement in IF-clause at %C");
1512 gfc_free_expr (expr
);
1517 gfc_error ("Syntax error in IF-clause at %C");
1520 gfc_free_expr (expr
);
1524 /* At this point, we've matched the single IF and the action clause
1525 is in new_st. Rearrange things so that the IF statement appears
1528 p
= gfc_get_code (EXEC_IF
);
1529 p
->next
= XCNEW (gfc_code
);
1531 p
->next
->loc
= gfc_current_locus
;
1535 gfc_clear_new_st ();
1537 new_st
.op
= EXEC_IF
;
1546 /* Match an ELSE statement. */
1549 gfc_match_else (void)
1551 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1553 if (gfc_match_eos () == MATCH_YES
)
1556 if (gfc_match_name (name
) != MATCH_YES
1557 || gfc_current_block () == NULL
1558 || gfc_match_eos () != MATCH_YES
)
1560 gfc_error ("Unexpected junk after ELSE statement at %C");
1564 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1566 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1567 name
, gfc_current_block ()->name
);
1575 /* Match an ELSE IF statement. */
1578 gfc_match_elseif (void)
1580 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1584 m
= gfc_match (" ( %e ) then", &expr
);
1588 if (gfc_match_eos () == MATCH_YES
)
1591 if (gfc_match_name (name
) != MATCH_YES
1592 || gfc_current_block () == NULL
1593 || gfc_match_eos () != MATCH_YES
)
1595 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1599 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1601 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1602 name
, gfc_current_block ()->name
);
1607 new_st
.op
= EXEC_IF
;
1608 new_st
.expr1
= expr
;
1612 gfc_free_expr (expr
);
1617 /* Free a gfc_iterator structure. */
1620 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1626 gfc_free_expr (iter
->var
);
1627 gfc_free_expr (iter
->start
);
1628 gfc_free_expr (iter
->end
);
1629 gfc_free_expr (iter
->step
);
1636 /* Match a CRITICAL statement. */
1638 gfc_match_critical (void)
1640 gfc_st_label
*label
= NULL
;
1642 if (gfc_match_label () == MATCH_ERROR
)
1645 if (gfc_match (" critical") != MATCH_YES
)
1648 if (gfc_match_st_label (&label
) == MATCH_ERROR
)
1651 if (gfc_match_eos () != MATCH_YES
)
1653 gfc_syntax_error (ST_CRITICAL
);
1657 if (gfc_pure (NULL
))
1659 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1663 if (gfc_find_state (COMP_DO_CONCURRENT
))
1665 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1670 gfc_unset_implicit_pure (NULL
);
1672 if (!gfc_notify_std (GFC_STD_F2008
, "CRITICAL statement at %C"))
1675 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1677 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1682 if (gfc_find_state (COMP_CRITICAL
))
1684 gfc_error ("Nested CRITICAL block at %C");
1688 new_st
.op
= EXEC_CRITICAL
;
1691 && !gfc_reference_st_label (label
, ST_LABEL_TARGET
))
1698 /* Match a BLOCK statement. */
1701 gfc_match_block (void)
1705 if (gfc_match_label () == MATCH_ERROR
)
1708 if (gfc_match (" block") != MATCH_YES
)
1711 /* For this to be a correct BLOCK statement, the line must end now. */
1712 m
= gfc_match_eos ();
1713 if (m
== MATCH_ERROR
)
1722 /* Match an ASSOCIATE statement. */
1725 gfc_match_associate (void)
1727 if (gfc_match_label () == MATCH_ERROR
)
1730 if (gfc_match (" associate") != MATCH_YES
)
1733 /* Match the association list. */
1734 if (gfc_match_char ('(') != MATCH_YES
)
1736 gfc_error ("Expected association list at %C");
1739 new_st
.ext
.block
.assoc
= NULL
;
1742 gfc_association_list
* newAssoc
= gfc_get_association_list ();
1743 gfc_association_list
* a
;
1745 /* Match the next association. */
1746 if (gfc_match (" %n => %e", newAssoc
->name
, &newAssoc
->target
)
1749 gfc_error ("Expected association at %C");
1750 goto assocListError
;
1752 newAssoc
->where
= gfc_current_locus
;
1754 /* Check that the current name is not yet in the list. */
1755 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
1756 if (!strcmp (a
->name
, newAssoc
->name
))
1758 gfc_error ("Duplicate name %qs in association at %C",
1760 goto assocListError
;
1763 /* The target expression must not be coindexed. */
1764 if (gfc_is_coindexed (newAssoc
->target
))
1766 gfc_error ("Association target at %C must not be coindexed");
1767 goto assocListError
;
1770 /* The `variable' field is left blank for now; because the target is not
1771 yet resolved, we can't use gfc_has_vector_subscript to determine it
1772 for now. This is set during resolution. */
1774 /* Put it into the list. */
1775 newAssoc
->next
= new_st
.ext
.block
.assoc
;
1776 new_st
.ext
.block
.assoc
= newAssoc
;
1778 /* Try next one or end if closing parenthesis is found. */
1779 gfc_gobble_whitespace ();
1780 if (gfc_peek_char () == ')')
1782 if (gfc_match_char (',') != MATCH_YES
)
1784 gfc_error ("Expected %<)%> or %<,%> at %C");
1794 if (gfc_match_char (')') != MATCH_YES
)
1796 /* This should never happen as we peek above. */
1800 if (gfc_match_eos () != MATCH_YES
)
1802 gfc_error ("Junk after ASSOCIATE statement at %C");
1809 gfc_free_association_list (new_st
.ext
.block
.assoc
);
1814 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1815 an accessible derived type. */
1818 match_derived_type_spec (gfc_typespec
*ts
)
1820 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1822 gfc_symbol
*derived
;
1824 old_locus
= gfc_current_locus
;
1826 if (gfc_match ("%n", name
) != MATCH_YES
)
1828 gfc_current_locus
= old_locus
;
1832 gfc_find_symbol (name
, NULL
, 1, &derived
);
1834 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
&& derived
->attr
.generic
)
1835 derived
= gfc_find_dt_in_generic (derived
);
1837 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
1839 ts
->type
= BT_DERIVED
;
1840 ts
->u
.derived
= derived
;
1844 gfc_current_locus
= old_locus
;
1849 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
1850 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
1851 It only includes the intrinsic types from the Fortran 2003 standard
1852 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
1853 the implicit_flag is not needed, so it was removed. Derived types are
1854 identified by their name alone. */
1857 gfc_match_type_spec (gfc_typespec
*ts
)
1863 gfc_gobble_whitespace ();
1864 old_locus
= gfc_current_locus
;
1866 if (match_derived_type_spec (ts
) == MATCH_YES
)
1868 /* Enforce F03:C401. */
1869 if (ts
->u
.derived
->attr
.abstract
)
1871 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
1872 ts
->u
.derived
->name
, &old_locus
);
1878 if (gfc_match ("integer") == MATCH_YES
)
1880 ts
->type
= BT_INTEGER
;
1881 ts
->kind
= gfc_default_integer_kind
;
1885 if (gfc_match ("real") == MATCH_YES
)
1888 ts
->kind
= gfc_default_real_kind
;
1892 if (gfc_match ("double precision") == MATCH_YES
)
1895 ts
->kind
= gfc_default_double_kind
;
1899 if (gfc_match ("complex") == MATCH_YES
)
1901 ts
->type
= BT_COMPLEX
;
1902 ts
->kind
= gfc_default_complex_kind
;
1906 if (gfc_match ("character") == MATCH_YES
)
1908 ts
->type
= BT_CHARACTER
;
1910 m
= gfc_match_char_spec (ts
);
1918 if (gfc_match ("logical") == MATCH_YES
)
1920 ts
->type
= BT_LOGICAL
;
1921 ts
->kind
= gfc_default_logical_kind
;
1925 /* If a type is not matched, simply return MATCH_NO. */
1926 gfc_current_locus
= old_locus
;
1931 gfc_gobble_whitespace ();
1932 if (gfc_peek_ascii_char () == '*')
1934 gfc_error ("Invalid type-spec at %C");
1938 m
= gfc_match_kind_spec (ts
, false);
1941 m
= MATCH_YES
; /* No kind specifier found. */
1947 /******************** FORALL subroutines ********************/
1949 /* Free a list of FORALL iterators. */
1952 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
1954 gfc_forall_iterator
*next
;
1959 gfc_free_expr (iter
->var
);
1960 gfc_free_expr (iter
->start
);
1961 gfc_free_expr (iter
->end
);
1962 gfc_free_expr (iter
->stride
);
1969 /* Match an iterator as part of a FORALL statement. The format is:
1971 <var> = <start>:<end>[:<stride>]
1973 On MATCH_NO, the caller tests for the possibility that there is a
1974 scalar mask expression. */
1977 match_forall_iterator (gfc_forall_iterator
**result
)
1979 gfc_forall_iterator
*iter
;
1983 where
= gfc_current_locus
;
1984 iter
= XCNEW (gfc_forall_iterator
);
1986 m
= gfc_match_expr (&iter
->var
);
1990 if (gfc_match_char ('=') != MATCH_YES
1991 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
1997 m
= gfc_match_expr (&iter
->start
);
2001 if (gfc_match_char (':') != MATCH_YES
)
2004 m
= gfc_match_expr (&iter
->end
);
2007 if (m
== MATCH_ERROR
)
2010 if (gfc_match_char (':') == MATCH_NO
)
2011 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2014 m
= gfc_match_expr (&iter
->stride
);
2017 if (m
== MATCH_ERROR
)
2021 /* Mark the iteration variable's symbol as used as a FORALL index. */
2022 iter
->var
->symtree
->n
.sym
->forall_index
= true;
2028 gfc_error ("Syntax error in FORALL iterator at %C");
2033 gfc_current_locus
= where
;
2034 gfc_free_forall_iterator (iter
);
2039 /* Match the header of a FORALL statement. */
2042 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
2044 gfc_forall_iterator
*head
, *tail
, *new_iter
;
2048 gfc_gobble_whitespace ();
2053 if (gfc_match_char ('(') != MATCH_YES
)
2056 m
= match_forall_iterator (&new_iter
);
2057 if (m
== MATCH_ERROR
)
2062 head
= tail
= new_iter
;
2066 if (gfc_match_char (',') != MATCH_YES
)
2069 m
= match_forall_iterator (&new_iter
);
2070 if (m
== MATCH_ERROR
)
2075 tail
->next
= new_iter
;
2080 /* Have to have a mask expression. */
2082 m
= gfc_match_expr (&msk
);
2085 if (m
== MATCH_ERROR
)
2091 if (gfc_match_char (')') == MATCH_NO
)
2099 gfc_syntax_error (ST_FORALL
);
2102 gfc_free_expr (msk
);
2103 gfc_free_forall_iterator (head
);
2108 /* Match the rest of a simple FORALL statement that follows an
2112 match_simple_forall (void)
2114 gfc_forall_iterator
*head
;
2123 m
= match_forall_header (&head
, &mask
);
2130 m
= gfc_match_assignment ();
2132 if (m
== MATCH_ERROR
)
2136 m
= gfc_match_pointer_assignment ();
2137 if (m
== MATCH_ERROR
)
2143 c
= XCNEW (gfc_code
);
2145 c
->loc
= gfc_current_locus
;
2147 if (gfc_match_eos () != MATCH_YES
)
2150 gfc_clear_new_st ();
2151 new_st
.op
= EXEC_FORALL
;
2152 new_st
.expr1
= mask
;
2153 new_st
.ext
.forall_iterator
= head
;
2154 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2155 new_st
.block
->next
= c
;
2160 gfc_syntax_error (ST_FORALL
);
2163 gfc_free_forall_iterator (head
);
2164 gfc_free_expr (mask
);
2170 /* Match a FORALL statement. */
2173 gfc_match_forall (gfc_statement
*st
)
2175 gfc_forall_iterator
*head
;
2184 m0
= gfc_match_label ();
2185 if (m0
== MATCH_ERROR
)
2188 m
= gfc_match (" forall");
2192 m
= match_forall_header (&head
, &mask
);
2193 if (m
== MATCH_ERROR
)
2198 if (gfc_match_eos () == MATCH_YES
)
2200 *st
= ST_FORALL_BLOCK
;
2201 new_st
.op
= EXEC_FORALL
;
2202 new_st
.expr1
= mask
;
2203 new_st
.ext
.forall_iterator
= head
;
2207 m
= gfc_match_assignment ();
2208 if (m
== MATCH_ERROR
)
2212 m
= gfc_match_pointer_assignment ();
2213 if (m
== MATCH_ERROR
)
2219 c
= XCNEW (gfc_code
);
2221 c
->loc
= gfc_current_locus
;
2223 gfc_clear_new_st ();
2224 new_st
.op
= EXEC_FORALL
;
2225 new_st
.expr1
= mask
;
2226 new_st
.ext
.forall_iterator
= head
;
2227 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2228 new_st
.block
->next
= c
;
2234 gfc_syntax_error (ST_FORALL
);
2237 gfc_free_forall_iterator (head
);
2238 gfc_free_expr (mask
);
2239 gfc_free_statements (c
);
2244 /* Match a DO statement. */
2249 gfc_iterator iter
, *ip
;
2251 gfc_st_label
*label
;
2254 old_loc
= gfc_current_locus
;
2257 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
2259 m
= gfc_match_label ();
2260 if (m
== MATCH_ERROR
)
2263 if (gfc_match (" do") != MATCH_YES
)
2266 m
= gfc_match_st_label (&label
);
2267 if (m
== MATCH_ERROR
)
2270 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2272 if (gfc_match_eos () == MATCH_YES
)
2274 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
2275 new_st
.op
= EXEC_DO_WHILE
;
2279 /* Match an optional comma, if no comma is found, a space is obligatory. */
2280 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
2283 /* Check for balanced parens. */
2285 if (gfc_match_parens () == MATCH_ERROR
)
2288 if (gfc_match (" concurrent") == MATCH_YES
)
2290 gfc_forall_iterator
*head
;
2293 if (!gfc_notify_std (GFC_STD_F2008
, "DO CONCURRENT construct at %C"))
2299 m
= match_forall_header (&head
, &mask
);
2303 if (m
== MATCH_ERROR
)
2304 goto concurr_cleanup
;
2306 if (gfc_match_eos () != MATCH_YES
)
2307 goto concurr_cleanup
;
2310 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2311 goto concurr_cleanup
;
2313 new_st
.label1
= label
;
2314 new_st
.op
= EXEC_DO_CONCURRENT
;
2315 new_st
.expr1
= mask
;
2316 new_st
.ext
.forall_iterator
= head
;
2321 gfc_syntax_error (ST_DO
);
2322 gfc_free_expr (mask
);
2323 gfc_free_forall_iterator (head
);
2327 /* See if we have a DO WHILE. */
2328 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
2330 new_st
.op
= EXEC_DO_WHILE
;
2334 /* The abortive DO WHILE may have done something to the symbol
2335 table, so we start over. */
2336 gfc_undo_symbols ();
2337 gfc_current_locus
= old_loc
;
2339 gfc_match_label (); /* This won't error. */
2340 gfc_match (" do "); /* This will work. */
2342 gfc_match_st_label (&label
); /* Can't error out. */
2343 gfc_match_char (','); /* Optional comma. */
2345 m
= gfc_match_iterator (&iter
, 0);
2348 if (m
== MATCH_ERROR
)
2351 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
2352 gfc_check_do_variable (iter
.var
->symtree
);
2354 if (gfc_match_eos () != MATCH_YES
)
2356 gfc_syntax_error (ST_DO
);
2360 new_st
.op
= EXEC_DO
;
2364 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2367 new_st
.label1
= label
;
2369 if (new_st
.op
== EXEC_DO_WHILE
)
2370 new_st
.expr1
= iter
.end
;
2373 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
2380 gfc_free_iterator (&iter
, 0);
2386 /* Match an EXIT or CYCLE statement. */
2389 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2391 gfc_state_data
*p
, *o
;
2396 if (gfc_match_eos () == MATCH_YES
)
2400 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2403 m
= gfc_match ("% %n%t", name
);
2404 if (m
== MATCH_ERROR
)
2408 gfc_syntax_error (st
);
2412 /* Find the corresponding symbol. If there's a BLOCK statement
2413 between here and the label, it is not in gfc_current_ns but a parent
2415 stree
= gfc_find_symtree_in_proc (name
, gfc_current_ns
);
2418 gfc_error ("Name %qs in %s statement at %C is unknown",
2419 name
, gfc_ascii_statement (st
));
2424 if (sym
->attr
.flavor
!= FL_LABEL
)
2426 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2427 name
, gfc_ascii_statement (st
));
2432 /* Find the loop specified by the label (or lack of a label). */
2433 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2434 if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2436 else if (p
->state
== COMP_CRITICAL
)
2438 gfc_error("%s statement at %C leaves CRITICAL construct",
2439 gfc_ascii_statement (st
));
2442 else if (p
->state
== COMP_DO_CONCURRENT
2443 && (op
== EXEC_EXIT
|| (sym
&& sym
!= p
->sym
)))
2445 /* F2008, C821 & C845. */
2446 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2447 gfc_ascii_statement (st
));
2450 else if ((sym
&& sym
== p
->sym
)
2451 || (!sym
&& (p
->state
== COMP_DO
2452 || p
->state
== COMP_DO_CONCURRENT
)))
2458 gfc_error ("%s statement at %C is not within a construct",
2459 gfc_ascii_statement (st
));
2461 gfc_error ("%s statement at %C is not within construct %qs",
2462 gfc_ascii_statement (st
), sym
->name
);
2467 /* Special checks for EXIT from non-loop constructs. */
2471 case COMP_DO_CONCURRENT
:
2475 /* This is already handled above. */
2478 case COMP_ASSOCIATE
:
2482 case COMP_SELECT_TYPE
:
2484 if (op
== EXEC_CYCLE
)
2486 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2487 " construct %qs", sym
->name
);
2490 gcc_assert (op
== EXEC_EXIT
);
2491 if (!gfc_notify_std (GFC_STD_F2008
, "EXIT statement with no"
2492 " do-construct-name at %C"))
2497 gfc_error ("%s statement at %C is not applicable to construct %qs",
2498 gfc_ascii_statement (st
), sym
->name
);
2504 gfc_error (is_oacc (p
)
2505 ? "%s statement at %C leaving OpenACC structured block"
2506 : "%s statement at %C leaving OpenMP structured block",
2507 gfc_ascii_statement (st
));
2511 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2515 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
2516 && (o
->head
->op
== EXEC_OACC_LOOP
2517 || o
->head
->op
== EXEC_OACC_PARALLEL_LOOP
))
2520 gcc_assert (o
->head
->next
!= NULL
2521 && (o
->head
->next
->op
== EXEC_DO
2522 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2523 && o
->previous
!= NULL
2524 && o
->previous
->tail
->op
== o
->head
->op
);
2525 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2526 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2527 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2528 if (st
== ST_EXIT
&& cnt
<= collapse
)
2530 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2533 if (st
== ST_CYCLE
&& cnt
< collapse
)
2535 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2536 " !$ACC LOOP loop");
2542 && (o
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2543 && (o
->head
->op
== EXEC_OMP_DO
2544 || o
->head
->op
== EXEC_OMP_PARALLEL_DO
2545 || o
->head
->op
== EXEC_OMP_SIMD
2546 || o
->head
->op
== EXEC_OMP_DO_SIMD
2547 || o
->head
->op
== EXEC_OMP_PARALLEL_DO_SIMD
))
2550 gcc_assert (o
->head
->next
!= NULL
2551 && (o
->head
->next
->op
== EXEC_DO
2552 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2553 && o
->previous
!= NULL
2554 && o
->previous
->tail
->op
== o
->head
->op
);
2555 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2556 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2557 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2558 if (st
== ST_EXIT
&& cnt
<= collapse
)
2560 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2563 if (st
== ST_CYCLE
&& cnt
< collapse
)
2565 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2571 /* Save the first statement in the construct - needed by the backend. */
2572 new_st
.ext
.which_construct
= p
->construct
;
2580 /* Match the EXIT statement. */
2583 gfc_match_exit (void)
2585 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2589 /* Match the CYCLE statement. */
2592 gfc_match_cycle (void)
2594 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2598 /* Match a number or character constant after an (ERROR) STOP or PAUSE
2602 gfc_match_stopcode (gfc_statement st
)
2609 if (gfc_match_eos () != MATCH_YES
)
2611 m
= gfc_match_init_expr (&e
);
2612 if (m
== MATCH_ERROR
)
2617 if (gfc_match_eos () != MATCH_YES
)
2621 if (gfc_pure (NULL
))
2623 if (st
== ST_ERROR_STOP
)
2625 if (!gfc_notify_std (GFC_STD_F2015
, "%s statement at %C in PURE "
2626 "procedure", gfc_ascii_statement (st
)))
2631 gfc_error ("%s statement not allowed in PURE procedure at %C",
2632 gfc_ascii_statement (st
));
2637 gfc_unset_implicit_pure (NULL
);
2639 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
))
2641 gfc_error ("Image control statement STOP at %C in CRITICAL block");
2644 if (st
== ST_STOP
&& gfc_find_state (COMP_DO_CONCURRENT
))
2646 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
2652 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
2654 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2661 gfc_error ("STOP code at %L must be scalar",
2666 if (e
->ts
.type
== BT_CHARACTER
2667 && e
->ts
.kind
!= gfc_default_character_kind
)
2669 gfc_error ("STOP code at %L must be default character KIND=%d",
2670 &e
->where
, (int) gfc_default_character_kind
);
2674 if (e
->ts
.type
== BT_INTEGER
2675 && e
->ts
.kind
!= gfc_default_integer_kind
)
2677 gfc_error ("STOP code at %L must be default integer KIND=%d",
2678 &e
->where
, (int) gfc_default_integer_kind
);
2686 new_st
.op
= EXEC_STOP
;
2689 new_st
.op
= EXEC_ERROR_STOP
;
2692 new_st
.op
= EXEC_PAUSE
;
2699 new_st
.ext
.stop_code
= -1;
2704 gfc_syntax_error (st
);
2713 /* Match the (deprecated) PAUSE statement. */
2716 gfc_match_pause (void)
2720 m
= gfc_match_stopcode (ST_PAUSE
);
2723 if (!gfc_notify_std (GFC_STD_F95_DEL
, "PAUSE statement at %C"))
2730 /* Match the STOP statement. */
2733 gfc_match_stop (void)
2735 return gfc_match_stopcode (ST_STOP
);
2739 /* Match the ERROR STOP statement. */
2742 gfc_match_error_stop (void)
2744 if (!gfc_notify_std (GFC_STD_F2008
, "ERROR STOP statement at %C"))
2747 return gfc_match_stopcode (ST_ERROR_STOP
);
2751 /* Match LOCK/UNLOCK statement. Syntax:
2752 LOCK ( lock-variable [ , lock-stat-list ] )
2753 UNLOCK ( lock-variable [ , sync-stat-list ] )
2754 where lock-stat is ACQUIRED_LOCK or sync-stat
2755 and sync-stat is STAT= or ERRMSG=. */
2758 lock_unlock_statement (gfc_statement st
)
2761 gfc_expr
*tmp
, *lockvar
, *acq_lock
, *stat
, *errmsg
;
2762 bool saw_acq_lock
, saw_stat
, saw_errmsg
;
2764 tmp
= lockvar
= acq_lock
= stat
= errmsg
= NULL
;
2765 saw_acq_lock
= saw_stat
= saw_errmsg
= false;
2767 if (gfc_pure (NULL
))
2769 gfc_error ("Image control statement %s at %C in PURE procedure",
2770 st
== ST_LOCK
? "LOCK" : "UNLOCK");
2774 gfc_unset_implicit_pure (NULL
);
2776 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2778 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2782 if (gfc_find_state (COMP_CRITICAL
))
2784 gfc_error ("Image control statement %s at %C in CRITICAL block",
2785 st
== ST_LOCK
? "LOCK" : "UNLOCK");
2789 if (gfc_find_state (COMP_DO_CONCURRENT
))
2791 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
2792 st
== ST_LOCK
? "LOCK" : "UNLOCK");
2796 if (gfc_match_char ('(') != MATCH_YES
)
2799 if (gfc_match ("%e", &lockvar
) != MATCH_YES
)
2801 m
= gfc_match_char (',');
2802 if (m
== MATCH_ERROR
)
2806 m
= gfc_match_char (')');
2814 m
= gfc_match (" stat = %v", &tmp
);
2815 if (m
== MATCH_ERROR
)
2821 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
2827 m
= gfc_match_char (',');
2835 m
= gfc_match (" errmsg = %v", &tmp
);
2836 if (m
== MATCH_ERROR
)
2842 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
2848 m
= gfc_match_char (',');
2856 m
= gfc_match (" acquired_lock = %v", &tmp
);
2857 if (m
== MATCH_ERROR
|| st
== ST_UNLOCK
)
2863 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
2868 saw_acq_lock
= true;
2870 m
= gfc_match_char (',');
2881 if (m
== MATCH_ERROR
)
2884 if (gfc_match (" )%t") != MATCH_YES
)
2891 new_st
.op
= EXEC_LOCK
;
2894 new_st
.op
= EXEC_UNLOCK
;
2900 new_st
.expr1
= lockvar
;
2901 new_st
.expr2
= stat
;
2902 new_st
.expr3
= errmsg
;
2903 new_st
.expr4
= acq_lock
;
2908 gfc_syntax_error (st
);
2911 if (acq_lock
!= tmp
)
2912 gfc_free_expr (acq_lock
);
2914 gfc_free_expr (errmsg
);
2916 gfc_free_expr (stat
);
2918 gfc_free_expr (tmp
);
2919 gfc_free_expr (lockvar
);
2926 gfc_match_lock (void)
2928 if (!gfc_notify_std (GFC_STD_F2008
, "LOCK statement at %C"))
2931 return lock_unlock_statement (ST_LOCK
);
2936 gfc_match_unlock (void)
2938 if (!gfc_notify_std (GFC_STD_F2008
, "UNLOCK statement at %C"))
2941 return lock_unlock_statement (ST_UNLOCK
);
2945 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
2946 SYNC ALL [(sync-stat-list)]
2947 SYNC MEMORY [(sync-stat-list)]
2948 SYNC IMAGES (image-set [, sync-stat-list] )
2949 with sync-stat is int-expr or *. */
2952 sync_statement (gfc_statement st
)
2955 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
2956 bool saw_stat
, saw_errmsg
;
2958 tmp
= imageset
= stat
= errmsg
= NULL
;
2959 saw_stat
= saw_errmsg
= false;
2961 if (gfc_pure (NULL
))
2963 gfc_error ("Image control statement SYNC at %C in PURE procedure");
2967 gfc_unset_implicit_pure (NULL
);
2969 if (!gfc_notify_std (GFC_STD_F2008
, "SYNC statement at %C"))
2972 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2974 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
2979 if (gfc_find_state (COMP_CRITICAL
))
2981 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
2985 if (gfc_find_state (COMP_DO_CONCURRENT
))
2987 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
2991 if (gfc_match_eos () == MATCH_YES
)
2993 if (st
== ST_SYNC_IMAGES
)
2998 if (gfc_match_char ('(') != MATCH_YES
)
3001 if (st
== ST_SYNC_IMAGES
)
3003 /* Denote '*' as imageset == NULL. */
3004 m
= gfc_match_char ('*');
3005 if (m
== MATCH_ERROR
)
3009 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
3012 m
= gfc_match_char (',');
3013 if (m
== MATCH_ERROR
)
3017 m
= gfc_match_char (')');
3026 m
= gfc_match (" stat = %v", &tmp
);
3027 if (m
== MATCH_ERROR
)
3033 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3039 if (gfc_match_char (',') == MATCH_YES
)
3046 m
= gfc_match (" errmsg = %v", &tmp
);
3047 if (m
== MATCH_ERROR
)
3053 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3059 if (gfc_match_char (',') == MATCH_YES
)
3069 if (gfc_match (" )%t") != MATCH_YES
)
3076 new_st
.op
= EXEC_SYNC_ALL
;
3078 case ST_SYNC_IMAGES
:
3079 new_st
.op
= EXEC_SYNC_IMAGES
;
3081 case ST_SYNC_MEMORY
:
3082 new_st
.op
= EXEC_SYNC_MEMORY
;
3088 new_st
.expr1
= imageset
;
3089 new_st
.expr2
= stat
;
3090 new_st
.expr3
= errmsg
;
3095 gfc_syntax_error (st
);
3099 gfc_free_expr (stat
);
3101 gfc_free_expr (errmsg
);
3103 gfc_free_expr (tmp
);
3104 gfc_free_expr (imageset
);
3110 /* Match SYNC ALL statement. */
3113 gfc_match_sync_all (void)
3115 return sync_statement (ST_SYNC_ALL
);
3119 /* Match SYNC IMAGES statement. */
3122 gfc_match_sync_images (void)
3124 return sync_statement (ST_SYNC_IMAGES
);
3128 /* Match SYNC MEMORY statement. */
3131 gfc_match_sync_memory (void)
3133 return sync_statement (ST_SYNC_MEMORY
);
3137 /* Match a CONTINUE statement. */
3140 gfc_match_continue (void)
3142 if (gfc_match_eos () != MATCH_YES
)
3144 gfc_syntax_error (ST_CONTINUE
);
3148 new_st
.op
= EXEC_CONTINUE
;
3153 /* Match the (deprecated) ASSIGN statement. */
3156 gfc_match_assign (void)
3159 gfc_st_label
*label
;
3161 if (gfc_match (" %l", &label
) == MATCH_YES
)
3163 if (!gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
))
3165 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
3167 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGN statement at %C"))
3170 expr
->symtree
->n
.sym
->attr
.assign
= 1;
3172 new_st
.op
= EXEC_LABEL_ASSIGN
;
3173 new_st
.label1
= label
;
3174 new_st
.expr1
= expr
;
3182 /* Match the GO TO statement. As a computed GOTO statement is
3183 matched, it is transformed into an equivalent SELECT block. No
3184 tree is necessary, and the resulting jumps-to-jumps are
3185 specifically optimized away by the back end. */
3188 gfc_match_goto (void)
3190 gfc_code
*head
, *tail
;
3193 gfc_st_label
*label
;
3197 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
3199 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3202 new_st
.op
= EXEC_GOTO
;
3203 new_st
.label1
= label
;
3207 /* The assigned GO TO statement. */
3209 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
3211 if (!gfc_notify_std (GFC_STD_F95_DEL
, "Assigned GOTO statement at %C"))
3214 new_st
.op
= EXEC_GOTO
;
3215 new_st
.expr1
= expr
;
3217 if (gfc_match_eos () == MATCH_YES
)
3220 /* Match label list. */
3221 gfc_match_char (',');
3222 if (gfc_match_char ('(') != MATCH_YES
)
3224 gfc_syntax_error (ST_GOTO
);
3231 m
= gfc_match_st_label (&label
);
3235 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3239 head
= tail
= gfc_get_code (EXEC_GOTO
);
3242 tail
->block
= gfc_get_code (EXEC_GOTO
);
3246 tail
->label1
= label
;
3248 while (gfc_match_char (',') == MATCH_YES
);
3250 if (gfc_match (")%t") != MATCH_YES
)
3255 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3258 new_st
.block
= head
;
3263 /* Last chance is a computed GO TO statement. */
3264 if (gfc_match_char ('(') != MATCH_YES
)
3266 gfc_syntax_error (ST_GOTO
);
3275 m
= gfc_match_st_label (&label
);
3279 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3283 head
= tail
= gfc_get_code (EXEC_SELECT
);
3286 tail
->block
= gfc_get_code (EXEC_SELECT
);
3290 cp
= gfc_get_case ();
3291 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
3294 tail
->ext
.block
.case_list
= cp
;
3296 tail
->next
= gfc_get_code (EXEC_GOTO
);
3297 tail
->next
->label1
= label
;
3299 while (gfc_match_char (',') == MATCH_YES
);
3301 if (gfc_match_char (')') != MATCH_YES
)
3306 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3310 /* Get the rest of the statement. */
3311 gfc_match_char (',');
3313 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
3316 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Computed GOTO at %C"))
3319 /* At this point, a computed GOTO has been fully matched and an
3320 equivalent SELECT statement constructed. */
3322 new_st
.op
= EXEC_SELECT
;
3323 new_st
.expr1
= NULL
;
3325 /* Hack: For a "real" SELECT, the expression is in expr. We put
3326 it in expr2 so we can distinguish then and produce the correct
3328 new_st
.expr2
= expr
;
3329 new_st
.block
= head
;
3333 gfc_syntax_error (ST_GOTO
);
3335 gfc_free_statements (head
);
3340 /* Frees a list of gfc_alloc structures. */
3343 gfc_free_alloc_list (gfc_alloc
*p
)
3350 gfc_free_expr (p
->expr
);
3356 /* Match an ALLOCATE statement. */
3359 gfc_match_allocate (void)
3361 gfc_alloc
*head
, *tail
;
3362 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
3366 locus old_locus
, deferred_locus
;
3367 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, saw_deferred
, b1
, b2
, b3
;
3368 bool saw_unlimited
= false;
3371 stat
= errmsg
= source
= mold
= tmp
= NULL
;
3372 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= saw_deferred
= false;
3374 if (gfc_match_char ('(') != MATCH_YES
)
3377 /* Match an optional type-spec. */
3378 old_locus
= gfc_current_locus
;
3379 m
= gfc_match_type_spec (&ts
);
3380 if (m
== MATCH_ERROR
)
3382 else if (m
== MATCH_NO
)
3384 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
3386 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
3388 gfc_error ("Error in type-spec at %L", &old_locus
);
3392 ts
.type
= BT_UNKNOWN
;
3396 if (gfc_match (" :: ") == MATCH_YES
)
3398 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
3404 gfc_error ("Type-spec at %L cannot contain a deferred "
3405 "type parameter", &old_locus
);
3409 if (ts
.type
== BT_CHARACTER
)
3410 ts
.u
.cl
->length_from_typespec
= true;
3414 ts
.type
= BT_UNKNOWN
;
3415 gfc_current_locus
= old_locus
;
3422 head
= tail
= gfc_get_alloc ();
3425 tail
->next
= gfc_get_alloc ();
3429 m
= gfc_match_variable (&tail
->expr
, 0);
3432 if (m
== MATCH_ERROR
)
3435 if (gfc_check_do_variable (tail
->expr
->symtree
))
3438 bool impure
= gfc_impure_variable (tail
->expr
->symtree
->n
.sym
);
3439 if (impure
&& gfc_pure (NULL
))
3441 gfc_error ("Bad allocate-object at %C for a PURE procedure");
3446 gfc_unset_implicit_pure (NULL
);
3448 if (tail
->expr
->ts
.deferred
)
3450 saw_deferred
= true;
3451 deferred_locus
= tail
->expr
->where
;
3454 if (gfc_find_state (COMP_DO_CONCURRENT
)
3455 || gfc_find_state (COMP_CRITICAL
))
3458 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
3459 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
3460 if (ref
->type
== REF_COMPONENT
)
3461 coarray
= ref
->u
.c
.component
->attr
.codimension
;
3463 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
3465 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
3468 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
3470 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
3475 /* Check for F08:C628. */
3476 sym
= tail
->expr
->symtree
->n
.sym
;
3477 b1
= !(tail
->expr
->ref
3478 && (tail
->expr
->ref
->type
== REF_COMPONENT
3479 || tail
->expr
->ref
->type
== REF_ARRAY
));
3480 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
3481 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
3482 || CLASS_DATA (sym
)->attr
.class_pointer
);
3484 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
3485 || sym
->attr
.proc_pointer
);
3486 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
3487 && (sym
->ns
->proc_name
->attr
.allocatable
3488 || sym
->ns
->proc_name
->attr
.pointer
3489 || sym
->ns
->proc_name
->attr
.proc_pointer
);
3490 if (b1
&& b2
&& !b3
)
3492 gfc_error ("Allocate-object at %L is neither a data pointer "
3493 "nor an allocatable variable", &tail
->expr
->where
);
3497 /* The ALLOCATE statement had an optional typespec. Check the
3499 if (ts
.type
!= BT_UNKNOWN
)
3501 /* Enforce F03:C624. */
3502 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
3504 gfc_error ("Type of entity at %L is type incompatible with "
3505 "typespec", &tail
->expr
->where
);
3509 /* Enforce F03:C627. */
3510 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
3512 gfc_error ("Kind type parameter for entity at %L differs from "
3513 "the kind type parameter of the typespec",
3514 &tail
->expr
->where
);
3519 if (tail
->expr
->ts
.type
== BT_DERIVED
)
3520 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
3522 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
3524 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
3526 gfc_error ("Shape specification for allocatable scalar at %C");
3530 if (gfc_match_char (',') != MATCH_YES
)
3535 m
= gfc_match (" stat = %v", &tmp
);
3536 if (m
== MATCH_ERROR
)
3543 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3551 if (gfc_check_do_variable (stat
->symtree
))
3554 if (gfc_match_char (',') == MATCH_YES
)
3555 goto alloc_opt_list
;
3558 m
= gfc_match (" errmsg = %v", &tmp
);
3559 if (m
== MATCH_ERROR
)
3563 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
3569 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3577 if (gfc_match_char (',') == MATCH_YES
)
3578 goto alloc_opt_list
;
3581 m
= gfc_match (" source = %e", &tmp
);
3582 if (m
== MATCH_ERROR
)
3586 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
3592 gfc_error ("Redundant SOURCE tag found at %L ", &tmp
->where
);
3596 /* The next 2 conditionals check C631. */
3597 if (ts
.type
!= BT_UNKNOWN
)
3599 gfc_error_1 ("SOURCE tag at %L conflicts with the typespec at %L",
3600 &tmp
->where
, &old_locus
);
3605 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
3606 " with more than a single allocate object",
3614 if (gfc_match_char (',') == MATCH_YES
)
3615 goto alloc_opt_list
;
3618 m
= gfc_match (" mold = %e", &tmp
);
3619 if (m
== MATCH_ERROR
)
3623 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
3626 /* Check F08:C636. */
3629 gfc_error ("Redundant MOLD tag found at %L ", &tmp
->where
);
3633 /* Check F08:C637. */
3634 if (ts
.type
!= BT_UNKNOWN
)
3636 gfc_error_1 ("MOLD tag at %L conflicts with the typespec at %L",
3637 &tmp
->where
, &old_locus
);
3646 if (gfc_match_char (',') == MATCH_YES
)
3647 goto alloc_opt_list
;
3650 gfc_gobble_whitespace ();
3652 if (gfc_peek_char () == ')')
3656 if (gfc_match (" )%t") != MATCH_YES
)
3659 /* Check F08:C637. */
3662 gfc_error_1 ("MOLD tag at %L conflicts with SOURCE tag at %L",
3663 &mold
->where
, &source
->where
);
3667 /* Check F03:C623, */
3668 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
3670 gfc_error ("Allocate-object at %L with a deferred type parameter "
3671 "requires either a type-spec or SOURCE tag or a MOLD tag",
3676 /* Check F03:C625, */
3677 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
3679 for (tail
= head
; tail
; tail
= tail
->next
)
3681 if (UNLIMITED_POLY (tail
->expr
))
3682 gfc_error ("Unlimited polymorphic allocate-object at %L "
3683 "requires either a type-spec or SOURCE tag "
3684 "or a MOLD tag", &tail
->expr
->where
);
3689 new_st
.op
= EXEC_ALLOCATE
;
3690 new_st
.expr1
= stat
;
3691 new_st
.expr2
= errmsg
;
3693 new_st
.expr3
= source
;
3695 new_st
.expr3
= mold
;
3696 new_st
.ext
.alloc
.list
= head
;
3697 new_st
.ext
.alloc
.ts
= ts
;
3702 gfc_syntax_error (ST_ALLOCATE
);
3705 gfc_free_expr (errmsg
);
3706 gfc_free_expr (source
);
3707 gfc_free_expr (stat
);
3708 gfc_free_expr (mold
);
3709 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
3710 gfc_free_alloc_list (head
);
3715 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
3716 a set of pointer assignments to intrinsic NULL(). */
3719 gfc_match_nullify (void)
3727 if (gfc_match_char ('(') != MATCH_YES
)
3732 m
= gfc_match_variable (&p
, 0);
3733 if (m
== MATCH_ERROR
)
3738 if (gfc_check_do_variable (p
->symtree
))
3742 if (gfc_is_coindexed (p
))
3744 gfc_error ("Pointer object at %C shall not be coindexed");
3748 /* build ' => NULL() '. */
3749 e
= gfc_get_null_expr (&gfc_current_locus
);
3751 /* Chain to list. */
3755 tail
->op
= EXEC_POINTER_ASSIGN
;
3759 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
3766 if (gfc_match (" )%t") == MATCH_YES
)
3768 if (gfc_match_char (',') != MATCH_YES
)
3775 gfc_syntax_error (ST_NULLIFY
);
3778 gfc_free_statements (new_st
.next
);
3780 gfc_free_expr (new_st
.expr1
);
3781 new_st
.expr1
= NULL
;
3782 gfc_free_expr (new_st
.expr2
);
3783 new_st
.expr2
= NULL
;
3788 /* Match a DEALLOCATE statement. */
3791 gfc_match_deallocate (void)
3793 gfc_alloc
*head
, *tail
;
3794 gfc_expr
*stat
, *errmsg
, *tmp
;
3797 bool saw_stat
, saw_errmsg
, b1
, b2
;
3800 stat
= errmsg
= tmp
= NULL
;
3801 saw_stat
= saw_errmsg
= false;
3803 if (gfc_match_char ('(') != MATCH_YES
)
3809 head
= tail
= gfc_get_alloc ();
3812 tail
->next
= gfc_get_alloc ();
3816 m
= gfc_match_variable (&tail
->expr
, 0);
3817 if (m
== MATCH_ERROR
)
3822 if (gfc_check_do_variable (tail
->expr
->symtree
))
3825 sym
= tail
->expr
->symtree
->n
.sym
;
3827 bool impure
= gfc_impure_variable (sym
);
3828 if (impure
&& gfc_pure (NULL
))
3830 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3835 gfc_unset_implicit_pure (NULL
);
3837 if (gfc_is_coarray (tail
->expr
)
3838 && gfc_find_state (COMP_DO_CONCURRENT
))
3840 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
3844 if (gfc_is_coarray (tail
->expr
)
3845 && gfc_find_state (COMP_CRITICAL
))
3847 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
3851 /* FIXME: disable the checking on derived types. */
3852 b1
= !(tail
->expr
->ref
3853 && (tail
->expr
->ref
->type
== REF_COMPONENT
3854 || tail
->expr
->ref
->type
== REF_ARRAY
));
3855 if (sym
&& sym
->ts
.type
== BT_CLASS
)
3856 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
3857 || CLASS_DATA (sym
)->attr
.class_pointer
);
3859 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
3860 || sym
->attr
.proc_pointer
);
3863 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3864 "nor an allocatable variable");
3868 if (gfc_match_char (',') != MATCH_YES
)
3873 m
= gfc_match (" stat = %v", &tmp
);
3874 if (m
== MATCH_ERROR
)
3880 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3881 gfc_free_expr (tmp
);
3888 if (gfc_check_do_variable (stat
->symtree
))
3891 if (gfc_match_char (',') == MATCH_YES
)
3892 goto dealloc_opt_list
;
3895 m
= gfc_match (" errmsg = %v", &tmp
);
3896 if (m
== MATCH_ERROR
)
3900 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
3905 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3906 gfc_free_expr (tmp
);
3913 if (gfc_match_char (',') == MATCH_YES
)
3914 goto dealloc_opt_list
;
3917 gfc_gobble_whitespace ();
3919 if (gfc_peek_char () == ')')
3923 if (gfc_match (" )%t") != MATCH_YES
)
3926 new_st
.op
= EXEC_DEALLOCATE
;
3927 new_st
.expr1
= stat
;
3928 new_st
.expr2
= errmsg
;
3929 new_st
.ext
.alloc
.list
= head
;
3934 gfc_syntax_error (ST_DEALLOCATE
);
3937 gfc_free_expr (errmsg
);
3938 gfc_free_expr (stat
);
3939 gfc_free_alloc_list (head
);
3944 /* Match a RETURN statement. */
3947 gfc_match_return (void)
3951 gfc_compile_state s
;
3955 if (gfc_find_state (COMP_CRITICAL
))
3957 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
3961 if (gfc_find_state (COMP_DO_CONCURRENT
))
3963 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
3967 if (gfc_match_eos () == MATCH_YES
)
3970 if (!gfc_find_state (COMP_SUBROUTINE
))
3972 gfc_error ("Alternate RETURN statement at %C is only allowed within "
3977 if (gfc_current_form
== FORM_FREE
)
3979 /* The following are valid, so we can't require a blank after the
3983 char c
= gfc_peek_ascii_char ();
3984 if (ISALPHA (c
) || ISDIGIT (c
))
3988 m
= gfc_match (" %e%t", &e
);
3991 if (m
== MATCH_ERROR
)
3994 gfc_syntax_error (ST_RETURN
);
4001 gfc_enclosing_unit (&s
);
4002 if (s
== COMP_PROGRAM
4003 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
4004 "main program at %C"))
4007 new_st
.op
= EXEC_RETURN
;
4014 /* Match the call of a type-bound procedure, if CALL%var has already been
4015 matched and var found to be a derived-type variable. */
4018 match_typebound_call (gfc_symtree
* varst
)
4023 base
= gfc_get_expr ();
4024 base
->expr_type
= EXPR_VARIABLE
;
4025 base
->symtree
= varst
;
4026 base
->where
= gfc_current_locus
;
4027 gfc_set_sym_referenced (varst
->n
.sym
);
4029 m
= gfc_match_varspec (base
, 0, true, true);
4031 gfc_error ("Expected component reference at %C");
4034 gfc_free_expr (base
);
4038 if (gfc_match_eos () != MATCH_YES
)
4040 gfc_error ("Junk after CALL at %C");
4041 gfc_free_expr (base
);
4045 if (base
->expr_type
== EXPR_COMPCALL
)
4046 new_st
.op
= EXEC_COMPCALL
;
4047 else if (base
->expr_type
== EXPR_PPC
)
4048 new_st
.op
= EXEC_CALL_PPC
;
4051 gfc_error ("Expected type-bound procedure or procedure pointer component "
4053 gfc_free_expr (base
);
4056 new_st
.expr1
= base
;
4062 /* Match a CALL statement. The tricky part here are possible
4063 alternate return specifiers. We handle these by having all
4064 "subroutines" actually return an integer via a register that gives
4065 the return number. If the call specifies alternate returns, we
4066 generate code for a SELECT statement whose case clauses contain
4067 GOTOs to the various labels. */
4070 gfc_match_call (void)
4072 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4073 gfc_actual_arglist
*a
, *arglist
;
4083 m
= gfc_match ("% %n", name
);
4089 if (gfc_get_ha_sym_tree (name
, &st
))
4094 /* If this is a variable of derived-type, it probably starts a type-bound
4096 if ((sym
->attr
.flavor
!= FL_PROCEDURE
4097 || gfc_is_function_return_value (sym
, gfc_current_ns
))
4098 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
4099 return match_typebound_call (st
);
4101 /* If it does not seem to be callable (include functions so that the
4102 right association is made. They are thrown out in resolution.)
4104 if (!sym
->attr
.generic
4105 && !sym
->attr
.subroutine
4106 && !sym
->attr
.function
)
4108 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
4110 /* ...create a symbol in this scope... */
4111 if (sym
->ns
!= gfc_current_ns
4112 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
4115 if (sym
!= st
->n
.sym
)
4119 /* ...and then to try to make the symbol into a subroutine. */
4120 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
4124 gfc_set_sym_referenced (sym
);
4126 if (gfc_match_eos () != MATCH_YES
)
4128 m
= gfc_match_actual_arglist (1, &arglist
);
4131 if (m
== MATCH_ERROR
)
4134 if (gfc_match_eos () != MATCH_YES
)
4138 /* If any alternate return labels were found, construct a SELECT
4139 statement that will jump to the right place. */
4142 for (a
= arglist
; a
; a
= a
->next
)
4143 if (a
->expr
== NULL
)
4151 gfc_symtree
*select_st
;
4152 gfc_symbol
*select_sym
;
4153 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4155 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
4156 sprintf (name
, "_result_%s", sym
->name
);
4157 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
4159 select_sym
= select_st
->n
.sym
;
4160 select_sym
->ts
.type
= BT_INTEGER
;
4161 select_sym
->ts
.kind
= gfc_default_integer_kind
;
4162 gfc_set_sym_referenced (select_sym
);
4163 c
->expr1
= gfc_get_expr ();
4164 c
->expr1
->expr_type
= EXPR_VARIABLE
;
4165 c
->expr1
->symtree
= select_st
;
4166 c
->expr1
->ts
= select_sym
->ts
;
4167 c
->expr1
->where
= gfc_current_locus
;
4170 for (a
= arglist
; a
; a
= a
->next
)
4172 if (a
->expr
!= NULL
)
4175 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
4180 c
->block
= gfc_get_code (EXEC_SELECT
);
4183 new_case
= gfc_get_case ();
4184 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
4185 new_case
->low
= new_case
->high
;
4186 c
->ext
.block
.case_list
= new_case
;
4188 c
->next
= gfc_get_code (EXEC_GOTO
);
4189 c
->next
->label1
= a
->label
;
4193 new_st
.op
= EXEC_CALL
;
4194 new_st
.symtree
= st
;
4195 new_st
.ext
.actual
= arglist
;
4200 gfc_syntax_error (ST_CALL
);
4203 gfc_free_actual_arglist (arglist
);
4208 /* Given a name, return a pointer to the common head structure,
4209 creating it if it does not exist. If FROM_MODULE is nonzero, we
4210 mangle the name so that it doesn't interfere with commons defined
4211 in the using namespace.
4212 TODO: Add to global symbol tree. */
4215 gfc_get_common (const char *name
, int from_module
)
4218 static int serial
= 0;
4219 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
4223 /* A use associated common block is only needed to correctly layout
4224 the variables it contains. */
4225 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
4226 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
4230 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
4233 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
4236 if (st
->n
.common
== NULL
)
4238 st
->n
.common
= gfc_get_common_head ();
4239 st
->n
.common
->where
= gfc_current_locus
;
4240 strcpy (st
->n
.common
->name
, name
);
4243 return st
->n
.common
;
4247 /* Match a common block name. */
4249 match
match_common_name (char *name
)
4253 if (gfc_match_char ('/') == MATCH_NO
)
4259 if (gfc_match_char ('/') == MATCH_YES
)
4265 m
= gfc_match_name (name
);
4267 if (m
== MATCH_ERROR
)
4269 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
4272 gfc_error ("Syntax error in common block name at %C");
4277 /* Match a COMMON statement. */
4280 gfc_match_common (void)
4282 gfc_symbol
*sym
, **head
, *tail
, *other
, *old_blank_common
;
4283 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4289 old_blank_common
= gfc_current_ns
->blank_common
.head
;
4290 if (old_blank_common
)
4292 while (old_blank_common
->common_next
)
4293 old_blank_common
= old_blank_common
->common_next
;
4300 m
= match_common_name (name
);
4301 if (m
== MATCH_ERROR
)
4304 if (name
[0] == '\0')
4306 t
= &gfc_current_ns
->blank_common
;
4307 if (t
->head
== NULL
)
4308 t
->where
= gfc_current_locus
;
4312 t
= gfc_get_common (name
, 0);
4321 while (tail
->common_next
)
4322 tail
= tail
->common_next
;
4325 /* Grab the list of symbols. */
4328 m
= gfc_match_symbol (&sym
, 0);
4329 if (m
== MATCH_ERROR
)
4334 /* Store a ref to the common block for error checking. */
4335 sym
->common_block
= t
;
4336 sym
->common_block
->refs
++;
4338 /* See if we know the current common block is bind(c), and if
4339 so, then see if we can check if the symbol is (which it'll
4340 need to be). This can happen if the bind(c) attr stmt was
4341 applied to the common block, and the variable(s) already
4342 defined, before declaring the common block. */
4343 if (t
->is_bind_c
== 1)
4345 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
4347 /* If we find an error, just print it and continue,
4348 cause it's just semantic, and we can see if there
4350 gfc_error_now_1 ("Variable '%s' at %L in common block '%s' "
4351 "at %C must be declared with a C "
4352 "interoperable kind since common block "
4354 sym
->name
, &(sym
->declared_at
), t
->name
,
4358 if (sym
->attr
.is_bind_c
== 1)
4359 gfc_error_now ("Variable %qs in common block %qs at %C can not "
4360 "be bind(c) since it is not global", sym
->name
,
4364 if (sym
->attr
.in_common
)
4366 gfc_error ("Symbol %qs at %C is already in a COMMON block",
4371 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
4372 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
4374 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol %qs at "
4375 "%C can only be COMMON in BLOCK DATA",
4380 if (!gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
))
4384 tail
->common_next
= sym
;
4390 /* Deal with an optional array specification after the
4392 m
= gfc_match_array_spec (&as
, true, true);
4393 if (m
== MATCH_ERROR
)
4398 if (as
->type
!= AS_EXPLICIT
)
4400 gfc_error ("Array specification for symbol %qs in COMMON "
4401 "at %C must be explicit", sym
->name
);
4405 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
4408 if (sym
->attr
.pointer
)
4410 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
4411 "POINTER array", sym
->name
);
4420 sym
->common_head
= t
;
4422 /* Check to see if the symbol is already in an equivalence group.
4423 If it is, set the other members as being in common. */
4424 if (sym
->attr
.in_equivalence
)
4426 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
4428 for (e2
= e1
; e2
; e2
= e2
->eq
)
4429 if (e2
->expr
->symtree
->n
.sym
== sym
)
4436 for (e2
= e1
; e2
; e2
= e2
->eq
)
4438 other
= e2
->expr
->symtree
->n
.sym
;
4439 if (other
->common_head
4440 && other
->common_head
!= sym
->common_head
)
4442 gfc_error ("Symbol %qs, in COMMON block %qs at "
4443 "%C is being indirectly equivalenced to "
4444 "another COMMON block %qs",
4445 sym
->name
, sym
->common_head
->name
,
4446 other
->common_head
->name
);
4449 other
->attr
.in_common
= 1;
4450 other
->common_head
= t
;
4456 gfc_gobble_whitespace ();
4457 if (gfc_match_eos () == MATCH_YES
)
4459 if (gfc_peek_ascii_char () == '/')
4461 if (gfc_match_char (',') != MATCH_YES
)
4463 gfc_gobble_whitespace ();
4464 if (gfc_peek_ascii_char () == '/')
4473 gfc_syntax_error (ST_COMMON
);
4476 gfc_free_array_spec (as
);
4481 /* Match a BLOCK DATA program unit. */
4484 gfc_match_block_data (void)
4486 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4490 if (gfc_match_eos () == MATCH_YES
)
4492 gfc_new_block
= NULL
;
4496 m
= gfc_match ("% %n%t", name
);
4500 if (gfc_get_symbol (name
, NULL
, &sym
))
4503 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
4506 gfc_new_block
= sym
;
4512 /* Free a namelist structure. */
4515 gfc_free_namelist (gfc_namelist
*name
)
4519 for (; name
; name
= n
)
4527 /* Free an OpenMP namelist structure. */
4530 gfc_free_omp_namelist (gfc_omp_namelist
*name
)
4532 gfc_omp_namelist
*n
;
4534 for (; name
; name
= n
)
4536 gfc_free_expr (name
->expr
);
4539 if (name
->udr
->combiner
)
4540 gfc_free_statement (name
->udr
->combiner
);
4541 if (name
->udr
->initializer
)
4542 gfc_free_statement (name
->udr
->initializer
);
4551 /* Match a NAMELIST statement. */
4554 gfc_match_namelist (void)
4556 gfc_symbol
*group_name
, *sym
;
4560 m
= gfc_match (" / %s /", &group_name
);
4563 if (m
== MATCH_ERROR
)
4568 if (group_name
->ts
.type
!= BT_UNKNOWN
)
4570 gfc_error ("Namelist group name %qs at %C already has a basic "
4571 "type of %s", group_name
->name
,
4572 gfc_typename (&group_name
->ts
));
4576 if (group_name
->attr
.flavor
== FL_NAMELIST
4577 && group_name
->attr
.use_assoc
4578 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name %qs "
4579 "at %C already is USE associated and can"
4580 "not be respecified.", group_name
->name
))
4583 if (group_name
->attr
.flavor
!= FL_NAMELIST
4584 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
4585 group_name
->name
, NULL
))
4590 m
= gfc_match_symbol (&sym
, 1);
4593 if (m
== MATCH_ERROR
)
4596 if (sym
->attr
.in_namelist
== 0
4597 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
4600 /* Use gfc_error_check here, rather than goto error, so that
4601 these are the only errors for the next two lines. */
4602 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
4604 gfc_error ("Assumed size array %qs in namelist %qs at "
4605 "%C is not allowed", sym
->name
, group_name
->name
);
4609 nl
= gfc_get_namelist ();
4613 if (group_name
->namelist
== NULL
)
4614 group_name
->namelist
= group_name
->namelist_tail
= nl
;
4617 group_name
->namelist_tail
->next
= nl
;
4618 group_name
->namelist_tail
= nl
;
4621 if (gfc_match_eos () == MATCH_YES
)
4624 m
= gfc_match_char (',');
4626 if (gfc_match_char ('/') == MATCH_YES
)
4628 m2
= gfc_match (" %s /", &group_name
);
4629 if (m2
== MATCH_YES
)
4631 if (m2
== MATCH_ERROR
)
4645 gfc_syntax_error (ST_NAMELIST
);
4652 /* Match a MODULE statement. */
4655 gfc_match_module (void)
4659 m
= gfc_match (" %s%t", &gfc_new_block
);
4663 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
4664 gfc_new_block
->name
, NULL
))
4671 /* Free equivalence sets and lists. Recursively is the easiest way to
4675 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
4680 gfc_free_equiv (eq
->eq
);
4681 gfc_free_equiv_until (eq
->next
, stop
);
4682 gfc_free_expr (eq
->expr
);
4688 gfc_free_equiv (gfc_equiv
*eq
)
4690 gfc_free_equiv_until (eq
, NULL
);
4694 /* Match an EQUIVALENCE statement. */
4697 gfc_match_equivalence (void)
4699 gfc_equiv
*eq
, *set
, *tail
;
4703 gfc_common_head
*common_head
= NULL
;
4711 eq
= gfc_get_equiv ();
4715 eq
->next
= gfc_current_ns
->equiv
;
4716 gfc_current_ns
->equiv
= eq
;
4718 if (gfc_match_char ('(') != MATCH_YES
)
4722 common_flag
= FALSE
;
4727 m
= gfc_match_equiv_variable (&set
->expr
);
4728 if (m
== MATCH_ERROR
)
4733 /* count the number of objects. */
4736 if (gfc_match_char ('%') == MATCH_YES
)
4738 gfc_error ("Derived type component %C is not a "
4739 "permitted EQUIVALENCE member");
4743 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
4744 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
4746 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
4747 "be an array section");
4751 sym
= set
->expr
->symtree
->n
.sym
;
4753 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
4756 if (sym
->attr
.in_common
)
4759 common_head
= sym
->common_head
;
4762 if (gfc_match_char (')') == MATCH_YES
)
4765 if (gfc_match_char (',') != MATCH_YES
)
4768 set
->eq
= gfc_get_equiv ();
4774 gfc_error ("EQUIVALENCE at %C requires two or more objects");
4778 /* If one of the members of an equivalence is in common, then
4779 mark them all as being in common. Before doing this, check
4780 that members of the equivalence group are not in different
4783 for (set
= eq
; set
; set
= set
->eq
)
4785 sym
= set
->expr
->symtree
->n
.sym
;
4786 if (sym
->common_head
&& sym
->common_head
!= common_head
)
4788 gfc_error ("Attempt to indirectly overlap COMMON "
4789 "blocks %s and %s by EQUIVALENCE at %C",
4790 sym
->common_head
->name
, common_head
->name
);
4793 sym
->attr
.in_common
= 1;
4794 sym
->common_head
= common_head
;
4797 if (gfc_match_eos () == MATCH_YES
)
4799 if (gfc_match_char (',') != MATCH_YES
)
4801 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
4809 gfc_syntax_error (ST_EQUIVALENCE
);
4815 gfc_free_equiv (gfc_current_ns
->equiv
);
4816 gfc_current_ns
->equiv
= eq
;
4822 /* Check that a statement function is not recursive. This is done by looking
4823 for the statement function symbol(sym) by looking recursively through its
4824 expression(e). If a reference to sym is found, true is returned.
4825 12.5.4 requires that any variable of function that is implicitly typed
4826 shall have that type confirmed by any subsequent type declaration. The
4827 implicit typing is conveniently done here. */
4829 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
4832 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
4838 switch (e
->expr_type
)
4841 if (e
->symtree
== NULL
)
4844 /* Check the name before testing for nested recursion! */
4845 if (sym
->name
== e
->symtree
->n
.sym
->name
)
4848 /* Catch recursion via other statement functions. */
4849 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
4850 && e
->symtree
->n
.sym
->value
4851 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
4854 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
4855 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
4860 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
4863 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
4864 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
4876 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
4878 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
4882 /* Match a statement function declaration. It is so easy to match
4883 non-statement function statements with a MATCH_ERROR as opposed to
4884 MATCH_NO that we suppress error message in most cases. */
4887 gfc_match_st_function (void)
4889 gfc_error_buf old_error_1
;
4890 output_buffer old_error
;
4896 m
= gfc_match_symbol (&sym
, 0);
4900 gfc_push_error (&old_error
, &old_error_1
);
4902 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
4905 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
4908 m
= gfc_match (" = %e%t", &expr
);
4912 gfc_free_error (&old_error
, &old_error_1
);
4914 if (m
== MATCH_ERROR
)
4917 if (recursive_stmt_fcn (expr
, sym
))
4919 gfc_error ("Statement function at %L is recursive", &expr
->where
);
4925 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
4931 gfc_pop_error (&old_error
, &old_error_1
);
4936 /***************** SELECT CASE subroutines ******************/
4938 /* Free a single case structure. */
4941 free_case (gfc_case
*p
)
4943 if (p
->low
== p
->high
)
4945 gfc_free_expr (p
->low
);
4946 gfc_free_expr (p
->high
);
4951 /* Free a list of case structures. */
4954 gfc_free_case_list (gfc_case
*p
)
4966 /* Match a single case selector. */
4969 match_case_selector (gfc_case
**cp
)
4974 c
= gfc_get_case ();
4975 c
->where
= gfc_current_locus
;
4977 if (gfc_match_char (':') == MATCH_YES
)
4979 m
= gfc_match_init_expr (&c
->high
);
4982 if (m
== MATCH_ERROR
)
4987 m
= gfc_match_init_expr (&c
->low
);
4988 if (m
== MATCH_ERROR
)
4993 /* If we're not looking at a ':' now, make a range out of a single
4994 target. Else get the upper bound for the case range. */
4995 if (gfc_match_char (':') != MATCH_YES
)
4999 m
= gfc_match_init_expr (&c
->high
);
5000 if (m
== MATCH_ERROR
)
5002 /* MATCH_NO is fine. It's OK if nothing is there! */
5010 gfc_error ("Expected initialization expression in CASE at %C");
5018 /* Match the end of a case statement. */
5021 match_case_eos (void)
5023 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5026 if (gfc_match_eos () == MATCH_YES
)
5029 /* If the case construct doesn't have a case-construct-name, we
5030 should have matched the EOS. */
5031 if (!gfc_current_block ())
5034 gfc_gobble_whitespace ();
5036 m
= gfc_match_name (name
);
5040 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5042 gfc_error ("Expected block name %qs of SELECT construct at %C",
5043 gfc_current_block ()->name
);
5047 return gfc_match_eos ();
5051 /* Match a SELECT statement. */
5054 gfc_match_select (void)
5059 m
= gfc_match_label ();
5060 if (m
== MATCH_ERROR
)
5063 m
= gfc_match (" select case ( %e )%t", &expr
);
5067 new_st
.op
= EXEC_SELECT
;
5068 new_st
.expr1
= expr
;
5074 /* Transfer the selector typespec to the associate name. */
5077 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
)
5080 gfc_symbol
*assoc_sym
;
5082 assoc_sym
= associate
->symtree
->n
.sym
;
5084 /* At this stage the expression rank and arrayspec dimensions have
5085 not been completely sorted out. We must get the expr2->rank
5086 right here, so that the correct class container is obtained. */
5087 ref
= selector
->ref
;
5088 while (ref
&& ref
->next
)
5091 if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
5092 && ref
&& ref
->type
== REF_ARRAY
)
5094 /* Ensure that the array reference type is set. We cannot use
5095 gfc_resolve_expr at this point, so the usable parts of
5096 resolve.c(resolve_array_ref) are employed to do it. */
5097 if (ref
->u
.ar
.type
== AR_UNKNOWN
)
5099 ref
->u
.ar
.type
= AR_ELEMENT
;
5100 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
5101 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5102 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
5103 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
5104 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
5106 ref
->u
.ar
.type
= AR_SECTION
;
5111 if (ref
->u
.ar
.type
== AR_FULL
)
5112 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
5113 else if (ref
->u
.ar
.type
== AR_SECTION
)
5114 selector
->rank
= ref
->u
.ar
.dimen
;
5121 assoc_sym
->attr
.dimension
= 1;
5122 assoc_sym
->as
= gfc_get_array_spec ();
5123 assoc_sym
->as
->rank
= selector
->rank
;
5124 assoc_sym
->as
->type
= AS_DEFERRED
;
5127 assoc_sym
->as
= NULL
;
5129 if (selector
->ts
.type
== BT_CLASS
)
5131 /* The correct class container has to be available. */
5132 assoc_sym
->ts
.type
= BT_CLASS
;
5133 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
5134 assoc_sym
->attr
.pointer
= 1;
5135 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
5140 /* Push the current selector onto the SELECT TYPE stack. */
5143 select_type_push (gfc_symbol
*sel
)
5145 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
5146 top
->selector
= sel
;
5148 top
->prev
= select_type_stack
;
5150 select_type_stack
= top
;
5154 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
5156 static gfc_symtree
*
5157 select_intrinsic_set_tmp (gfc_typespec
*ts
)
5159 char name
[GFC_MAX_SYMBOL_LEN
];
5163 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
5166 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5167 && !select_type_stack
->selector
->attr
.class_ok
)
5170 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
5171 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5172 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
5174 if (ts
->type
!= BT_CHARACTER
)
5175 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
5178 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (ts
->type
),
5181 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5182 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5184 /* Copy across the array spec to the selector. */
5185 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5186 && (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5187 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
))
5189 tmp
->n
.sym
->attr
.pointer
= 1;
5190 tmp
->n
.sym
->attr
.dimension
5191 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5192 tmp
->n
.sym
->attr
.codimension
5193 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5195 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5198 gfc_set_sym_referenced (tmp
->n
.sym
);
5199 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5200 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5206 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
5209 select_type_set_tmp (gfc_typespec
*ts
)
5211 char name
[GFC_MAX_SYMBOL_LEN
];
5212 gfc_symtree
*tmp
= NULL
;
5216 select_type_stack
->tmp
= NULL
;
5220 tmp
= select_intrinsic_set_tmp (ts
);
5227 if (ts
->type
== BT_CLASS
)
5228 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
5230 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
5231 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5232 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5234 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5235 && select_type_stack
->selector
->attr
.class_ok
)
5237 tmp
->n
.sym
->attr
.pointer
5238 = CLASS_DATA (select_type_stack
->selector
)->attr
.class_pointer
;
5240 /* Copy across the array spec to the selector. */
5241 if (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5242 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
)
5244 tmp
->n
.sym
->attr
.dimension
5245 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5246 tmp
->n
.sym
->attr
.codimension
5247 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5249 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5253 gfc_set_sym_referenced (tmp
->n
.sym
);
5254 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5255 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5257 if (ts
->type
== BT_CLASS
)
5258 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
5262 /* Add an association for it, so the rest of the parser knows it is
5263 an associate-name. The target will be set during resolution. */
5264 tmp
->n
.sym
->assoc
= gfc_get_association_list ();
5265 tmp
->n
.sym
->assoc
->dangling
= 1;
5266 tmp
->n
.sym
->assoc
->st
= tmp
;
5268 select_type_stack
->tmp
= tmp
;
5272 /* Match a SELECT TYPE statement. */
5275 gfc_match_select_type (void)
5277 gfc_expr
*expr1
, *expr2
= NULL
;
5279 char name
[GFC_MAX_SYMBOL_LEN
];
5283 m
= gfc_match_label ();
5284 if (m
== MATCH_ERROR
)
5287 m
= gfc_match (" select type ( ");
5291 m
= gfc_match (" %n => %e", name
, &expr2
);
5294 expr1
= gfc_get_expr();
5295 expr1
->expr_type
= EXPR_VARIABLE
;
5296 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
5302 sym
= expr1
->symtree
->n
.sym
;
5303 if (expr2
->ts
.type
== BT_UNKNOWN
)
5304 sym
->attr
.untyped
= 1;
5306 copy_ts_from_selector_to_associate (expr1
, expr2
);
5308 sym
->attr
.flavor
= FL_VARIABLE
;
5309 sym
->attr
.referenced
= 1;
5310 sym
->attr
.class_ok
= 1;
5314 m
= gfc_match (" %e ", &expr1
);
5319 m
= gfc_match (" )%t");
5322 gfc_error ("parse error in SELECT TYPE statement at %C");
5326 /* This ghastly expression seems to be needed to distinguish a CLASS
5327 array, which can have a reference, from other expressions that
5328 have references, such as derived type components, and are not
5329 allowed by the standard.
5330 TODO: see if it is sufficient to exclude component and substring
5332 class_array
= expr1
->expr_type
== EXPR_VARIABLE
5333 && expr1
->ts
.type
== BT_CLASS
5334 && CLASS_DATA (expr1
)
5335 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
5336 && (CLASS_DATA (expr1
)->attr
.dimension
5337 || CLASS_DATA (expr1
)->attr
.codimension
)
5339 && expr1
->ref
->type
== REF_ARRAY
5340 && expr1
->ref
->next
== NULL
;
5342 /* Check for F03:C811. */
5343 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
5344 || (!class_array
&& expr1
->ref
!= NULL
)))
5346 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
5347 "use associate-name=>");
5352 new_st
.op
= EXEC_SELECT_TYPE
;
5353 new_st
.expr1
= expr1
;
5354 new_st
.expr2
= expr2
;
5355 new_st
.ext
.block
.ns
= gfc_current_ns
;
5357 select_type_push (expr1
->symtree
->n
.sym
);
5362 gfc_free_expr (expr1
);
5363 gfc_free_expr (expr2
);
5368 /* Match a CASE statement. */
5371 gfc_match_case (void)
5373 gfc_case
*c
, *head
, *tail
;
5378 if (gfc_current_state () != COMP_SELECT
)
5380 gfc_error ("Unexpected CASE statement at %C");
5384 if (gfc_match ("% default") == MATCH_YES
)
5386 m
= match_case_eos ();
5389 if (m
== MATCH_ERROR
)
5392 new_st
.op
= EXEC_SELECT
;
5393 c
= gfc_get_case ();
5394 c
->where
= gfc_current_locus
;
5395 new_st
.ext
.block
.case_list
= c
;
5399 if (gfc_match_char ('(') != MATCH_YES
)
5404 if (match_case_selector (&c
) == MATCH_ERROR
)
5414 if (gfc_match_char (')') == MATCH_YES
)
5416 if (gfc_match_char (',') != MATCH_YES
)
5420 m
= match_case_eos ();
5423 if (m
== MATCH_ERROR
)
5426 new_st
.op
= EXEC_SELECT
;
5427 new_st
.ext
.block
.case_list
= head
;
5432 gfc_error ("Syntax error in CASE specification at %C");
5435 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
5440 /* Match a TYPE IS statement. */
5443 gfc_match_type_is (void)
5448 if (gfc_current_state () != COMP_SELECT_TYPE
)
5450 gfc_error ("Unexpected TYPE IS statement at %C");
5454 if (gfc_match_char ('(') != MATCH_YES
)
5457 c
= gfc_get_case ();
5458 c
->where
= gfc_current_locus
;
5460 if (gfc_match_type_spec (&c
->ts
) == MATCH_ERROR
)
5463 if (gfc_match_char (')') != MATCH_YES
)
5466 m
= match_case_eos ();
5469 if (m
== MATCH_ERROR
)
5472 new_st
.op
= EXEC_SELECT_TYPE
;
5473 new_st
.ext
.block
.case_list
= c
;
5475 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
5476 && (c
->ts
.u
.derived
->attr
.sequence
5477 || c
->ts
.u
.derived
->attr
.is_bind_c
))
5479 gfc_error ("The type-spec shall not specify a sequence derived "
5480 "type or a type with the BIND attribute in SELECT "
5481 "TYPE at %C [F2003:C815]");
5485 /* Create temporary variable. */
5486 select_type_set_tmp (&c
->ts
);
5491 gfc_error ("Syntax error in TYPE IS specification at %C");
5495 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
5500 /* Match a CLASS IS or CLASS DEFAULT statement. */
5503 gfc_match_class_is (void)
5508 if (gfc_current_state () != COMP_SELECT_TYPE
)
5511 if (gfc_match ("% default") == MATCH_YES
)
5513 m
= match_case_eos ();
5516 if (m
== MATCH_ERROR
)
5519 new_st
.op
= EXEC_SELECT_TYPE
;
5520 c
= gfc_get_case ();
5521 c
->where
= gfc_current_locus
;
5522 c
->ts
.type
= BT_UNKNOWN
;
5523 new_st
.ext
.block
.case_list
= c
;
5524 select_type_set_tmp (NULL
);
5528 m
= gfc_match ("% is");
5531 if (m
== MATCH_ERROR
)
5534 if (gfc_match_char ('(') != MATCH_YES
)
5537 c
= gfc_get_case ();
5538 c
->where
= gfc_current_locus
;
5540 if (match_derived_type_spec (&c
->ts
) == MATCH_ERROR
)
5543 if (c
->ts
.type
== BT_DERIVED
)
5544 c
->ts
.type
= BT_CLASS
;
5546 if (gfc_match_char (')') != MATCH_YES
)
5549 m
= match_case_eos ();
5552 if (m
== MATCH_ERROR
)
5555 new_st
.op
= EXEC_SELECT_TYPE
;
5556 new_st
.ext
.block
.case_list
= c
;
5558 /* Create temporary variable. */
5559 select_type_set_tmp (&c
->ts
);
5564 gfc_error ("Syntax error in CLASS IS specification at %C");
5568 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
5573 /********************* WHERE subroutines ********************/
5575 /* Match the rest of a simple WHERE statement that follows an IF statement.
5579 match_simple_where (void)
5585 m
= gfc_match (" ( %e )", &expr
);
5589 m
= gfc_match_assignment ();
5592 if (m
== MATCH_ERROR
)
5595 if (gfc_match_eos () != MATCH_YES
)
5598 c
= gfc_get_code (EXEC_WHERE
);
5601 c
->next
= XCNEW (gfc_code
);
5603 gfc_clear_new_st ();
5605 new_st
.op
= EXEC_WHERE
;
5611 gfc_syntax_error (ST_WHERE
);
5614 gfc_free_expr (expr
);
5619 /* Match a WHERE statement. */
5622 gfc_match_where (gfc_statement
*st
)
5628 m0
= gfc_match_label ();
5629 if (m0
== MATCH_ERROR
)
5632 m
= gfc_match (" where ( %e )", &expr
);
5636 if (gfc_match_eos () == MATCH_YES
)
5638 *st
= ST_WHERE_BLOCK
;
5639 new_st
.op
= EXEC_WHERE
;
5640 new_st
.expr1
= expr
;
5644 m
= gfc_match_assignment ();
5646 gfc_syntax_error (ST_WHERE
);
5650 gfc_free_expr (expr
);
5654 /* We've got a simple WHERE statement. */
5656 c
= gfc_get_code (EXEC_WHERE
);
5659 c
->next
= XCNEW (gfc_code
);
5661 gfc_clear_new_st ();
5663 new_st
.op
= EXEC_WHERE
;
5670 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
5671 new_st if successful. */
5674 gfc_match_elsewhere (void)
5676 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5680 if (gfc_current_state () != COMP_WHERE
)
5682 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
5688 if (gfc_match_char ('(') == MATCH_YES
)
5690 m
= gfc_match_expr (&expr
);
5693 if (m
== MATCH_ERROR
)
5696 if (gfc_match_char (')') != MATCH_YES
)
5700 if (gfc_match_eos () != MATCH_YES
)
5702 /* Only makes sense if we have a where-construct-name. */
5703 if (!gfc_current_block ())
5708 /* Better be a name at this point. */
5709 m
= gfc_match_name (name
);
5712 if (m
== MATCH_ERROR
)
5715 if (gfc_match_eos () != MATCH_YES
)
5718 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5720 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
5721 name
, gfc_current_block ()->name
);
5726 new_st
.op
= EXEC_WHERE
;
5727 new_st
.expr1
= expr
;
5731 gfc_syntax_error (ST_ELSEWHERE
);
5734 gfc_free_expr (expr
);