1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000-2014 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 #include "stringpool.h"
31 int gfc_matching_ptr_assignment
= 0;
32 int gfc_matching_procptr_assignment
= 0;
33 bool gfc_matching_prefix
= false;
35 /* Stack of SELECT TYPE statements. */
36 gfc_select_type_stack
*select_type_stack
= NULL
;
38 /* For debugging and diagnostic purposes. Return the textual representation
39 of the intrinsic operator OP. */
41 gfc_op2string (gfc_intrinsic_op op
)
49 case INTRINSIC_UMINUS
:
55 case INTRINSIC_CONCAT
:
59 case INTRINSIC_DIVIDE
:
98 case INTRINSIC_ASSIGN
:
101 case INTRINSIC_PARENTHESES
:
108 gfc_internal_error ("gfc_op2string(): Bad code");
113 /******************** Generic matching subroutines ************************/
115 /* This function scans the current statement counting the opened and closed
116 parenthesis to make sure they are balanced. */
119 gfc_match_parens (void)
121 locus old_loc
, where
;
123 gfc_instring instring
;
126 old_loc
= gfc_current_locus
;
128 instring
= NONSTRING
;
133 c
= gfc_next_char_literal (instring
);
136 if (quote
== ' ' && ((c
== '\'') || (c
== '"')))
139 instring
= INSTRING_WARN
;
142 if (quote
!= ' ' && c
== quote
)
145 instring
= NONSTRING
;
149 if (c
== '(' && quote
== ' ')
152 where
= gfc_current_locus
;
154 if (c
== ')' && quote
== ' ')
157 where
= gfc_current_locus
;
161 gfc_current_locus
= old_loc
;
165 gfc_error ("Missing %<)%> in statement at or before %L", &where
);
170 gfc_error ("Missing %<(%> in statement at or before %L", &where
);
178 /* See if the next character is a special character that has
179 escaped by a \ via the -fbackslash option. */
182 gfc_match_special_char (gfc_char_t
*res
)
190 switch ((c
= gfc_next_char_literal (INSTRING_WARN
)))
223 /* Hexadecimal form of wide characters. */
224 len
= (c
== 'x' ? 2 : (c
== 'u' ? 4 : 8));
226 for (i
= 0; i
< len
; i
++)
228 char buf
[2] = { '\0', '\0' };
230 c
= gfc_next_char_literal (INSTRING_WARN
);
231 if (!gfc_wide_fits_in_byte (c
)
232 || !gfc_check_digit ((unsigned char) c
, 16))
235 buf
[0] = (unsigned char) c
;
237 n
+= strtol (buf
, NULL
, 16);
243 /* Unknown backslash codes are simply not expanded. */
252 /* In free form, match at least one space. Always matches in fixed
256 gfc_match_space (void)
261 if (gfc_current_form
== FORM_FIXED
)
264 old_loc
= gfc_current_locus
;
266 c
= gfc_next_ascii_char ();
267 if (!gfc_is_whitespace (c
))
269 gfc_current_locus
= old_loc
;
273 gfc_gobble_whitespace ();
279 /* Match an end of statement. End of statement is optional
280 whitespace, followed by a ';' or '\n' or comment '!'. If a
281 semicolon is found, we continue to eat whitespace and semicolons. */
294 old_loc
= gfc_current_locus
;
295 gfc_gobble_whitespace ();
297 c
= gfc_next_ascii_char ();
303 c
= gfc_next_ascii_char ();
320 gfc_current_locus
= old_loc
;
321 return (flag
) ? MATCH_YES
: MATCH_NO
;
325 /* Match a literal integer on the input, setting the value on
326 MATCH_YES. Literal ints occur in kind-parameters as well as
327 old-style character length specifications. If cnt is non-NULL it
328 will be set to the number of digits. */
331 gfc_match_small_literal_int (int *value
, int *cnt
)
337 old_loc
= gfc_current_locus
;
340 gfc_gobble_whitespace ();
341 c
= gfc_next_ascii_char ();
347 gfc_current_locus
= old_loc
;
356 old_loc
= gfc_current_locus
;
357 c
= gfc_next_ascii_char ();
362 i
= 10 * i
+ c
- '0';
367 gfc_error ("Integer too large at %C");
372 gfc_current_locus
= old_loc
;
381 /* Match a small, constant integer expression, like in a kind
382 statement. On MATCH_YES, 'value' is set. */
385 gfc_match_small_int (int *value
)
392 m
= gfc_match_expr (&expr
);
396 p
= gfc_extract_int (expr
, &i
);
397 gfc_free_expr (expr
);
410 /* This function is the same as the gfc_match_small_int, except that
411 we're keeping the pointer to the expr. This function could just be
412 removed and the previously mentioned one modified, though all calls
413 to it would have to be modified then (and there were a number of
414 them). Return MATCH_ERROR if fail to extract the int; otherwise,
415 return the result of gfc_match_expr(). The expr (if any) that was
416 matched is returned in the parameter expr. */
419 gfc_match_small_int_expr (int *value
, gfc_expr
**expr
)
425 m
= gfc_match_expr (expr
);
429 p
= gfc_extract_int (*expr
, &i
);
442 /* Matches a statement label. Uses gfc_match_small_literal_int() to
443 do most of the work. */
446 gfc_match_st_label (gfc_st_label
**label
)
452 old_loc
= gfc_current_locus
;
454 m
= gfc_match_small_literal_int (&i
, &cnt
);
460 gfc_error ("Too many digits in statement label at %C");
466 gfc_error ("Statement label at %C is zero");
470 *label
= gfc_get_st_label (i
);
475 gfc_current_locus
= old_loc
;
480 /* Match and validate a label associated with a named IF, DO or SELECT
481 statement. If the symbol does not have the label attribute, we add
482 it. We also make sure the symbol does not refer to another
483 (active) block. A matched label is pointed to by gfc_new_block. */
486 gfc_match_label (void)
488 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
491 gfc_new_block
= NULL
;
493 m
= gfc_match (" %n :", name
);
497 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
499 gfc_error ("Label name %qs at %C is ambiguous", name
);
503 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
505 gfc_error ("Duplicate construct label %qs at %C", name
);
509 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
510 gfc_new_block
->name
, NULL
))
517 /* See if the current input looks like a name of some sort. Modifies
518 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
519 Note that options.c restricts max_identifier_length to not more
520 than GFC_MAX_SYMBOL_LEN. */
523 gfc_match_name (char *buffer
)
529 old_loc
= gfc_current_locus
;
530 gfc_gobble_whitespace ();
532 c
= gfc_next_ascii_char ();
533 if (!(ISALPHA (c
) || (c
== '_' && flag_allow_leading_underscore
)))
535 if (!gfc_error_flag_test () && c
!= '(')
536 gfc_error ("Invalid character in name at %C");
537 gfc_current_locus
= old_loc
;
547 if (i
> gfc_option
.max_identifier_length
)
549 gfc_error ("Name at %C is too long");
553 old_loc
= gfc_current_locus
;
554 c
= gfc_next_ascii_char ();
556 while (ISALNUM (c
) || c
== '_' || (flag_dollar_ok
&& c
== '$'));
558 if (c
== '$' && !flag_dollar_ok
)
560 gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to "
561 "allow it as an extension", &old_loc
);
566 gfc_current_locus
= old_loc
;
572 /* Match a symbol on the input. Modifies the pointer to the symbol
573 pointer if successful. */
576 gfc_match_sym_tree (gfc_symtree
**matched_symbol
, int host_assoc
)
578 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
581 m
= gfc_match_name (buffer
);
586 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
587 ? MATCH_ERROR
: MATCH_YES
;
589 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
, false))
597 gfc_match_symbol (gfc_symbol
**matched_symbol
, int host_assoc
)
602 m
= gfc_match_sym_tree (&st
, host_assoc
);
607 *matched_symbol
= st
->n
.sym
;
609 *matched_symbol
= NULL
;
612 *matched_symbol
= NULL
;
617 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
618 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
622 gfc_match_intrinsic_op (gfc_intrinsic_op
*result
)
624 locus orig_loc
= gfc_current_locus
;
627 gfc_gobble_whitespace ();
628 ch
= gfc_next_ascii_char ();
633 *result
= INTRINSIC_PLUS
;
638 *result
= INTRINSIC_MINUS
;
642 if (gfc_next_ascii_char () == '=')
645 *result
= INTRINSIC_EQ
;
651 if (gfc_peek_ascii_char () == '=')
654 gfc_next_ascii_char ();
655 *result
= INTRINSIC_LE
;
659 *result
= INTRINSIC_LT
;
663 if (gfc_peek_ascii_char () == '=')
666 gfc_next_ascii_char ();
667 *result
= INTRINSIC_GE
;
671 *result
= INTRINSIC_GT
;
675 if (gfc_peek_ascii_char () == '*')
678 gfc_next_ascii_char ();
679 *result
= INTRINSIC_POWER
;
683 *result
= INTRINSIC_TIMES
;
687 ch
= gfc_peek_ascii_char ();
691 gfc_next_ascii_char ();
692 *result
= INTRINSIC_NE
;
698 gfc_next_ascii_char ();
699 *result
= INTRINSIC_CONCAT
;
703 *result
= INTRINSIC_DIVIDE
;
707 ch
= gfc_next_ascii_char ();
711 if (gfc_next_ascii_char () == 'n'
712 && gfc_next_ascii_char () == 'd'
713 && gfc_next_ascii_char () == '.')
715 /* Matched ".and.". */
716 *result
= INTRINSIC_AND
;
722 if (gfc_next_ascii_char () == 'q')
724 ch
= gfc_next_ascii_char ();
727 /* Matched ".eq.". */
728 *result
= INTRINSIC_EQ_OS
;
733 if (gfc_next_ascii_char () == '.')
735 /* Matched ".eqv.". */
736 *result
= INTRINSIC_EQV
;
744 ch
= gfc_next_ascii_char ();
747 if (gfc_next_ascii_char () == '.')
749 /* Matched ".ge.". */
750 *result
= INTRINSIC_GE_OS
;
756 if (gfc_next_ascii_char () == '.')
758 /* Matched ".gt.". */
759 *result
= INTRINSIC_GT_OS
;
766 ch
= gfc_next_ascii_char ();
769 if (gfc_next_ascii_char () == '.')
771 /* Matched ".le.". */
772 *result
= INTRINSIC_LE_OS
;
778 if (gfc_next_ascii_char () == '.')
780 /* Matched ".lt.". */
781 *result
= INTRINSIC_LT_OS
;
788 ch
= gfc_next_ascii_char ();
791 ch
= gfc_next_ascii_char ();
794 /* Matched ".ne.". */
795 *result
= INTRINSIC_NE_OS
;
800 if (gfc_next_ascii_char () == 'v'
801 && gfc_next_ascii_char () == '.')
803 /* Matched ".neqv.". */
804 *result
= INTRINSIC_NEQV
;
811 if (gfc_next_ascii_char () == 't'
812 && gfc_next_ascii_char () == '.')
814 /* Matched ".not.". */
815 *result
= INTRINSIC_NOT
;
822 if (gfc_next_ascii_char () == 'r'
823 && gfc_next_ascii_char () == '.')
825 /* Matched ".or.". */
826 *result
= INTRINSIC_OR
;
840 gfc_current_locus
= orig_loc
;
845 /* Match a loop control phrase:
847 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
849 If the final integer expression is not present, a constant unity
850 expression is returned. We don't return MATCH_ERROR until after
851 the equals sign is seen. */
854 gfc_match_iterator (gfc_iterator
*iter
, int init_flag
)
856 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
857 gfc_expr
*var
, *e1
, *e2
, *e3
;
863 /* Match the start of an iterator without affecting the symbol table. */
865 start
= gfc_current_locus
;
866 m
= gfc_match (" %n =", name
);
867 gfc_current_locus
= start
;
872 m
= gfc_match_variable (&var
, 0);
876 /* F2008, C617 & C565. */
877 if (var
->symtree
->n
.sym
->attr
.codimension
)
879 gfc_error ("Loop variable at %C cannot be a coarray");
883 if (var
->ref
!= NULL
)
885 gfc_error ("Loop variable at %C cannot be a sub-component");
889 gfc_match_char ('=');
891 var
->symtree
->n
.sym
->attr
.implied_index
= 1;
893 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
896 if (m
== MATCH_ERROR
)
899 if (gfc_match_char (',') != MATCH_YES
)
902 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
905 if (m
== MATCH_ERROR
)
908 if (gfc_match_char (',') != MATCH_YES
)
910 e3
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
914 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
915 if (m
== MATCH_ERROR
)
919 gfc_error ("Expected a step value in iterator at %C");
931 gfc_error ("Syntax error in iterator at %C");
942 /* Tries to match the next non-whitespace character on the input.
943 This subroutine does not return MATCH_ERROR. */
946 gfc_match_char (char c
)
950 where
= gfc_current_locus
;
951 gfc_gobble_whitespace ();
953 if (gfc_next_ascii_char () == c
)
956 gfc_current_locus
= where
;
961 /* General purpose matching subroutine. The target string is a
962 scanf-like format string in which spaces correspond to arbitrary
963 whitespace (including no whitespace), characters correspond to
964 themselves. The %-codes are:
966 %% Literal percent sign
967 %e Expression, pointer to a pointer is set
968 %s Symbol, pointer to the symbol is set
969 %n Name, character buffer is set to name
970 %t Matches end of statement.
971 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
972 %l Matches a statement label
973 %v Matches a variable expression (an lvalue)
974 % Matches a required space (in free form) and optional spaces. */
977 gfc_match (const char *target
, ...)
979 gfc_st_label
**label
;
988 old_loc
= gfc_current_locus
;
989 va_start (argp
, target
);
999 gfc_gobble_whitespace ();
1010 vp
= va_arg (argp
, void **);
1011 n
= gfc_match_expr ((gfc_expr
**) vp
);
1022 vp
= va_arg (argp
, void **);
1023 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
1034 vp
= va_arg (argp
, void **);
1035 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
1046 np
= va_arg (argp
, char *);
1047 n
= gfc_match_name (np
);
1058 label
= va_arg (argp
, gfc_st_label
**);
1059 n
= gfc_match_st_label (label
);
1070 ip
= va_arg (argp
, int *);
1071 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
1082 if (gfc_match_eos () != MATCH_YES
)
1090 if (gfc_match_space () == MATCH_YES
)
1096 break; /* Fall through to character matcher. */
1099 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
1104 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1105 expect an upper case character here! */
1106 gcc_assert (TOLOWER (c
) == c
);
1108 if (c
== gfc_next_ascii_char ())
1118 /* Clean up after a failed match. */
1119 gfc_current_locus
= old_loc
;
1120 va_start (argp
, target
);
1123 for (; matches
> 0; matches
--)
1125 while (*p
++ != '%');
1133 /* Matches that don't have to be undone */
1138 (void) va_arg (argp
, void **);
1143 vp
= va_arg (argp
, void **);
1144 gfc_free_expr ((struct gfc_expr
*)*vp
);
1157 /*********************** Statement level matching **********************/
1159 /* Matches the start of a program unit, which is the program keyword
1160 followed by an obligatory symbol. */
1163 gfc_match_program (void)
1168 m
= gfc_match ("% %s%t", &sym
);
1172 gfc_error ("Invalid form of PROGRAM statement at %C");
1176 if (m
== MATCH_ERROR
)
1179 if (!gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
))
1182 gfc_new_block
= sym
;
1188 /* Match a simple assignment statement. */
1191 gfc_match_assignment (void)
1193 gfc_expr
*lvalue
, *rvalue
;
1197 old_loc
= gfc_current_locus
;
1200 m
= gfc_match (" %v =", &lvalue
);
1203 gfc_current_locus
= old_loc
;
1204 gfc_free_expr (lvalue
);
1209 m
= gfc_match (" %e%t", &rvalue
);
1212 gfc_current_locus
= old_loc
;
1213 gfc_free_expr (lvalue
);
1214 gfc_free_expr (rvalue
);
1218 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1220 new_st
.op
= EXEC_ASSIGN
;
1221 new_st
.expr1
= lvalue
;
1222 new_st
.expr2
= rvalue
;
1224 gfc_check_do_variable (lvalue
->symtree
);
1230 /* Match a pointer assignment statement. */
1233 gfc_match_pointer_assignment (void)
1235 gfc_expr
*lvalue
, *rvalue
;
1239 old_loc
= gfc_current_locus
;
1241 lvalue
= rvalue
= NULL
;
1242 gfc_matching_ptr_assignment
= 0;
1243 gfc_matching_procptr_assignment
= 0;
1245 m
= gfc_match (" %v =>", &lvalue
);
1252 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1253 || gfc_is_proc_ptr_comp (lvalue
))
1254 gfc_matching_procptr_assignment
= 1;
1256 gfc_matching_ptr_assignment
= 1;
1258 m
= gfc_match (" %e%t", &rvalue
);
1259 gfc_matching_ptr_assignment
= 0;
1260 gfc_matching_procptr_assignment
= 0;
1264 new_st
.op
= EXEC_POINTER_ASSIGN
;
1265 new_st
.expr1
= lvalue
;
1266 new_st
.expr2
= rvalue
;
1271 gfc_current_locus
= old_loc
;
1272 gfc_free_expr (lvalue
);
1273 gfc_free_expr (rvalue
);
1278 /* We try to match an easy arithmetic IF statement. This only happens
1279 when just after having encountered a simple IF statement. This code
1280 is really duplicate with parts of the gfc_match_if code, but this is
1284 match_arithmetic_if (void)
1286 gfc_st_label
*l1
, *l2
, *l3
;
1290 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1294 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1295 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1296 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1298 gfc_free_expr (expr
);
1302 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Arithmetic IF statement at %C"))
1305 new_st
.op
= EXEC_ARITHMETIC_IF
;
1306 new_st
.expr1
= expr
;
1315 /* The IF statement is a bit of a pain. First of all, there are three
1316 forms of it, the simple IF, the IF that starts a block and the
1319 There is a problem with the simple IF and that is the fact that we
1320 only have a single level of undo information on symbols. What this
1321 means is for a simple IF, we must re-match the whole IF statement
1322 multiple times in order to guarantee that the symbol table ends up
1323 in the proper state. */
1325 static match
match_simple_forall (void);
1326 static match
match_simple_where (void);
1329 gfc_match_if (gfc_statement
*if_type
)
1332 gfc_st_label
*l1
, *l2
, *l3
;
1333 locus old_loc
, old_loc2
;
1337 n
= gfc_match_label ();
1338 if (n
== MATCH_ERROR
)
1341 old_loc
= gfc_current_locus
;
1343 m
= gfc_match (" if ( %e", &expr
);
1347 old_loc2
= gfc_current_locus
;
1348 gfc_current_locus
= old_loc
;
1350 if (gfc_match_parens () == MATCH_ERROR
)
1353 gfc_current_locus
= old_loc2
;
1355 if (gfc_match_char (')') != MATCH_YES
)
1357 gfc_error ("Syntax error in IF-expression at %C");
1358 gfc_free_expr (expr
);
1362 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1368 gfc_error ("Block label not appropriate for arithmetic IF "
1370 gfc_free_expr (expr
);
1374 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1375 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1376 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1378 gfc_free_expr (expr
);
1382 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Arithmetic IF statement at %C"))
1385 new_st
.op
= EXEC_ARITHMETIC_IF
;
1386 new_st
.expr1
= expr
;
1391 *if_type
= ST_ARITHMETIC_IF
;
1395 if (gfc_match (" then%t") == MATCH_YES
)
1397 new_st
.op
= EXEC_IF
;
1398 new_st
.expr1
= expr
;
1399 *if_type
= ST_IF_BLOCK
;
1405 gfc_error ("Block label is not appropriate for IF statement at %C");
1406 gfc_free_expr (expr
);
1410 /* At this point the only thing left is a simple IF statement. At
1411 this point, n has to be MATCH_NO, so we don't have to worry about
1412 re-matching a block label. From what we've got so far, try
1413 matching an assignment. */
1415 *if_type
= ST_SIMPLE_IF
;
1417 m
= gfc_match_assignment ();
1421 gfc_free_expr (expr
);
1422 gfc_undo_symbols ();
1423 gfc_current_locus
= old_loc
;
1425 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1426 assignment was found. For MATCH_NO, continue to call the various
1428 if (m
== MATCH_ERROR
)
1431 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1433 m
= gfc_match_pointer_assignment ();
1437 gfc_free_expr (expr
);
1438 gfc_undo_symbols ();
1439 gfc_current_locus
= old_loc
;
1441 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1443 /* Look at the next keyword to see which matcher to call. Matching
1444 the keyword doesn't affect the symbol table, so we don't have to
1445 restore between tries. */
1447 #define match(string, subr, statement) \
1448 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1452 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1453 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1454 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1455 match ("call", gfc_match_call
, ST_CALL
)
1456 match ("close", gfc_match_close
, ST_CLOSE
)
1457 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1458 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1459 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1460 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1461 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
)
1462 match ("exit", gfc_match_exit
, ST_EXIT
)
1463 match ("flush", gfc_match_flush
, ST_FLUSH
)
1464 match ("forall", match_simple_forall
, ST_FORALL
)
1465 match ("go to", gfc_match_goto
, ST_GOTO
)
1466 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1467 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1468 match ("lock", gfc_match_lock
, ST_LOCK
)
1469 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1470 match ("open", gfc_match_open
, ST_OPEN
)
1471 match ("pause", gfc_match_pause
, ST_NONE
)
1472 match ("print", gfc_match_print
, ST_WRITE
)
1473 match ("read", gfc_match_read
, ST_READ
)
1474 match ("return", gfc_match_return
, ST_RETURN
)
1475 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1476 match ("stop", gfc_match_stop
, ST_STOP
)
1477 match ("wait", gfc_match_wait
, ST_WAIT
)
1478 match ("sync all", gfc_match_sync_all
, ST_SYNC_CALL
);
1479 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
1480 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
1481 match ("unlock", gfc_match_unlock
, ST_UNLOCK
)
1482 match ("where", match_simple_where
, ST_WHERE
)
1483 match ("write", gfc_match_write
, ST_WRITE
)
1485 /* The gfc_match_assignment() above may have returned a MATCH_NO
1486 where the assignment was to a named constant. Check that
1487 special case here. */
1488 m
= gfc_match_assignment ();
1491 gfc_error ("Cannot assign to a named constant at %C");
1492 gfc_free_expr (expr
);
1493 gfc_undo_symbols ();
1494 gfc_current_locus
= old_loc
;
1498 /* All else has failed, so give up. See if any of the matchers has
1499 stored an error message of some sort. */
1500 if (!gfc_error_check ())
1501 gfc_error ("Unclassifiable statement in IF-clause at %C");
1503 gfc_free_expr (expr
);
1508 gfc_error ("Syntax error in IF-clause at %C");
1511 gfc_free_expr (expr
);
1515 /* At this point, we've matched the single IF and the action clause
1516 is in new_st. Rearrange things so that the IF statement appears
1519 p
= gfc_get_code (EXEC_IF
);
1520 p
->next
= XCNEW (gfc_code
);
1522 p
->next
->loc
= gfc_current_locus
;
1526 gfc_clear_new_st ();
1528 new_st
.op
= EXEC_IF
;
1537 /* Match an ELSE statement. */
1540 gfc_match_else (void)
1542 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1544 if (gfc_match_eos () == MATCH_YES
)
1547 if (gfc_match_name (name
) != MATCH_YES
1548 || gfc_current_block () == NULL
1549 || gfc_match_eos () != MATCH_YES
)
1551 gfc_error ("Unexpected junk after ELSE statement at %C");
1555 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1557 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1558 name
, gfc_current_block ()->name
);
1566 /* Match an ELSE IF statement. */
1569 gfc_match_elseif (void)
1571 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1575 m
= gfc_match (" ( %e ) then", &expr
);
1579 if (gfc_match_eos () == MATCH_YES
)
1582 if (gfc_match_name (name
) != MATCH_YES
1583 || gfc_current_block () == NULL
1584 || gfc_match_eos () != MATCH_YES
)
1586 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1590 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1592 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1593 name
, gfc_current_block ()->name
);
1598 new_st
.op
= EXEC_IF
;
1599 new_st
.expr1
= expr
;
1603 gfc_free_expr (expr
);
1608 /* Free a gfc_iterator structure. */
1611 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1617 gfc_free_expr (iter
->var
);
1618 gfc_free_expr (iter
->start
);
1619 gfc_free_expr (iter
->end
);
1620 gfc_free_expr (iter
->step
);
1627 /* Match a CRITICAL statement. */
1629 gfc_match_critical (void)
1631 gfc_st_label
*label
= NULL
;
1633 if (gfc_match_label () == MATCH_ERROR
)
1636 if (gfc_match (" critical") != MATCH_YES
)
1639 if (gfc_match_st_label (&label
) == MATCH_ERROR
)
1642 if (gfc_match_eos () != MATCH_YES
)
1644 gfc_syntax_error (ST_CRITICAL
);
1648 if (gfc_pure (NULL
))
1650 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1654 if (gfc_find_state (COMP_DO_CONCURRENT
))
1656 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1661 gfc_unset_implicit_pure (NULL
);
1663 if (!gfc_notify_std (GFC_STD_F2008
, "CRITICAL statement at %C"))
1666 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1668 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1673 if (gfc_find_state (COMP_CRITICAL
))
1675 gfc_error ("Nested CRITICAL block at %C");
1679 new_st
.op
= EXEC_CRITICAL
;
1682 && !gfc_reference_st_label (label
, ST_LABEL_TARGET
))
1689 /* Match a BLOCK statement. */
1692 gfc_match_block (void)
1696 if (gfc_match_label () == MATCH_ERROR
)
1699 if (gfc_match (" block") != MATCH_YES
)
1702 /* For this to be a correct BLOCK statement, the line must end now. */
1703 m
= gfc_match_eos ();
1704 if (m
== MATCH_ERROR
)
1713 /* Match an ASSOCIATE statement. */
1716 gfc_match_associate (void)
1718 if (gfc_match_label () == MATCH_ERROR
)
1721 if (gfc_match (" associate") != MATCH_YES
)
1724 /* Match the association list. */
1725 if (gfc_match_char ('(') != MATCH_YES
)
1727 gfc_error ("Expected association list at %C");
1730 new_st
.ext
.block
.assoc
= NULL
;
1733 gfc_association_list
* newAssoc
= gfc_get_association_list ();
1734 gfc_association_list
* a
;
1736 /* Match the next association. */
1737 if (gfc_match (" %n => %e", newAssoc
->name
, &newAssoc
->target
)
1740 gfc_error ("Expected association at %C");
1741 goto assocListError
;
1743 newAssoc
->where
= gfc_current_locus
;
1745 /* Check that the current name is not yet in the list. */
1746 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
1747 if (!strcmp (a
->name
, newAssoc
->name
))
1749 gfc_error ("Duplicate name %qs in association at %C",
1751 goto assocListError
;
1754 /* The target expression must not be coindexed. */
1755 if (gfc_is_coindexed (newAssoc
->target
))
1757 gfc_error ("Association target at %C must not be coindexed");
1758 goto assocListError
;
1761 /* The `variable' field is left blank for now; because the target is not
1762 yet resolved, we can't use gfc_has_vector_subscript to determine it
1763 for now. This is set during resolution. */
1765 /* Put it into the list. */
1766 newAssoc
->next
= new_st
.ext
.block
.assoc
;
1767 new_st
.ext
.block
.assoc
= newAssoc
;
1769 /* Try next one or end if closing parenthesis is found. */
1770 gfc_gobble_whitespace ();
1771 if (gfc_peek_char () == ')')
1773 if (gfc_match_char (',') != MATCH_YES
)
1775 gfc_error ("Expected %<)%> or %<,%> at %C");
1785 if (gfc_match_char (')') != MATCH_YES
)
1787 /* This should never happen as we peek above. */
1791 if (gfc_match_eos () != MATCH_YES
)
1793 gfc_error ("Junk after ASSOCIATE statement at %C");
1800 gfc_free_association_list (new_st
.ext
.block
.assoc
);
1805 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1806 an accessible derived type. */
1809 match_derived_type_spec (gfc_typespec
*ts
)
1811 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1813 gfc_symbol
*derived
;
1815 old_locus
= gfc_current_locus
;
1817 if (gfc_match ("%n", name
) != MATCH_YES
)
1819 gfc_current_locus
= old_locus
;
1823 gfc_find_symbol (name
, NULL
, 1, &derived
);
1825 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
&& derived
->attr
.generic
)
1826 derived
= gfc_find_dt_in_generic (derived
);
1828 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
1830 ts
->type
= BT_DERIVED
;
1831 ts
->u
.derived
= derived
;
1835 gfc_current_locus
= old_locus
;
1840 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
1841 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
1842 It only includes the intrinsic types from the Fortran 2003 standard
1843 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
1844 the implicit_flag is not needed, so it was removed. Derived types are
1845 identified by their name alone. */
1848 gfc_match_type_spec (gfc_typespec
*ts
)
1854 gfc_gobble_whitespace ();
1855 old_locus
= gfc_current_locus
;
1857 if (match_derived_type_spec (ts
) == MATCH_YES
)
1859 /* Enforce F03:C401. */
1860 if (ts
->u
.derived
->attr
.abstract
)
1862 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
1863 ts
->u
.derived
->name
, &old_locus
);
1869 if (gfc_match ("integer") == MATCH_YES
)
1871 ts
->type
= BT_INTEGER
;
1872 ts
->kind
= gfc_default_integer_kind
;
1876 if (gfc_match ("real") == MATCH_YES
)
1879 ts
->kind
= gfc_default_real_kind
;
1883 if (gfc_match ("double precision") == MATCH_YES
)
1886 ts
->kind
= gfc_default_double_kind
;
1890 if (gfc_match ("complex") == MATCH_YES
)
1892 ts
->type
= BT_COMPLEX
;
1893 ts
->kind
= gfc_default_complex_kind
;
1897 if (gfc_match ("character") == MATCH_YES
)
1899 ts
->type
= BT_CHARACTER
;
1901 m
= gfc_match_char_spec (ts
);
1909 if (gfc_match ("logical") == MATCH_YES
)
1911 ts
->type
= BT_LOGICAL
;
1912 ts
->kind
= gfc_default_logical_kind
;
1916 /* If a type is not matched, simply return MATCH_NO. */
1917 gfc_current_locus
= old_locus
;
1922 gfc_gobble_whitespace ();
1923 if (gfc_peek_ascii_char () == '*')
1925 gfc_error ("Invalid type-spec at %C");
1929 m
= gfc_match_kind_spec (ts
, false);
1932 m
= MATCH_YES
; /* No kind specifier found. */
1938 /******************** FORALL subroutines ********************/
1940 /* Free a list of FORALL iterators. */
1943 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
1945 gfc_forall_iterator
*next
;
1950 gfc_free_expr (iter
->var
);
1951 gfc_free_expr (iter
->start
);
1952 gfc_free_expr (iter
->end
);
1953 gfc_free_expr (iter
->stride
);
1960 /* Match an iterator as part of a FORALL statement. The format is:
1962 <var> = <start>:<end>[:<stride>]
1964 On MATCH_NO, the caller tests for the possibility that there is a
1965 scalar mask expression. */
1968 match_forall_iterator (gfc_forall_iterator
**result
)
1970 gfc_forall_iterator
*iter
;
1974 where
= gfc_current_locus
;
1975 iter
= XCNEW (gfc_forall_iterator
);
1977 m
= gfc_match_expr (&iter
->var
);
1981 if (gfc_match_char ('=') != MATCH_YES
1982 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
1988 m
= gfc_match_expr (&iter
->start
);
1992 if (gfc_match_char (':') != MATCH_YES
)
1995 m
= gfc_match_expr (&iter
->end
);
1998 if (m
== MATCH_ERROR
)
2001 if (gfc_match_char (':') == MATCH_NO
)
2002 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2005 m
= gfc_match_expr (&iter
->stride
);
2008 if (m
== MATCH_ERROR
)
2012 /* Mark the iteration variable's symbol as used as a FORALL index. */
2013 iter
->var
->symtree
->n
.sym
->forall_index
= true;
2019 gfc_error ("Syntax error in FORALL iterator at %C");
2024 gfc_current_locus
= where
;
2025 gfc_free_forall_iterator (iter
);
2030 /* Match the header of a FORALL statement. */
2033 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
2035 gfc_forall_iterator
*head
, *tail
, *new_iter
;
2039 gfc_gobble_whitespace ();
2044 if (gfc_match_char ('(') != MATCH_YES
)
2047 m
= match_forall_iterator (&new_iter
);
2048 if (m
== MATCH_ERROR
)
2053 head
= tail
= new_iter
;
2057 if (gfc_match_char (',') != MATCH_YES
)
2060 m
= match_forall_iterator (&new_iter
);
2061 if (m
== MATCH_ERROR
)
2066 tail
->next
= new_iter
;
2071 /* Have to have a mask expression. */
2073 m
= gfc_match_expr (&msk
);
2076 if (m
== MATCH_ERROR
)
2082 if (gfc_match_char (')') == MATCH_NO
)
2090 gfc_syntax_error (ST_FORALL
);
2093 gfc_free_expr (msk
);
2094 gfc_free_forall_iterator (head
);
2099 /* Match the rest of a simple FORALL statement that follows an
2103 match_simple_forall (void)
2105 gfc_forall_iterator
*head
;
2114 m
= match_forall_header (&head
, &mask
);
2121 m
= gfc_match_assignment ();
2123 if (m
== MATCH_ERROR
)
2127 m
= gfc_match_pointer_assignment ();
2128 if (m
== MATCH_ERROR
)
2134 c
= XCNEW (gfc_code
);
2136 c
->loc
= gfc_current_locus
;
2138 if (gfc_match_eos () != MATCH_YES
)
2141 gfc_clear_new_st ();
2142 new_st
.op
= EXEC_FORALL
;
2143 new_st
.expr1
= mask
;
2144 new_st
.ext
.forall_iterator
= head
;
2145 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2146 new_st
.block
->next
= c
;
2151 gfc_syntax_error (ST_FORALL
);
2154 gfc_free_forall_iterator (head
);
2155 gfc_free_expr (mask
);
2161 /* Match a FORALL statement. */
2164 gfc_match_forall (gfc_statement
*st
)
2166 gfc_forall_iterator
*head
;
2175 m0
= gfc_match_label ();
2176 if (m0
== MATCH_ERROR
)
2179 m
= gfc_match (" forall");
2183 m
= match_forall_header (&head
, &mask
);
2184 if (m
== MATCH_ERROR
)
2189 if (gfc_match_eos () == MATCH_YES
)
2191 *st
= ST_FORALL_BLOCK
;
2192 new_st
.op
= EXEC_FORALL
;
2193 new_st
.expr1
= mask
;
2194 new_st
.ext
.forall_iterator
= head
;
2198 m
= gfc_match_assignment ();
2199 if (m
== MATCH_ERROR
)
2203 m
= gfc_match_pointer_assignment ();
2204 if (m
== MATCH_ERROR
)
2210 c
= XCNEW (gfc_code
);
2212 c
->loc
= gfc_current_locus
;
2214 gfc_clear_new_st ();
2215 new_st
.op
= EXEC_FORALL
;
2216 new_st
.expr1
= mask
;
2217 new_st
.ext
.forall_iterator
= head
;
2218 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2219 new_st
.block
->next
= c
;
2225 gfc_syntax_error (ST_FORALL
);
2228 gfc_free_forall_iterator (head
);
2229 gfc_free_expr (mask
);
2230 gfc_free_statements (c
);
2235 /* Match a DO statement. */
2240 gfc_iterator iter
, *ip
;
2242 gfc_st_label
*label
;
2245 old_loc
= gfc_current_locus
;
2248 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
2250 m
= gfc_match_label ();
2251 if (m
== MATCH_ERROR
)
2254 if (gfc_match (" do") != MATCH_YES
)
2257 m
= gfc_match_st_label (&label
);
2258 if (m
== MATCH_ERROR
)
2261 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2263 if (gfc_match_eos () == MATCH_YES
)
2265 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
2266 new_st
.op
= EXEC_DO_WHILE
;
2270 /* Match an optional comma, if no comma is found, a space is obligatory. */
2271 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
2274 /* Check for balanced parens. */
2276 if (gfc_match_parens () == MATCH_ERROR
)
2279 if (gfc_match (" concurrent") == MATCH_YES
)
2281 gfc_forall_iterator
*head
;
2284 if (!gfc_notify_std (GFC_STD_F2008
, "DO CONCURRENT construct at %C"))
2290 m
= match_forall_header (&head
, &mask
);
2294 if (m
== MATCH_ERROR
)
2295 goto concurr_cleanup
;
2297 if (gfc_match_eos () != MATCH_YES
)
2298 goto concurr_cleanup
;
2301 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2302 goto concurr_cleanup
;
2304 new_st
.label1
= label
;
2305 new_st
.op
= EXEC_DO_CONCURRENT
;
2306 new_st
.expr1
= mask
;
2307 new_st
.ext
.forall_iterator
= head
;
2312 gfc_syntax_error (ST_DO
);
2313 gfc_free_expr (mask
);
2314 gfc_free_forall_iterator (head
);
2318 /* See if we have a DO WHILE. */
2319 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
2321 new_st
.op
= EXEC_DO_WHILE
;
2325 /* The abortive DO WHILE may have done something to the symbol
2326 table, so we start over. */
2327 gfc_undo_symbols ();
2328 gfc_current_locus
= old_loc
;
2330 gfc_match_label (); /* This won't error. */
2331 gfc_match (" do "); /* This will work. */
2333 gfc_match_st_label (&label
); /* Can't error out. */
2334 gfc_match_char (','); /* Optional comma. */
2336 m
= gfc_match_iterator (&iter
, 0);
2339 if (m
== MATCH_ERROR
)
2342 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
2343 gfc_check_do_variable (iter
.var
->symtree
);
2345 if (gfc_match_eos () != MATCH_YES
)
2347 gfc_syntax_error (ST_DO
);
2351 new_st
.op
= EXEC_DO
;
2355 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2358 new_st
.label1
= label
;
2360 if (new_st
.op
== EXEC_DO_WHILE
)
2361 new_st
.expr1
= iter
.end
;
2364 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
2371 gfc_free_iterator (&iter
, 0);
2377 /* Match an EXIT or CYCLE statement. */
2380 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2382 gfc_state_data
*p
, *o
;
2387 if (gfc_match_eos () == MATCH_YES
)
2391 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2394 m
= gfc_match ("% %n%t", name
);
2395 if (m
== MATCH_ERROR
)
2399 gfc_syntax_error (st
);
2403 /* Find the corresponding symbol. If there's a BLOCK statement
2404 between here and the label, it is not in gfc_current_ns but a parent
2406 stree
= gfc_find_symtree_in_proc (name
, gfc_current_ns
);
2409 gfc_error ("Name %qs in %s statement at %C is unknown",
2410 name
, gfc_ascii_statement (st
));
2415 if (sym
->attr
.flavor
!= FL_LABEL
)
2417 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2418 name
, gfc_ascii_statement (st
));
2423 /* Find the loop specified by the label (or lack of a label). */
2424 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2425 if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2427 else if (p
->state
== COMP_CRITICAL
)
2429 gfc_error("%s statement at %C leaves CRITICAL construct",
2430 gfc_ascii_statement (st
));
2433 else if (p
->state
== COMP_DO_CONCURRENT
2434 && (op
== EXEC_EXIT
|| (sym
&& sym
!= p
->sym
)))
2436 /* F2008, C821 & C845. */
2437 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2438 gfc_ascii_statement (st
));
2441 else if ((sym
&& sym
== p
->sym
)
2442 || (!sym
&& (p
->state
== COMP_DO
2443 || p
->state
== COMP_DO_CONCURRENT
)))
2449 gfc_error ("%s statement at %C is not within a construct",
2450 gfc_ascii_statement (st
));
2452 gfc_error ("%s statement at %C is not within construct %qs",
2453 gfc_ascii_statement (st
), sym
->name
);
2458 /* Special checks for EXIT from non-loop constructs. */
2462 case COMP_DO_CONCURRENT
:
2466 /* This is already handled above. */
2469 case COMP_ASSOCIATE
:
2473 case COMP_SELECT_TYPE
:
2475 if (op
== EXEC_CYCLE
)
2477 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2478 " construct %qs", sym
->name
);
2481 gcc_assert (op
== EXEC_EXIT
);
2482 if (!gfc_notify_std (GFC_STD_F2008
, "EXIT statement with no"
2483 " do-construct-name at %C"))
2488 gfc_error ("%s statement at %C is not applicable to construct %qs",
2489 gfc_ascii_statement (st
), sym
->name
);
2495 gfc_error (is_oacc (p
)
2496 ? "%s statement at %C leaving OpenACC structured block"
2497 : "%s statement at %C leaving OpenMP structured block",
2498 gfc_ascii_statement (st
));
2502 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2506 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
2507 && (o
->head
->op
== EXEC_OACC_LOOP
2508 || o
->head
->op
== EXEC_OACC_PARALLEL_LOOP
))
2511 gcc_assert (o
->head
->next
!= NULL
2512 && (o
->head
->next
->op
== EXEC_DO
2513 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2514 && o
->previous
!= NULL
2515 && o
->previous
->tail
->op
== o
->head
->op
);
2516 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2517 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2518 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2519 if (st
== ST_EXIT
&& cnt
<= collapse
)
2521 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2524 if (st
== ST_CYCLE
&& cnt
< collapse
)
2526 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2527 " !$ACC LOOP loop");
2533 && (o
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2534 && (o
->head
->op
== EXEC_OMP_DO
2535 || o
->head
->op
== EXEC_OMP_PARALLEL_DO
2536 || o
->head
->op
== EXEC_OMP_SIMD
2537 || o
->head
->op
== EXEC_OMP_DO_SIMD
2538 || o
->head
->op
== EXEC_OMP_PARALLEL_DO_SIMD
))
2541 gcc_assert (o
->head
->next
!= NULL
2542 && (o
->head
->next
->op
== EXEC_DO
2543 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2544 && o
->previous
!= NULL
2545 && o
->previous
->tail
->op
== o
->head
->op
);
2546 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2547 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2548 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2549 if (st
== ST_EXIT
&& cnt
<= collapse
)
2551 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2554 if (st
== ST_CYCLE
&& cnt
< collapse
)
2556 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2562 /* Save the first statement in the construct - needed by the backend. */
2563 new_st
.ext
.which_construct
= p
->construct
;
2571 /* Match the EXIT statement. */
2574 gfc_match_exit (void)
2576 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2580 /* Match the CYCLE statement. */
2583 gfc_match_cycle (void)
2585 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2589 /* Match a number or character constant after an (ALL) STOP or PAUSE statement. */
2592 gfc_match_stopcode (gfc_statement st
)
2599 if (gfc_match_eos () != MATCH_YES
)
2601 m
= gfc_match_init_expr (&e
);
2602 if (m
== MATCH_ERROR
)
2607 if (gfc_match_eos () != MATCH_YES
)
2611 if (gfc_pure (NULL
))
2613 gfc_error ("%s statement not allowed in PURE procedure at %C",
2614 gfc_ascii_statement (st
));
2618 gfc_unset_implicit_pure (NULL
);
2620 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
))
2622 gfc_error ("Image control statement STOP at %C in CRITICAL block");
2625 if (st
== ST_STOP
&& gfc_find_state (COMP_DO_CONCURRENT
))
2627 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
2633 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
2635 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2642 gfc_error ("STOP code at %L must be scalar",
2647 if (e
->ts
.type
== BT_CHARACTER
2648 && e
->ts
.kind
!= gfc_default_character_kind
)
2650 gfc_error ("STOP code at %L must be default character KIND=%d",
2651 &e
->where
, (int) gfc_default_character_kind
);
2655 if (e
->ts
.type
== BT_INTEGER
2656 && e
->ts
.kind
!= gfc_default_integer_kind
)
2658 gfc_error ("STOP code at %L must be default integer KIND=%d",
2659 &e
->where
, (int) gfc_default_integer_kind
);
2667 new_st
.op
= EXEC_STOP
;
2670 new_st
.op
= EXEC_ERROR_STOP
;
2673 new_st
.op
= EXEC_PAUSE
;
2680 new_st
.ext
.stop_code
= -1;
2685 gfc_syntax_error (st
);
2694 /* Match the (deprecated) PAUSE statement. */
2697 gfc_match_pause (void)
2701 m
= gfc_match_stopcode (ST_PAUSE
);
2704 if (!gfc_notify_std (GFC_STD_F95_DEL
, "PAUSE statement at %C"))
2711 /* Match the STOP statement. */
2714 gfc_match_stop (void)
2716 return gfc_match_stopcode (ST_STOP
);
2720 /* Match the ERROR STOP statement. */
2723 gfc_match_error_stop (void)
2725 if (!gfc_notify_std (GFC_STD_F2008
, "ERROR STOP statement at %C"))
2728 return gfc_match_stopcode (ST_ERROR_STOP
);
2732 /* Match LOCK/UNLOCK statement. Syntax:
2733 LOCK ( lock-variable [ , lock-stat-list ] )
2734 UNLOCK ( lock-variable [ , sync-stat-list ] )
2735 where lock-stat is ACQUIRED_LOCK or sync-stat
2736 and sync-stat is STAT= or ERRMSG=. */
2739 lock_unlock_statement (gfc_statement st
)
2742 gfc_expr
*tmp
, *lockvar
, *acq_lock
, *stat
, *errmsg
;
2743 bool saw_acq_lock
, saw_stat
, saw_errmsg
;
2745 tmp
= lockvar
= acq_lock
= stat
= errmsg
= NULL
;
2746 saw_acq_lock
= saw_stat
= saw_errmsg
= false;
2748 if (gfc_pure (NULL
))
2750 gfc_error ("Image control statement %s at %C in PURE procedure",
2751 st
== ST_LOCK
? "LOCK" : "UNLOCK");
2755 gfc_unset_implicit_pure (NULL
);
2757 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2759 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2763 if (gfc_find_state (COMP_CRITICAL
))
2765 gfc_error ("Image control statement %s at %C in CRITICAL block",
2766 st
== ST_LOCK
? "LOCK" : "UNLOCK");
2770 if (gfc_find_state (COMP_DO_CONCURRENT
))
2772 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
2773 st
== ST_LOCK
? "LOCK" : "UNLOCK");
2777 if (gfc_match_char ('(') != MATCH_YES
)
2780 if (gfc_match ("%e", &lockvar
) != MATCH_YES
)
2782 m
= gfc_match_char (',');
2783 if (m
== MATCH_ERROR
)
2787 m
= gfc_match_char (')');
2795 m
= gfc_match (" stat = %v", &tmp
);
2796 if (m
== MATCH_ERROR
)
2802 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
2808 m
= gfc_match_char (',');
2816 m
= gfc_match (" errmsg = %v", &tmp
);
2817 if (m
== MATCH_ERROR
)
2823 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
2829 m
= gfc_match_char (',');
2837 m
= gfc_match (" acquired_lock = %v", &tmp
);
2838 if (m
== MATCH_ERROR
|| st
== ST_UNLOCK
)
2844 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
2849 saw_acq_lock
= true;
2851 m
= gfc_match_char (',');
2862 if (m
== MATCH_ERROR
)
2865 if (gfc_match (" )%t") != MATCH_YES
)
2872 new_st
.op
= EXEC_LOCK
;
2875 new_st
.op
= EXEC_UNLOCK
;
2881 new_st
.expr1
= lockvar
;
2882 new_st
.expr2
= stat
;
2883 new_st
.expr3
= errmsg
;
2884 new_st
.expr4
= acq_lock
;
2889 gfc_syntax_error (st
);
2892 if (acq_lock
!= tmp
)
2893 gfc_free_expr (acq_lock
);
2895 gfc_free_expr (errmsg
);
2897 gfc_free_expr (stat
);
2899 gfc_free_expr (tmp
);
2900 gfc_free_expr (lockvar
);
2907 gfc_match_lock (void)
2909 if (!gfc_notify_std (GFC_STD_F2008
, "LOCK statement at %C"))
2912 return lock_unlock_statement (ST_LOCK
);
2917 gfc_match_unlock (void)
2919 if (!gfc_notify_std (GFC_STD_F2008
, "UNLOCK statement at %C"))
2922 return lock_unlock_statement (ST_UNLOCK
);
2926 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
2927 SYNC ALL [(sync-stat-list)]
2928 SYNC MEMORY [(sync-stat-list)]
2929 SYNC IMAGES (image-set [, sync-stat-list] )
2930 with sync-stat is int-expr or *. */
2933 sync_statement (gfc_statement st
)
2936 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
2937 bool saw_stat
, saw_errmsg
;
2939 tmp
= imageset
= stat
= errmsg
= NULL
;
2940 saw_stat
= saw_errmsg
= false;
2942 if (gfc_pure (NULL
))
2944 gfc_error ("Image control statement SYNC at %C in PURE procedure");
2948 gfc_unset_implicit_pure (NULL
);
2950 if (!gfc_notify_std (GFC_STD_F2008
, "SYNC statement at %C"))
2953 if (flag_coarray
== GFC_FCOARRAY_NONE
)
2955 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
2960 if (gfc_find_state (COMP_CRITICAL
))
2962 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
2966 if (gfc_find_state (COMP_DO_CONCURRENT
))
2968 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
2972 if (gfc_match_eos () == MATCH_YES
)
2974 if (st
== ST_SYNC_IMAGES
)
2979 if (gfc_match_char ('(') != MATCH_YES
)
2982 if (st
== ST_SYNC_IMAGES
)
2984 /* Denote '*' as imageset == NULL. */
2985 m
= gfc_match_char ('*');
2986 if (m
== MATCH_ERROR
)
2990 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
2993 m
= gfc_match_char (',');
2994 if (m
== MATCH_ERROR
)
2998 m
= gfc_match_char (')');
3007 m
= gfc_match (" stat = %v", &tmp
);
3008 if (m
== MATCH_ERROR
)
3014 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3020 if (gfc_match_char (',') == MATCH_YES
)
3027 m
= gfc_match (" errmsg = %v", &tmp
);
3028 if (m
== MATCH_ERROR
)
3034 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3040 if (gfc_match_char (',') == MATCH_YES
)
3050 if (gfc_match (" )%t") != MATCH_YES
)
3057 new_st
.op
= EXEC_SYNC_ALL
;
3059 case ST_SYNC_IMAGES
:
3060 new_st
.op
= EXEC_SYNC_IMAGES
;
3062 case ST_SYNC_MEMORY
:
3063 new_st
.op
= EXEC_SYNC_MEMORY
;
3069 new_st
.expr1
= imageset
;
3070 new_st
.expr2
= stat
;
3071 new_st
.expr3
= errmsg
;
3076 gfc_syntax_error (st
);
3080 gfc_free_expr (stat
);
3082 gfc_free_expr (errmsg
);
3084 gfc_free_expr (tmp
);
3085 gfc_free_expr (imageset
);
3091 /* Match SYNC ALL statement. */
3094 gfc_match_sync_all (void)
3096 return sync_statement (ST_SYNC_ALL
);
3100 /* Match SYNC IMAGES statement. */
3103 gfc_match_sync_images (void)
3105 return sync_statement (ST_SYNC_IMAGES
);
3109 /* Match SYNC MEMORY statement. */
3112 gfc_match_sync_memory (void)
3114 return sync_statement (ST_SYNC_MEMORY
);
3118 /* Match a CONTINUE statement. */
3121 gfc_match_continue (void)
3123 if (gfc_match_eos () != MATCH_YES
)
3125 gfc_syntax_error (ST_CONTINUE
);
3129 new_st
.op
= EXEC_CONTINUE
;
3134 /* Match the (deprecated) ASSIGN statement. */
3137 gfc_match_assign (void)
3140 gfc_st_label
*label
;
3142 if (gfc_match (" %l", &label
) == MATCH_YES
)
3144 if (!gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
))
3146 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
3148 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGN statement at %C"))
3151 expr
->symtree
->n
.sym
->attr
.assign
= 1;
3153 new_st
.op
= EXEC_LABEL_ASSIGN
;
3154 new_st
.label1
= label
;
3155 new_st
.expr1
= expr
;
3163 /* Match the GO TO statement. As a computed GOTO statement is
3164 matched, it is transformed into an equivalent SELECT block. No
3165 tree is necessary, and the resulting jumps-to-jumps are
3166 specifically optimized away by the back end. */
3169 gfc_match_goto (void)
3171 gfc_code
*head
, *tail
;
3174 gfc_st_label
*label
;
3178 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
3180 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3183 new_st
.op
= EXEC_GOTO
;
3184 new_st
.label1
= label
;
3188 /* The assigned GO TO statement. */
3190 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
3192 if (!gfc_notify_std (GFC_STD_F95_DEL
, "Assigned GOTO statement at %C"))
3195 new_st
.op
= EXEC_GOTO
;
3196 new_st
.expr1
= expr
;
3198 if (gfc_match_eos () == MATCH_YES
)
3201 /* Match label list. */
3202 gfc_match_char (',');
3203 if (gfc_match_char ('(') != MATCH_YES
)
3205 gfc_syntax_error (ST_GOTO
);
3212 m
= gfc_match_st_label (&label
);
3216 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3220 head
= tail
= gfc_get_code (EXEC_GOTO
);
3223 tail
->block
= gfc_get_code (EXEC_GOTO
);
3227 tail
->label1
= label
;
3229 while (gfc_match_char (',') == MATCH_YES
);
3231 if (gfc_match (")%t") != MATCH_YES
)
3236 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3239 new_st
.block
= head
;
3244 /* Last chance is a computed GO TO statement. */
3245 if (gfc_match_char ('(') != MATCH_YES
)
3247 gfc_syntax_error (ST_GOTO
);
3256 m
= gfc_match_st_label (&label
);
3260 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3264 head
= tail
= gfc_get_code (EXEC_SELECT
);
3267 tail
->block
= gfc_get_code (EXEC_SELECT
);
3271 cp
= gfc_get_case ();
3272 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
3275 tail
->ext
.block
.case_list
= cp
;
3277 tail
->next
= gfc_get_code (EXEC_GOTO
);
3278 tail
->next
->label1
= label
;
3280 while (gfc_match_char (',') == MATCH_YES
);
3282 if (gfc_match_char (')') != MATCH_YES
)
3287 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3291 /* Get the rest of the statement. */
3292 gfc_match_char (',');
3294 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
3297 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Computed GOTO at %C"))
3300 /* At this point, a computed GOTO has been fully matched and an
3301 equivalent SELECT statement constructed. */
3303 new_st
.op
= EXEC_SELECT
;
3304 new_st
.expr1
= NULL
;
3306 /* Hack: For a "real" SELECT, the expression is in expr. We put
3307 it in expr2 so we can distinguish then and produce the correct
3309 new_st
.expr2
= expr
;
3310 new_st
.block
= head
;
3314 gfc_syntax_error (ST_GOTO
);
3316 gfc_free_statements (head
);
3321 /* Frees a list of gfc_alloc structures. */
3324 gfc_free_alloc_list (gfc_alloc
*p
)
3331 gfc_free_expr (p
->expr
);
3337 /* Match an ALLOCATE statement. */
3340 gfc_match_allocate (void)
3342 gfc_alloc
*head
, *tail
;
3343 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
3347 locus old_locus
, deferred_locus
;
3348 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, saw_deferred
, b1
, b2
, b3
;
3349 bool saw_unlimited
= false;
3352 stat
= errmsg
= source
= mold
= tmp
= NULL
;
3353 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= saw_deferred
= false;
3355 if (gfc_match_char ('(') != MATCH_YES
)
3358 /* Match an optional type-spec. */
3359 old_locus
= gfc_current_locus
;
3360 m
= gfc_match_type_spec (&ts
);
3361 if (m
== MATCH_ERROR
)
3363 else if (m
== MATCH_NO
)
3365 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
3367 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
3369 gfc_error ("Error in type-spec at %L", &old_locus
);
3373 ts
.type
= BT_UNKNOWN
;
3377 if (gfc_match (" :: ") == MATCH_YES
)
3379 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
3385 gfc_error ("Type-spec at %L cannot contain a deferred "
3386 "type parameter", &old_locus
);
3390 if (ts
.type
== BT_CHARACTER
)
3391 ts
.u
.cl
->length_from_typespec
= true;
3395 ts
.type
= BT_UNKNOWN
;
3396 gfc_current_locus
= old_locus
;
3403 head
= tail
= gfc_get_alloc ();
3406 tail
->next
= gfc_get_alloc ();
3410 m
= gfc_match_variable (&tail
->expr
, 0);
3413 if (m
== MATCH_ERROR
)
3416 if (gfc_check_do_variable (tail
->expr
->symtree
))
3419 bool impure
= gfc_impure_variable (tail
->expr
->symtree
->n
.sym
);
3420 if (impure
&& gfc_pure (NULL
))
3422 gfc_error ("Bad allocate-object at %C for a PURE procedure");
3427 gfc_unset_implicit_pure (NULL
);
3429 if (tail
->expr
->ts
.deferred
)
3431 saw_deferred
= true;
3432 deferred_locus
= tail
->expr
->where
;
3435 if (gfc_find_state (COMP_DO_CONCURRENT
)
3436 || gfc_find_state (COMP_CRITICAL
))
3439 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
3440 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
3441 if (ref
->type
== REF_COMPONENT
)
3442 coarray
= ref
->u
.c
.component
->attr
.codimension
;
3444 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
3446 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
3449 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
3451 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
3456 /* Check for F08:C628. */
3457 sym
= tail
->expr
->symtree
->n
.sym
;
3458 b1
= !(tail
->expr
->ref
3459 && (tail
->expr
->ref
->type
== REF_COMPONENT
3460 || tail
->expr
->ref
->type
== REF_ARRAY
));
3461 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
3462 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
3463 || CLASS_DATA (sym
)->attr
.class_pointer
);
3465 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
3466 || sym
->attr
.proc_pointer
);
3467 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
3468 && (sym
->ns
->proc_name
->attr
.allocatable
3469 || sym
->ns
->proc_name
->attr
.pointer
3470 || sym
->ns
->proc_name
->attr
.proc_pointer
);
3471 if (b1
&& b2
&& !b3
)
3473 gfc_error ("Allocate-object at %L is neither a data pointer "
3474 "nor an allocatable variable", &tail
->expr
->where
);
3478 /* The ALLOCATE statement had an optional typespec. Check the
3480 if (ts
.type
!= BT_UNKNOWN
)
3482 /* Enforce F03:C624. */
3483 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
3485 gfc_error ("Type of entity at %L is type incompatible with "
3486 "typespec", &tail
->expr
->where
);
3490 /* Enforce F03:C627. */
3491 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
3493 gfc_error ("Kind type parameter for entity at %L differs from "
3494 "the kind type parameter of the typespec",
3495 &tail
->expr
->where
);
3500 if (tail
->expr
->ts
.type
== BT_DERIVED
)
3501 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
3503 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
3505 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
3507 gfc_error ("Shape specification for allocatable scalar at %C");
3511 if (gfc_match_char (',') != MATCH_YES
)
3516 m
= gfc_match (" stat = %v", &tmp
);
3517 if (m
== MATCH_ERROR
)
3524 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3532 if (gfc_check_do_variable (stat
->symtree
))
3535 if (gfc_match_char (',') == MATCH_YES
)
3536 goto alloc_opt_list
;
3539 m
= gfc_match (" errmsg = %v", &tmp
);
3540 if (m
== MATCH_ERROR
)
3544 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
3550 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3558 if (gfc_match_char (',') == MATCH_YES
)
3559 goto alloc_opt_list
;
3562 m
= gfc_match (" source = %e", &tmp
);
3563 if (m
== MATCH_ERROR
)
3567 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
3573 gfc_error ("Redundant SOURCE tag found at %L ", &tmp
->where
);
3577 /* The next 2 conditionals check C631. */
3578 if (ts
.type
!= BT_UNKNOWN
)
3580 gfc_error_1 ("SOURCE tag at %L conflicts with the typespec at %L",
3581 &tmp
->where
, &old_locus
);
3586 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
3587 " with more than a single allocate object",
3595 if (gfc_match_char (',') == MATCH_YES
)
3596 goto alloc_opt_list
;
3599 m
= gfc_match (" mold = %e", &tmp
);
3600 if (m
== MATCH_ERROR
)
3604 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
3607 /* Check F08:C636. */
3610 gfc_error ("Redundant MOLD tag found at %L ", &tmp
->where
);
3614 /* Check F08:C637. */
3615 if (ts
.type
!= BT_UNKNOWN
)
3617 gfc_error_1 ("MOLD tag at %L conflicts with the typespec at %L",
3618 &tmp
->where
, &old_locus
);
3627 if (gfc_match_char (',') == MATCH_YES
)
3628 goto alloc_opt_list
;
3631 gfc_gobble_whitespace ();
3633 if (gfc_peek_char () == ')')
3637 if (gfc_match (" )%t") != MATCH_YES
)
3640 /* Check F08:C637. */
3643 gfc_error_1 ("MOLD tag at %L conflicts with SOURCE tag at %L",
3644 &mold
->where
, &source
->where
);
3648 /* Check F03:C623, */
3649 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
3651 gfc_error ("Allocate-object at %L with a deferred type parameter "
3652 "requires either a type-spec or SOURCE tag or a MOLD tag",
3657 /* Check F03:C625, */
3658 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
3660 for (tail
= head
; tail
; tail
= tail
->next
)
3662 if (UNLIMITED_POLY (tail
->expr
))
3663 gfc_error ("Unlimited polymorphic allocate-object at %L "
3664 "requires either a type-spec or SOURCE tag "
3665 "or a MOLD tag", &tail
->expr
->where
);
3670 new_st
.op
= EXEC_ALLOCATE
;
3671 new_st
.expr1
= stat
;
3672 new_st
.expr2
= errmsg
;
3674 new_st
.expr3
= source
;
3676 new_st
.expr3
= mold
;
3677 new_st
.ext
.alloc
.list
= head
;
3678 new_st
.ext
.alloc
.ts
= ts
;
3683 gfc_syntax_error (ST_ALLOCATE
);
3686 gfc_free_expr (errmsg
);
3687 gfc_free_expr (source
);
3688 gfc_free_expr (stat
);
3689 gfc_free_expr (mold
);
3690 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
3691 gfc_free_alloc_list (head
);
3696 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
3697 a set of pointer assignments to intrinsic NULL(). */
3700 gfc_match_nullify (void)
3708 if (gfc_match_char ('(') != MATCH_YES
)
3713 m
= gfc_match_variable (&p
, 0);
3714 if (m
== MATCH_ERROR
)
3719 if (gfc_check_do_variable (p
->symtree
))
3723 if (gfc_is_coindexed (p
))
3725 gfc_error ("Pointer object at %C shall not be coindexed");
3729 /* build ' => NULL() '. */
3730 e
= gfc_get_null_expr (&gfc_current_locus
);
3732 /* Chain to list. */
3736 tail
->op
= EXEC_POINTER_ASSIGN
;
3740 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
3747 if (gfc_match (" )%t") == MATCH_YES
)
3749 if (gfc_match_char (',') != MATCH_YES
)
3756 gfc_syntax_error (ST_NULLIFY
);
3759 gfc_free_statements (new_st
.next
);
3761 gfc_free_expr (new_st
.expr1
);
3762 new_st
.expr1
= NULL
;
3763 gfc_free_expr (new_st
.expr2
);
3764 new_st
.expr2
= NULL
;
3769 /* Match a DEALLOCATE statement. */
3772 gfc_match_deallocate (void)
3774 gfc_alloc
*head
, *tail
;
3775 gfc_expr
*stat
, *errmsg
, *tmp
;
3778 bool saw_stat
, saw_errmsg
, b1
, b2
;
3781 stat
= errmsg
= tmp
= NULL
;
3782 saw_stat
= saw_errmsg
= false;
3784 if (gfc_match_char ('(') != MATCH_YES
)
3790 head
= tail
= gfc_get_alloc ();
3793 tail
->next
= gfc_get_alloc ();
3797 m
= gfc_match_variable (&tail
->expr
, 0);
3798 if (m
== MATCH_ERROR
)
3803 if (gfc_check_do_variable (tail
->expr
->symtree
))
3806 sym
= tail
->expr
->symtree
->n
.sym
;
3808 bool impure
= gfc_impure_variable (sym
);
3809 if (impure
&& gfc_pure (NULL
))
3811 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3816 gfc_unset_implicit_pure (NULL
);
3818 if (gfc_is_coarray (tail
->expr
)
3819 && gfc_find_state (COMP_DO_CONCURRENT
))
3821 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
3825 if (gfc_is_coarray (tail
->expr
)
3826 && gfc_find_state (COMP_CRITICAL
))
3828 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
3832 /* FIXME: disable the checking on derived types. */
3833 b1
= !(tail
->expr
->ref
3834 && (tail
->expr
->ref
->type
== REF_COMPONENT
3835 || tail
->expr
->ref
->type
== REF_ARRAY
));
3836 if (sym
&& sym
->ts
.type
== BT_CLASS
)
3837 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
3838 || CLASS_DATA (sym
)->attr
.class_pointer
);
3840 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
3841 || sym
->attr
.proc_pointer
);
3844 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3845 "nor an allocatable variable");
3849 if (gfc_match_char (',') != MATCH_YES
)
3854 m
= gfc_match (" stat = %v", &tmp
);
3855 if (m
== MATCH_ERROR
)
3861 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3862 gfc_free_expr (tmp
);
3869 if (gfc_check_do_variable (stat
->symtree
))
3872 if (gfc_match_char (',') == MATCH_YES
)
3873 goto dealloc_opt_list
;
3876 m
= gfc_match (" errmsg = %v", &tmp
);
3877 if (m
== MATCH_ERROR
)
3881 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
3886 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3887 gfc_free_expr (tmp
);
3894 if (gfc_match_char (',') == MATCH_YES
)
3895 goto dealloc_opt_list
;
3898 gfc_gobble_whitespace ();
3900 if (gfc_peek_char () == ')')
3904 if (gfc_match (" )%t") != MATCH_YES
)
3907 new_st
.op
= EXEC_DEALLOCATE
;
3908 new_st
.expr1
= stat
;
3909 new_st
.expr2
= errmsg
;
3910 new_st
.ext
.alloc
.list
= head
;
3915 gfc_syntax_error (ST_DEALLOCATE
);
3918 gfc_free_expr (errmsg
);
3919 gfc_free_expr (stat
);
3920 gfc_free_alloc_list (head
);
3925 /* Match a RETURN statement. */
3928 gfc_match_return (void)
3932 gfc_compile_state s
;
3936 if (gfc_find_state (COMP_CRITICAL
))
3938 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
3942 if (gfc_find_state (COMP_DO_CONCURRENT
))
3944 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
3948 if (gfc_match_eos () == MATCH_YES
)
3951 if (!gfc_find_state (COMP_SUBROUTINE
))
3953 gfc_error ("Alternate RETURN statement at %C is only allowed within "
3958 if (gfc_current_form
== FORM_FREE
)
3960 /* The following are valid, so we can't require a blank after the
3964 char c
= gfc_peek_ascii_char ();
3965 if (ISALPHA (c
) || ISDIGIT (c
))
3969 m
= gfc_match (" %e%t", &e
);
3972 if (m
== MATCH_ERROR
)
3975 gfc_syntax_error (ST_RETURN
);
3982 gfc_enclosing_unit (&s
);
3983 if (s
== COMP_PROGRAM
3984 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
3985 "main program at %C"))
3988 new_st
.op
= EXEC_RETURN
;
3995 /* Match the call of a type-bound procedure, if CALL%var has already been
3996 matched and var found to be a derived-type variable. */
3999 match_typebound_call (gfc_symtree
* varst
)
4004 base
= gfc_get_expr ();
4005 base
->expr_type
= EXPR_VARIABLE
;
4006 base
->symtree
= varst
;
4007 base
->where
= gfc_current_locus
;
4008 gfc_set_sym_referenced (varst
->n
.sym
);
4010 m
= gfc_match_varspec (base
, 0, true, true);
4012 gfc_error ("Expected component reference at %C");
4015 gfc_free_expr (base
);
4019 if (gfc_match_eos () != MATCH_YES
)
4021 gfc_error ("Junk after CALL at %C");
4022 gfc_free_expr (base
);
4026 if (base
->expr_type
== EXPR_COMPCALL
)
4027 new_st
.op
= EXEC_COMPCALL
;
4028 else if (base
->expr_type
== EXPR_PPC
)
4029 new_st
.op
= EXEC_CALL_PPC
;
4032 gfc_error ("Expected type-bound procedure or procedure pointer component "
4034 gfc_free_expr (base
);
4037 new_st
.expr1
= base
;
4043 /* Match a CALL statement. The tricky part here are possible
4044 alternate return specifiers. We handle these by having all
4045 "subroutines" actually return an integer via a register that gives
4046 the return number. If the call specifies alternate returns, we
4047 generate code for a SELECT statement whose case clauses contain
4048 GOTOs to the various labels. */
4051 gfc_match_call (void)
4053 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4054 gfc_actual_arglist
*a
, *arglist
;
4064 m
= gfc_match ("% %n", name
);
4070 if (gfc_get_ha_sym_tree (name
, &st
))
4075 /* If this is a variable of derived-type, it probably starts a type-bound
4077 if ((sym
->attr
.flavor
!= FL_PROCEDURE
4078 || gfc_is_function_return_value (sym
, gfc_current_ns
))
4079 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
4080 return match_typebound_call (st
);
4082 /* If it does not seem to be callable (include functions so that the
4083 right association is made. They are thrown out in resolution.)
4085 if (!sym
->attr
.generic
4086 && !sym
->attr
.subroutine
4087 && !sym
->attr
.function
)
4089 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
4091 /* ...create a symbol in this scope... */
4092 if (sym
->ns
!= gfc_current_ns
4093 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
4096 if (sym
!= st
->n
.sym
)
4100 /* ...and then to try to make the symbol into a subroutine. */
4101 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
4105 gfc_set_sym_referenced (sym
);
4107 if (gfc_match_eos () != MATCH_YES
)
4109 m
= gfc_match_actual_arglist (1, &arglist
);
4112 if (m
== MATCH_ERROR
)
4115 if (gfc_match_eos () != MATCH_YES
)
4119 /* If any alternate return labels were found, construct a SELECT
4120 statement that will jump to the right place. */
4123 for (a
= arglist
; a
; a
= a
->next
)
4124 if (a
->expr
== NULL
)
4132 gfc_symtree
*select_st
;
4133 gfc_symbol
*select_sym
;
4134 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4136 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
4137 sprintf (name
, "_result_%s", sym
->name
);
4138 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
4140 select_sym
= select_st
->n
.sym
;
4141 select_sym
->ts
.type
= BT_INTEGER
;
4142 select_sym
->ts
.kind
= gfc_default_integer_kind
;
4143 gfc_set_sym_referenced (select_sym
);
4144 c
->expr1
= gfc_get_expr ();
4145 c
->expr1
->expr_type
= EXPR_VARIABLE
;
4146 c
->expr1
->symtree
= select_st
;
4147 c
->expr1
->ts
= select_sym
->ts
;
4148 c
->expr1
->where
= gfc_current_locus
;
4151 for (a
= arglist
; a
; a
= a
->next
)
4153 if (a
->expr
!= NULL
)
4156 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
4161 c
->block
= gfc_get_code (EXEC_SELECT
);
4164 new_case
= gfc_get_case ();
4165 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
4166 new_case
->low
= new_case
->high
;
4167 c
->ext
.block
.case_list
= new_case
;
4169 c
->next
= gfc_get_code (EXEC_GOTO
);
4170 c
->next
->label1
= a
->label
;
4174 new_st
.op
= EXEC_CALL
;
4175 new_st
.symtree
= st
;
4176 new_st
.ext
.actual
= arglist
;
4181 gfc_syntax_error (ST_CALL
);
4184 gfc_free_actual_arglist (arglist
);
4189 /* Given a name, return a pointer to the common head structure,
4190 creating it if it does not exist. If FROM_MODULE is nonzero, we
4191 mangle the name so that it doesn't interfere with commons defined
4192 in the using namespace.
4193 TODO: Add to global symbol tree. */
4196 gfc_get_common (const char *name
, int from_module
)
4199 static int serial
= 0;
4200 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
4204 /* A use associated common block is only needed to correctly layout
4205 the variables it contains. */
4206 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
4207 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
4211 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
4214 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
4217 if (st
->n
.common
== NULL
)
4219 st
->n
.common
= gfc_get_common_head ();
4220 st
->n
.common
->where
= gfc_current_locus
;
4221 strcpy (st
->n
.common
->name
, name
);
4224 return st
->n
.common
;
4228 /* Match a common block name. */
4230 match
match_common_name (char *name
)
4234 if (gfc_match_char ('/') == MATCH_NO
)
4240 if (gfc_match_char ('/') == MATCH_YES
)
4246 m
= gfc_match_name (name
);
4248 if (m
== MATCH_ERROR
)
4250 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
4253 gfc_error ("Syntax error in common block name at %C");
4258 /* Match a COMMON statement. */
4261 gfc_match_common (void)
4263 gfc_symbol
*sym
, **head
, *tail
, *other
, *old_blank_common
;
4264 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4270 old_blank_common
= gfc_current_ns
->blank_common
.head
;
4271 if (old_blank_common
)
4273 while (old_blank_common
->common_next
)
4274 old_blank_common
= old_blank_common
->common_next
;
4281 m
= match_common_name (name
);
4282 if (m
== MATCH_ERROR
)
4285 if (name
[0] == '\0')
4287 t
= &gfc_current_ns
->blank_common
;
4288 if (t
->head
== NULL
)
4289 t
->where
= gfc_current_locus
;
4293 t
= gfc_get_common (name
, 0);
4302 while (tail
->common_next
)
4303 tail
= tail
->common_next
;
4306 /* Grab the list of symbols. */
4309 m
= gfc_match_symbol (&sym
, 0);
4310 if (m
== MATCH_ERROR
)
4315 /* Store a ref to the common block for error checking. */
4316 sym
->common_block
= t
;
4317 sym
->common_block
->refs
++;
4319 /* See if we know the current common block is bind(c), and if
4320 so, then see if we can check if the symbol is (which it'll
4321 need to be). This can happen if the bind(c) attr stmt was
4322 applied to the common block, and the variable(s) already
4323 defined, before declaring the common block. */
4324 if (t
->is_bind_c
== 1)
4326 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
4328 /* If we find an error, just print it and continue,
4329 cause it's just semantic, and we can see if there
4331 gfc_error_now_1 ("Variable '%s' at %L in common block '%s' "
4332 "at %C must be declared with a C "
4333 "interoperable kind since common block "
4335 sym
->name
, &(sym
->declared_at
), t
->name
,
4339 if (sym
->attr
.is_bind_c
== 1)
4340 gfc_error_now ("Variable %qs in common block %qs at %C can not "
4341 "be bind(c) since it is not global", sym
->name
,
4345 if (sym
->attr
.in_common
)
4347 gfc_error ("Symbol %qs at %C is already in a COMMON block",
4352 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
4353 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
4355 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol %qs at "
4356 "%C can only be COMMON in BLOCK DATA",
4361 if (!gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
))
4365 tail
->common_next
= sym
;
4371 /* Deal with an optional array specification after the
4373 m
= gfc_match_array_spec (&as
, true, true);
4374 if (m
== MATCH_ERROR
)
4379 if (as
->type
!= AS_EXPLICIT
)
4381 gfc_error ("Array specification for symbol %qs in COMMON "
4382 "at %C must be explicit", sym
->name
);
4386 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
4389 if (sym
->attr
.pointer
)
4391 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
4392 "POINTER array", sym
->name
);
4401 sym
->common_head
= t
;
4403 /* Check to see if the symbol is already in an equivalence group.
4404 If it is, set the other members as being in common. */
4405 if (sym
->attr
.in_equivalence
)
4407 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
4409 for (e2
= e1
; e2
; e2
= e2
->eq
)
4410 if (e2
->expr
->symtree
->n
.sym
== sym
)
4417 for (e2
= e1
; e2
; e2
= e2
->eq
)
4419 other
= e2
->expr
->symtree
->n
.sym
;
4420 if (other
->common_head
4421 && other
->common_head
!= sym
->common_head
)
4423 gfc_error ("Symbol %qs, in COMMON block %qs at "
4424 "%C is being indirectly equivalenced to "
4425 "another COMMON block %qs",
4426 sym
->name
, sym
->common_head
->name
,
4427 other
->common_head
->name
);
4430 other
->attr
.in_common
= 1;
4431 other
->common_head
= t
;
4437 gfc_gobble_whitespace ();
4438 if (gfc_match_eos () == MATCH_YES
)
4440 if (gfc_peek_ascii_char () == '/')
4442 if (gfc_match_char (',') != MATCH_YES
)
4444 gfc_gobble_whitespace ();
4445 if (gfc_peek_ascii_char () == '/')
4454 gfc_syntax_error (ST_COMMON
);
4457 gfc_free_array_spec (as
);
4462 /* Match a BLOCK DATA program unit. */
4465 gfc_match_block_data (void)
4467 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4471 if (gfc_match_eos () == MATCH_YES
)
4473 gfc_new_block
= NULL
;
4477 m
= gfc_match ("% %n%t", name
);
4481 if (gfc_get_symbol (name
, NULL
, &sym
))
4484 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
4487 gfc_new_block
= sym
;
4493 /* Free a namelist structure. */
4496 gfc_free_namelist (gfc_namelist
*name
)
4500 for (; name
; name
= n
)
4508 /* Free an OpenMP namelist structure. */
4511 gfc_free_omp_namelist (gfc_omp_namelist
*name
)
4513 gfc_omp_namelist
*n
;
4515 for (; name
; name
= n
)
4517 gfc_free_expr (name
->expr
);
4520 if (name
->udr
->combiner
)
4521 gfc_free_statement (name
->udr
->combiner
);
4522 if (name
->udr
->initializer
)
4523 gfc_free_statement (name
->udr
->initializer
);
4532 /* Match a NAMELIST statement. */
4535 gfc_match_namelist (void)
4537 gfc_symbol
*group_name
, *sym
;
4541 m
= gfc_match (" / %s /", &group_name
);
4544 if (m
== MATCH_ERROR
)
4549 if (group_name
->ts
.type
!= BT_UNKNOWN
)
4551 gfc_error ("Namelist group name %qs at %C already has a basic "
4552 "type of %s", group_name
->name
,
4553 gfc_typename (&group_name
->ts
));
4557 if (group_name
->attr
.flavor
== FL_NAMELIST
4558 && group_name
->attr
.use_assoc
4559 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name %qs "
4560 "at %C already is USE associated and can"
4561 "not be respecified.", group_name
->name
))
4564 if (group_name
->attr
.flavor
!= FL_NAMELIST
4565 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
4566 group_name
->name
, NULL
))
4571 m
= gfc_match_symbol (&sym
, 1);
4574 if (m
== MATCH_ERROR
)
4577 if (sym
->attr
.in_namelist
== 0
4578 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
4581 /* Use gfc_error_check here, rather than goto error, so that
4582 these are the only errors for the next two lines. */
4583 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
4585 gfc_error ("Assumed size array %qs in namelist %qs at "
4586 "%C is not allowed", sym
->name
, group_name
->name
);
4590 nl
= gfc_get_namelist ();
4594 if (group_name
->namelist
== NULL
)
4595 group_name
->namelist
= group_name
->namelist_tail
= nl
;
4598 group_name
->namelist_tail
->next
= nl
;
4599 group_name
->namelist_tail
= nl
;
4602 if (gfc_match_eos () == MATCH_YES
)
4605 m
= gfc_match_char (',');
4607 if (gfc_match_char ('/') == MATCH_YES
)
4609 m2
= gfc_match (" %s /", &group_name
);
4610 if (m2
== MATCH_YES
)
4612 if (m2
== MATCH_ERROR
)
4626 gfc_syntax_error (ST_NAMELIST
);
4633 /* Match a MODULE statement. */
4636 gfc_match_module (void)
4640 m
= gfc_match (" %s%t", &gfc_new_block
);
4644 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
4645 gfc_new_block
->name
, NULL
))
4652 /* Free equivalence sets and lists. Recursively is the easiest way to
4656 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
4661 gfc_free_equiv (eq
->eq
);
4662 gfc_free_equiv_until (eq
->next
, stop
);
4663 gfc_free_expr (eq
->expr
);
4669 gfc_free_equiv (gfc_equiv
*eq
)
4671 gfc_free_equiv_until (eq
, NULL
);
4675 /* Match an EQUIVALENCE statement. */
4678 gfc_match_equivalence (void)
4680 gfc_equiv
*eq
, *set
, *tail
;
4684 gfc_common_head
*common_head
= NULL
;
4692 eq
= gfc_get_equiv ();
4696 eq
->next
= gfc_current_ns
->equiv
;
4697 gfc_current_ns
->equiv
= eq
;
4699 if (gfc_match_char ('(') != MATCH_YES
)
4703 common_flag
= FALSE
;
4708 m
= gfc_match_equiv_variable (&set
->expr
);
4709 if (m
== MATCH_ERROR
)
4714 /* count the number of objects. */
4717 if (gfc_match_char ('%') == MATCH_YES
)
4719 gfc_error ("Derived type component %C is not a "
4720 "permitted EQUIVALENCE member");
4724 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
4725 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
4727 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
4728 "be an array section");
4732 sym
= set
->expr
->symtree
->n
.sym
;
4734 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
4737 if (sym
->attr
.in_common
)
4740 common_head
= sym
->common_head
;
4743 if (gfc_match_char (')') == MATCH_YES
)
4746 if (gfc_match_char (',') != MATCH_YES
)
4749 set
->eq
= gfc_get_equiv ();
4755 gfc_error ("EQUIVALENCE at %C requires two or more objects");
4759 /* If one of the members of an equivalence is in common, then
4760 mark them all as being in common. Before doing this, check
4761 that members of the equivalence group are not in different
4764 for (set
= eq
; set
; set
= set
->eq
)
4766 sym
= set
->expr
->symtree
->n
.sym
;
4767 if (sym
->common_head
&& sym
->common_head
!= common_head
)
4769 gfc_error ("Attempt to indirectly overlap COMMON "
4770 "blocks %s and %s by EQUIVALENCE at %C",
4771 sym
->common_head
->name
, common_head
->name
);
4774 sym
->attr
.in_common
= 1;
4775 sym
->common_head
= common_head
;
4778 if (gfc_match_eos () == MATCH_YES
)
4780 if (gfc_match_char (',') != MATCH_YES
)
4782 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
4790 gfc_syntax_error (ST_EQUIVALENCE
);
4796 gfc_free_equiv (gfc_current_ns
->equiv
);
4797 gfc_current_ns
->equiv
= eq
;
4803 /* Check that a statement function is not recursive. This is done by looking
4804 for the statement function symbol(sym) by looking recursively through its
4805 expression(e). If a reference to sym is found, true is returned.
4806 12.5.4 requires that any variable of function that is implicitly typed
4807 shall have that type confirmed by any subsequent type declaration. The
4808 implicit typing is conveniently done here. */
4810 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
4813 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
4819 switch (e
->expr_type
)
4822 if (e
->symtree
== NULL
)
4825 /* Check the name before testing for nested recursion! */
4826 if (sym
->name
== e
->symtree
->n
.sym
->name
)
4829 /* Catch recursion via other statement functions. */
4830 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
4831 && e
->symtree
->n
.sym
->value
4832 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
4835 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
4836 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
4841 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
4844 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
4845 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
4857 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
4859 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
4863 /* Match a statement function declaration. It is so easy to match
4864 non-statement function statements with a MATCH_ERROR as opposed to
4865 MATCH_NO that we suppress error message in most cases. */
4868 gfc_match_st_function (void)
4870 gfc_error_buf old_error_1
;
4871 output_buffer old_error
;
4877 m
= gfc_match_symbol (&sym
, 0);
4881 gfc_push_error (&old_error
, &old_error_1
);
4883 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
4886 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
4889 m
= gfc_match (" = %e%t", &expr
);
4893 gfc_free_error (&old_error
, &old_error_1
);
4895 if (m
== MATCH_ERROR
)
4898 if (recursive_stmt_fcn (expr
, sym
))
4900 gfc_error ("Statement function at %L is recursive", &expr
->where
);
4906 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
4912 gfc_pop_error (&old_error
, &old_error_1
);
4917 /***************** SELECT CASE subroutines ******************/
4919 /* Free a single case structure. */
4922 free_case (gfc_case
*p
)
4924 if (p
->low
== p
->high
)
4926 gfc_free_expr (p
->low
);
4927 gfc_free_expr (p
->high
);
4932 /* Free a list of case structures. */
4935 gfc_free_case_list (gfc_case
*p
)
4947 /* Match a single case selector. */
4950 match_case_selector (gfc_case
**cp
)
4955 c
= gfc_get_case ();
4956 c
->where
= gfc_current_locus
;
4958 if (gfc_match_char (':') == MATCH_YES
)
4960 m
= gfc_match_init_expr (&c
->high
);
4963 if (m
== MATCH_ERROR
)
4968 m
= gfc_match_init_expr (&c
->low
);
4969 if (m
== MATCH_ERROR
)
4974 /* If we're not looking at a ':' now, make a range out of a single
4975 target. Else get the upper bound for the case range. */
4976 if (gfc_match_char (':') != MATCH_YES
)
4980 m
= gfc_match_init_expr (&c
->high
);
4981 if (m
== MATCH_ERROR
)
4983 /* MATCH_NO is fine. It's OK if nothing is there! */
4991 gfc_error ("Expected initialization expression in CASE at %C");
4999 /* Match the end of a case statement. */
5002 match_case_eos (void)
5004 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5007 if (gfc_match_eos () == MATCH_YES
)
5010 /* If the case construct doesn't have a case-construct-name, we
5011 should have matched the EOS. */
5012 if (!gfc_current_block ())
5015 gfc_gobble_whitespace ();
5017 m
= gfc_match_name (name
);
5021 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5023 gfc_error ("Expected block name %qs of SELECT construct at %C",
5024 gfc_current_block ()->name
);
5028 return gfc_match_eos ();
5032 /* Match a SELECT statement. */
5035 gfc_match_select (void)
5040 m
= gfc_match_label ();
5041 if (m
== MATCH_ERROR
)
5044 m
= gfc_match (" select case ( %e )%t", &expr
);
5048 new_st
.op
= EXEC_SELECT
;
5049 new_st
.expr1
= expr
;
5055 /* Transfer the selector typespec to the associate name. */
5058 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
)
5061 gfc_symbol
*assoc_sym
;
5063 assoc_sym
= associate
->symtree
->n
.sym
;
5065 /* At this stage the expression rank and arrayspec dimensions have
5066 not been completely sorted out. We must get the expr2->rank
5067 right here, so that the correct class container is obtained. */
5068 ref
= selector
->ref
;
5069 while (ref
&& ref
->next
)
5072 if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
5073 && ref
&& ref
->type
== REF_ARRAY
)
5075 /* Ensure that the array reference type is set. We cannot use
5076 gfc_resolve_expr at this point, so the usable parts of
5077 resolve.c(resolve_array_ref) are employed to do it. */
5078 if (ref
->u
.ar
.type
== AR_UNKNOWN
)
5080 ref
->u
.ar
.type
= AR_ELEMENT
;
5081 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
5082 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5083 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
5084 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
5085 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
5087 ref
->u
.ar
.type
= AR_SECTION
;
5092 if (ref
->u
.ar
.type
== AR_FULL
)
5093 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
5094 else if (ref
->u
.ar
.type
== AR_SECTION
)
5095 selector
->rank
= ref
->u
.ar
.dimen
;
5102 assoc_sym
->attr
.dimension
= 1;
5103 assoc_sym
->as
= gfc_get_array_spec ();
5104 assoc_sym
->as
->rank
= selector
->rank
;
5105 assoc_sym
->as
->type
= AS_DEFERRED
;
5108 assoc_sym
->as
= NULL
;
5110 if (selector
->ts
.type
== BT_CLASS
)
5112 /* The correct class container has to be available. */
5113 assoc_sym
->ts
.type
= BT_CLASS
;
5114 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
5115 assoc_sym
->attr
.pointer
= 1;
5116 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
5121 /* Push the current selector onto the SELECT TYPE stack. */
5124 select_type_push (gfc_symbol
*sel
)
5126 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
5127 top
->selector
= sel
;
5129 top
->prev
= select_type_stack
;
5131 select_type_stack
= top
;
5135 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
5137 static gfc_symtree
*
5138 select_intrinsic_set_tmp (gfc_typespec
*ts
)
5140 char name
[GFC_MAX_SYMBOL_LEN
];
5144 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
5147 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5148 && !select_type_stack
->selector
->attr
.class_ok
)
5151 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
5152 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5153 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
5155 if (ts
->type
!= BT_CHARACTER
)
5156 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
5159 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (ts
->type
),
5162 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5163 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5165 /* Copy across the array spec to the selector. */
5166 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5167 && (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5168 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
))
5170 tmp
->n
.sym
->attr
.pointer
= 1;
5171 tmp
->n
.sym
->attr
.dimension
5172 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5173 tmp
->n
.sym
->attr
.codimension
5174 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5176 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5179 gfc_set_sym_referenced (tmp
->n
.sym
);
5180 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5181 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5187 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
5190 select_type_set_tmp (gfc_typespec
*ts
)
5192 char name
[GFC_MAX_SYMBOL_LEN
];
5193 gfc_symtree
*tmp
= NULL
;
5197 select_type_stack
->tmp
= NULL
;
5201 tmp
= select_intrinsic_set_tmp (ts
);
5208 if (ts
->type
== BT_CLASS
)
5209 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
5211 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
5212 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5213 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5215 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5216 && select_type_stack
->selector
->attr
.class_ok
)
5218 tmp
->n
.sym
->attr
.pointer
5219 = CLASS_DATA (select_type_stack
->selector
)->attr
.class_pointer
;
5221 /* Copy across the array spec to the selector. */
5222 if (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5223 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
)
5225 tmp
->n
.sym
->attr
.dimension
5226 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5227 tmp
->n
.sym
->attr
.codimension
5228 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5230 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5234 gfc_set_sym_referenced (tmp
->n
.sym
);
5235 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5236 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5238 if (ts
->type
== BT_CLASS
)
5239 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
5243 /* Add an association for it, so the rest of the parser knows it is
5244 an associate-name. The target will be set during resolution. */
5245 tmp
->n
.sym
->assoc
= gfc_get_association_list ();
5246 tmp
->n
.sym
->assoc
->dangling
= 1;
5247 tmp
->n
.sym
->assoc
->st
= tmp
;
5249 select_type_stack
->tmp
= tmp
;
5253 /* Match a SELECT TYPE statement. */
5256 gfc_match_select_type (void)
5258 gfc_expr
*expr1
, *expr2
= NULL
;
5260 char name
[GFC_MAX_SYMBOL_LEN
];
5264 m
= gfc_match_label ();
5265 if (m
== MATCH_ERROR
)
5268 m
= gfc_match (" select type ( ");
5272 m
= gfc_match (" %n => %e", name
, &expr2
);
5275 expr1
= gfc_get_expr();
5276 expr1
->expr_type
= EXPR_VARIABLE
;
5277 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
5283 sym
= expr1
->symtree
->n
.sym
;
5284 if (expr2
->ts
.type
== BT_UNKNOWN
)
5285 sym
->attr
.untyped
= 1;
5287 copy_ts_from_selector_to_associate (expr1
, expr2
);
5289 sym
->attr
.flavor
= FL_VARIABLE
;
5290 sym
->attr
.referenced
= 1;
5291 sym
->attr
.class_ok
= 1;
5295 m
= gfc_match (" %e ", &expr1
);
5300 m
= gfc_match (" )%t");
5303 gfc_error ("parse error in SELECT TYPE statement at %C");
5307 /* This ghastly expression seems to be needed to distinguish a CLASS
5308 array, which can have a reference, from other expressions that
5309 have references, such as derived type components, and are not
5310 allowed by the standard.
5311 TODO: see if it is sufficient to exclude component and substring
5313 class_array
= expr1
->expr_type
== EXPR_VARIABLE
5314 && expr1
->ts
.type
== BT_CLASS
5315 && CLASS_DATA (expr1
)
5316 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
5317 && (CLASS_DATA (expr1
)->attr
.dimension
5318 || CLASS_DATA (expr1
)->attr
.codimension
)
5320 && expr1
->ref
->type
== REF_ARRAY
5321 && expr1
->ref
->next
== NULL
;
5323 /* Check for F03:C811. */
5324 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
5325 || (!class_array
&& expr1
->ref
!= NULL
)))
5327 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
5328 "use associate-name=>");
5333 new_st
.op
= EXEC_SELECT_TYPE
;
5334 new_st
.expr1
= expr1
;
5335 new_st
.expr2
= expr2
;
5336 new_st
.ext
.block
.ns
= gfc_current_ns
;
5338 select_type_push (expr1
->symtree
->n
.sym
);
5343 gfc_free_expr (expr1
);
5344 gfc_free_expr (expr2
);
5349 /* Match a CASE statement. */
5352 gfc_match_case (void)
5354 gfc_case
*c
, *head
, *tail
;
5359 if (gfc_current_state () != COMP_SELECT
)
5361 gfc_error ("Unexpected CASE statement at %C");
5365 if (gfc_match ("% default") == MATCH_YES
)
5367 m
= match_case_eos ();
5370 if (m
== MATCH_ERROR
)
5373 new_st
.op
= EXEC_SELECT
;
5374 c
= gfc_get_case ();
5375 c
->where
= gfc_current_locus
;
5376 new_st
.ext
.block
.case_list
= c
;
5380 if (gfc_match_char ('(') != MATCH_YES
)
5385 if (match_case_selector (&c
) == MATCH_ERROR
)
5395 if (gfc_match_char (')') == MATCH_YES
)
5397 if (gfc_match_char (',') != MATCH_YES
)
5401 m
= match_case_eos ();
5404 if (m
== MATCH_ERROR
)
5407 new_st
.op
= EXEC_SELECT
;
5408 new_st
.ext
.block
.case_list
= head
;
5413 gfc_error ("Syntax error in CASE specification at %C");
5416 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
5421 /* Match a TYPE IS statement. */
5424 gfc_match_type_is (void)
5429 if (gfc_current_state () != COMP_SELECT_TYPE
)
5431 gfc_error ("Unexpected TYPE IS statement at %C");
5435 if (gfc_match_char ('(') != MATCH_YES
)
5438 c
= gfc_get_case ();
5439 c
->where
= gfc_current_locus
;
5441 if (gfc_match_type_spec (&c
->ts
) == MATCH_ERROR
)
5444 if (gfc_match_char (')') != MATCH_YES
)
5447 m
= match_case_eos ();
5450 if (m
== MATCH_ERROR
)
5453 new_st
.op
= EXEC_SELECT_TYPE
;
5454 new_st
.ext
.block
.case_list
= c
;
5456 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
5457 && (c
->ts
.u
.derived
->attr
.sequence
5458 || c
->ts
.u
.derived
->attr
.is_bind_c
))
5460 gfc_error ("The type-spec shall not specify a sequence derived "
5461 "type or a type with the BIND attribute in SELECT "
5462 "TYPE at %C [F2003:C815]");
5466 /* Create temporary variable. */
5467 select_type_set_tmp (&c
->ts
);
5472 gfc_error ("Syntax error in TYPE IS specification at %C");
5476 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
5481 /* Match a CLASS IS or CLASS DEFAULT statement. */
5484 gfc_match_class_is (void)
5489 if (gfc_current_state () != COMP_SELECT_TYPE
)
5492 if (gfc_match ("% default") == MATCH_YES
)
5494 m
= match_case_eos ();
5497 if (m
== MATCH_ERROR
)
5500 new_st
.op
= EXEC_SELECT_TYPE
;
5501 c
= gfc_get_case ();
5502 c
->where
= gfc_current_locus
;
5503 c
->ts
.type
= BT_UNKNOWN
;
5504 new_st
.ext
.block
.case_list
= c
;
5505 select_type_set_tmp (NULL
);
5509 m
= gfc_match ("% is");
5512 if (m
== MATCH_ERROR
)
5515 if (gfc_match_char ('(') != MATCH_YES
)
5518 c
= gfc_get_case ();
5519 c
->where
= gfc_current_locus
;
5521 if (match_derived_type_spec (&c
->ts
) == MATCH_ERROR
)
5524 if (c
->ts
.type
== BT_DERIVED
)
5525 c
->ts
.type
= BT_CLASS
;
5527 if (gfc_match_char (')') != MATCH_YES
)
5530 m
= match_case_eos ();
5533 if (m
== MATCH_ERROR
)
5536 new_st
.op
= EXEC_SELECT_TYPE
;
5537 new_st
.ext
.block
.case_list
= c
;
5539 /* Create temporary variable. */
5540 select_type_set_tmp (&c
->ts
);
5545 gfc_error ("Syntax error in CLASS IS specification at %C");
5549 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
5554 /********************* WHERE subroutines ********************/
5556 /* Match the rest of a simple WHERE statement that follows an IF statement.
5560 match_simple_where (void)
5566 m
= gfc_match (" ( %e )", &expr
);
5570 m
= gfc_match_assignment ();
5573 if (m
== MATCH_ERROR
)
5576 if (gfc_match_eos () != MATCH_YES
)
5579 c
= gfc_get_code (EXEC_WHERE
);
5582 c
->next
= XCNEW (gfc_code
);
5584 gfc_clear_new_st ();
5586 new_st
.op
= EXEC_WHERE
;
5592 gfc_syntax_error (ST_WHERE
);
5595 gfc_free_expr (expr
);
5600 /* Match a WHERE statement. */
5603 gfc_match_where (gfc_statement
*st
)
5609 m0
= gfc_match_label ();
5610 if (m0
== MATCH_ERROR
)
5613 m
= gfc_match (" where ( %e )", &expr
);
5617 if (gfc_match_eos () == MATCH_YES
)
5619 *st
= ST_WHERE_BLOCK
;
5620 new_st
.op
= EXEC_WHERE
;
5621 new_st
.expr1
= expr
;
5625 m
= gfc_match_assignment ();
5627 gfc_syntax_error (ST_WHERE
);
5631 gfc_free_expr (expr
);
5635 /* We've got a simple WHERE statement. */
5637 c
= gfc_get_code (EXEC_WHERE
);
5640 c
->next
= XCNEW (gfc_code
);
5642 gfc_clear_new_st ();
5644 new_st
.op
= EXEC_WHERE
;
5651 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
5652 new_st if successful. */
5655 gfc_match_elsewhere (void)
5657 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5661 if (gfc_current_state () != COMP_WHERE
)
5663 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
5669 if (gfc_match_char ('(') == MATCH_YES
)
5671 m
= gfc_match_expr (&expr
);
5674 if (m
== MATCH_ERROR
)
5677 if (gfc_match_char (')') != MATCH_YES
)
5681 if (gfc_match_eos () != MATCH_YES
)
5683 /* Only makes sense if we have a where-construct-name. */
5684 if (!gfc_current_block ())
5689 /* Better be a name at this point. */
5690 m
= gfc_match_name (name
);
5693 if (m
== MATCH_ERROR
)
5696 if (gfc_match_eos () != MATCH_YES
)
5699 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5701 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
5702 name
, gfc_current_block ()->name
);
5707 new_st
.op
= EXEC_WHERE
;
5708 new_st
.expr1
= expr
;
5712 gfc_syntax_error (ST_ELSEWHERE
);
5715 gfc_free_expr (expr
);