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 '%s' at %C is ambiguous", name
);
503 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
505 gfc_error ("Duplicate construct label '%s' 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
== '_' && gfc_option
.flag_allow_leading_underscore
)))
535 if (gfc_error_flag_test () == 0 && 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
== '_' || (gfc_option
.flag_dollar_ok
&& c
== '$'));
558 if (c
== '$' && !gfc_option
.flag_dollar_ok
)
560 gfc_fatal_error_1 ("Invalid character '$' at %L. Use -fdollar-ok to allow"
561 " 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 () == 0)
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 '%s' at %C doesn't match IF label '%s'",
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 '%s' at %C doesn't match IF label '%s'",
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 (gfc_option
.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 '%s' 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 '%s' 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 '%s' in %s statement at %C is unknown",
2410 name
, gfc_ascii_statement (st
));
2415 if (sym
->attr
.flavor
!= FL_LABEL
)
2417 gfc_error ("Name '%s' 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 '%s'",
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 '%s'", 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 '%s'",
2489 gfc_ascii_statement (st
), sym
->name
);
2495 gfc_error ("%s statement at %C leaving OpenMP structured block",
2496 gfc_ascii_statement (st
));
2500 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2504 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
2505 && (o
->head
->op
== EXEC_OMP_DO
2506 || o
->head
->op
== EXEC_OMP_PARALLEL_DO
2507 || o
->head
->op
== EXEC_OMP_SIMD
2508 || o
->head
->op
== EXEC_OMP_DO_SIMD
2509 || o
->head
->op
== EXEC_OMP_PARALLEL_DO_SIMD
))
2512 gcc_assert (o
->head
->next
!= NULL
2513 && (o
->head
->next
->op
== EXEC_DO
2514 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2515 && o
->previous
!= NULL
2516 && o
->previous
->tail
->op
== o
->head
->op
);
2517 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2518 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2519 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2520 if (st
== ST_EXIT
&& cnt
<= collapse
)
2522 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2525 if (st
== ST_CYCLE
&& cnt
< collapse
)
2527 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2533 /* Save the first statement in the construct - needed by the backend. */
2534 new_st
.ext
.which_construct
= p
->construct
;
2542 /* Match the EXIT statement. */
2545 gfc_match_exit (void)
2547 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2551 /* Match the CYCLE statement. */
2554 gfc_match_cycle (void)
2556 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2560 /* Match a number or character constant after an (ALL) STOP or PAUSE statement. */
2563 gfc_match_stopcode (gfc_statement st
)
2570 if (gfc_match_eos () != MATCH_YES
)
2572 m
= gfc_match_init_expr (&e
);
2573 if (m
== MATCH_ERROR
)
2578 if (gfc_match_eos () != MATCH_YES
)
2582 if (gfc_pure (NULL
))
2584 gfc_error ("%s statement not allowed in PURE procedure at %C",
2585 gfc_ascii_statement (st
));
2589 gfc_unset_implicit_pure (NULL
);
2591 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
))
2593 gfc_error ("Image control statement STOP at %C in CRITICAL block");
2596 if (st
== ST_STOP
&& gfc_find_state (COMP_DO_CONCURRENT
))
2598 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
2604 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
2606 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2613 gfc_error ("STOP code at %L must be scalar",
2618 if (e
->ts
.type
== BT_CHARACTER
2619 && e
->ts
.kind
!= gfc_default_character_kind
)
2621 gfc_error ("STOP code at %L must be default character KIND=%d",
2622 &e
->where
, (int) gfc_default_character_kind
);
2626 if (e
->ts
.type
== BT_INTEGER
2627 && e
->ts
.kind
!= gfc_default_integer_kind
)
2629 gfc_error ("STOP code at %L must be default integer KIND=%d",
2630 &e
->where
, (int) gfc_default_integer_kind
);
2638 new_st
.op
= EXEC_STOP
;
2641 new_st
.op
= EXEC_ERROR_STOP
;
2644 new_st
.op
= EXEC_PAUSE
;
2651 new_st
.ext
.stop_code
= -1;
2656 gfc_syntax_error (st
);
2665 /* Match the (deprecated) PAUSE statement. */
2668 gfc_match_pause (void)
2672 m
= gfc_match_stopcode (ST_PAUSE
);
2675 if (!gfc_notify_std (GFC_STD_F95_DEL
, "PAUSE statement at %C"))
2682 /* Match the STOP statement. */
2685 gfc_match_stop (void)
2687 return gfc_match_stopcode (ST_STOP
);
2691 /* Match the ERROR STOP statement. */
2694 gfc_match_error_stop (void)
2696 if (!gfc_notify_std (GFC_STD_F2008
, "ERROR STOP statement at %C"))
2699 return gfc_match_stopcode (ST_ERROR_STOP
);
2703 /* Match LOCK/UNLOCK statement. Syntax:
2704 LOCK ( lock-variable [ , lock-stat-list ] )
2705 UNLOCK ( lock-variable [ , sync-stat-list ] )
2706 where lock-stat is ACQUIRED_LOCK or sync-stat
2707 and sync-stat is STAT= or ERRMSG=. */
2710 lock_unlock_statement (gfc_statement st
)
2713 gfc_expr
*tmp
, *lockvar
, *acq_lock
, *stat
, *errmsg
;
2714 bool saw_acq_lock
, saw_stat
, saw_errmsg
;
2716 tmp
= lockvar
= acq_lock
= stat
= errmsg
= NULL
;
2717 saw_acq_lock
= saw_stat
= saw_errmsg
= false;
2719 if (gfc_pure (NULL
))
2721 gfc_error ("Image control statement %s at %C in PURE procedure",
2722 st
== ST_LOCK
? "LOCK" : "UNLOCK");
2726 gfc_unset_implicit_pure (NULL
);
2728 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
2730 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
2734 if (gfc_find_state (COMP_CRITICAL
))
2736 gfc_error ("Image control statement %s at %C in CRITICAL block",
2737 st
== ST_LOCK
? "LOCK" : "UNLOCK");
2741 if (gfc_find_state (COMP_DO_CONCURRENT
))
2743 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
2744 st
== ST_LOCK
? "LOCK" : "UNLOCK");
2748 if (gfc_match_char ('(') != MATCH_YES
)
2751 if (gfc_match ("%e", &lockvar
) != MATCH_YES
)
2753 m
= gfc_match_char (',');
2754 if (m
== MATCH_ERROR
)
2758 m
= gfc_match_char (')');
2766 m
= gfc_match (" stat = %v", &tmp
);
2767 if (m
== MATCH_ERROR
)
2773 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
2779 m
= gfc_match_char (',');
2787 m
= gfc_match (" errmsg = %v", &tmp
);
2788 if (m
== MATCH_ERROR
)
2794 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
2800 m
= gfc_match_char (',');
2808 m
= gfc_match (" acquired_lock = %v", &tmp
);
2809 if (m
== MATCH_ERROR
|| st
== ST_UNLOCK
)
2815 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
2820 saw_acq_lock
= true;
2822 m
= gfc_match_char (',');
2833 if (m
== MATCH_ERROR
)
2836 if (gfc_match (" )%t") != MATCH_YES
)
2843 new_st
.op
= EXEC_LOCK
;
2846 new_st
.op
= EXEC_UNLOCK
;
2852 new_st
.expr1
= lockvar
;
2853 new_st
.expr2
= stat
;
2854 new_st
.expr3
= errmsg
;
2855 new_st
.expr4
= acq_lock
;
2860 gfc_syntax_error (st
);
2863 if (acq_lock
!= tmp
)
2864 gfc_free_expr (acq_lock
);
2866 gfc_free_expr (errmsg
);
2868 gfc_free_expr (stat
);
2870 gfc_free_expr (tmp
);
2871 gfc_free_expr (lockvar
);
2878 gfc_match_lock (void)
2880 if (!gfc_notify_std (GFC_STD_F2008
, "LOCK statement at %C"))
2883 return lock_unlock_statement (ST_LOCK
);
2888 gfc_match_unlock (void)
2890 if (!gfc_notify_std (GFC_STD_F2008
, "UNLOCK statement at %C"))
2893 return lock_unlock_statement (ST_UNLOCK
);
2897 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
2898 SYNC ALL [(sync-stat-list)]
2899 SYNC MEMORY [(sync-stat-list)]
2900 SYNC IMAGES (image-set [, sync-stat-list] )
2901 with sync-stat is int-expr or *. */
2904 sync_statement (gfc_statement st
)
2907 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
2908 bool saw_stat
, saw_errmsg
;
2910 tmp
= imageset
= stat
= errmsg
= NULL
;
2911 saw_stat
= saw_errmsg
= false;
2913 if (gfc_pure (NULL
))
2915 gfc_error ("Image control statement SYNC at %C in PURE procedure");
2919 gfc_unset_implicit_pure (NULL
);
2921 if (!gfc_notify_std (GFC_STD_F2008
, "SYNC statement at %C"))
2924 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
2926 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
2931 if (gfc_find_state (COMP_CRITICAL
))
2933 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
2937 if (gfc_find_state (COMP_DO_CONCURRENT
))
2939 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
2943 if (gfc_match_eos () == MATCH_YES
)
2945 if (st
== ST_SYNC_IMAGES
)
2950 if (gfc_match_char ('(') != MATCH_YES
)
2953 if (st
== ST_SYNC_IMAGES
)
2955 /* Denote '*' as imageset == NULL. */
2956 m
= gfc_match_char ('*');
2957 if (m
== MATCH_ERROR
)
2961 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
2964 m
= gfc_match_char (',');
2965 if (m
== MATCH_ERROR
)
2969 m
= gfc_match_char (')');
2978 m
= gfc_match (" stat = %v", &tmp
);
2979 if (m
== MATCH_ERROR
)
2985 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
2991 if (gfc_match_char (',') == MATCH_YES
)
2998 m
= gfc_match (" errmsg = %v", &tmp
);
2999 if (m
== MATCH_ERROR
)
3005 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3011 if (gfc_match_char (',') == MATCH_YES
)
3021 if (gfc_match (" )%t") != MATCH_YES
)
3028 new_st
.op
= EXEC_SYNC_ALL
;
3030 case ST_SYNC_IMAGES
:
3031 new_st
.op
= EXEC_SYNC_IMAGES
;
3033 case ST_SYNC_MEMORY
:
3034 new_st
.op
= EXEC_SYNC_MEMORY
;
3040 new_st
.expr1
= imageset
;
3041 new_st
.expr2
= stat
;
3042 new_st
.expr3
= errmsg
;
3047 gfc_syntax_error (st
);
3051 gfc_free_expr (stat
);
3053 gfc_free_expr (errmsg
);
3055 gfc_free_expr (tmp
);
3056 gfc_free_expr (imageset
);
3062 /* Match SYNC ALL statement. */
3065 gfc_match_sync_all (void)
3067 return sync_statement (ST_SYNC_ALL
);
3071 /* Match SYNC IMAGES statement. */
3074 gfc_match_sync_images (void)
3076 return sync_statement (ST_SYNC_IMAGES
);
3080 /* Match SYNC MEMORY statement. */
3083 gfc_match_sync_memory (void)
3085 return sync_statement (ST_SYNC_MEMORY
);
3089 /* Match a CONTINUE statement. */
3092 gfc_match_continue (void)
3094 if (gfc_match_eos () != MATCH_YES
)
3096 gfc_syntax_error (ST_CONTINUE
);
3100 new_st
.op
= EXEC_CONTINUE
;
3105 /* Match the (deprecated) ASSIGN statement. */
3108 gfc_match_assign (void)
3111 gfc_st_label
*label
;
3113 if (gfc_match (" %l", &label
) == MATCH_YES
)
3115 if (!gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
))
3117 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
3119 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGN statement at %C"))
3122 expr
->symtree
->n
.sym
->attr
.assign
= 1;
3124 new_st
.op
= EXEC_LABEL_ASSIGN
;
3125 new_st
.label1
= label
;
3126 new_st
.expr1
= expr
;
3134 /* Match the GO TO statement. As a computed GOTO statement is
3135 matched, it is transformed into an equivalent SELECT block. No
3136 tree is necessary, and the resulting jumps-to-jumps are
3137 specifically optimized away by the back end. */
3140 gfc_match_goto (void)
3142 gfc_code
*head
, *tail
;
3145 gfc_st_label
*label
;
3149 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
3151 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3154 new_st
.op
= EXEC_GOTO
;
3155 new_st
.label1
= label
;
3159 /* The assigned GO TO statement. */
3161 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
3163 if (!gfc_notify_std (GFC_STD_F95_DEL
, "Assigned GOTO statement at %C"))
3166 new_st
.op
= EXEC_GOTO
;
3167 new_st
.expr1
= expr
;
3169 if (gfc_match_eos () == MATCH_YES
)
3172 /* Match label list. */
3173 gfc_match_char (',');
3174 if (gfc_match_char ('(') != MATCH_YES
)
3176 gfc_syntax_error (ST_GOTO
);
3183 m
= gfc_match_st_label (&label
);
3187 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3191 head
= tail
= gfc_get_code (EXEC_GOTO
);
3194 tail
->block
= gfc_get_code (EXEC_GOTO
);
3198 tail
->label1
= label
;
3200 while (gfc_match_char (',') == MATCH_YES
);
3202 if (gfc_match (")%t") != MATCH_YES
)
3207 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3210 new_st
.block
= head
;
3215 /* Last chance is a computed GO TO statement. */
3216 if (gfc_match_char ('(') != MATCH_YES
)
3218 gfc_syntax_error (ST_GOTO
);
3227 m
= gfc_match_st_label (&label
);
3231 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3235 head
= tail
= gfc_get_code (EXEC_SELECT
);
3238 tail
->block
= gfc_get_code (EXEC_SELECT
);
3242 cp
= gfc_get_case ();
3243 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
3246 tail
->ext
.block
.case_list
= cp
;
3248 tail
->next
= gfc_get_code (EXEC_GOTO
);
3249 tail
->next
->label1
= label
;
3251 while (gfc_match_char (',') == MATCH_YES
);
3253 if (gfc_match_char (')') != MATCH_YES
)
3258 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3262 /* Get the rest of the statement. */
3263 gfc_match_char (',');
3265 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
3268 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Computed GOTO at %C"))
3271 /* At this point, a computed GOTO has been fully matched and an
3272 equivalent SELECT statement constructed. */
3274 new_st
.op
= EXEC_SELECT
;
3275 new_st
.expr1
= NULL
;
3277 /* Hack: For a "real" SELECT, the expression is in expr. We put
3278 it in expr2 so we can distinguish then and produce the correct
3280 new_st
.expr2
= expr
;
3281 new_st
.block
= head
;
3285 gfc_syntax_error (ST_GOTO
);
3287 gfc_free_statements (head
);
3292 /* Frees a list of gfc_alloc structures. */
3295 gfc_free_alloc_list (gfc_alloc
*p
)
3302 gfc_free_expr (p
->expr
);
3308 /* Match an ALLOCATE statement. */
3311 gfc_match_allocate (void)
3313 gfc_alloc
*head
, *tail
;
3314 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
3318 locus old_locus
, deferred_locus
;
3319 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, saw_deferred
, b1
, b2
, b3
;
3320 bool saw_unlimited
= false;
3323 stat
= errmsg
= source
= mold
= tmp
= NULL
;
3324 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= saw_deferred
= false;
3326 if (gfc_match_char ('(') != MATCH_YES
)
3329 /* Match an optional type-spec. */
3330 old_locus
= gfc_current_locus
;
3331 m
= gfc_match_type_spec (&ts
);
3332 if (m
== MATCH_ERROR
)
3334 else if (m
== MATCH_NO
)
3336 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
3338 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
3340 gfc_error ("Error in type-spec at %L", &old_locus
);
3344 ts
.type
= BT_UNKNOWN
;
3348 if (gfc_match (" :: ") == MATCH_YES
)
3350 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
3356 gfc_error ("Type-spec at %L cannot contain a deferred "
3357 "type parameter", &old_locus
);
3361 if (ts
.type
== BT_CHARACTER
)
3362 ts
.u
.cl
->length_from_typespec
= true;
3366 ts
.type
= BT_UNKNOWN
;
3367 gfc_current_locus
= old_locus
;
3374 head
= tail
= gfc_get_alloc ();
3377 tail
->next
= gfc_get_alloc ();
3381 m
= gfc_match_variable (&tail
->expr
, 0);
3384 if (m
== MATCH_ERROR
)
3387 if (gfc_check_do_variable (tail
->expr
->symtree
))
3390 bool impure
= gfc_impure_variable (tail
->expr
->symtree
->n
.sym
);
3391 if (impure
&& gfc_pure (NULL
))
3393 gfc_error ("Bad allocate-object at %C for a PURE procedure");
3398 gfc_unset_implicit_pure (NULL
);
3400 if (tail
->expr
->ts
.deferred
)
3402 saw_deferred
= true;
3403 deferred_locus
= tail
->expr
->where
;
3406 if (gfc_find_state (COMP_DO_CONCURRENT
)
3407 || gfc_find_state (COMP_CRITICAL
))
3410 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
3411 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
3412 if (ref
->type
== REF_COMPONENT
)
3413 coarray
= ref
->u
.c
.component
->attr
.codimension
;
3415 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
3417 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
3420 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
3422 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
3427 /* Check for F08:C628. */
3428 sym
= tail
->expr
->symtree
->n
.sym
;
3429 b1
= !(tail
->expr
->ref
3430 && (tail
->expr
->ref
->type
== REF_COMPONENT
3431 || tail
->expr
->ref
->type
== REF_ARRAY
));
3432 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
3433 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
3434 || CLASS_DATA (sym
)->attr
.class_pointer
);
3436 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
3437 || sym
->attr
.proc_pointer
);
3438 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
3439 && (sym
->ns
->proc_name
->attr
.allocatable
3440 || sym
->ns
->proc_name
->attr
.pointer
3441 || sym
->ns
->proc_name
->attr
.proc_pointer
);
3442 if (b1
&& b2
&& !b3
)
3444 gfc_error ("Allocate-object at %L is neither a data pointer "
3445 "nor an allocatable variable", &tail
->expr
->where
);
3449 /* The ALLOCATE statement had an optional typespec. Check the
3451 if (ts
.type
!= BT_UNKNOWN
)
3453 /* Enforce F03:C624. */
3454 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
3456 gfc_error ("Type of entity at %L is type incompatible with "
3457 "typespec", &tail
->expr
->where
);
3461 /* Enforce F03:C627. */
3462 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
3464 gfc_error ("Kind type parameter for entity at %L differs from "
3465 "the kind type parameter of the typespec",
3466 &tail
->expr
->where
);
3471 if (tail
->expr
->ts
.type
== BT_DERIVED
)
3472 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
3474 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
3476 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
3478 gfc_error ("Shape specification for allocatable scalar at %C");
3482 if (gfc_match_char (',') != MATCH_YES
)
3487 m
= gfc_match (" stat = %v", &tmp
);
3488 if (m
== MATCH_ERROR
)
3495 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3503 if (gfc_check_do_variable (stat
->symtree
))
3506 if (gfc_match_char (',') == MATCH_YES
)
3507 goto alloc_opt_list
;
3510 m
= gfc_match (" errmsg = %v", &tmp
);
3511 if (m
== MATCH_ERROR
)
3515 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
3521 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3529 if (gfc_match_char (',') == MATCH_YES
)
3530 goto alloc_opt_list
;
3533 m
= gfc_match (" source = %e", &tmp
);
3534 if (m
== MATCH_ERROR
)
3538 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
3544 gfc_error ("Redundant SOURCE tag found at %L ", &tmp
->where
);
3548 /* The next 2 conditionals check C631. */
3549 if (ts
.type
!= BT_UNKNOWN
)
3551 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
3552 &tmp
->where
, &old_locus
);
3557 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
3558 " with more than a single allocate object",
3566 if (gfc_match_char (',') == MATCH_YES
)
3567 goto alloc_opt_list
;
3570 m
= gfc_match (" mold = %e", &tmp
);
3571 if (m
== MATCH_ERROR
)
3575 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
3578 /* Check F08:C636. */
3581 gfc_error ("Redundant MOLD tag found at %L ", &tmp
->where
);
3585 /* Check F08:C637. */
3586 if (ts
.type
!= BT_UNKNOWN
)
3588 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
3589 &tmp
->where
, &old_locus
);
3598 if (gfc_match_char (',') == MATCH_YES
)
3599 goto alloc_opt_list
;
3602 gfc_gobble_whitespace ();
3604 if (gfc_peek_char () == ')')
3608 if (gfc_match (" )%t") != MATCH_YES
)
3611 /* Check F08:C637. */
3614 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
3615 &mold
->where
, &source
->where
);
3619 /* Check F03:C623, */
3620 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
3622 gfc_error ("Allocate-object at %L with a deferred type parameter "
3623 "requires either a type-spec or SOURCE tag or a MOLD tag",
3628 /* Check F03:C625, */
3629 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
3631 for (tail
= head
; tail
; tail
= tail
->next
)
3633 if (UNLIMITED_POLY (tail
->expr
))
3634 gfc_error ("Unlimited polymorphic allocate-object at %L "
3635 "requires either a type-spec or SOURCE tag "
3636 "or a MOLD tag", &tail
->expr
->where
);
3641 new_st
.op
= EXEC_ALLOCATE
;
3642 new_st
.expr1
= stat
;
3643 new_st
.expr2
= errmsg
;
3645 new_st
.expr3
= source
;
3647 new_st
.expr3
= mold
;
3648 new_st
.ext
.alloc
.list
= head
;
3649 new_st
.ext
.alloc
.ts
= ts
;
3654 gfc_syntax_error (ST_ALLOCATE
);
3657 gfc_free_expr (errmsg
);
3658 gfc_free_expr (source
);
3659 gfc_free_expr (stat
);
3660 gfc_free_expr (mold
);
3661 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
3662 gfc_free_alloc_list (head
);
3667 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
3668 a set of pointer assignments to intrinsic NULL(). */
3671 gfc_match_nullify (void)
3679 if (gfc_match_char ('(') != MATCH_YES
)
3684 m
= gfc_match_variable (&p
, 0);
3685 if (m
== MATCH_ERROR
)
3690 if (gfc_check_do_variable (p
->symtree
))
3694 if (gfc_is_coindexed (p
))
3696 gfc_error ("Pointer object at %C shall not be coindexed");
3700 /* build ' => NULL() '. */
3701 e
= gfc_get_null_expr (&gfc_current_locus
);
3703 /* Chain to list. */
3707 tail
->op
= EXEC_POINTER_ASSIGN
;
3711 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
3718 if (gfc_match (" )%t") == MATCH_YES
)
3720 if (gfc_match_char (',') != MATCH_YES
)
3727 gfc_syntax_error (ST_NULLIFY
);
3730 gfc_free_statements (new_st
.next
);
3732 gfc_free_expr (new_st
.expr1
);
3733 new_st
.expr1
= NULL
;
3734 gfc_free_expr (new_st
.expr2
);
3735 new_st
.expr2
= NULL
;
3740 /* Match a DEALLOCATE statement. */
3743 gfc_match_deallocate (void)
3745 gfc_alloc
*head
, *tail
;
3746 gfc_expr
*stat
, *errmsg
, *tmp
;
3749 bool saw_stat
, saw_errmsg
, b1
, b2
;
3752 stat
= errmsg
= tmp
= NULL
;
3753 saw_stat
= saw_errmsg
= false;
3755 if (gfc_match_char ('(') != MATCH_YES
)
3761 head
= tail
= gfc_get_alloc ();
3764 tail
->next
= gfc_get_alloc ();
3768 m
= gfc_match_variable (&tail
->expr
, 0);
3769 if (m
== MATCH_ERROR
)
3774 if (gfc_check_do_variable (tail
->expr
->symtree
))
3777 sym
= tail
->expr
->symtree
->n
.sym
;
3779 bool impure
= gfc_impure_variable (sym
);
3780 if (impure
&& gfc_pure (NULL
))
3782 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3787 gfc_unset_implicit_pure (NULL
);
3789 if (gfc_is_coarray (tail
->expr
)
3790 && gfc_find_state (COMP_DO_CONCURRENT
))
3792 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
3796 if (gfc_is_coarray (tail
->expr
)
3797 && gfc_find_state (COMP_CRITICAL
))
3799 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
3803 /* FIXME: disable the checking on derived types. */
3804 b1
= !(tail
->expr
->ref
3805 && (tail
->expr
->ref
->type
== REF_COMPONENT
3806 || tail
->expr
->ref
->type
== REF_ARRAY
));
3807 if (sym
&& sym
->ts
.type
== BT_CLASS
)
3808 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
3809 || CLASS_DATA (sym
)->attr
.class_pointer
);
3811 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
3812 || sym
->attr
.proc_pointer
);
3815 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3816 "nor an allocatable variable");
3820 if (gfc_match_char (',') != MATCH_YES
)
3825 m
= gfc_match (" stat = %v", &tmp
);
3826 if (m
== MATCH_ERROR
)
3832 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3833 gfc_free_expr (tmp
);
3840 if (gfc_check_do_variable (stat
->symtree
))
3843 if (gfc_match_char (',') == MATCH_YES
)
3844 goto dealloc_opt_list
;
3847 m
= gfc_match (" errmsg = %v", &tmp
);
3848 if (m
== MATCH_ERROR
)
3852 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
3857 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3858 gfc_free_expr (tmp
);
3865 if (gfc_match_char (',') == MATCH_YES
)
3866 goto dealloc_opt_list
;
3869 gfc_gobble_whitespace ();
3871 if (gfc_peek_char () == ')')
3875 if (gfc_match (" )%t") != MATCH_YES
)
3878 new_st
.op
= EXEC_DEALLOCATE
;
3879 new_st
.expr1
= stat
;
3880 new_st
.expr2
= errmsg
;
3881 new_st
.ext
.alloc
.list
= head
;
3886 gfc_syntax_error (ST_DEALLOCATE
);
3889 gfc_free_expr (errmsg
);
3890 gfc_free_expr (stat
);
3891 gfc_free_alloc_list (head
);
3896 /* Match a RETURN statement. */
3899 gfc_match_return (void)
3903 gfc_compile_state s
;
3907 if (gfc_find_state (COMP_CRITICAL
))
3909 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
3913 if (gfc_find_state (COMP_DO_CONCURRENT
))
3915 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
3919 if (gfc_match_eos () == MATCH_YES
)
3922 if (!gfc_find_state (COMP_SUBROUTINE
))
3924 gfc_error ("Alternate RETURN statement at %C is only allowed within "
3929 if (gfc_current_form
== FORM_FREE
)
3931 /* The following are valid, so we can't require a blank after the
3935 char c
= gfc_peek_ascii_char ();
3936 if (ISALPHA (c
) || ISDIGIT (c
))
3940 m
= gfc_match (" %e%t", &e
);
3943 if (m
== MATCH_ERROR
)
3946 gfc_syntax_error (ST_RETURN
);
3953 gfc_enclosing_unit (&s
);
3954 if (s
== COMP_PROGRAM
3955 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
3956 "main program at %C"))
3959 new_st
.op
= EXEC_RETURN
;
3966 /* Match the call of a type-bound procedure, if CALL%var has already been
3967 matched and var found to be a derived-type variable. */
3970 match_typebound_call (gfc_symtree
* varst
)
3975 base
= gfc_get_expr ();
3976 base
->expr_type
= EXPR_VARIABLE
;
3977 base
->symtree
= varst
;
3978 base
->where
= gfc_current_locus
;
3979 gfc_set_sym_referenced (varst
->n
.sym
);
3981 m
= gfc_match_varspec (base
, 0, true, true);
3983 gfc_error ("Expected component reference at %C");
3986 gfc_free_expr (base
);
3990 if (gfc_match_eos () != MATCH_YES
)
3992 gfc_error ("Junk after CALL at %C");
3993 gfc_free_expr (base
);
3997 if (base
->expr_type
== EXPR_COMPCALL
)
3998 new_st
.op
= EXEC_COMPCALL
;
3999 else if (base
->expr_type
== EXPR_PPC
)
4000 new_st
.op
= EXEC_CALL_PPC
;
4003 gfc_error ("Expected type-bound procedure or procedure pointer component "
4005 gfc_free_expr (base
);
4008 new_st
.expr1
= base
;
4014 /* Match a CALL statement. The tricky part here are possible
4015 alternate return specifiers. We handle these by having all
4016 "subroutines" actually return an integer via a register that gives
4017 the return number. If the call specifies alternate returns, we
4018 generate code for a SELECT statement whose case clauses contain
4019 GOTOs to the various labels. */
4022 gfc_match_call (void)
4024 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4025 gfc_actual_arglist
*a
, *arglist
;
4035 m
= gfc_match ("% %n", name
);
4041 if (gfc_get_ha_sym_tree (name
, &st
))
4046 /* If this is a variable of derived-type, it probably starts a type-bound
4048 if ((sym
->attr
.flavor
!= FL_PROCEDURE
4049 || gfc_is_function_return_value (sym
, gfc_current_ns
))
4050 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
4051 return match_typebound_call (st
);
4053 /* If it does not seem to be callable (include functions so that the
4054 right association is made. They are thrown out in resolution.)
4056 if (!sym
->attr
.generic
4057 && !sym
->attr
.subroutine
4058 && !sym
->attr
.function
)
4060 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
4062 /* ...create a symbol in this scope... */
4063 if (sym
->ns
!= gfc_current_ns
4064 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
4067 if (sym
!= st
->n
.sym
)
4071 /* ...and then to try to make the symbol into a subroutine. */
4072 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
4076 gfc_set_sym_referenced (sym
);
4078 if (gfc_match_eos () != MATCH_YES
)
4080 m
= gfc_match_actual_arglist (1, &arglist
);
4083 if (m
== MATCH_ERROR
)
4086 if (gfc_match_eos () != MATCH_YES
)
4090 /* If any alternate return labels were found, construct a SELECT
4091 statement that will jump to the right place. */
4094 for (a
= arglist
; a
; a
= a
->next
)
4095 if (a
->expr
== NULL
)
4103 gfc_symtree
*select_st
;
4104 gfc_symbol
*select_sym
;
4105 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4107 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
4108 sprintf (name
, "_result_%s", sym
->name
);
4109 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
4111 select_sym
= select_st
->n
.sym
;
4112 select_sym
->ts
.type
= BT_INTEGER
;
4113 select_sym
->ts
.kind
= gfc_default_integer_kind
;
4114 gfc_set_sym_referenced (select_sym
);
4115 c
->expr1
= gfc_get_expr ();
4116 c
->expr1
->expr_type
= EXPR_VARIABLE
;
4117 c
->expr1
->symtree
= select_st
;
4118 c
->expr1
->ts
= select_sym
->ts
;
4119 c
->expr1
->where
= gfc_current_locus
;
4122 for (a
= arglist
; a
; a
= a
->next
)
4124 if (a
->expr
!= NULL
)
4127 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
4132 c
->block
= gfc_get_code (EXEC_SELECT
);
4135 new_case
= gfc_get_case ();
4136 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
4137 new_case
->low
= new_case
->high
;
4138 c
->ext
.block
.case_list
= new_case
;
4140 c
->next
= gfc_get_code (EXEC_GOTO
);
4141 c
->next
->label1
= a
->label
;
4145 new_st
.op
= EXEC_CALL
;
4146 new_st
.symtree
= st
;
4147 new_st
.ext
.actual
= arglist
;
4152 gfc_syntax_error (ST_CALL
);
4155 gfc_free_actual_arglist (arglist
);
4160 /* Given a name, return a pointer to the common head structure,
4161 creating it if it does not exist. If FROM_MODULE is nonzero, we
4162 mangle the name so that it doesn't interfere with commons defined
4163 in the using namespace.
4164 TODO: Add to global symbol tree. */
4167 gfc_get_common (const char *name
, int from_module
)
4170 static int serial
= 0;
4171 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
4175 /* A use associated common block is only needed to correctly layout
4176 the variables it contains. */
4177 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
4178 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
4182 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
4185 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
4188 if (st
->n
.common
== NULL
)
4190 st
->n
.common
= gfc_get_common_head ();
4191 st
->n
.common
->where
= gfc_current_locus
;
4192 strcpy (st
->n
.common
->name
, name
);
4195 return st
->n
.common
;
4199 /* Match a common block name. */
4201 match
match_common_name (char *name
)
4205 if (gfc_match_char ('/') == MATCH_NO
)
4211 if (gfc_match_char ('/') == MATCH_YES
)
4217 m
= gfc_match_name (name
);
4219 if (m
== MATCH_ERROR
)
4221 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
4224 gfc_error ("Syntax error in common block name at %C");
4229 /* Match a COMMON statement. */
4232 gfc_match_common (void)
4234 gfc_symbol
*sym
, **head
, *tail
, *other
, *old_blank_common
;
4235 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4241 old_blank_common
= gfc_current_ns
->blank_common
.head
;
4242 if (old_blank_common
)
4244 while (old_blank_common
->common_next
)
4245 old_blank_common
= old_blank_common
->common_next
;
4252 m
= match_common_name (name
);
4253 if (m
== MATCH_ERROR
)
4256 if (name
[0] == '\0')
4258 t
= &gfc_current_ns
->blank_common
;
4259 if (t
->head
== NULL
)
4260 t
->where
= gfc_current_locus
;
4264 t
= gfc_get_common (name
, 0);
4273 while (tail
->common_next
)
4274 tail
= tail
->common_next
;
4277 /* Grab the list of symbols. */
4280 m
= gfc_match_symbol (&sym
, 0);
4281 if (m
== MATCH_ERROR
)
4286 /* Store a ref to the common block for error checking. */
4287 sym
->common_block
= t
;
4288 sym
->common_block
->refs
++;
4290 /* See if we know the current common block is bind(c), and if
4291 so, then see if we can check if the symbol is (which it'll
4292 need to be). This can happen if the bind(c) attr stmt was
4293 applied to the common block, and the variable(s) already
4294 defined, before declaring the common block. */
4295 if (t
->is_bind_c
== 1)
4297 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
4299 /* If we find an error, just print it and continue,
4300 cause it's just semantic, and we can see if there
4302 gfc_error_now ("Variable '%s' at %L in common block '%s' "
4303 "at %C must be declared with a C "
4304 "interoperable kind since common block "
4306 sym
->name
, &(sym
->declared_at
), t
->name
,
4310 if (sym
->attr
.is_bind_c
== 1)
4311 gfc_error_now ("Variable '%s' in common block "
4312 "'%s' at %C can not be bind(c) since "
4313 "it is not global", sym
->name
, t
->name
);
4316 if (sym
->attr
.in_common
)
4318 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
4323 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
4324 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
4326 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol '%s' at "
4327 "%C can only be COMMON in BLOCK DATA",
4332 if (!gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
))
4336 tail
->common_next
= sym
;
4342 /* Deal with an optional array specification after the
4344 m
= gfc_match_array_spec (&as
, true, true);
4345 if (m
== MATCH_ERROR
)
4350 if (as
->type
!= AS_EXPLICIT
)
4352 gfc_error ("Array specification for symbol '%s' in COMMON "
4353 "at %C must be explicit", sym
->name
);
4357 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
4360 if (sym
->attr
.pointer
)
4362 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
4363 "POINTER array", sym
->name
);
4372 sym
->common_head
= t
;
4374 /* Check to see if the symbol is already in an equivalence group.
4375 If it is, set the other members as being in common. */
4376 if (sym
->attr
.in_equivalence
)
4378 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
4380 for (e2
= e1
; e2
; e2
= e2
->eq
)
4381 if (e2
->expr
->symtree
->n
.sym
== sym
)
4388 for (e2
= e1
; e2
; e2
= e2
->eq
)
4390 other
= e2
->expr
->symtree
->n
.sym
;
4391 if (other
->common_head
4392 && other
->common_head
!= sym
->common_head
)
4394 gfc_error ("Symbol '%s', in COMMON block '%s' at "
4395 "%C is being indirectly equivalenced to "
4396 "another COMMON block '%s'",
4397 sym
->name
, sym
->common_head
->name
,
4398 other
->common_head
->name
);
4401 other
->attr
.in_common
= 1;
4402 other
->common_head
= t
;
4408 gfc_gobble_whitespace ();
4409 if (gfc_match_eos () == MATCH_YES
)
4411 if (gfc_peek_ascii_char () == '/')
4413 if (gfc_match_char (',') != MATCH_YES
)
4415 gfc_gobble_whitespace ();
4416 if (gfc_peek_ascii_char () == '/')
4425 gfc_syntax_error (ST_COMMON
);
4428 gfc_free_array_spec (as
);
4433 /* Match a BLOCK DATA program unit. */
4436 gfc_match_block_data (void)
4438 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4442 if (gfc_match_eos () == MATCH_YES
)
4444 gfc_new_block
= NULL
;
4448 m
= gfc_match ("% %n%t", name
);
4452 if (gfc_get_symbol (name
, NULL
, &sym
))
4455 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
4458 gfc_new_block
= sym
;
4464 /* Free a namelist structure. */
4467 gfc_free_namelist (gfc_namelist
*name
)
4471 for (; name
; name
= n
)
4479 /* Free an OpenMP namelist structure. */
4482 gfc_free_omp_namelist (gfc_omp_namelist
*name
)
4484 gfc_omp_namelist
*n
;
4486 for (; name
; name
= n
)
4488 gfc_free_expr (name
->expr
);
4491 if (name
->udr
->combiner
)
4492 gfc_free_statement (name
->udr
->combiner
);
4493 if (name
->udr
->initializer
)
4494 gfc_free_statement (name
->udr
->initializer
);
4503 /* Match a NAMELIST statement. */
4506 gfc_match_namelist (void)
4508 gfc_symbol
*group_name
, *sym
;
4512 m
= gfc_match (" / %s /", &group_name
);
4515 if (m
== MATCH_ERROR
)
4520 if (group_name
->ts
.type
!= BT_UNKNOWN
)
4522 gfc_error ("Namelist group name '%s' at %C already has a basic "
4523 "type of %s", group_name
->name
,
4524 gfc_typename (&group_name
->ts
));
4528 if (group_name
->attr
.flavor
== FL_NAMELIST
4529 && group_name
->attr
.use_assoc
4530 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name '%s' "
4531 "at %C already is USE associated and can"
4532 "not be respecified.", group_name
->name
))
4535 if (group_name
->attr
.flavor
!= FL_NAMELIST
4536 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
4537 group_name
->name
, NULL
))
4542 m
= gfc_match_symbol (&sym
, 1);
4545 if (m
== MATCH_ERROR
)
4548 if (sym
->attr
.in_namelist
== 0
4549 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
4552 /* Use gfc_error_check here, rather than goto error, so that
4553 these are the only errors for the next two lines. */
4554 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
4556 gfc_error ("Assumed size array '%s' in namelist '%s' at "
4557 "%C is not allowed", sym
->name
, group_name
->name
);
4561 nl
= gfc_get_namelist ();
4565 if (group_name
->namelist
== NULL
)
4566 group_name
->namelist
= group_name
->namelist_tail
= nl
;
4569 group_name
->namelist_tail
->next
= nl
;
4570 group_name
->namelist_tail
= nl
;
4573 if (gfc_match_eos () == MATCH_YES
)
4576 m
= gfc_match_char (',');
4578 if (gfc_match_char ('/') == MATCH_YES
)
4580 m2
= gfc_match (" %s /", &group_name
);
4581 if (m2
== MATCH_YES
)
4583 if (m2
== MATCH_ERROR
)
4597 gfc_syntax_error (ST_NAMELIST
);
4604 /* Match a MODULE statement. */
4607 gfc_match_module (void)
4611 m
= gfc_match (" %s%t", &gfc_new_block
);
4615 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
4616 gfc_new_block
->name
, NULL
))
4623 /* Free equivalence sets and lists. Recursively is the easiest way to
4627 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
4632 gfc_free_equiv (eq
->eq
);
4633 gfc_free_equiv_until (eq
->next
, stop
);
4634 gfc_free_expr (eq
->expr
);
4640 gfc_free_equiv (gfc_equiv
*eq
)
4642 gfc_free_equiv_until (eq
, NULL
);
4646 /* Match an EQUIVALENCE statement. */
4649 gfc_match_equivalence (void)
4651 gfc_equiv
*eq
, *set
, *tail
;
4655 gfc_common_head
*common_head
= NULL
;
4663 eq
= gfc_get_equiv ();
4667 eq
->next
= gfc_current_ns
->equiv
;
4668 gfc_current_ns
->equiv
= eq
;
4670 if (gfc_match_char ('(') != MATCH_YES
)
4674 common_flag
= FALSE
;
4679 m
= gfc_match_equiv_variable (&set
->expr
);
4680 if (m
== MATCH_ERROR
)
4685 /* count the number of objects. */
4688 if (gfc_match_char ('%') == MATCH_YES
)
4690 gfc_error ("Derived type component %C is not a "
4691 "permitted EQUIVALENCE member");
4695 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
4696 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
4698 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
4699 "be an array section");
4703 sym
= set
->expr
->symtree
->n
.sym
;
4705 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
4708 if (sym
->attr
.in_common
)
4711 common_head
= sym
->common_head
;
4714 if (gfc_match_char (')') == MATCH_YES
)
4717 if (gfc_match_char (',') != MATCH_YES
)
4720 set
->eq
= gfc_get_equiv ();
4726 gfc_error ("EQUIVALENCE at %C requires two or more objects");
4730 /* If one of the members of an equivalence is in common, then
4731 mark them all as being in common. Before doing this, check
4732 that members of the equivalence group are not in different
4735 for (set
= eq
; set
; set
= set
->eq
)
4737 sym
= set
->expr
->symtree
->n
.sym
;
4738 if (sym
->common_head
&& sym
->common_head
!= common_head
)
4740 gfc_error ("Attempt to indirectly overlap COMMON "
4741 "blocks %s and %s by EQUIVALENCE at %C",
4742 sym
->common_head
->name
, common_head
->name
);
4745 sym
->attr
.in_common
= 1;
4746 sym
->common_head
= common_head
;
4749 if (gfc_match_eos () == MATCH_YES
)
4751 if (gfc_match_char (',') != MATCH_YES
)
4753 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
4761 gfc_syntax_error (ST_EQUIVALENCE
);
4767 gfc_free_equiv (gfc_current_ns
->equiv
);
4768 gfc_current_ns
->equiv
= eq
;
4774 /* Check that a statement function is not recursive. This is done by looking
4775 for the statement function symbol(sym) by looking recursively through its
4776 expression(e). If a reference to sym is found, true is returned.
4777 12.5.4 requires that any variable of function that is implicitly typed
4778 shall have that type confirmed by any subsequent type declaration. The
4779 implicit typing is conveniently done here. */
4781 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
4784 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
4790 switch (e
->expr_type
)
4793 if (e
->symtree
== NULL
)
4796 /* Check the name before testing for nested recursion! */
4797 if (sym
->name
== e
->symtree
->n
.sym
->name
)
4800 /* Catch recursion via other statement functions. */
4801 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
4802 && e
->symtree
->n
.sym
->value
4803 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
4806 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
4807 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
4812 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
4815 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
4816 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
4828 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
4830 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
4834 /* Match a statement function declaration. It is so easy to match
4835 non-statement function statements with a MATCH_ERROR as opposed to
4836 MATCH_NO that we suppress error message in most cases. */
4839 gfc_match_st_function (void)
4841 gfc_error_buf old_error
;
4846 m
= gfc_match_symbol (&sym
, 0);
4850 gfc_push_error (&old_error
);
4852 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
4855 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
4858 m
= gfc_match (" = %e%t", &expr
);
4862 gfc_free_error (&old_error
);
4863 if (m
== MATCH_ERROR
)
4866 if (recursive_stmt_fcn (expr
, sym
))
4868 gfc_error ("Statement function at %L is recursive", &expr
->where
);
4874 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
4880 gfc_pop_error (&old_error
);
4885 /***************** SELECT CASE subroutines ******************/
4887 /* Free a single case structure. */
4890 free_case (gfc_case
*p
)
4892 if (p
->low
== p
->high
)
4894 gfc_free_expr (p
->low
);
4895 gfc_free_expr (p
->high
);
4900 /* Free a list of case structures. */
4903 gfc_free_case_list (gfc_case
*p
)
4915 /* Match a single case selector. */
4918 match_case_selector (gfc_case
**cp
)
4923 c
= gfc_get_case ();
4924 c
->where
= gfc_current_locus
;
4926 if (gfc_match_char (':') == MATCH_YES
)
4928 m
= gfc_match_init_expr (&c
->high
);
4931 if (m
== MATCH_ERROR
)
4936 m
= gfc_match_init_expr (&c
->low
);
4937 if (m
== MATCH_ERROR
)
4942 /* If we're not looking at a ':' now, make a range out of a single
4943 target. Else get the upper bound for the case range. */
4944 if (gfc_match_char (':') != MATCH_YES
)
4948 m
= gfc_match_init_expr (&c
->high
);
4949 if (m
== MATCH_ERROR
)
4951 /* MATCH_NO is fine. It's OK if nothing is there! */
4959 gfc_error ("Expected initialization expression in CASE at %C");
4967 /* Match the end of a case statement. */
4970 match_case_eos (void)
4972 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4975 if (gfc_match_eos () == MATCH_YES
)
4978 /* If the case construct doesn't have a case-construct-name, we
4979 should have matched the EOS. */
4980 if (!gfc_current_block ())
4983 gfc_gobble_whitespace ();
4985 m
= gfc_match_name (name
);
4989 if (strcmp (name
, gfc_current_block ()->name
) != 0)
4991 gfc_error ("Expected block name '%s' of SELECT construct at %C",
4992 gfc_current_block ()->name
);
4996 return gfc_match_eos ();
5000 /* Match a SELECT statement. */
5003 gfc_match_select (void)
5008 m
= gfc_match_label ();
5009 if (m
== MATCH_ERROR
)
5012 m
= gfc_match (" select case ( %e )%t", &expr
);
5016 new_st
.op
= EXEC_SELECT
;
5017 new_st
.expr1
= expr
;
5023 /* Transfer the selector typespec to the associate name. */
5026 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
)
5029 gfc_symbol
*assoc_sym
;
5031 assoc_sym
= associate
->symtree
->n
.sym
;
5033 /* At this stage the expression rank and arrayspec dimensions have
5034 not been completely sorted out. We must get the expr2->rank
5035 right here, so that the correct class container is obtained. */
5036 ref
= selector
->ref
;
5037 while (ref
&& ref
->next
)
5040 if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
5041 && ref
&& ref
->type
== REF_ARRAY
)
5043 /* Ensure that the array reference type is set. We cannot use
5044 gfc_resolve_expr at this point, so the usable parts of
5045 resolve.c(resolve_array_ref) are employed to do it. */
5046 if (ref
->u
.ar
.type
== AR_UNKNOWN
)
5048 ref
->u
.ar
.type
= AR_ELEMENT
;
5049 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
5050 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5051 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
5052 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
5053 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
5055 ref
->u
.ar
.type
= AR_SECTION
;
5060 if (ref
->u
.ar
.type
== AR_FULL
)
5061 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
5062 else if (ref
->u
.ar
.type
== AR_SECTION
)
5063 selector
->rank
= ref
->u
.ar
.dimen
;
5070 assoc_sym
->attr
.dimension
= 1;
5071 assoc_sym
->as
= gfc_get_array_spec ();
5072 assoc_sym
->as
->rank
= selector
->rank
;
5073 assoc_sym
->as
->type
= AS_DEFERRED
;
5076 assoc_sym
->as
= NULL
;
5078 if (selector
->ts
.type
== BT_CLASS
)
5080 /* The correct class container has to be available. */
5081 assoc_sym
->ts
.type
= BT_CLASS
;
5082 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
5083 assoc_sym
->attr
.pointer
= 1;
5084 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
5089 /* Push the current selector onto the SELECT TYPE stack. */
5092 select_type_push (gfc_symbol
*sel
)
5094 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
5095 top
->selector
= sel
;
5097 top
->prev
= select_type_stack
;
5099 select_type_stack
= top
;
5103 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
5105 static gfc_symtree
*
5106 select_intrinsic_set_tmp (gfc_typespec
*ts
)
5108 char name
[GFC_MAX_SYMBOL_LEN
];
5112 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
5115 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5116 && !select_type_stack
->selector
->attr
.class_ok
)
5119 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
5120 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5121 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
5123 if (ts
->type
!= BT_CHARACTER
)
5124 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
5127 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (ts
->type
),
5130 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5131 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5133 /* Copy across the array spec to the selector. */
5134 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5135 && (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5136 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
))
5138 tmp
->n
.sym
->attr
.pointer
= 1;
5139 tmp
->n
.sym
->attr
.dimension
5140 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5141 tmp
->n
.sym
->attr
.codimension
5142 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5144 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5147 gfc_set_sym_referenced (tmp
->n
.sym
);
5148 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5149 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5155 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
5158 select_type_set_tmp (gfc_typespec
*ts
)
5160 char name
[GFC_MAX_SYMBOL_LEN
];
5161 gfc_symtree
*tmp
= NULL
;
5165 select_type_stack
->tmp
= NULL
;
5169 tmp
= select_intrinsic_set_tmp (ts
);
5176 if (ts
->type
== BT_CLASS
)
5177 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
5179 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
5180 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5181 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5183 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5184 && select_type_stack
->selector
->attr
.class_ok
)
5186 tmp
->n
.sym
->attr
.pointer
5187 = CLASS_DATA (select_type_stack
->selector
)->attr
.class_pointer
;
5189 /* Copy across the array spec to the selector. */
5190 if (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5191 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
)
5193 tmp
->n
.sym
->attr
.dimension
5194 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5195 tmp
->n
.sym
->attr
.codimension
5196 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5198 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5202 gfc_set_sym_referenced (tmp
->n
.sym
);
5203 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5204 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5206 if (ts
->type
== BT_CLASS
)
5207 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
5211 /* Add an association for it, so the rest of the parser knows it is
5212 an associate-name. The target will be set during resolution. */
5213 tmp
->n
.sym
->assoc
= gfc_get_association_list ();
5214 tmp
->n
.sym
->assoc
->dangling
= 1;
5215 tmp
->n
.sym
->assoc
->st
= tmp
;
5217 select_type_stack
->tmp
= tmp
;
5221 /* Match a SELECT TYPE statement. */
5224 gfc_match_select_type (void)
5226 gfc_expr
*expr1
, *expr2
= NULL
;
5228 char name
[GFC_MAX_SYMBOL_LEN
];
5232 m
= gfc_match_label ();
5233 if (m
== MATCH_ERROR
)
5236 m
= gfc_match (" select type ( ");
5240 m
= gfc_match (" %n => %e", name
, &expr2
);
5243 expr1
= gfc_get_expr();
5244 expr1
->expr_type
= EXPR_VARIABLE
;
5245 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
5251 sym
= expr1
->symtree
->n
.sym
;
5252 if (expr2
->ts
.type
== BT_UNKNOWN
)
5253 sym
->attr
.untyped
= 1;
5255 copy_ts_from_selector_to_associate (expr1
, expr2
);
5257 sym
->attr
.flavor
= FL_VARIABLE
;
5258 sym
->attr
.referenced
= 1;
5259 sym
->attr
.class_ok
= 1;
5263 m
= gfc_match (" %e ", &expr1
);
5268 m
= gfc_match (" )%t");
5271 gfc_error ("parse error in SELECT TYPE statement at %C");
5275 /* This ghastly expression seems to be needed to distinguish a CLASS
5276 array, which can have a reference, from other expressions that
5277 have references, such as derived type components, and are not
5278 allowed by the standard.
5279 TODO: see if it is sufficient to exclude component and substring
5281 class_array
= expr1
->expr_type
== EXPR_VARIABLE
5282 && expr1
->ts
.type
== BT_CLASS
5283 && CLASS_DATA (expr1
)
5284 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
5285 && (CLASS_DATA (expr1
)->attr
.dimension
5286 || CLASS_DATA (expr1
)->attr
.codimension
)
5288 && expr1
->ref
->type
== REF_ARRAY
5289 && expr1
->ref
->next
== NULL
;
5291 /* Check for F03:C811. */
5292 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
5293 || (!class_array
&& expr1
->ref
!= NULL
)))
5295 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
5296 "use associate-name=>");
5301 new_st
.op
= EXEC_SELECT_TYPE
;
5302 new_st
.expr1
= expr1
;
5303 new_st
.expr2
= expr2
;
5304 new_st
.ext
.block
.ns
= gfc_current_ns
;
5306 select_type_push (expr1
->symtree
->n
.sym
);
5311 gfc_free_expr (expr1
);
5312 gfc_free_expr (expr2
);
5317 /* Match a CASE statement. */
5320 gfc_match_case (void)
5322 gfc_case
*c
, *head
, *tail
;
5327 if (gfc_current_state () != COMP_SELECT
)
5329 gfc_error ("Unexpected CASE statement at %C");
5333 if (gfc_match ("% default") == MATCH_YES
)
5335 m
= match_case_eos ();
5338 if (m
== MATCH_ERROR
)
5341 new_st
.op
= EXEC_SELECT
;
5342 c
= gfc_get_case ();
5343 c
->where
= gfc_current_locus
;
5344 new_st
.ext
.block
.case_list
= c
;
5348 if (gfc_match_char ('(') != MATCH_YES
)
5353 if (match_case_selector (&c
) == MATCH_ERROR
)
5363 if (gfc_match_char (')') == MATCH_YES
)
5365 if (gfc_match_char (',') != MATCH_YES
)
5369 m
= match_case_eos ();
5372 if (m
== MATCH_ERROR
)
5375 new_st
.op
= EXEC_SELECT
;
5376 new_st
.ext
.block
.case_list
= head
;
5381 gfc_error ("Syntax error in CASE specification at %C");
5384 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
5389 /* Match a TYPE IS statement. */
5392 gfc_match_type_is (void)
5397 if (gfc_current_state () != COMP_SELECT_TYPE
)
5399 gfc_error ("Unexpected TYPE IS statement at %C");
5403 if (gfc_match_char ('(') != MATCH_YES
)
5406 c
= gfc_get_case ();
5407 c
->where
= gfc_current_locus
;
5409 if (gfc_match_type_spec (&c
->ts
) == MATCH_ERROR
)
5412 if (gfc_match_char (')') != MATCH_YES
)
5415 m
= match_case_eos ();
5418 if (m
== MATCH_ERROR
)
5421 new_st
.op
= EXEC_SELECT_TYPE
;
5422 new_st
.ext
.block
.case_list
= c
;
5424 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
5425 && (c
->ts
.u
.derived
->attr
.sequence
5426 || c
->ts
.u
.derived
->attr
.is_bind_c
))
5428 gfc_error ("The type-spec shall not specify a sequence derived "
5429 "type or a type with the BIND attribute in SELECT "
5430 "TYPE at %C [F2003:C815]");
5434 /* Create temporary variable. */
5435 select_type_set_tmp (&c
->ts
);
5440 gfc_error ("Syntax error in TYPE IS specification at %C");
5444 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
5449 /* Match a CLASS IS or CLASS DEFAULT statement. */
5452 gfc_match_class_is (void)
5457 if (gfc_current_state () != COMP_SELECT_TYPE
)
5460 if (gfc_match ("% default") == MATCH_YES
)
5462 m
= match_case_eos ();
5465 if (m
== MATCH_ERROR
)
5468 new_st
.op
= EXEC_SELECT_TYPE
;
5469 c
= gfc_get_case ();
5470 c
->where
= gfc_current_locus
;
5471 c
->ts
.type
= BT_UNKNOWN
;
5472 new_st
.ext
.block
.case_list
= c
;
5473 select_type_set_tmp (NULL
);
5477 m
= gfc_match ("% is");
5480 if (m
== MATCH_ERROR
)
5483 if (gfc_match_char ('(') != MATCH_YES
)
5486 c
= gfc_get_case ();
5487 c
->where
= gfc_current_locus
;
5489 if (match_derived_type_spec (&c
->ts
) == MATCH_ERROR
)
5492 if (c
->ts
.type
== BT_DERIVED
)
5493 c
->ts
.type
= BT_CLASS
;
5495 if (gfc_match_char (')') != MATCH_YES
)
5498 m
= match_case_eos ();
5501 if (m
== MATCH_ERROR
)
5504 new_st
.op
= EXEC_SELECT_TYPE
;
5505 new_st
.ext
.block
.case_list
= c
;
5507 /* Create temporary variable. */
5508 select_type_set_tmp (&c
->ts
);
5513 gfc_error ("Syntax error in CLASS IS specification at %C");
5517 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
5522 /********************* WHERE subroutines ********************/
5524 /* Match the rest of a simple WHERE statement that follows an IF statement.
5528 match_simple_where (void)
5534 m
= gfc_match (" ( %e )", &expr
);
5538 m
= gfc_match_assignment ();
5541 if (m
== MATCH_ERROR
)
5544 if (gfc_match_eos () != MATCH_YES
)
5547 c
= gfc_get_code (EXEC_WHERE
);
5550 c
->next
= XCNEW (gfc_code
);
5552 gfc_clear_new_st ();
5554 new_st
.op
= EXEC_WHERE
;
5560 gfc_syntax_error (ST_WHERE
);
5563 gfc_free_expr (expr
);
5568 /* Match a WHERE statement. */
5571 gfc_match_where (gfc_statement
*st
)
5577 m0
= gfc_match_label ();
5578 if (m0
== MATCH_ERROR
)
5581 m
= gfc_match (" where ( %e )", &expr
);
5585 if (gfc_match_eos () == MATCH_YES
)
5587 *st
= ST_WHERE_BLOCK
;
5588 new_st
.op
= EXEC_WHERE
;
5589 new_st
.expr1
= expr
;
5593 m
= gfc_match_assignment ();
5595 gfc_syntax_error (ST_WHERE
);
5599 gfc_free_expr (expr
);
5603 /* We've got a simple WHERE statement. */
5605 c
= gfc_get_code (EXEC_WHERE
);
5608 c
->next
= XCNEW (gfc_code
);
5610 gfc_clear_new_st ();
5612 new_st
.op
= EXEC_WHERE
;
5619 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
5620 new_st if successful. */
5623 gfc_match_elsewhere (void)
5625 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5629 if (gfc_current_state () != COMP_WHERE
)
5631 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
5637 if (gfc_match_char ('(') == MATCH_YES
)
5639 m
= gfc_match_expr (&expr
);
5642 if (m
== MATCH_ERROR
)
5645 if (gfc_match_char (')') != MATCH_YES
)
5649 if (gfc_match_eos () != MATCH_YES
)
5651 /* Only makes sense if we have a where-construct-name. */
5652 if (!gfc_current_block ())
5657 /* Better be a name at this point. */
5658 m
= gfc_match_name (name
);
5661 if (m
== MATCH_ERROR
)
5664 if (gfc_match_eos () != MATCH_YES
)
5667 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5669 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
5670 name
, gfc_current_block ()->name
);
5675 new_st
.op
= EXEC_WHERE
;
5676 new_st
.expr1
= expr
;
5680 gfc_syntax_error (ST_ELSEWHERE
);
5683 gfc_free_expr (expr
);