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"
29 int gfc_matching_ptr_assignment
= 0;
30 int gfc_matching_procptr_assignment
= 0;
31 bool gfc_matching_prefix
= false;
33 /* Stack of SELECT TYPE statements. */
34 gfc_select_type_stack
*select_type_stack
= NULL
;
36 /* For debugging and diagnostic purposes. Return the textual representation
37 of the intrinsic operator OP. */
39 gfc_op2string (gfc_intrinsic_op op
)
47 case INTRINSIC_UMINUS
:
53 case INTRINSIC_CONCAT
:
57 case INTRINSIC_DIVIDE
:
96 case INTRINSIC_ASSIGN
:
99 case INTRINSIC_PARENTHESES
:
109 gfc_internal_error ("gfc_op2string(): Bad code");
114 /******************** Generic matching subroutines ************************/
116 /* This function scans the current statement counting the opened and closed
117 parenthesis to make sure they are balanced. */
120 gfc_match_parens (void)
122 locus old_loc
, where
;
124 gfc_instring instring
;
127 old_loc
= gfc_current_locus
;
129 instring
= NONSTRING
;
134 c
= gfc_next_char_literal (instring
);
137 if (quote
== ' ' && ((c
== '\'') || (c
== '"')))
140 instring
= INSTRING_WARN
;
143 if (quote
!= ' ' && c
== quote
)
146 instring
= NONSTRING
;
150 if (c
== '(' && quote
== ' ')
153 where
= gfc_current_locus
;
155 if (c
== ')' && quote
== ' ')
158 where
= gfc_current_locus
;
162 gfc_current_locus
= old_loc
;
166 gfc_error ("Missing %<)%> in statement at or before %L", &where
);
171 gfc_error ("Missing %<(%> in statement at or before %L", &where
);
179 /* See if the next character is a special character that has
180 escaped by a \ via the -fbackslash option. */
183 gfc_match_special_char (gfc_char_t
*res
)
191 switch ((c
= gfc_next_char_literal (INSTRING_WARN
)))
224 /* Hexadecimal form of wide characters. */
225 len
= (c
== 'x' ? 2 : (c
== 'u' ? 4 : 8));
227 for (i
= 0; i
< len
; i
++)
229 char buf
[2] = { '\0', '\0' };
231 c
= gfc_next_char_literal (INSTRING_WARN
);
232 if (!gfc_wide_fits_in_byte (c
)
233 || !gfc_check_digit ((unsigned char) c
, 16))
236 buf
[0] = (unsigned char) c
;
238 n
+= strtol (buf
, NULL
, 16);
244 /* Unknown backslash codes are simply not expanded. */
253 /* In free form, match at least one space. Always matches in fixed
257 gfc_match_space (void)
262 if (gfc_current_form
== FORM_FIXED
)
265 old_loc
= gfc_current_locus
;
267 c
= gfc_next_ascii_char ();
268 if (!gfc_is_whitespace (c
))
270 gfc_current_locus
= old_loc
;
274 gfc_gobble_whitespace ();
280 /* Match an end of statement. End of statement is optional
281 whitespace, followed by a ';' or '\n' or comment '!'. If a
282 semicolon is found, we continue to eat whitespace and semicolons. */
295 old_loc
= gfc_current_locus
;
296 gfc_gobble_whitespace ();
298 c
= gfc_next_ascii_char ();
304 c
= gfc_next_ascii_char ();
321 gfc_current_locus
= old_loc
;
322 return (flag
) ? MATCH_YES
: MATCH_NO
;
326 /* Match a literal integer on the input, setting the value on
327 MATCH_YES. Literal ints occur in kind-parameters as well as
328 old-style character length specifications. If cnt is non-NULL it
329 will be set to the number of digits. */
332 gfc_match_small_literal_int (int *value
, int *cnt
)
338 old_loc
= gfc_current_locus
;
341 gfc_gobble_whitespace ();
342 c
= gfc_next_ascii_char ();
348 gfc_current_locus
= old_loc
;
357 old_loc
= gfc_current_locus
;
358 c
= gfc_next_ascii_char ();
363 i
= 10 * i
+ c
- '0';
368 gfc_error ("Integer too large at %C");
373 gfc_current_locus
= old_loc
;
382 /* Match a small, constant integer expression, like in a kind
383 statement. On MATCH_YES, 'value' is set. */
386 gfc_match_small_int (int *value
)
393 m
= gfc_match_expr (&expr
);
397 p
= gfc_extract_int (expr
, &i
);
398 gfc_free_expr (expr
);
411 /* This function is the same as the gfc_match_small_int, except that
412 we're keeping the pointer to the expr. This function could just be
413 removed and the previously mentioned one modified, though all calls
414 to it would have to be modified then (and there were a number of
415 them). Return MATCH_ERROR if fail to extract the int; otherwise,
416 return the result of gfc_match_expr(). The expr (if any) that was
417 matched is returned in the parameter expr. */
420 gfc_match_small_int_expr (int *value
, gfc_expr
**expr
)
426 m
= gfc_match_expr (expr
);
430 p
= gfc_extract_int (*expr
, &i
);
443 /* Matches a statement label. Uses gfc_match_small_literal_int() to
444 do most of the work. */
447 gfc_match_st_label (gfc_st_label
**label
)
453 old_loc
= gfc_current_locus
;
455 m
= gfc_match_small_literal_int (&i
, &cnt
);
461 gfc_error ("Too many digits in statement label at %C");
467 gfc_error ("Statement label at %C is zero");
471 *label
= gfc_get_st_label (i
);
476 gfc_current_locus
= old_loc
;
481 /* Match and validate a label associated with a named IF, DO or SELECT
482 statement. If the symbol does not have the label attribute, we add
483 it. We also make sure the symbol does not refer to another
484 (active) block. A matched label is pointed to by gfc_new_block. */
487 gfc_match_label (void)
489 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
492 gfc_new_block
= NULL
;
494 m
= gfc_match (" %n :", name
);
498 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
500 gfc_error ("Label name %qs at %C is ambiguous", name
);
504 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
506 gfc_error ("Duplicate construct label %qs at %C", name
);
510 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
511 gfc_new_block
->name
, NULL
))
518 /* See if the current input looks like a name of some sort. Modifies
519 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
520 Note that options.c restricts max_identifier_length to not more
521 than GFC_MAX_SYMBOL_LEN. */
524 gfc_match_name (char *buffer
)
530 old_loc
= gfc_current_locus
;
531 gfc_gobble_whitespace ();
533 c
= gfc_next_ascii_char ();
534 if (!(ISALPHA (c
) || (c
== '_' && flag_allow_leading_underscore
)))
536 /* Special cases for unary minus and plus, which allows for a sensible
537 error message for code of the form 'c = exp(-a*b) )' where an
538 extra ')' appears at the end of statement. */
539 if (!gfc_error_flag_test () && c
!= '(' && c
!= '-' && c
!= '+')
540 gfc_error ("Invalid character in name at %C");
541 gfc_current_locus
= old_loc
;
551 if (i
> gfc_option
.max_identifier_length
)
553 gfc_error ("Name at %C is too long");
557 old_loc
= gfc_current_locus
;
558 c
= gfc_next_ascii_char ();
560 while (ISALNUM (c
) || c
== '_' || (flag_dollar_ok
&& c
== '$'));
562 if (c
== '$' && !flag_dollar_ok
)
564 gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to "
565 "allow it as an extension", &old_loc
);
570 gfc_current_locus
= old_loc
;
576 /* Match a symbol on the input. Modifies the pointer to the symbol
577 pointer if successful. */
580 gfc_match_sym_tree (gfc_symtree
**matched_symbol
, int host_assoc
)
582 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
585 m
= gfc_match_name (buffer
);
590 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
591 ? MATCH_ERROR
: MATCH_YES
;
593 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
, false))
601 gfc_match_symbol (gfc_symbol
**matched_symbol
, int host_assoc
)
606 m
= gfc_match_sym_tree (&st
, host_assoc
);
611 *matched_symbol
= st
->n
.sym
;
613 *matched_symbol
= NULL
;
616 *matched_symbol
= NULL
;
621 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
622 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
626 gfc_match_intrinsic_op (gfc_intrinsic_op
*result
)
628 locus orig_loc
= gfc_current_locus
;
631 gfc_gobble_whitespace ();
632 ch
= gfc_next_ascii_char ();
637 *result
= INTRINSIC_PLUS
;
642 *result
= INTRINSIC_MINUS
;
646 if (gfc_next_ascii_char () == '=')
649 *result
= INTRINSIC_EQ
;
655 if (gfc_peek_ascii_char () == '=')
658 gfc_next_ascii_char ();
659 *result
= INTRINSIC_LE
;
663 *result
= INTRINSIC_LT
;
667 if (gfc_peek_ascii_char () == '=')
670 gfc_next_ascii_char ();
671 *result
= INTRINSIC_GE
;
675 *result
= INTRINSIC_GT
;
679 if (gfc_peek_ascii_char () == '*')
682 gfc_next_ascii_char ();
683 *result
= INTRINSIC_POWER
;
687 *result
= INTRINSIC_TIMES
;
691 ch
= gfc_peek_ascii_char ();
695 gfc_next_ascii_char ();
696 *result
= INTRINSIC_NE
;
702 gfc_next_ascii_char ();
703 *result
= INTRINSIC_CONCAT
;
707 *result
= INTRINSIC_DIVIDE
;
711 ch
= gfc_next_ascii_char ();
715 if (gfc_next_ascii_char () == 'n'
716 && gfc_next_ascii_char () == 'd'
717 && gfc_next_ascii_char () == '.')
719 /* Matched ".and.". */
720 *result
= INTRINSIC_AND
;
726 if (gfc_next_ascii_char () == 'q')
728 ch
= gfc_next_ascii_char ();
731 /* Matched ".eq.". */
732 *result
= INTRINSIC_EQ_OS
;
737 if (gfc_next_ascii_char () == '.')
739 /* Matched ".eqv.". */
740 *result
= INTRINSIC_EQV
;
748 ch
= gfc_next_ascii_char ();
751 if (gfc_next_ascii_char () == '.')
753 /* Matched ".ge.". */
754 *result
= INTRINSIC_GE_OS
;
760 if (gfc_next_ascii_char () == '.')
762 /* Matched ".gt.". */
763 *result
= INTRINSIC_GT_OS
;
770 ch
= gfc_next_ascii_char ();
773 if (gfc_next_ascii_char () == '.')
775 /* Matched ".le.". */
776 *result
= INTRINSIC_LE_OS
;
782 if (gfc_next_ascii_char () == '.')
784 /* Matched ".lt.". */
785 *result
= INTRINSIC_LT_OS
;
792 ch
= gfc_next_ascii_char ();
795 ch
= gfc_next_ascii_char ();
798 /* Matched ".ne.". */
799 *result
= INTRINSIC_NE_OS
;
804 if (gfc_next_ascii_char () == 'v'
805 && gfc_next_ascii_char () == '.')
807 /* Matched ".neqv.". */
808 *result
= INTRINSIC_NEQV
;
815 if (gfc_next_ascii_char () == 't'
816 && gfc_next_ascii_char () == '.')
818 /* Matched ".not.". */
819 *result
= INTRINSIC_NOT
;
826 if (gfc_next_ascii_char () == 'r'
827 && gfc_next_ascii_char () == '.')
829 /* Matched ".or.". */
830 *result
= INTRINSIC_OR
;
844 gfc_current_locus
= orig_loc
;
849 /* Match a loop control phrase:
851 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
853 If the final integer expression is not present, a constant unity
854 expression is returned. We don't return MATCH_ERROR until after
855 the equals sign is seen. */
858 gfc_match_iterator (gfc_iterator
*iter
, int init_flag
)
860 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
861 gfc_expr
*var
, *e1
, *e2
, *e3
;
867 /* Match the start of an iterator without affecting the symbol table. */
869 start
= gfc_current_locus
;
870 m
= gfc_match (" %n =", name
);
871 gfc_current_locus
= start
;
876 m
= gfc_match_variable (&var
, 0);
880 /* F2008, C617 & C565. */
881 if (var
->symtree
->n
.sym
->attr
.codimension
)
883 gfc_error ("Loop variable at %C cannot be a coarray");
887 if (var
->ref
!= NULL
)
889 gfc_error ("Loop variable at %C cannot be a sub-component");
893 gfc_match_char ('=');
895 var
->symtree
->n
.sym
->attr
.implied_index
= 1;
897 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
900 if (m
== MATCH_ERROR
)
903 if (gfc_match_char (',') != MATCH_YES
)
906 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
909 if (m
== MATCH_ERROR
)
912 if (gfc_match_char (',') != MATCH_YES
)
914 e3
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
918 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
919 if (m
== MATCH_ERROR
)
923 gfc_error ("Expected a step value in iterator at %C");
935 gfc_error ("Syntax error in iterator at %C");
946 /* Tries to match the next non-whitespace character on the input.
947 This subroutine does not return MATCH_ERROR. */
950 gfc_match_char (char c
)
954 where
= gfc_current_locus
;
955 gfc_gobble_whitespace ();
957 if (gfc_next_ascii_char () == c
)
960 gfc_current_locus
= where
;
965 /* General purpose matching subroutine. The target string is a
966 scanf-like format string in which spaces correspond to arbitrary
967 whitespace (including no whitespace), characters correspond to
968 themselves. The %-codes are:
970 %% Literal percent sign
971 %e Expression, pointer to a pointer is set
972 %s Symbol, pointer to the symbol is set
973 %n Name, character buffer is set to name
974 %t Matches end of statement.
975 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
976 %l Matches a statement label
977 %v Matches a variable expression (an lvalue)
978 % Matches a required space (in free form) and optional spaces. */
981 gfc_match (const char *target
, ...)
983 gfc_st_label
**label
;
992 old_loc
= gfc_current_locus
;
993 va_start (argp
, target
);
1003 gfc_gobble_whitespace ();
1014 vp
= va_arg (argp
, void **);
1015 n
= gfc_match_expr ((gfc_expr
**) vp
);
1026 vp
= va_arg (argp
, void **);
1027 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
1038 vp
= va_arg (argp
, void **);
1039 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
1050 np
= va_arg (argp
, char *);
1051 n
= gfc_match_name (np
);
1062 label
= va_arg (argp
, gfc_st_label
**);
1063 n
= gfc_match_st_label (label
);
1074 ip
= va_arg (argp
, int *);
1075 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
1086 if (gfc_match_eos () != MATCH_YES
)
1094 if (gfc_match_space () == MATCH_YES
)
1100 break; /* Fall through to character matcher. */
1103 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
1108 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1109 expect an upper case character here! */
1110 gcc_assert (TOLOWER (c
) == c
);
1112 if (c
== gfc_next_ascii_char ())
1122 /* Clean up after a failed match. */
1123 gfc_current_locus
= old_loc
;
1124 va_start (argp
, target
);
1127 for (; matches
> 0; matches
--)
1129 while (*p
++ != '%');
1137 /* Matches that don't have to be undone */
1142 (void) va_arg (argp
, void **);
1147 vp
= va_arg (argp
, void **);
1148 gfc_free_expr ((struct gfc_expr
*)*vp
);
1161 /*********************** Statement level matching **********************/
1163 /* Matches the start of a program unit, which is the program keyword
1164 followed by an obligatory symbol. */
1167 gfc_match_program (void)
1172 m
= gfc_match ("% %s%t", &sym
);
1176 gfc_error ("Invalid form of PROGRAM statement at %C");
1180 if (m
== MATCH_ERROR
)
1183 if (!gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
))
1186 gfc_new_block
= sym
;
1192 /* Match a simple assignment statement. */
1195 gfc_match_assignment (void)
1197 gfc_expr
*lvalue
, *rvalue
;
1201 old_loc
= gfc_current_locus
;
1204 m
= gfc_match (" %v =", &lvalue
);
1207 gfc_current_locus
= old_loc
;
1208 gfc_free_expr (lvalue
);
1213 m
= gfc_match (" %e%t", &rvalue
);
1216 gfc_current_locus
= old_loc
;
1217 gfc_free_expr (lvalue
);
1218 gfc_free_expr (rvalue
);
1222 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1224 new_st
.op
= EXEC_ASSIGN
;
1225 new_st
.expr1
= lvalue
;
1226 new_st
.expr2
= rvalue
;
1228 gfc_check_do_variable (lvalue
->symtree
);
1234 /* Match a pointer assignment statement. */
1237 gfc_match_pointer_assignment (void)
1239 gfc_expr
*lvalue
, *rvalue
;
1243 old_loc
= gfc_current_locus
;
1245 lvalue
= rvalue
= NULL
;
1246 gfc_matching_ptr_assignment
= 0;
1247 gfc_matching_procptr_assignment
= 0;
1249 m
= gfc_match (" %v =>", &lvalue
);
1256 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1257 || gfc_is_proc_ptr_comp (lvalue
))
1258 gfc_matching_procptr_assignment
= 1;
1260 gfc_matching_ptr_assignment
= 1;
1262 m
= gfc_match (" %e%t", &rvalue
);
1263 gfc_matching_ptr_assignment
= 0;
1264 gfc_matching_procptr_assignment
= 0;
1268 new_st
.op
= EXEC_POINTER_ASSIGN
;
1269 new_st
.expr1
= lvalue
;
1270 new_st
.expr2
= rvalue
;
1275 gfc_current_locus
= old_loc
;
1276 gfc_free_expr (lvalue
);
1277 gfc_free_expr (rvalue
);
1282 /* We try to match an easy arithmetic IF statement. This only happens
1283 when just after having encountered a simple IF statement. This code
1284 is really duplicate with parts of the gfc_match_if code, but this is
1288 match_arithmetic_if (void)
1290 gfc_st_label
*l1
, *l2
, *l3
;
1294 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1298 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1299 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1300 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1302 gfc_free_expr (expr
);
1306 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Arithmetic IF statement at %C"))
1309 new_st
.op
= EXEC_ARITHMETIC_IF
;
1310 new_st
.expr1
= expr
;
1319 /* The IF statement is a bit of a pain. First of all, there are three
1320 forms of it, the simple IF, the IF that starts a block and the
1323 There is a problem with the simple IF and that is the fact that we
1324 only have a single level of undo information on symbols. What this
1325 means is for a simple IF, we must re-match the whole IF statement
1326 multiple times in order to guarantee that the symbol table ends up
1327 in the proper state. */
1329 static match
match_simple_forall (void);
1330 static match
match_simple_where (void);
1333 gfc_match_if (gfc_statement
*if_type
)
1336 gfc_st_label
*l1
, *l2
, *l3
;
1337 locus old_loc
, old_loc2
;
1341 n
= gfc_match_label ();
1342 if (n
== MATCH_ERROR
)
1345 old_loc
= gfc_current_locus
;
1347 m
= gfc_match (" if ( %e", &expr
);
1351 old_loc2
= gfc_current_locus
;
1352 gfc_current_locus
= old_loc
;
1354 if (gfc_match_parens () == MATCH_ERROR
)
1357 gfc_current_locus
= old_loc2
;
1359 if (gfc_match_char (')') != MATCH_YES
)
1361 gfc_error ("Syntax error in IF-expression at %C");
1362 gfc_free_expr (expr
);
1366 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1372 gfc_error ("Block label not appropriate for arithmetic IF "
1374 gfc_free_expr (expr
);
1378 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1379 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1380 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1382 gfc_free_expr (expr
);
1386 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Arithmetic IF statement at %C"))
1389 new_st
.op
= EXEC_ARITHMETIC_IF
;
1390 new_st
.expr1
= expr
;
1395 *if_type
= ST_ARITHMETIC_IF
;
1399 if (gfc_match (" then%t") == MATCH_YES
)
1401 new_st
.op
= EXEC_IF
;
1402 new_st
.expr1
= expr
;
1403 *if_type
= ST_IF_BLOCK
;
1409 gfc_error ("Block label is not appropriate for IF statement at %C");
1410 gfc_free_expr (expr
);
1414 /* At this point the only thing left is a simple IF statement. At
1415 this point, n has to be MATCH_NO, so we don't have to worry about
1416 re-matching a block label. From what we've got so far, try
1417 matching an assignment. */
1419 *if_type
= ST_SIMPLE_IF
;
1421 m
= gfc_match_assignment ();
1425 gfc_free_expr (expr
);
1426 gfc_undo_symbols ();
1427 gfc_current_locus
= old_loc
;
1429 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1430 assignment was found. For MATCH_NO, continue to call the various
1432 if (m
== MATCH_ERROR
)
1435 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1437 m
= gfc_match_pointer_assignment ();
1441 gfc_free_expr (expr
);
1442 gfc_undo_symbols ();
1443 gfc_current_locus
= old_loc
;
1445 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1447 /* Look at the next keyword to see which matcher to call. Matching
1448 the keyword doesn't affect the symbol table, so we don't have to
1449 restore between tries. */
1451 #define match(string, subr, statement) \
1452 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1456 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1457 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1458 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1459 match ("call", gfc_match_call
, ST_CALL
)
1460 match ("close", gfc_match_close
, ST_CLOSE
)
1461 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1462 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1463 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1464 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1465 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
)
1466 match ("event post", gfc_match_event_post
, ST_EVENT_POST
)
1467 match ("event wait", gfc_match_event_wait
, ST_EVENT_WAIT
)
1468 match ("exit", gfc_match_exit
, ST_EXIT
)
1469 match ("flush", gfc_match_flush
, ST_FLUSH
)
1470 match ("forall", match_simple_forall
, ST_FORALL
)
1471 match ("go to", gfc_match_goto
, ST_GOTO
)
1472 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1473 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1474 match ("lock", gfc_match_lock
, ST_LOCK
)
1475 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1476 match ("open", gfc_match_open
, ST_OPEN
)
1477 match ("pause", gfc_match_pause
, ST_NONE
)
1478 match ("print", gfc_match_print
, ST_WRITE
)
1479 match ("read", gfc_match_read
, ST_READ
)
1480 match ("return", gfc_match_return
, ST_RETURN
)
1481 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1482 match ("stop", gfc_match_stop
, ST_STOP
)
1483 match ("wait", gfc_match_wait
, ST_WAIT
)
1484 match ("sync all", gfc_match_sync_all
, ST_SYNC_CALL
);
1485 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
1486 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
1487 match ("unlock", gfc_match_unlock
, ST_UNLOCK
)
1488 match ("where", match_simple_where
, ST_WHERE
)
1489 match ("write", gfc_match_write
, ST_WRITE
)
1491 /* The gfc_match_assignment() above may have returned a MATCH_NO
1492 where the assignment was to a named constant. Check that
1493 special case here. */
1494 m
= gfc_match_assignment ();
1497 gfc_error ("Cannot assign to a named constant at %C");
1498 gfc_free_expr (expr
);
1499 gfc_undo_symbols ();
1500 gfc_current_locus
= old_loc
;
1504 /* All else has failed, so give up. See if any of the matchers has
1505 stored an error message of some sort. */
1506 if (!gfc_error_check ())
1507 gfc_error ("Unclassifiable statement in IF-clause at %C");
1509 gfc_free_expr (expr
);
1514 gfc_error ("Syntax error in IF-clause at %C");
1517 gfc_free_expr (expr
);
1521 /* At this point, we've matched the single IF and the action clause
1522 is in new_st. Rearrange things so that the IF statement appears
1525 p
= gfc_get_code (EXEC_IF
);
1526 p
->next
= XCNEW (gfc_code
);
1528 p
->next
->loc
= gfc_current_locus
;
1532 gfc_clear_new_st ();
1534 new_st
.op
= EXEC_IF
;
1543 /* Match an ELSE statement. */
1546 gfc_match_else (void)
1548 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1550 if (gfc_match_eos () == MATCH_YES
)
1553 if (gfc_match_name (name
) != MATCH_YES
1554 || gfc_current_block () == NULL
1555 || gfc_match_eos () != MATCH_YES
)
1557 gfc_error ("Unexpected junk after ELSE statement at %C");
1561 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1563 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1564 name
, gfc_current_block ()->name
);
1572 /* Match an ELSE IF statement. */
1575 gfc_match_elseif (void)
1577 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1581 m
= gfc_match (" ( %e ) then", &expr
);
1585 if (gfc_match_eos () == MATCH_YES
)
1588 if (gfc_match_name (name
) != MATCH_YES
1589 || gfc_current_block () == NULL
1590 || gfc_match_eos () != MATCH_YES
)
1592 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1596 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1598 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1599 name
, gfc_current_block ()->name
);
1604 new_st
.op
= EXEC_IF
;
1605 new_st
.expr1
= expr
;
1609 gfc_free_expr (expr
);
1614 /* Free a gfc_iterator structure. */
1617 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1623 gfc_free_expr (iter
->var
);
1624 gfc_free_expr (iter
->start
);
1625 gfc_free_expr (iter
->end
);
1626 gfc_free_expr (iter
->step
);
1633 /* Match a CRITICAL statement. */
1635 gfc_match_critical (void)
1637 gfc_st_label
*label
= NULL
;
1639 if (gfc_match_label () == MATCH_ERROR
)
1642 if (gfc_match (" critical") != MATCH_YES
)
1645 if (gfc_match_st_label (&label
) == MATCH_ERROR
)
1648 if (gfc_match_eos () != MATCH_YES
)
1650 gfc_syntax_error (ST_CRITICAL
);
1654 if (gfc_pure (NULL
))
1656 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1660 if (gfc_find_state (COMP_DO_CONCURRENT
))
1662 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1667 gfc_unset_implicit_pure (NULL
);
1669 if (!gfc_notify_std (GFC_STD_F2008
, "CRITICAL statement at %C"))
1672 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1674 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1679 if (gfc_find_state (COMP_CRITICAL
))
1681 gfc_error ("Nested CRITICAL block at %C");
1685 new_st
.op
= EXEC_CRITICAL
;
1688 && !gfc_reference_st_label (label
, ST_LABEL_TARGET
))
1695 /* Match a BLOCK statement. */
1698 gfc_match_block (void)
1702 if (gfc_match_label () == MATCH_ERROR
)
1705 if (gfc_match (" block") != MATCH_YES
)
1708 /* For this to be a correct BLOCK statement, the line must end now. */
1709 m
= gfc_match_eos ();
1710 if (m
== MATCH_ERROR
)
1719 /* Match an ASSOCIATE statement. */
1722 gfc_match_associate (void)
1724 if (gfc_match_label () == MATCH_ERROR
)
1727 if (gfc_match (" associate") != MATCH_YES
)
1730 /* Match the association list. */
1731 if (gfc_match_char ('(') != MATCH_YES
)
1733 gfc_error ("Expected association list at %C");
1736 new_st
.ext
.block
.assoc
= NULL
;
1739 gfc_association_list
* newAssoc
= gfc_get_association_list ();
1740 gfc_association_list
* a
;
1742 /* Match the next association. */
1743 if (gfc_match (" %n => %e", newAssoc
->name
, &newAssoc
->target
)
1746 gfc_error ("Expected association at %C");
1747 goto assocListError
;
1749 newAssoc
->where
= gfc_current_locus
;
1751 /* Check that the current name is not yet in the list. */
1752 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
1753 if (!strcmp (a
->name
, newAssoc
->name
))
1755 gfc_error ("Duplicate name %qs in association at %C",
1757 goto assocListError
;
1760 /* The target expression must not be coindexed. */
1761 if (gfc_is_coindexed (newAssoc
->target
))
1763 gfc_error ("Association target at %C must not be coindexed");
1764 goto assocListError
;
1767 /* The `variable' field is left blank for now; because the target is not
1768 yet resolved, we can't use gfc_has_vector_subscript to determine it
1769 for now. This is set during resolution. */
1771 /* Put it into the list. */
1772 newAssoc
->next
= new_st
.ext
.block
.assoc
;
1773 new_st
.ext
.block
.assoc
= newAssoc
;
1775 /* Try next one or end if closing parenthesis is found. */
1776 gfc_gobble_whitespace ();
1777 if (gfc_peek_char () == ')')
1779 if (gfc_match_char (',') != MATCH_YES
)
1781 gfc_error ("Expected %<)%> or %<,%> at %C");
1791 if (gfc_match_char (')') != MATCH_YES
)
1793 /* This should never happen as we peek above. */
1797 if (gfc_match_eos () != MATCH_YES
)
1799 gfc_error ("Junk after ASSOCIATE statement at %C");
1806 gfc_free_association_list (new_st
.ext
.block
.assoc
);
1811 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1812 an accessible derived type. */
1815 match_derived_type_spec (gfc_typespec
*ts
)
1817 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1819 gfc_symbol
*derived
;
1821 old_locus
= gfc_current_locus
;
1823 if (gfc_match ("%n", name
) != MATCH_YES
)
1825 gfc_current_locus
= old_locus
;
1829 gfc_find_symbol (name
, NULL
, 1, &derived
);
1831 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
&& derived
->attr
.generic
)
1832 derived
= gfc_find_dt_in_generic (derived
);
1834 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
1836 ts
->type
= BT_DERIVED
;
1837 ts
->u
.derived
= derived
;
1841 gfc_current_locus
= old_locus
;
1846 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
1847 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
1848 It only includes the intrinsic types from the Fortran 2003 standard
1849 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
1850 the implicit_flag is not needed, so it was removed. Derived types are
1851 identified by their name alone. */
1854 gfc_match_type_spec (gfc_typespec
*ts
)
1860 gfc_gobble_whitespace ();
1861 old_locus
= gfc_current_locus
;
1863 if (match_derived_type_spec (ts
) == MATCH_YES
)
1865 /* Enforce F03:C401. */
1866 if (ts
->u
.derived
->attr
.abstract
)
1868 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
1869 ts
->u
.derived
->name
, &old_locus
);
1875 if (gfc_match ("integer") == MATCH_YES
)
1877 ts
->type
= BT_INTEGER
;
1878 ts
->kind
= gfc_default_integer_kind
;
1882 if (gfc_match ("real") == MATCH_YES
)
1885 ts
->kind
= gfc_default_real_kind
;
1889 if (gfc_match ("double precision") == MATCH_YES
)
1892 ts
->kind
= gfc_default_double_kind
;
1896 if (gfc_match ("complex") == MATCH_YES
)
1898 ts
->type
= BT_COMPLEX
;
1899 ts
->kind
= gfc_default_complex_kind
;
1903 if (gfc_match ("character") == MATCH_YES
)
1905 ts
->type
= BT_CHARACTER
;
1907 m
= gfc_match_char_spec (ts
);
1915 if (gfc_match ("logical") == MATCH_YES
)
1917 ts
->type
= BT_LOGICAL
;
1918 ts
->kind
= gfc_default_logical_kind
;
1922 /* If a type is not matched, simply return MATCH_NO. */
1923 gfc_current_locus
= old_locus
;
1928 gfc_gobble_whitespace ();
1929 if (gfc_peek_ascii_char () == '*')
1931 gfc_error ("Invalid type-spec at %C");
1935 m
= gfc_match_kind_spec (ts
, false);
1938 m
= MATCH_YES
; /* No kind specifier found. */
1940 /* gfortran may have matched REAL(a=1), which is the keyword form of the
1941 intrinsic procedure. */
1942 if (ts
->type
== BT_REAL
&& m
== MATCH_ERROR
)
1949 /******************** FORALL subroutines ********************/
1951 /* Free a list of FORALL iterators. */
1954 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
1956 gfc_forall_iterator
*next
;
1961 gfc_free_expr (iter
->var
);
1962 gfc_free_expr (iter
->start
);
1963 gfc_free_expr (iter
->end
);
1964 gfc_free_expr (iter
->stride
);
1971 /* Match an iterator as part of a FORALL statement. The format is:
1973 <var> = <start>:<end>[:<stride>]
1975 On MATCH_NO, the caller tests for the possibility that there is a
1976 scalar mask expression. */
1979 match_forall_iterator (gfc_forall_iterator
**result
)
1981 gfc_forall_iterator
*iter
;
1985 where
= gfc_current_locus
;
1986 iter
= XCNEW (gfc_forall_iterator
);
1988 m
= gfc_match_expr (&iter
->var
);
1992 if (gfc_match_char ('=') != MATCH_YES
1993 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
1999 m
= gfc_match_expr (&iter
->start
);
2003 if (gfc_match_char (':') != MATCH_YES
)
2006 m
= gfc_match_expr (&iter
->end
);
2009 if (m
== MATCH_ERROR
)
2012 if (gfc_match_char (':') == MATCH_NO
)
2013 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2016 m
= gfc_match_expr (&iter
->stride
);
2019 if (m
== MATCH_ERROR
)
2023 /* Mark the iteration variable's symbol as used as a FORALL index. */
2024 iter
->var
->symtree
->n
.sym
->forall_index
= true;
2030 gfc_error ("Syntax error in FORALL iterator at %C");
2035 gfc_current_locus
= where
;
2036 gfc_free_forall_iterator (iter
);
2041 /* Match the header of a FORALL statement. */
2044 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
2046 gfc_forall_iterator
*head
, *tail
, *new_iter
;
2050 gfc_gobble_whitespace ();
2055 if (gfc_match_char ('(') != MATCH_YES
)
2058 m
= match_forall_iterator (&new_iter
);
2059 if (m
== MATCH_ERROR
)
2064 head
= tail
= new_iter
;
2068 if (gfc_match_char (',') != MATCH_YES
)
2071 m
= match_forall_iterator (&new_iter
);
2072 if (m
== MATCH_ERROR
)
2077 tail
->next
= new_iter
;
2082 /* Have to have a mask expression. */
2084 m
= gfc_match_expr (&msk
);
2087 if (m
== MATCH_ERROR
)
2093 if (gfc_match_char (')') == MATCH_NO
)
2101 gfc_syntax_error (ST_FORALL
);
2104 gfc_free_expr (msk
);
2105 gfc_free_forall_iterator (head
);
2110 /* Match the rest of a simple FORALL statement that follows an
2114 match_simple_forall (void)
2116 gfc_forall_iterator
*head
;
2125 m
= match_forall_header (&head
, &mask
);
2132 m
= gfc_match_assignment ();
2134 if (m
== MATCH_ERROR
)
2138 m
= gfc_match_pointer_assignment ();
2139 if (m
== MATCH_ERROR
)
2145 c
= XCNEW (gfc_code
);
2147 c
->loc
= gfc_current_locus
;
2149 if (gfc_match_eos () != MATCH_YES
)
2152 gfc_clear_new_st ();
2153 new_st
.op
= EXEC_FORALL
;
2154 new_st
.expr1
= mask
;
2155 new_st
.ext
.forall_iterator
= head
;
2156 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2157 new_st
.block
->next
= c
;
2162 gfc_syntax_error (ST_FORALL
);
2165 gfc_free_forall_iterator (head
);
2166 gfc_free_expr (mask
);
2172 /* Match a FORALL statement. */
2175 gfc_match_forall (gfc_statement
*st
)
2177 gfc_forall_iterator
*head
;
2186 m0
= gfc_match_label ();
2187 if (m0
== MATCH_ERROR
)
2190 m
= gfc_match (" forall");
2194 m
= match_forall_header (&head
, &mask
);
2195 if (m
== MATCH_ERROR
)
2200 if (gfc_match_eos () == MATCH_YES
)
2202 *st
= ST_FORALL_BLOCK
;
2203 new_st
.op
= EXEC_FORALL
;
2204 new_st
.expr1
= mask
;
2205 new_st
.ext
.forall_iterator
= head
;
2209 m
= gfc_match_assignment ();
2210 if (m
== MATCH_ERROR
)
2214 m
= gfc_match_pointer_assignment ();
2215 if (m
== MATCH_ERROR
)
2221 c
= XCNEW (gfc_code
);
2223 c
->loc
= gfc_current_locus
;
2225 gfc_clear_new_st ();
2226 new_st
.op
= EXEC_FORALL
;
2227 new_st
.expr1
= mask
;
2228 new_st
.ext
.forall_iterator
= head
;
2229 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2230 new_st
.block
->next
= c
;
2236 gfc_syntax_error (ST_FORALL
);
2239 gfc_free_forall_iterator (head
);
2240 gfc_free_expr (mask
);
2241 gfc_free_statements (c
);
2246 /* Match a DO statement. */
2251 gfc_iterator iter
, *ip
;
2253 gfc_st_label
*label
;
2256 old_loc
= gfc_current_locus
;
2259 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
2261 m
= gfc_match_label ();
2262 if (m
== MATCH_ERROR
)
2265 if (gfc_match (" do") != MATCH_YES
)
2268 m
= gfc_match_st_label (&label
);
2269 if (m
== MATCH_ERROR
)
2272 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2274 if (gfc_match_eos () == MATCH_YES
)
2276 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
2277 new_st
.op
= EXEC_DO_WHILE
;
2281 /* Match an optional comma, if no comma is found, a space is obligatory. */
2282 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
2285 /* Check for balanced parens. */
2287 if (gfc_match_parens () == MATCH_ERROR
)
2290 if (gfc_match (" concurrent") == MATCH_YES
)
2292 gfc_forall_iterator
*head
;
2295 if (!gfc_notify_std (GFC_STD_F2008
, "DO CONCURRENT construct at %C"))
2301 m
= match_forall_header (&head
, &mask
);
2305 if (m
== MATCH_ERROR
)
2306 goto concurr_cleanup
;
2308 if (gfc_match_eos () != MATCH_YES
)
2309 goto concurr_cleanup
;
2312 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2313 goto concurr_cleanup
;
2315 new_st
.label1
= label
;
2316 new_st
.op
= EXEC_DO_CONCURRENT
;
2317 new_st
.expr1
= mask
;
2318 new_st
.ext
.forall_iterator
= head
;
2323 gfc_syntax_error (ST_DO
);
2324 gfc_free_expr (mask
);
2325 gfc_free_forall_iterator (head
);
2329 /* See if we have a DO WHILE. */
2330 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
2332 new_st
.op
= EXEC_DO_WHILE
;
2336 /* The abortive DO WHILE may have done something to the symbol
2337 table, so we start over. */
2338 gfc_undo_symbols ();
2339 gfc_current_locus
= old_loc
;
2341 gfc_match_label (); /* This won't error. */
2342 gfc_match (" do "); /* This will work. */
2344 gfc_match_st_label (&label
); /* Can't error out. */
2345 gfc_match_char (','); /* Optional comma. */
2347 m
= gfc_match_iterator (&iter
, 0);
2350 if (m
== MATCH_ERROR
)
2353 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
2354 gfc_check_do_variable (iter
.var
->symtree
);
2356 if (gfc_match_eos () != MATCH_YES
)
2358 gfc_syntax_error (ST_DO
);
2362 new_st
.op
= EXEC_DO
;
2366 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2369 new_st
.label1
= label
;
2371 if (new_st
.op
== EXEC_DO_WHILE
)
2372 new_st
.expr1
= iter
.end
;
2375 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
2382 gfc_free_iterator (&iter
, 0);
2388 /* Match an EXIT or CYCLE statement. */
2391 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2393 gfc_state_data
*p
, *o
;
2398 if (gfc_match_eos () == MATCH_YES
)
2402 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2405 m
= gfc_match ("% %n%t", name
);
2406 if (m
== MATCH_ERROR
)
2410 gfc_syntax_error (st
);
2414 /* Find the corresponding symbol. If there's a BLOCK statement
2415 between here and the label, it is not in gfc_current_ns but a parent
2417 stree
= gfc_find_symtree_in_proc (name
, gfc_current_ns
);
2420 gfc_error ("Name %qs in %s statement at %C is unknown",
2421 name
, gfc_ascii_statement (st
));
2426 if (sym
->attr
.flavor
!= FL_LABEL
)
2428 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2429 name
, gfc_ascii_statement (st
));
2434 /* Find the loop specified by the label (or lack of a label). */
2435 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2436 if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2438 else if (p
->state
== COMP_CRITICAL
)
2440 gfc_error("%s statement at %C leaves CRITICAL construct",
2441 gfc_ascii_statement (st
));
2444 else if (p
->state
== COMP_DO_CONCURRENT
2445 && (op
== EXEC_EXIT
|| (sym
&& sym
!= p
->sym
)))
2447 /* F2008, C821 & C845. */
2448 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2449 gfc_ascii_statement (st
));
2452 else if ((sym
&& sym
== p
->sym
)
2453 || (!sym
&& (p
->state
== COMP_DO
2454 || p
->state
== COMP_DO_CONCURRENT
)))
2460 gfc_error ("%s statement at %C is not within a construct",
2461 gfc_ascii_statement (st
));
2463 gfc_error ("%s statement at %C is not within construct %qs",
2464 gfc_ascii_statement (st
), sym
->name
);
2469 /* Special checks for EXIT from non-loop constructs. */
2473 case COMP_DO_CONCURRENT
:
2477 /* This is already handled above. */
2480 case COMP_ASSOCIATE
:
2484 case COMP_SELECT_TYPE
:
2486 if (op
== EXEC_CYCLE
)
2488 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2489 " construct %qs", sym
->name
);
2492 gcc_assert (op
== EXEC_EXIT
);
2493 if (!gfc_notify_std (GFC_STD_F2008
, "EXIT statement with no"
2494 " do-construct-name at %C"))
2499 gfc_error ("%s statement at %C is not applicable to construct %qs",
2500 gfc_ascii_statement (st
), sym
->name
);
2506 gfc_error (is_oacc (p
)
2507 ? "%s statement at %C leaving OpenACC structured block"
2508 : "%s statement at %C leaving OpenMP structured block",
2509 gfc_ascii_statement (st
));
2513 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2517 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
2518 && (o
->head
->op
== EXEC_OACC_LOOP
2519 || o
->head
->op
== EXEC_OACC_PARALLEL_LOOP
))
2522 gcc_assert (o
->head
->next
!= NULL
2523 && (o
->head
->next
->op
== EXEC_DO
2524 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2525 && o
->previous
!= NULL
2526 && o
->previous
->tail
->op
== o
->head
->op
);
2527 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2528 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2529 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2530 if (st
== ST_EXIT
&& cnt
<= collapse
)
2532 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2535 if (st
== ST_CYCLE
&& cnt
< collapse
)
2537 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2538 " !$ACC LOOP loop");
2544 && (o
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2545 && (o
->head
->op
== EXEC_OMP_DO
2546 || o
->head
->op
== EXEC_OMP_PARALLEL_DO
2547 || o
->head
->op
== EXEC_OMP_SIMD
2548 || o
->head
->op
== EXEC_OMP_DO_SIMD
2549 || o
->head
->op
== EXEC_OMP_PARALLEL_DO_SIMD
))
2552 gcc_assert (o
->head
->next
!= NULL
2553 && (o
->head
->next
->op
== EXEC_DO
2554 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2555 && o
->previous
!= NULL
2556 && o
->previous
->tail
->op
== o
->head
->op
);
2557 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2558 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2559 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2560 if (st
== ST_EXIT
&& cnt
<= collapse
)
2562 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2565 if (st
== ST_CYCLE
&& cnt
< collapse
)
2567 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2573 /* Save the first statement in the construct - needed by the backend. */
2574 new_st
.ext
.which_construct
= p
->construct
;
2582 /* Match the EXIT statement. */
2585 gfc_match_exit (void)
2587 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2591 /* Match the CYCLE statement. */
2594 gfc_match_cycle (void)
2596 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2600 /* Match a number or character constant after an (ERROR) STOP or PAUSE
2604 gfc_match_stopcode (gfc_statement st
)
2611 if (gfc_match_eos () != MATCH_YES
)
2613 m
= gfc_match_init_expr (&e
);
2614 if (m
== MATCH_ERROR
)
2619 if (gfc_match_eos () != MATCH_YES
)
2623 if (gfc_pure (NULL
))
2625 if (st
== ST_ERROR_STOP
)
2627 if (!gfc_notify_std (GFC_STD_F2015
, "%s statement at %C in PURE "
2628 "procedure", gfc_ascii_statement (st
)))
2633 gfc_error ("%s statement not allowed in PURE procedure at %C",
2634 gfc_ascii_statement (st
));
2639 gfc_unset_implicit_pure (NULL
);
2641 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
))
2643 gfc_error ("Image control statement STOP at %C in CRITICAL block");
2646 if (st
== ST_STOP
&& gfc_find_state (COMP_DO_CONCURRENT
))
2648 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
2654 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
2656 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2663 gfc_error ("STOP code at %L must be scalar",
2668 if (e
->ts
.type
== BT_CHARACTER
2669 && e
->ts
.kind
!= gfc_default_character_kind
)
2671 gfc_error ("STOP code at %L must be default character KIND=%d",
2672 &e
->where
, (int) gfc_default_character_kind
);
2676 if (e
->ts
.type
== BT_INTEGER
2677 && e
->ts
.kind
!= gfc_default_integer_kind
)
2679 gfc_error ("STOP code at %L must be default integer KIND=%d",
2680 &e
->where
, (int) gfc_default_integer_kind
);
2688 new_st
.op
= EXEC_STOP
;
2691 new_st
.op
= EXEC_ERROR_STOP
;
2694 new_st
.op
= EXEC_PAUSE
;
2701 new_st
.ext
.stop_code
= -1;
2706 gfc_syntax_error (st
);
2715 /* Match the (deprecated) PAUSE statement. */
2718 gfc_match_pause (void)
2722 m
= gfc_match_stopcode (ST_PAUSE
);
2725 if (!gfc_notify_std (GFC_STD_F95_DEL
, "PAUSE statement at %C"))
2732 /* Match the STOP statement. */
2735 gfc_match_stop (void)
2737 return gfc_match_stopcode (ST_STOP
);
2741 /* Match the ERROR STOP statement. */
2744 gfc_match_error_stop (void)
2746 if (!gfc_notify_std (GFC_STD_F2008
, "ERROR STOP statement at %C"))
2749 return gfc_match_stopcode (ST_ERROR_STOP
);
2752 /* Match EVENT POST/WAIT statement. Syntax:
2753 EVENT POST ( event-variable [, sync-stat-list] )
2754 EVENT WAIT ( event-variable [, wait-spec-list] )
2756 wait-spec-list is sync-stat-list or until-spec
2757 until-spec is UNTIL_COUNT = scalar-int-expr
2758 sync-stat is STAT= or ERRMSG=. */
2761 event_statement (gfc_statement st
)
2764 gfc_expr
*tmp
, *eventvar
, *until_count
, *stat
, *errmsg
;
2765 bool saw_until_count
, saw_stat
, saw_errmsg
;
2767 tmp
= eventvar
= until_count
= stat
= errmsg
= NULL
;
2768 saw_until_count
= saw_stat
= saw_errmsg
= false;
2770 if (gfc_pure (NULL
))
2772 gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
2773 st
== ST_EVENT_POST
? "POST" : "WAIT");
2777 gfc_unset_implicit_pure (NULL
);
2779 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2781 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2785 if (gfc_find_state (COMP_CRITICAL
))
2787 gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
2788 st
== ST_EVENT_POST
? "POST" : "WAIT");
2792 if (gfc_find_state (COMP_DO_CONCURRENT
))
2794 gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
2795 "block", st
== ST_EVENT_POST
? "POST" : "WAIT");
2799 if (gfc_match_char ('(') != MATCH_YES
)
2802 if (gfc_match ("%e", &eventvar
) != MATCH_YES
)
2804 m
= gfc_match_char (',');
2805 if (m
== MATCH_ERROR
)
2809 m
= gfc_match_char (')');
2817 m
= gfc_match (" stat = %v", &tmp
);
2818 if (m
== MATCH_ERROR
)
2824 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
2830 m
= gfc_match_char (',');
2838 m
= gfc_match (" errmsg = %v", &tmp
);
2839 if (m
== MATCH_ERROR
)
2845 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
2851 m
= gfc_match_char (',');
2859 m
= gfc_match (" until_count = %e", &tmp
);
2860 if (m
== MATCH_ERROR
|| st
== ST_EVENT_POST
)
2864 if (saw_until_count
)
2866 gfc_error ("Redundant UNTIL_COUNT tag found at %L ",
2871 saw_until_count
= true;
2873 m
= gfc_match_char (',');
2884 if (m
== MATCH_ERROR
)
2887 if (gfc_match (" )%t") != MATCH_YES
)
2894 new_st
.op
= EXEC_EVENT_POST
;
2897 new_st
.op
= EXEC_EVENT_WAIT
;
2903 new_st
.expr1
= eventvar
;
2904 new_st
.expr2
= stat
;
2905 new_st
.expr3
= errmsg
;
2906 new_st
.expr4
= until_count
;
2911 gfc_syntax_error (st
);
2914 if (until_count
!= tmp
)
2915 gfc_free_expr (until_count
);
2917 gfc_free_expr (errmsg
);
2919 gfc_free_expr (stat
);
2921 gfc_free_expr (tmp
);
2922 gfc_free_expr (eventvar
);
2930 gfc_match_event_post (void)
2932 if (!gfc_notify_std (GFC_STD_F2008_TS
, "EVENT POST statement at %C"))
2935 return event_statement (ST_EVENT_POST
);
2940 gfc_match_event_wait (void)
2942 if (!gfc_notify_std (GFC_STD_F2008_TS
, "EVENT WAIT statement at %C"))
2945 return event_statement (ST_EVENT_WAIT
);
2949 /* Match LOCK/UNLOCK statement. Syntax:
2950 LOCK ( lock-variable [ , lock-stat-list ] )
2951 UNLOCK ( lock-variable [ , sync-stat-list ] )
2952 where lock-stat is ACQUIRED_LOCK or sync-stat
2953 and sync-stat is STAT= or ERRMSG=. */
2956 lock_unlock_statement (gfc_statement st
)
2959 gfc_expr
*tmp
, *lockvar
, *acq_lock
, *stat
, *errmsg
;
2960 bool saw_acq_lock
, saw_stat
, saw_errmsg
;
2962 tmp
= lockvar
= acq_lock
= stat
= errmsg
= NULL
;
2963 saw_acq_lock
= saw_stat
= saw_errmsg
= false;
2965 if (gfc_pure (NULL
))
2967 gfc_error ("Image control statement %s at %C in PURE procedure",
2968 st
== ST_LOCK
? "LOCK" : "UNLOCK");
2972 gfc_unset_implicit_pure (NULL
);
2974 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2976 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2980 if (gfc_find_state (COMP_CRITICAL
))
2982 gfc_error ("Image control statement %s at %C in CRITICAL block",
2983 st
== ST_LOCK
? "LOCK" : "UNLOCK");
2987 if (gfc_find_state (COMP_DO_CONCURRENT
))
2989 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
2990 st
== ST_LOCK
? "LOCK" : "UNLOCK");
2994 if (gfc_match_char ('(') != MATCH_YES
)
2997 if (gfc_match ("%e", &lockvar
) != MATCH_YES
)
2999 m
= gfc_match_char (',');
3000 if (m
== MATCH_ERROR
)
3004 m
= gfc_match_char (')');
3012 m
= gfc_match (" stat = %v", &tmp
);
3013 if (m
== MATCH_ERROR
)
3019 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3025 m
= gfc_match_char (',');
3033 m
= gfc_match (" errmsg = %v", &tmp
);
3034 if (m
== MATCH_ERROR
)
3040 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3046 m
= gfc_match_char (',');
3054 m
= gfc_match (" acquired_lock = %v", &tmp
);
3055 if (m
== MATCH_ERROR
|| st
== ST_UNLOCK
)
3061 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
3066 saw_acq_lock
= true;
3068 m
= gfc_match_char (',');
3079 if (m
== MATCH_ERROR
)
3082 if (gfc_match (" )%t") != MATCH_YES
)
3089 new_st
.op
= EXEC_LOCK
;
3092 new_st
.op
= EXEC_UNLOCK
;
3098 new_st
.expr1
= lockvar
;
3099 new_st
.expr2
= stat
;
3100 new_st
.expr3
= errmsg
;
3101 new_st
.expr4
= acq_lock
;
3106 gfc_syntax_error (st
);
3109 if (acq_lock
!= tmp
)
3110 gfc_free_expr (acq_lock
);
3112 gfc_free_expr (errmsg
);
3114 gfc_free_expr (stat
);
3116 gfc_free_expr (tmp
);
3117 gfc_free_expr (lockvar
);
3124 gfc_match_lock (void)
3126 if (!gfc_notify_std (GFC_STD_F2008
, "LOCK statement at %C"))
3129 return lock_unlock_statement (ST_LOCK
);
3134 gfc_match_unlock (void)
3136 if (!gfc_notify_std (GFC_STD_F2008
, "UNLOCK statement at %C"))
3139 return lock_unlock_statement (ST_UNLOCK
);
3143 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
3144 SYNC ALL [(sync-stat-list)]
3145 SYNC MEMORY [(sync-stat-list)]
3146 SYNC IMAGES (image-set [, sync-stat-list] )
3147 with sync-stat is int-expr or *. */
3150 sync_statement (gfc_statement st
)
3153 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
3154 bool saw_stat
, saw_errmsg
;
3156 tmp
= imageset
= stat
= errmsg
= NULL
;
3157 saw_stat
= saw_errmsg
= false;
3159 if (gfc_pure (NULL
))
3161 gfc_error ("Image control statement SYNC at %C in PURE procedure");
3165 gfc_unset_implicit_pure (NULL
);
3167 if (!gfc_notify_std (GFC_STD_F2008
, "SYNC statement at %C"))
3170 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3172 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
3177 if (gfc_find_state (COMP_CRITICAL
))
3179 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3183 if (gfc_find_state (COMP_DO_CONCURRENT
))
3185 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3189 if (gfc_match_eos () == MATCH_YES
)
3191 if (st
== ST_SYNC_IMAGES
)
3196 if (gfc_match_char ('(') != MATCH_YES
)
3199 if (st
== ST_SYNC_IMAGES
)
3201 /* Denote '*' as imageset == NULL. */
3202 m
= gfc_match_char ('*');
3203 if (m
== MATCH_ERROR
)
3207 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
3210 m
= gfc_match_char (',');
3211 if (m
== MATCH_ERROR
)
3215 m
= gfc_match_char (')');
3224 m
= gfc_match (" stat = %v", &tmp
);
3225 if (m
== MATCH_ERROR
)
3231 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3237 if (gfc_match_char (',') == MATCH_YES
)
3244 m
= gfc_match (" errmsg = %v", &tmp
);
3245 if (m
== MATCH_ERROR
)
3251 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3257 if (gfc_match_char (',') == MATCH_YES
)
3267 if (gfc_match (" )%t") != MATCH_YES
)
3274 new_st
.op
= EXEC_SYNC_ALL
;
3276 case ST_SYNC_IMAGES
:
3277 new_st
.op
= EXEC_SYNC_IMAGES
;
3279 case ST_SYNC_MEMORY
:
3280 new_st
.op
= EXEC_SYNC_MEMORY
;
3286 new_st
.expr1
= imageset
;
3287 new_st
.expr2
= stat
;
3288 new_st
.expr3
= errmsg
;
3293 gfc_syntax_error (st
);
3297 gfc_free_expr (stat
);
3299 gfc_free_expr (errmsg
);
3301 gfc_free_expr (tmp
);
3302 gfc_free_expr (imageset
);
3308 /* Match SYNC ALL statement. */
3311 gfc_match_sync_all (void)
3313 return sync_statement (ST_SYNC_ALL
);
3317 /* Match SYNC IMAGES statement. */
3320 gfc_match_sync_images (void)
3322 return sync_statement (ST_SYNC_IMAGES
);
3326 /* Match SYNC MEMORY statement. */
3329 gfc_match_sync_memory (void)
3331 return sync_statement (ST_SYNC_MEMORY
);
3335 /* Match a CONTINUE statement. */
3338 gfc_match_continue (void)
3340 if (gfc_match_eos () != MATCH_YES
)
3342 gfc_syntax_error (ST_CONTINUE
);
3346 new_st
.op
= EXEC_CONTINUE
;
3351 /* Match the (deprecated) ASSIGN statement. */
3354 gfc_match_assign (void)
3357 gfc_st_label
*label
;
3359 if (gfc_match (" %l", &label
) == MATCH_YES
)
3361 if (!gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
))
3363 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
3365 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGN statement at %C"))
3368 expr
->symtree
->n
.sym
->attr
.assign
= 1;
3370 new_st
.op
= EXEC_LABEL_ASSIGN
;
3371 new_st
.label1
= label
;
3372 new_st
.expr1
= expr
;
3380 /* Match the GO TO statement. As a computed GOTO statement is
3381 matched, it is transformed into an equivalent SELECT block. No
3382 tree is necessary, and the resulting jumps-to-jumps are
3383 specifically optimized away by the back end. */
3386 gfc_match_goto (void)
3388 gfc_code
*head
, *tail
;
3391 gfc_st_label
*label
;
3395 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
3397 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3400 new_st
.op
= EXEC_GOTO
;
3401 new_st
.label1
= label
;
3405 /* The assigned GO TO statement. */
3407 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
3409 if (!gfc_notify_std (GFC_STD_F95_DEL
, "Assigned GOTO statement at %C"))
3412 new_st
.op
= EXEC_GOTO
;
3413 new_st
.expr1
= expr
;
3415 if (gfc_match_eos () == MATCH_YES
)
3418 /* Match label list. */
3419 gfc_match_char (',');
3420 if (gfc_match_char ('(') != MATCH_YES
)
3422 gfc_syntax_error (ST_GOTO
);
3429 m
= gfc_match_st_label (&label
);
3433 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3437 head
= tail
= gfc_get_code (EXEC_GOTO
);
3440 tail
->block
= gfc_get_code (EXEC_GOTO
);
3444 tail
->label1
= label
;
3446 while (gfc_match_char (',') == MATCH_YES
);
3448 if (gfc_match (")%t") != MATCH_YES
)
3453 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3456 new_st
.block
= head
;
3461 /* Last chance is a computed GO TO statement. */
3462 if (gfc_match_char ('(') != MATCH_YES
)
3464 gfc_syntax_error (ST_GOTO
);
3473 m
= gfc_match_st_label (&label
);
3477 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3481 head
= tail
= gfc_get_code (EXEC_SELECT
);
3484 tail
->block
= gfc_get_code (EXEC_SELECT
);
3488 cp
= gfc_get_case ();
3489 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
3492 tail
->ext
.block
.case_list
= cp
;
3494 tail
->next
= gfc_get_code (EXEC_GOTO
);
3495 tail
->next
->label1
= label
;
3497 while (gfc_match_char (',') == MATCH_YES
);
3499 if (gfc_match_char (')') != MATCH_YES
)
3504 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3508 /* Get the rest of the statement. */
3509 gfc_match_char (',');
3511 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
3514 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Computed GOTO at %C"))
3517 /* At this point, a computed GOTO has been fully matched and an
3518 equivalent SELECT statement constructed. */
3520 new_st
.op
= EXEC_SELECT
;
3521 new_st
.expr1
= NULL
;
3523 /* Hack: For a "real" SELECT, the expression is in expr. We put
3524 it in expr2 so we can distinguish then and produce the correct
3526 new_st
.expr2
= expr
;
3527 new_st
.block
= head
;
3531 gfc_syntax_error (ST_GOTO
);
3533 gfc_free_statements (head
);
3538 /* Frees a list of gfc_alloc structures. */
3541 gfc_free_alloc_list (gfc_alloc
*p
)
3548 gfc_free_expr (p
->expr
);
3554 /* Match an ALLOCATE statement. */
3557 gfc_match_allocate (void)
3559 gfc_alloc
*head
, *tail
;
3560 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
3564 locus old_locus
, deferred_locus
;
3565 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, saw_deferred
, b1
, b2
, b3
;
3566 bool saw_unlimited
= false;
3569 stat
= errmsg
= source
= mold
= tmp
= NULL
;
3570 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= saw_deferred
= false;
3572 if (gfc_match_char ('(') != MATCH_YES
)
3575 /* Match an optional type-spec. */
3576 old_locus
= gfc_current_locus
;
3577 m
= gfc_match_type_spec (&ts
);
3578 if (m
== MATCH_ERROR
)
3580 else if (m
== MATCH_NO
)
3582 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
3584 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
3586 gfc_error ("Error in type-spec at %L", &old_locus
);
3590 ts
.type
= BT_UNKNOWN
;
3594 if (gfc_match (" :: ") == MATCH_YES
)
3596 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
3602 gfc_error ("Type-spec at %L cannot contain a deferred "
3603 "type parameter", &old_locus
);
3607 if (ts
.type
== BT_CHARACTER
)
3608 ts
.u
.cl
->length_from_typespec
= true;
3612 ts
.type
= BT_UNKNOWN
;
3613 gfc_current_locus
= old_locus
;
3620 head
= tail
= gfc_get_alloc ();
3623 tail
->next
= gfc_get_alloc ();
3627 m
= gfc_match_variable (&tail
->expr
, 0);
3630 if (m
== MATCH_ERROR
)
3633 if (gfc_check_do_variable (tail
->expr
->symtree
))
3636 bool impure
= gfc_impure_variable (tail
->expr
->symtree
->n
.sym
);
3637 if (impure
&& gfc_pure (NULL
))
3639 gfc_error ("Bad allocate-object at %C for a PURE procedure");
3644 gfc_unset_implicit_pure (NULL
);
3646 if (tail
->expr
->ts
.deferred
)
3648 saw_deferred
= true;
3649 deferred_locus
= tail
->expr
->where
;
3652 if (gfc_find_state (COMP_DO_CONCURRENT
)
3653 || gfc_find_state (COMP_CRITICAL
))
3656 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
3657 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
3658 if (ref
->type
== REF_COMPONENT
)
3659 coarray
= ref
->u
.c
.component
->attr
.codimension
;
3661 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
3663 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
3666 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
3668 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
3673 /* Check for F08:C628. */
3674 sym
= tail
->expr
->symtree
->n
.sym
;
3675 b1
= !(tail
->expr
->ref
3676 && (tail
->expr
->ref
->type
== REF_COMPONENT
3677 || tail
->expr
->ref
->type
== REF_ARRAY
));
3678 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
3679 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
3680 || CLASS_DATA (sym
)->attr
.class_pointer
);
3682 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
3683 || sym
->attr
.proc_pointer
);
3684 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
3685 && (sym
->ns
->proc_name
->attr
.allocatable
3686 || sym
->ns
->proc_name
->attr
.pointer
3687 || sym
->ns
->proc_name
->attr
.proc_pointer
);
3688 if (b1
&& b2
&& !b3
)
3690 gfc_error ("Allocate-object at %L is neither a data pointer "
3691 "nor an allocatable variable", &tail
->expr
->where
);
3695 /* The ALLOCATE statement had an optional typespec. Check the
3697 if (ts
.type
!= BT_UNKNOWN
)
3699 /* Enforce F03:C624. */
3700 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
3702 gfc_error ("Type of entity at %L is type incompatible with "
3703 "typespec", &tail
->expr
->where
);
3707 /* Enforce F03:C627. */
3708 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
3710 gfc_error ("Kind type parameter for entity at %L differs from "
3711 "the kind type parameter of the typespec",
3712 &tail
->expr
->where
);
3717 if (tail
->expr
->ts
.type
== BT_DERIVED
)
3718 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
3720 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
3722 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
3724 gfc_error ("Shape specification for allocatable scalar at %C");
3728 if (gfc_match_char (',') != MATCH_YES
)
3733 m
= gfc_match (" stat = %v", &tmp
);
3734 if (m
== MATCH_ERROR
)
3741 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3749 if (gfc_check_do_variable (stat
->symtree
))
3752 if (gfc_match_char (',') == MATCH_YES
)
3753 goto alloc_opt_list
;
3756 m
= gfc_match (" errmsg = %v", &tmp
);
3757 if (m
== MATCH_ERROR
)
3761 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
3767 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3775 if (gfc_match_char (',') == MATCH_YES
)
3776 goto alloc_opt_list
;
3779 m
= gfc_match (" source = %e", &tmp
);
3780 if (m
== MATCH_ERROR
)
3784 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
3790 gfc_error ("Redundant SOURCE tag found at %L ", &tmp
->where
);
3794 /* The next 2 conditionals check C631. */
3795 if (ts
.type
!= BT_UNKNOWN
)
3797 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
3798 &tmp
->where
, &old_locus
);
3803 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
3804 " with more than a single allocate object",
3812 if (gfc_match_char (',') == MATCH_YES
)
3813 goto alloc_opt_list
;
3816 m
= gfc_match (" mold = %e", &tmp
);
3817 if (m
== MATCH_ERROR
)
3821 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
3824 /* Check F08:C636. */
3827 gfc_error ("Redundant MOLD tag found at %L ", &tmp
->where
);
3831 /* Check F08:C637. */
3832 if (ts
.type
!= BT_UNKNOWN
)
3834 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
3835 &tmp
->where
, &old_locus
);
3844 if (gfc_match_char (',') == MATCH_YES
)
3845 goto alloc_opt_list
;
3848 gfc_gobble_whitespace ();
3850 if (gfc_peek_char () == ')')
3854 if (gfc_match (" )%t") != MATCH_YES
)
3857 /* Check F08:C637. */
3860 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
3861 &mold
->where
, &source
->where
);
3865 /* Check F03:C623, */
3866 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
3868 gfc_error ("Allocate-object at %L with a deferred type parameter "
3869 "requires either a type-spec or SOURCE tag or a MOLD tag",
3874 /* Check F03:C625, */
3875 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
3877 for (tail
= head
; tail
; tail
= tail
->next
)
3879 if (UNLIMITED_POLY (tail
->expr
))
3880 gfc_error ("Unlimited polymorphic allocate-object at %L "
3881 "requires either a type-spec or SOURCE tag "
3882 "or a MOLD tag", &tail
->expr
->where
);
3887 new_st
.op
= EXEC_ALLOCATE
;
3888 new_st
.expr1
= stat
;
3889 new_st
.expr2
= errmsg
;
3891 new_st
.expr3
= source
;
3893 new_st
.expr3
= mold
;
3894 new_st
.ext
.alloc
.list
= head
;
3895 new_st
.ext
.alloc
.ts
= ts
;
3900 gfc_syntax_error (ST_ALLOCATE
);
3903 gfc_free_expr (errmsg
);
3904 gfc_free_expr (source
);
3905 gfc_free_expr (stat
);
3906 gfc_free_expr (mold
);
3907 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
3908 gfc_free_alloc_list (head
);
3913 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
3914 a set of pointer assignments to intrinsic NULL(). */
3917 gfc_match_nullify (void)
3925 if (gfc_match_char ('(') != MATCH_YES
)
3930 m
= gfc_match_variable (&p
, 0);
3931 if (m
== MATCH_ERROR
)
3936 if (gfc_check_do_variable (p
->symtree
))
3940 if (gfc_is_coindexed (p
))
3942 gfc_error ("Pointer object at %C shall not be coindexed");
3946 /* build ' => NULL() '. */
3947 e
= gfc_get_null_expr (&gfc_current_locus
);
3949 /* Chain to list. */
3953 tail
->op
= EXEC_POINTER_ASSIGN
;
3957 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
3964 if (gfc_match (" )%t") == MATCH_YES
)
3966 if (gfc_match_char (',') != MATCH_YES
)
3973 gfc_syntax_error (ST_NULLIFY
);
3976 gfc_free_statements (new_st
.next
);
3978 gfc_free_expr (new_st
.expr1
);
3979 new_st
.expr1
= NULL
;
3980 gfc_free_expr (new_st
.expr2
);
3981 new_st
.expr2
= NULL
;
3986 /* Match a DEALLOCATE statement. */
3989 gfc_match_deallocate (void)
3991 gfc_alloc
*head
, *tail
;
3992 gfc_expr
*stat
, *errmsg
, *tmp
;
3995 bool saw_stat
, saw_errmsg
, b1
, b2
;
3998 stat
= errmsg
= tmp
= NULL
;
3999 saw_stat
= saw_errmsg
= false;
4001 if (gfc_match_char ('(') != MATCH_YES
)
4007 head
= tail
= gfc_get_alloc ();
4010 tail
->next
= gfc_get_alloc ();
4014 m
= gfc_match_variable (&tail
->expr
, 0);
4015 if (m
== MATCH_ERROR
)
4020 if (gfc_check_do_variable (tail
->expr
->symtree
))
4023 sym
= tail
->expr
->symtree
->n
.sym
;
4025 bool impure
= gfc_impure_variable (sym
);
4026 if (impure
&& gfc_pure (NULL
))
4028 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
4033 gfc_unset_implicit_pure (NULL
);
4035 if (gfc_is_coarray (tail
->expr
)
4036 && gfc_find_state (COMP_DO_CONCURRENT
))
4038 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
4042 if (gfc_is_coarray (tail
->expr
)
4043 && gfc_find_state (COMP_CRITICAL
))
4045 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
4049 /* FIXME: disable the checking on derived types. */
4050 b1
= !(tail
->expr
->ref
4051 && (tail
->expr
->ref
->type
== REF_COMPONENT
4052 || tail
->expr
->ref
->type
== REF_ARRAY
));
4053 if (sym
&& sym
->ts
.type
== BT_CLASS
)
4054 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
4055 || CLASS_DATA (sym
)->attr
.class_pointer
);
4057 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4058 || sym
->attr
.proc_pointer
);
4061 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
4062 "nor an allocatable variable");
4066 if (gfc_match_char (',') != MATCH_YES
)
4071 m
= gfc_match (" stat = %v", &tmp
);
4072 if (m
== MATCH_ERROR
)
4078 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
4079 gfc_free_expr (tmp
);
4086 if (gfc_check_do_variable (stat
->symtree
))
4089 if (gfc_match_char (',') == MATCH_YES
)
4090 goto dealloc_opt_list
;
4093 m
= gfc_match (" errmsg = %v", &tmp
);
4094 if (m
== MATCH_ERROR
)
4098 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
4103 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
4104 gfc_free_expr (tmp
);
4111 if (gfc_match_char (',') == MATCH_YES
)
4112 goto dealloc_opt_list
;
4115 gfc_gobble_whitespace ();
4117 if (gfc_peek_char () == ')')
4121 if (gfc_match (" )%t") != MATCH_YES
)
4124 new_st
.op
= EXEC_DEALLOCATE
;
4125 new_st
.expr1
= stat
;
4126 new_st
.expr2
= errmsg
;
4127 new_st
.ext
.alloc
.list
= head
;
4132 gfc_syntax_error (ST_DEALLOCATE
);
4135 gfc_free_expr (errmsg
);
4136 gfc_free_expr (stat
);
4137 gfc_free_alloc_list (head
);
4142 /* Match a RETURN statement. */
4145 gfc_match_return (void)
4149 gfc_compile_state s
;
4153 if (gfc_find_state (COMP_CRITICAL
))
4155 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4159 if (gfc_find_state (COMP_DO_CONCURRENT
))
4161 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4165 if (gfc_match_eos () == MATCH_YES
)
4168 if (!gfc_find_state (COMP_SUBROUTINE
))
4170 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4175 if (gfc_current_form
== FORM_FREE
)
4177 /* The following are valid, so we can't require a blank after the
4181 char c
= gfc_peek_ascii_char ();
4182 if (ISALPHA (c
) || ISDIGIT (c
))
4186 m
= gfc_match (" %e%t", &e
);
4189 if (m
== MATCH_ERROR
)
4192 gfc_syntax_error (ST_RETURN
);
4199 gfc_enclosing_unit (&s
);
4200 if (s
== COMP_PROGRAM
4201 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
4202 "main program at %C"))
4205 new_st
.op
= EXEC_RETURN
;
4212 /* Match the call of a type-bound procedure, if CALL%var has already been
4213 matched and var found to be a derived-type variable. */
4216 match_typebound_call (gfc_symtree
* varst
)
4221 base
= gfc_get_expr ();
4222 base
->expr_type
= EXPR_VARIABLE
;
4223 base
->symtree
= varst
;
4224 base
->where
= gfc_current_locus
;
4225 gfc_set_sym_referenced (varst
->n
.sym
);
4227 m
= gfc_match_varspec (base
, 0, true, true);
4229 gfc_error ("Expected component reference at %C");
4232 gfc_free_expr (base
);
4236 if (gfc_match_eos () != MATCH_YES
)
4238 gfc_error ("Junk after CALL at %C");
4239 gfc_free_expr (base
);
4243 if (base
->expr_type
== EXPR_COMPCALL
)
4244 new_st
.op
= EXEC_COMPCALL
;
4245 else if (base
->expr_type
== EXPR_PPC
)
4246 new_st
.op
= EXEC_CALL_PPC
;
4249 gfc_error ("Expected type-bound procedure or procedure pointer component "
4251 gfc_free_expr (base
);
4254 new_st
.expr1
= base
;
4260 /* Match a CALL statement. The tricky part here are possible
4261 alternate return specifiers. We handle these by having all
4262 "subroutines" actually return an integer via a register that gives
4263 the return number. If the call specifies alternate returns, we
4264 generate code for a SELECT statement whose case clauses contain
4265 GOTOs to the various labels. */
4268 gfc_match_call (void)
4270 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4271 gfc_actual_arglist
*a
, *arglist
;
4281 m
= gfc_match ("% %n", name
);
4287 if (gfc_get_ha_sym_tree (name
, &st
))
4292 /* If this is a variable of derived-type, it probably starts a type-bound
4294 if ((sym
->attr
.flavor
!= FL_PROCEDURE
4295 || gfc_is_function_return_value (sym
, gfc_current_ns
))
4296 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
4297 return match_typebound_call (st
);
4299 /* If it does not seem to be callable (include functions so that the
4300 right association is made. They are thrown out in resolution.)
4302 if (!sym
->attr
.generic
4303 && !sym
->attr
.subroutine
4304 && !sym
->attr
.function
)
4306 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
4308 /* ...create a symbol in this scope... */
4309 if (sym
->ns
!= gfc_current_ns
4310 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
4313 if (sym
!= st
->n
.sym
)
4317 /* ...and then to try to make the symbol into a subroutine. */
4318 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
4322 gfc_set_sym_referenced (sym
);
4324 if (gfc_match_eos () != MATCH_YES
)
4326 m
= gfc_match_actual_arglist (1, &arglist
);
4329 if (m
== MATCH_ERROR
)
4332 if (gfc_match_eos () != MATCH_YES
)
4336 /* If any alternate return labels were found, construct a SELECT
4337 statement that will jump to the right place. */
4340 for (a
= arglist
; a
; a
= a
->next
)
4341 if (a
->expr
== NULL
)
4349 gfc_symtree
*select_st
;
4350 gfc_symbol
*select_sym
;
4351 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4353 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
4354 sprintf (name
, "_result_%s", sym
->name
);
4355 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
4357 select_sym
= select_st
->n
.sym
;
4358 select_sym
->ts
.type
= BT_INTEGER
;
4359 select_sym
->ts
.kind
= gfc_default_integer_kind
;
4360 gfc_set_sym_referenced (select_sym
);
4361 c
->expr1
= gfc_get_expr ();
4362 c
->expr1
->expr_type
= EXPR_VARIABLE
;
4363 c
->expr1
->symtree
= select_st
;
4364 c
->expr1
->ts
= select_sym
->ts
;
4365 c
->expr1
->where
= gfc_current_locus
;
4368 for (a
= arglist
; a
; a
= a
->next
)
4370 if (a
->expr
!= NULL
)
4373 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
4378 c
->block
= gfc_get_code (EXEC_SELECT
);
4381 new_case
= gfc_get_case ();
4382 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
4383 new_case
->low
= new_case
->high
;
4384 c
->ext
.block
.case_list
= new_case
;
4386 c
->next
= gfc_get_code (EXEC_GOTO
);
4387 c
->next
->label1
= a
->label
;
4391 new_st
.op
= EXEC_CALL
;
4392 new_st
.symtree
= st
;
4393 new_st
.ext
.actual
= arglist
;
4398 gfc_syntax_error (ST_CALL
);
4401 gfc_free_actual_arglist (arglist
);
4406 /* Given a name, return a pointer to the common head structure,
4407 creating it if it does not exist. If FROM_MODULE is nonzero, we
4408 mangle the name so that it doesn't interfere with commons defined
4409 in the using namespace.
4410 TODO: Add to global symbol tree. */
4413 gfc_get_common (const char *name
, int from_module
)
4416 static int serial
= 0;
4417 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
4421 /* A use associated common block is only needed to correctly layout
4422 the variables it contains. */
4423 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
4424 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
4428 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
4431 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
4434 if (st
->n
.common
== NULL
)
4436 st
->n
.common
= gfc_get_common_head ();
4437 st
->n
.common
->where
= gfc_current_locus
;
4438 strcpy (st
->n
.common
->name
, name
);
4441 return st
->n
.common
;
4445 /* Match a common block name. */
4447 match
match_common_name (char *name
)
4451 if (gfc_match_char ('/') == MATCH_NO
)
4457 if (gfc_match_char ('/') == MATCH_YES
)
4463 m
= gfc_match_name (name
);
4465 if (m
== MATCH_ERROR
)
4467 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
4470 gfc_error ("Syntax error in common block name at %C");
4475 /* Match a COMMON statement. */
4478 gfc_match_common (void)
4480 gfc_symbol
*sym
, **head
, *tail
, *other
;
4481 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4491 m
= match_common_name (name
);
4492 if (m
== MATCH_ERROR
)
4495 if (name
[0] == '\0')
4497 t
= &gfc_current_ns
->blank_common
;
4498 if (t
->head
== NULL
)
4499 t
->where
= gfc_current_locus
;
4503 t
= gfc_get_common (name
, 0);
4512 while (tail
->common_next
)
4513 tail
= tail
->common_next
;
4516 /* Grab the list of symbols. */
4519 m
= gfc_match_symbol (&sym
, 0);
4520 if (m
== MATCH_ERROR
)
4525 /* See if we know the current common block is bind(c), and if
4526 so, then see if we can check if the symbol is (which it'll
4527 need to be). This can happen if the bind(c) attr stmt was
4528 applied to the common block, and the variable(s) already
4529 defined, before declaring the common block. */
4530 if (t
->is_bind_c
== 1)
4532 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
4534 /* If we find an error, just print it and continue,
4535 cause it's just semantic, and we can see if there
4537 gfc_error_now ("Variable %qs at %L in common block %qs "
4538 "at %C must be declared with a C "
4539 "interoperable kind since common block "
4541 sym
->name
, &(sym
->declared_at
), t
->name
,
4545 if (sym
->attr
.is_bind_c
== 1)
4546 gfc_error_now ("Variable %qs in common block %qs at %C can not "
4547 "be bind(c) since it is not global", sym
->name
,
4551 if (sym
->attr
.in_common
)
4553 gfc_error ("Symbol %qs at %C is already in a COMMON block",
4558 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
4559 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
4561 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol %qs at "
4562 "%C can only be COMMON in BLOCK DATA",
4567 /* Deal with an optional array specification after the
4569 m
= gfc_match_array_spec (&as
, true, true);
4570 if (m
== MATCH_ERROR
)
4575 if (as
->type
!= AS_EXPLICIT
)
4577 gfc_error ("Array specification for symbol %qs in COMMON "
4578 "at %C must be explicit", sym
->name
);
4582 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
4585 if (sym
->attr
.pointer
)
4587 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
4588 "POINTER array", sym
->name
);
4597 /* Add the in_common attribute, but ignore the reported errors
4598 if any, and continue matching. */
4599 gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
);
4601 sym
->common_block
= t
;
4602 sym
->common_block
->refs
++;
4605 tail
->common_next
= sym
;
4611 sym
->common_head
= t
;
4613 /* Check to see if the symbol is already in an equivalence group.
4614 If it is, set the other members as being in common. */
4615 if (sym
->attr
.in_equivalence
)
4617 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
4619 for (e2
= e1
; e2
; e2
= e2
->eq
)
4620 if (e2
->expr
->symtree
->n
.sym
== sym
)
4627 for (e2
= e1
; e2
; e2
= e2
->eq
)
4629 other
= e2
->expr
->symtree
->n
.sym
;
4630 if (other
->common_head
4631 && other
->common_head
!= sym
->common_head
)
4633 gfc_error ("Symbol %qs, in COMMON block %qs at "
4634 "%C is being indirectly equivalenced to "
4635 "another COMMON block %qs",
4636 sym
->name
, sym
->common_head
->name
,
4637 other
->common_head
->name
);
4640 other
->attr
.in_common
= 1;
4641 other
->common_head
= t
;
4647 gfc_gobble_whitespace ();
4648 if (gfc_match_eos () == MATCH_YES
)
4650 if (gfc_peek_ascii_char () == '/')
4652 if (gfc_match_char (',') != MATCH_YES
)
4654 gfc_gobble_whitespace ();
4655 if (gfc_peek_ascii_char () == '/')
4664 gfc_syntax_error (ST_COMMON
);
4667 gfc_free_array_spec (as
);
4672 /* Match a BLOCK DATA program unit. */
4675 gfc_match_block_data (void)
4677 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4681 if (gfc_match_eos () == MATCH_YES
)
4683 gfc_new_block
= NULL
;
4687 m
= gfc_match ("% %n%t", name
);
4691 if (gfc_get_symbol (name
, NULL
, &sym
))
4694 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
4697 gfc_new_block
= sym
;
4703 /* Free a namelist structure. */
4706 gfc_free_namelist (gfc_namelist
*name
)
4710 for (; name
; name
= n
)
4718 /* Free an OpenMP namelist structure. */
4721 gfc_free_omp_namelist (gfc_omp_namelist
*name
)
4723 gfc_omp_namelist
*n
;
4725 for (; name
; name
= n
)
4727 gfc_free_expr (name
->expr
);
4730 if (name
->udr
->combiner
)
4731 gfc_free_statement (name
->udr
->combiner
);
4732 if (name
->udr
->initializer
)
4733 gfc_free_statement (name
->udr
->initializer
);
4742 /* Match a NAMELIST statement. */
4745 gfc_match_namelist (void)
4747 gfc_symbol
*group_name
, *sym
;
4751 m
= gfc_match (" / %s /", &group_name
);
4754 if (m
== MATCH_ERROR
)
4759 if (group_name
->ts
.type
!= BT_UNKNOWN
)
4761 gfc_error ("Namelist group name %qs at %C already has a basic "
4762 "type of %s", group_name
->name
,
4763 gfc_typename (&group_name
->ts
));
4767 if (group_name
->attr
.flavor
== FL_NAMELIST
4768 && group_name
->attr
.use_assoc
4769 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name %qs "
4770 "at %C already is USE associated and can"
4771 "not be respecified.", group_name
->name
))
4774 if (group_name
->attr
.flavor
!= FL_NAMELIST
4775 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
4776 group_name
->name
, NULL
))
4781 m
= gfc_match_symbol (&sym
, 1);
4784 if (m
== MATCH_ERROR
)
4787 if (sym
->attr
.in_namelist
== 0
4788 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
4791 /* Use gfc_error_check here, rather than goto error, so that
4792 these are the only errors for the next two lines. */
4793 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
4795 gfc_error ("Assumed size array %qs in namelist %qs at "
4796 "%C is not allowed", sym
->name
, group_name
->name
);
4800 nl
= gfc_get_namelist ();
4804 if (group_name
->namelist
== NULL
)
4805 group_name
->namelist
= group_name
->namelist_tail
= nl
;
4808 group_name
->namelist_tail
->next
= nl
;
4809 group_name
->namelist_tail
= nl
;
4812 if (gfc_match_eos () == MATCH_YES
)
4815 m
= gfc_match_char (',');
4817 if (gfc_match_char ('/') == MATCH_YES
)
4819 m2
= gfc_match (" %s /", &group_name
);
4820 if (m2
== MATCH_YES
)
4822 if (m2
== MATCH_ERROR
)
4836 gfc_syntax_error (ST_NAMELIST
);
4843 /* Match a MODULE statement. */
4846 gfc_match_module (void)
4850 m
= gfc_match (" %s%t", &gfc_new_block
);
4854 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
4855 gfc_new_block
->name
, NULL
))
4862 /* Free equivalence sets and lists. Recursively is the easiest way to
4866 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
4871 gfc_free_equiv (eq
->eq
);
4872 gfc_free_equiv_until (eq
->next
, stop
);
4873 gfc_free_expr (eq
->expr
);
4879 gfc_free_equiv (gfc_equiv
*eq
)
4881 gfc_free_equiv_until (eq
, NULL
);
4885 /* Match an EQUIVALENCE statement. */
4888 gfc_match_equivalence (void)
4890 gfc_equiv
*eq
, *set
, *tail
;
4894 gfc_common_head
*common_head
= NULL
;
4902 eq
= gfc_get_equiv ();
4906 eq
->next
= gfc_current_ns
->equiv
;
4907 gfc_current_ns
->equiv
= eq
;
4909 if (gfc_match_char ('(') != MATCH_YES
)
4913 common_flag
= FALSE
;
4918 m
= gfc_match_equiv_variable (&set
->expr
);
4919 if (m
== MATCH_ERROR
)
4924 /* count the number of objects. */
4927 if (gfc_match_char ('%') == MATCH_YES
)
4929 gfc_error ("Derived type component %C is not a "
4930 "permitted EQUIVALENCE member");
4934 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
4935 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
4937 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
4938 "be an array section");
4942 sym
= set
->expr
->symtree
->n
.sym
;
4944 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
4947 if (sym
->attr
.in_common
)
4950 common_head
= sym
->common_head
;
4953 if (gfc_match_char (')') == MATCH_YES
)
4956 if (gfc_match_char (',') != MATCH_YES
)
4959 set
->eq
= gfc_get_equiv ();
4965 gfc_error ("EQUIVALENCE at %C requires two or more objects");
4969 /* If one of the members of an equivalence is in common, then
4970 mark them all as being in common. Before doing this, check
4971 that members of the equivalence group are not in different
4974 for (set
= eq
; set
; set
= set
->eq
)
4976 sym
= set
->expr
->symtree
->n
.sym
;
4977 if (sym
->common_head
&& sym
->common_head
!= common_head
)
4979 gfc_error ("Attempt to indirectly overlap COMMON "
4980 "blocks %s and %s by EQUIVALENCE at %C",
4981 sym
->common_head
->name
, common_head
->name
);
4984 sym
->attr
.in_common
= 1;
4985 sym
->common_head
= common_head
;
4988 if (gfc_match_eos () == MATCH_YES
)
4990 if (gfc_match_char (',') != MATCH_YES
)
4992 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
5000 gfc_syntax_error (ST_EQUIVALENCE
);
5006 gfc_free_equiv (gfc_current_ns
->equiv
);
5007 gfc_current_ns
->equiv
= eq
;
5013 /* Check that a statement function is not recursive. This is done by looking
5014 for the statement function symbol(sym) by looking recursively through its
5015 expression(e). If a reference to sym is found, true is returned.
5016 12.5.4 requires that any variable of function that is implicitly typed
5017 shall have that type confirmed by any subsequent type declaration. The
5018 implicit typing is conveniently done here. */
5020 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
5023 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
5029 switch (e
->expr_type
)
5032 if (e
->symtree
== NULL
)
5035 /* Check the name before testing for nested recursion! */
5036 if (sym
->name
== e
->symtree
->n
.sym
->name
)
5039 /* Catch recursion via other statement functions. */
5040 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
5041 && e
->symtree
->n
.sym
->value
5042 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
5045 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5046 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5051 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
5054 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5055 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5067 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
5069 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
5073 /* Match a statement function declaration. It is so easy to match
5074 non-statement function statements with a MATCH_ERROR as opposed to
5075 MATCH_NO that we suppress error message in most cases. */
5078 gfc_match_st_function (void)
5080 gfc_error_buffer old_error
;
5085 m
= gfc_match_symbol (&sym
, 0);
5089 gfc_push_error (&old_error
);
5091 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
5094 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
5097 m
= gfc_match (" = %e%t", &expr
);
5101 gfc_free_error (&old_error
);
5103 if (m
== MATCH_ERROR
)
5106 if (recursive_stmt_fcn (expr
, sym
))
5108 gfc_error ("Statement function at %L is recursive", &expr
->where
);
5114 if ((gfc_current_state () == COMP_FUNCTION
5115 || gfc_current_state () == COMP_SUBROUTINE
)
5116 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
5118 gfc_error ("Statement function at %L cannot appear within an INTERFACE",
5123 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
5129 gfc_pop_error (&old_error
);
5134 /* Match an assignment to a pointer function (F2008). This could, in
5135 general be ambiguous with a statement function. In this implementation
5136 it remains so if it is the first statement after the specification
5140 gfc_match_ptr_fcn_assign (void)
5142 gfc_error_buffer old_error
;
5147 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5149 old_loc
= gfc_current_locus
;
5150 m
= gfc_match_name (name
);
5154 gfc_find_symbol (name
, NULL
, 1, &sym
);
5155 if (sym
&& sym
->attr
.flavor
!= FL_PROCEDURE
)
5158 gfc_push_error (&old_error
);
5160 if (sym
&& sym
->attr
.function
)
5161 goto match_actual_arglist
;
5163 gfc_current_locus
= old_loc
;
5164 m
= gfc_match_symbol (&sym
, 0);
5168 if (!gfc_add_procedure (&sym
->attr
, PROC_UNKNOWN
, sym
->name
, NULL
))
5171 match_actual_arglist
:
5172 gfc_current_locus
= old_loc
;
5173 m
= gfc_match (" %e", &expr
);
5177 new_st
.op
= EXEC_ASSIGN
;
5178 new_st
.expr1
= expr
;
5181 m
= gfc_match (" = %e%t", &expr
);
5185 new_st
.expr2
= expr
;
5189 gfc_pop_error (&old_error
);
5194 /***************** SELECT CASE subroutines ******************/
5196 /* Free a single case structure. */
5199 free_case (gfc_case
*p
)
5201 if (p
->low
== p
->high
)
5203 gfc_free_expr (p
->low
);
5204 gfc_free_expr (p
->high
);
5209 /* Free a list of case structures. */
5212 gfc_free_case_list (gfc_case
*p
)
5224 /* Match a single case selector. Combining the requirements of F08:C830
5225 and F08:C832 (R838) means that the case-value must have either CHARACTER,
5226 INTEGER, or LOGICAL type. */
5229 match_case_selector (gfc_case
**cp
)
5234 c
= gfc_get_case ();
5235 c
->where
= gfc_current_locus
;
5237 if (gfc_match_char (':') == MATCH_YES
)
5239 m
= gfc_match_init_expr (&c
->high
);
5242 if (m
== MATCH_ERROR
)
5245 if (c
->high
->ts
.type
!= BT_LOGICAL
&& c
->high
->ts
.type
!= BT_INTEGER
5246 && c
->high
->ts
.type
!= BT_CHARACTER
)
5248 gfc_error ("Expression in CASE selector at %L cannot be %s",
5249 &c
->high
->where
, gfc_typename (&c
->high
->ts
));
5255 m
= gfc_match_init_expr (&c
->low
);
5256 if (m
== MATCH_ERROR
)
5261 if (c
->low
->ts
.type
!= BT_LOGICAL
&& c
->low
->ts
.type
!= BT_INTEGER
5262 && c
->low
->ts
.type
!= BT_CHARACTER
)
5264 gfc_error ("Expression in CASE selector at %L cannot be %s",
5265 &c
->low
->where
, gfc_typename (&c
->low
->ts
));
5269 /* If we're not looking at a ':' now, make a range out of a single
5270 target. Else get the upper bound for the case range. */
5271 if (gfc_match_char (':') != MATCH_YES
)
5275 m
= gfc_match_init_expr (&c
->high
);
5276 if (m
== MATCH_ERROR
)
5278 /* MATCH_NO is fine. It's OK if nothing is there! */
5286 gfc_error ("Expected initialization expression in CASE at %C");
5294 /* Match the end of a case statement. */
5297 match_case_eos (void)
5299 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5302 if (gfc_match_eos () == MATCH_YES
)
5305 /* If the case construct doesn't have a case-construct-name, we
5306 should have matched the EOS. */
5307 if (!gfc_current_block ())
5310 gfc_gobble_whitespace ();
5312 m
= gfc_match_name (name
);
5316 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5318 gfc_error ("Expected block name %qs of SELECT construct at %C",
5319 gfc_current_block ()->name
);
5323 return gfc_match_eos ();
5327 /* Match a SELECT statement. */
5330 gfc_match_select (void)
5335 m
= gfc_match_label ();
5336 if (m
== MATCH_ERROR
)
5339 m
= gfc_match (" select case ( %e )%t", &expr
);
5343 new_st
.op
= EXEC_SELECT
;
5344 new_st
.expr1
= expr
;
5350 /* Transfer the selector typespec to the associate name. */
5353 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
)
5356 gfc_symbol
*assoc_sym
;
5358 assoc_sym
= associate
->symtree
->n
.sym
;
5360 /* At this stage the expression rank and arrayspec dimensions have
5361 not been completely sorted out. We must get the expr2->rank
5362 right here, so that the correct class container is obtained. */
5363 ref
= selector
->ref
;
5364 while (ref
&& ref
->next
)
5367 if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
5368 && ref
&& ref
->type
== REF_ARRAY
)
5370 /* Ensure that the array reference type is set. We cannot use
5371 gfc_resolve_expr at this point, so the usable parts of
5372 resolve.c(resolve_array_ref) are employed to do it. */
5373 if (ref
->u
.ar
.type
== AR_UNKNOWN
)
5375 ref
->u
.ar
.type
= AR_ELEMENT
;
5376 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
5377 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5378 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
5379 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
5380 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
5382 ref
->u
.ar
.type
= AR_SECTION
;
5387 if (ref
->u
.ar
.type
== AR_FULL
)
5388 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
5389 else if (ref
->u
.ar
.type
== AR_SECTION
)
5390 selector
->rank
= ref
->u
.ar
.dimen
;
5397 assoc_sym
->attr
.dimension
= 1;
5398 assoc_sym
->as
= gfc_get_array_spec ();
5399 assoc_sym
->as
->rank
= selector
->rank
;
5400 assoc_sym
->as
->type
= AS_DEFERRED
;
5403 assoc_sym
->as
= NULL
;
5405 if (selector
->ts
.type
== BT_CLASS
)
5407 /* The correct class container has to be available. */
5408 assoc_sym
->ts
.type
= BT_CLASS
;
5409 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
5410 assoc_sym
->attr
.pointer
= 1;
5411 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
5416 /* Push the current selector onto the SELECT TYPE stack. */
5419 select_type_push (gfc_symbol
*sel
)
5421 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
5422 top
->selector
= sel
;
5424 top
->prev
= select_type_stack
;
5426 select_type_stack
= top
;
5430 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
5432 static gfc_symtree
*
5433 select_intrinsic_set_tmp (gfc_typespec
*ts
)
5435 char name
[GFC_MAX_SYMBOL_LEN
];
5439 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
5442 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5443 && !select_type_stack
->selector
->attr
.class_ok
)
5446 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
5447 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5448 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
5450 if (ts
->type
!= BT_CHARACTER
)
5451 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
5454 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (ts
->type
),
5457 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5458 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5460 /* Copy across the array spec to the selector. */
5461 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5462 && (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5463 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
))
5465 tmp
->n
.sym
->attr
.pointer
= 1;
5466 tmp
->n
.sym
->attr
.dimension
5467 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5468 tmp
->n
.sym
->attr
.codimension
5469 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5471 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5474 gfc_set_sym_referenced (tmp
->n
.sym
);
5475 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5476 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5482 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
5485 select_type_set_tmp (gfc_typespec
*ts
)
5487 char name
[GFC_MAX_SYMBOL_LEN
];
5488 gfc_symtree
*tmp
= NULL
;
5492 select_type_stack
->tmp
= NULL
;
5496 tmp
= select_intrinsic_set_tmp (ts
);
5503 if (ts
->type
== BT_CLASS
)
5504 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
5506 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
5507 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5508 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5510 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5511 && select_type_stack
->selector
->attr
.class_ok
)
5513 tmp
->n
.sym
->attr
.pointer
5514 = CLASS_DATA (select_type_stack
->selector
)->attr
.class_pointer
;
5516 /* Copy across the array spec to the selector. */
5517 if (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5518 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
)
5520 tmp
->n
.sym
->attr
.dimension
5521 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5522 tmp
->n
.sym
->attr
.codimension
5523 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5525 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5529 gfc_set_sym_referenced (tmp
->n
.sym
);
5530 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5531 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5533 if (ts
->type
== BT_CLASS
)
5534 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
5538 /* Add an association for it, so the rest of the parser knows it is
5539 an associate-name. The target will be set during resolution. */
5540 tmp
->n
.sym
->assoc
= gfc_get_association_list ();
5541 tmp
->n
.sym
->assoc
->dangling
= 1;
5542 tmp
->n
.sym
->assoc
->st
= tmp
;
5544 select_type_stack
->tmp
= tmp
;
5548 /* Match a SELECT TYPE statement. */
5551 gfc_match_select_type (void)
5553 gfc_expr
*expr1
, *expr2
= NULL
;
5555 char name
[GFC_MAX_SYMBOL_LEN
];
5559 m
= gfc_match_label ();
5560 if (m
== MATCH_ERROR
)
5563 m
= gfc_match (" select type ( ");
5567 m
= gfc_match (" %n => %e", name
, &expr2
);
5570 expr1
= gfc_get_expr();
5571 expr1
->expr_type
= EXPR_VARIABLE
;
5572 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
5578 sym
= expr1
->symtree
->n
.sym
;
5579 if (expr2
->ts
.type
== BT_UNKNOWN
)
5580 sym
->attr
.untyped
= 1;
5582 copy_ts_from_selector_to_associate (expr1
, expr2
);
5584 sym
->attr
.flavor
= FL_VARIABLE
;
5585 sym
->attr
.referenced
= 1;
5586 sym
->attr
.class_ok
= 1;
5590 m
= gfc_match (" %e ", &expr1
);
5595 m
= gfc_match (" )%t");
5598 gfc_error ("parse error in SELECT TYPE statement at %C");
5602 /* This ghastly expression seems to be needed to distinguish a CLASS
5603 array, which can have a reference, from other expressions that
5604 have references, such as derived type components, and are not
5605 allowed by the standard.
5606 TODO: see if it is sufficient to exclude component and substring
5608 class_array
= expr1
->expr_type
== EXPR_VARIABLE
5609 && expr1
->ts
.type
== BT_CLASS
5610 && CLASS_DATA (expr1
)
5611 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
5612 && (CLASS_DATA (expr1
)->attr
.dimension
5613 || CLASS_DATA (expr1
)->attr
.codimension
)
5615 && expr1
->ref
->type
== REF_ARRAY
5616 && expr1
->ref
->next
== NULL
;
5618 /* Check for F03:C811. */
5619 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
5620 || (!class_array
&& expr1
->ref
!= NULL
)))
5622 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
5623 "use associate-name=>");
5628 new_st
.op
= EXEC_SELECT_TYPE
;
5629 new_st
.expr1
= expr1
;
5630 new_st
.expr2
= expr2
;
5631 new_st
.ext
.block
.ns
= gfc_current_ns
;
5633 select_type_push (expr1
->symtree
->n
.sym
);
5638 gfc_free_expr (expr1
);
5639 gfc_free_expr (expr2
);
5644 /* Match a CASE statement. */
5647 gfc_match_case (void)
5649 gfc_case
*c
, *head
, *tail
;
5654 if (gfc_current_state () != COMP_SELECT
)
5656 gfc_error ("Unexpected CASE statement at %C");
5660 if (gfc_match ("% default") == MATCH_YES
)
5662 m
= match_case_eos ();
5665 if (m
== MATCH_ERROR
)
5668 new_st
.op
= EXEC_SELECT
;
5669 c
= gfc_get_case ();
5670 c
->where
= gfc_current_locus
;
5671 new_st
.ext
.block
.case_list
= c
;
5675 if (gfc_match_char ('(') != MATCH_YES
)
5680 if (match_case_selector (&c
) == MATCH_ERROR
)
5690 if (gfc_match_char (')') == MATCH_YES
)
5692 if (gfc_match_char (',') != MATCH_YES
)
5696 m
= match_case_eos ();
5699 if (m
== MATCH_ERROR
)
5702 new_st
.op
= EXEC_SELECT
;
5703 new_st
.ext
.block
.case_list
= head
;
5708 gfc_error ("Syntax error in CASE specification at %C");
5711 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
5716 /* Match a TYPE IS statement. */
5719 gfc_match_type_is (void)
5724 if (gfc_current_state () != COMP_SELECT_TYPE
)
5726 gfc_error ("Unexpected TYPE IS statement at %C");
5730 if (gfc_match_char ('(') != MATCH_YES
)
5733 c
= gfc_get_case ();
5734 c
->where
= gfc_current_locus
;
5736 m
= gfc_match_type_spec (&c
->ts
);
5739 if (m
== MATCH_ERROR
)
5742 if (gfc_match_char (')') != MATCH_YES
)
5745 m
= match_case_eos ();
5748 if (m
== MATCH_ERROR
)
5751 new_st
.op
= EXEC_SELECT_TYPE
;
5752 new_st
.ext
.block
.case_list
= c
;
5754 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
5755 && (c
->ts
.u
.derived
->attr
.sequence
5756 || c
->ts
.u
.derived
->attr
.is_bind_c
))
5758 gfc_error ("The type-spec shall not specify a sequence derived "
5759 "type or a type with the BIND attribute in SELECT "
5760 "TYPE at %C [F2003:C815]");
5764 /* Create temporary variable. */
5765 select_type_set_tmp (&c
->ts
);
5770 gfc_error ("Syntax error in TYPE IS specification at %C");
5774 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
5779 /* Match a CLASS IS or CLASS DEFAULT statement. */
5782 gfc_match_class_is (void)
5787 if (gfc_current_state () != COMP_SELECT_TYPE
)
5790 if (gfc_match ("% default") == MATCH_YES
)
5792 m
= match_case_eos ();
5795 if (m
== MATCH_ERROR
)
5798 new_st
.op
= EXEC_SELECT_TYPE
;
5799 c
= gfc_get_case ();
5800 c
->where
= gfc_current_locus
;
5801 c
->ts
.type
= BT_UNKNOWN
;
5802 new_st
.ext
.block
.case_list
= c
;
5803 select_type_set_tmp (NULL
);
5807 m
= gfc_match ("% is");
5810 if (m
== MATCH_ERROR
)
5813 if (gfc_match_char ('(') != MATCH_YES
)
5816 c
= gfc_get_case ();
5817 c
->where
= gfc_current_locus
;
5819 m
= match_derived_type_spec (&c
->ts
);
5822 if (m
== MATCH_ERROR
)
5825 if (c
->ts
.type
== BT_DERIVED
)
5826 c
->ts
.type
= BT_CLASS
;
5828 if (gfc_match_char (')') != MATCH_YES
)
5831 m
= match_case_eos ();
5834 if (m
== MATCH_ERROR
)
5837 new_st
.op
= EXEC_SELECT_TYPE
;
5838 new_st
.ext
.block
.case_list
= c
;
5840 /* Create temporary variable. */
5841 select_type_set_tmp (&c
->ts
);
5846 gfc_error ("Syntax error in CLASS IS specification at %C");
5850 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
5855 /********************* WHERE subroutines ********************/
5857 /* Match the rest of a simple WHERE statement that follows an IF statement.
5861 match_simple_where (void)
5867 m
= gfc_match (" ( %e )", &expr
);
5871 m
= gfc_match_assignment ();
5874 if (m
== MATCH_ERROR
)
5877 if (gfc_match_eos () != MATCH_YES
)
5880 c
= gfc_get_code (EXEC_WHERE
);
5883 c
->next
= XCNEW (gfc_code
);
5885 gfc_clear_new_st ();
5887 new_st
.op
= EXEC_WHERE
;
5893 gfc_syntax_error (ST_WHERE
);
5896 gfc_free_expr (expr
);
5901 /* Match a WHERE statement. */
5904 gfc_match_where (gfc_statement
*st
)
5910 m0
= gfc_match_label ();
5911 if (m0
== MATCH_ERROR
)
5914 m
= gfc_match (" where ( %e )", &expr
);
5918 if (gfc_match_eos () == MATCH_YES
)
5920 *st
= ST_WHERE_BLOCK
;
5921 new_st
.op
= EXEC_WHERE
;
5922 new_st
.expr1
= expr
;
5926 m
= gfc_match_assignment ();
5928 gfc_syntax_error (ST_WHERE
);
5932 gfc_free_expr (expr
);
5936 /* We've got a simple WHERE statement. */
5938 c
= gfc_get_code (EXEC_WHERE
);
5941 c
->next
= XCNEW (gfc_code
);
5943 gfc_clear_new_st ();
5945 new_st
.op
= EXEC_WHERE
;
5952 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
5953 new_st if successful. */
5956 gfc_match_elsewhere (void)
5958 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5962 if (gfc_current_state () != COMP_WHERE
)
5964 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
5970 if (gfc_match_char ('(') == MATCH_YES
)
5972 m
= gfc_match_expr (&expr
);
5975 if (m
== MATCH_ERROR
)
5978 if (gfc_match_char (')') != MATCH_YES
)
5982 if (gfc_match_eos () != MATCH_YES
)
5984 /* Only makes sense if we have a where-construct-name. */
5985 if (!gfc_current_block ())
5990 /* Better be a name at this point. */
5991 m
= gfc_match_name (name
);
5994 if (m
== MATCH_ERROR
)
5997 if (gfc_match_eos () != MATCH_YES
)
6000 if (strcmp (name
, gfc_current_block ()->name
) != 0)
6002 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
6003 name
, gfc_current_block ()->name
);
6008 new_st
.op
= EXEC_WHERE
;
6009 new_st
.expr1
= expr
;
6013 gfc_syntax_error (ST_ELSEWHERE
);
6016 gfc_free_expr (expr
);