1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000-2017 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
29 int gfc_matching_ptr_assignment
= 0;
30 int gfc_matching_procptr_assignment
= 0;
31 bool gfc_matching_prefix
= false;
33 /* Stack of SELECT TYPE statements. */
34 gfc_select_type_stack
*select_type_stack
= NULL
;
36 /* For debugging and diagnostic purposes. Return the textual representation
37 of the intrinsic operator OP. */
39 gfc_op2string (gfc_intrinsic_op op
)
47 case INTRINSIC_UMINUS
:
53 case INTRINSIC_CONCAT
:
57 case INTRINSIC_DIVIDE
:
96 case INTRINSIC_ASSIGN
:
99 case INTRINSIC_PARENTHESES
:
106 case INTRINSIC_FORMATTED
:
108 case INTRINSIC_UNFORMATTED
:
109 return "unformatted";
115 gfc_internal_error ("gfc_op2string(): Bad code");
120 /******************** Generic matching subroutines ************************/
122 /* Matches a member separator. With standard FORTRAN this is '%', but with
123 DEC structures we must carefully match dot ('.').
124 Because operators are spelled ".op.", a dotted string such as "x.y.z..."
125 can be either a component reference chain or a combination of binary
127 There is no real way to win because the string may be grammatically
128 ambiguous. The following rules help avoid ambiguities - they match
129 some behavior of other (older) compilers. If the rules here are changed
130 the test cases should be updated. If the user has problems with these rules
131 they probably deserve the consequences. Consider "x.y.z":
132 (1) If any user defined operator ".y." exists, this is always y(x,z)
133 (even if ".y." is the wrong type and/or x has a member y).
134 (2) Otherwise if x has a member y, and y is itself a derived type,
135 this is (x->y)->z, even if an intrinsic operator exists which
137 (3) If x has no member y or (x->y) is not a derived type but ".y."
138 is an intrinsic operator (such as ".eq."), this is y(x,z).
139 (4) Lastly if there is no operator ".y." and x has no member "y", it is an
141 It is worth noting that the logic here does not support mixed use of member
142 accessors within a single string. That is, even if x has component y and y
143 has component z, the following are all syntax errors:
144 "x%y.z" "x.y%z" "(x.y).z" "(x%y)%z"
148 gfc_match_member_sep(gfc_symbol
*sym
)
150 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
151 locus dot_loc
, start_loc
;
152 gfc_intrinsic_op iop
;
155 gfc_component
*c
= NULL
;
157 /* What a relief: '%' is an unambiguous member separator. */
158 if (gfc_match_char ('%') == MATCH_YES
)
161 /* Beware ye who enter here. */
162 if (!flag_dec_structure
|| !sym
)
167 /* We may be given either a derived type variable or the derived type
168 declaration itself (which actually contains the components);
169 we need the latter to search for components. */
170 if (gfc_fl_struct (sym
->attr
.flavor
))
172 else if (gfc_bt_struct (sym
->ts
.type
))
173 tsym
= sym
->ts
.u
.derived
;
175 iop
= INTRINSIC_NONE
;
179 /* If we have to reject come back here later. */
180 start_loc
= gfc_current_locus
;
182 /* Look for a component access next. */
183 if (gfc_match_char ('.') != MATCH_YES
)
186 /* If we accept, come back here. */
187 dot_loc
= gfc_current_locus
;
189 /* Try to match a symbol name following the dot. */
190 if (gfc_match_name (name
) != MATCH_YES
)
192 gfc_error ("Expected structure component or operator name "
197 /* If no dot follows we have "x.y" which should be a component access. */
198 if (gfc_match_char ('.') != MATCH_YES
)
201 /* Now we have a string "x.y.z" which could be a nested member access
202 (x->y)->z or a binary operation y on x and z. */
204 /* First use any user-defined operators ".y." */
205 if (gfc_find_uop (name
, sym
->ns
) != NULL
)
208 /* Match accesses to existing derived-type components for
209 derived-type vars: "x.y.z" = (x->y)->z */
210 c
= gfc_find_component(tsym
, name
, false, true, NULL
);
211 if (c
&& (gfc_bt_struct (c
->ts
.type
) || c
->ts
.type
== BT_CLASS
))
214 /* If y is not a component or has no members, try intrinsic operators. */
215 gfc_current_locus
= start_loc
;
216 if (gfc_match_intrinsic_op (&iop
) != MATCH_YES
)
218 /* If ".y." is not an intrinsic operator but y was a valid non-
219 structure component, match and leave the trailing dot to be
224 gfc_error ("'%s' is neither a defined operator nor a "
225 "structure component in dotted string at %C", name
);
229 /* .y. is an intrinsic operator, overriding any possible member access. */
232 /* Return keeping the current locus consistent with the match result. */
236 gfc_current_locus
= start_loc
;
239 gfc_current_locus
= dot_loc
;
244 /* This function scans the current statement counting the opened and closed
245 parenthesis to make sure they are balanced. */
248 gfc_match_parens (void)
250 locus old_loc
, where
;
252 gfc_instring instring
;
255 old_loc
= gfc_current_locus
;
257 instring
= NONSTRING
;
262 c
= gfc_next_char_literal (instring
);
265 if (quote
== ' ' && ((c
== '\'') || (c
== '"')))
268 instring
= INSTRING_WARN
;
271 if (quote
!= ' ' && c
== quote
)
274 instring
= NONSTRING
;
278 if (c
== '(' && quote
== ' ')
281 where
= gfc_current_locus
;
283 if (c
== ')' && quote
== ' ')
286 where
= gfc_current_locus
;
290 gfc_current_locus
= old_loc
;
294 gfc_error ("Missing %<)%> in statement at or before %L", &where
);
299 gfc_error ("Missing %<(%> in statement at or before %L", &where
);
307 /* See if the next character is a special character that has
308 escaped by a \ via the -fbackslash option. */
311 gfc_match_special_char (gfc_char_t
*res
)
319 switch ((c
= gfc_next_char_literal (INSTRING_WARN
)))
352 /* Hexadecimal form of wide characters. */
353 len
= (c
== 'x' ? 2 : (c
== 'u' ? 4 : 8));
355 for (i
= 0; i
< len
; i
++)
357 char buf
[2] = { '\0', '\0' };
359 c
= gfc_next_char_literal (INSTRING_WARN
);
360 if (!gfc_wide_fits_in_byte (c
)
361 || !gfc_check_digit ((unsigned char) c
, 16))
364 buf
[0] = (unsigned char) c
;
366 n
+= strtol (buf
, NULL
, 16);
372 /* Unknown backslash codes are simply not expanded. */
381 /* In free form, match at least one space. Always matches in fixed
385 gfc_match_space (void)
390 if (gfc_current_form
== FORM_FIXED
)
393 old_loc
= gfc_current_locus
;
395 c
= gfc_next_ascii_char ();
396 if (!gfc_is_whitespace (c
))
398 gfc_current_locus
= old_loc
;
402 gfc_gobble_whitespace ();
408 /* Match an end of statement. End of statement is optional
409 whitespace, followed by a ';' or '\n' or comment '!'. If a
410 semicolon is found, we continue to eat whitespace and semicolons. */
423 old_loc
= gfc_current_locus
;
424 gfc_gobble_whitespace ();
426 c
= gfc_next_ascii_char ();
432 c
= gfc_next_ascii_char ();
449 gfc_current_locus
= old_loc
;
450 return (flag
) ? MATCH_YES
: MATCH_NO
;
454 /* Match a literal integer on the input, setting the value on
455 MATCH_YES. Literal ints occur in kind-parameters as well as
456 old-style character length specifications. If cnt is non-NULL it
457 will be set to the number of digits. */
460 gfc_match_small_literal_int (int *value
, int *cnt
)
466 old_loc
= gfc_current_locus
;
469 gfc_gobble_whitespace ();
470 c
= gfc_next_ascii_char ();
476 gfc_current_locus
= old_loc
;
485 old_loc
= gfc_current_locus
;
486 c
= gfc_next_ascii_char ();
491 i
= 10 * i
+ c
- '0';
496 gfc_error ("Integer too large at %C");
501 gfc_current_locus
= old_loc
;
510 /* Match a small, constant integer expression, like in a kind
511 statement. On MATCH_YES, 'value' is set. */
514 gfc_match_small_int (int *value
)
520 m
= gfc_match_expr (&expr
);
524 if (gfc_extract_int (expr
, &i
, 1))
526 gfc_free_expr (expr
);
533 /* This function is the same as the gfc_match_small_int, except that
534 we're keeping the pointer to the expr. This function could just be
535 removed and the previously mentioned one modified, though all calls
536 to it would have to be modified then (and there were a number of
537 them). Return MATCH_ERROR if fail to extract the int; otherwise,
538 return the result of gfc_match_expr(). The expr (if any) that was
539 matched is returned in the parameter expr. */
542 gfc_match_small_int_expr (int *value
, gfc_expr
**expr
)
547 m
= gfc_match_expr (expr
);
551 if (gfc_extract_int (*expr
, &i
, 1))
559 /* Matches a statement label. Uses gfc_match_small_literal_int() to
560 do most of the work. */
563 gfc_match_st_label (gfc_st_label
**label
)
569 old_loc
= gfc_current_locus
;
571 m
= gfc_match_small_literal_int (&i
, &cnt
);
577 gfc_error ("Too many digits in statement label at %C");
583 gfc_error ("Statement label at %C is zero");
587 *label
= gfc_get_st_label (i
);
592 gfc_current_locus
= old_loc
;
597 /* Match and validate a label associated with a named IF, DO or SELECT
598 statement. If the symbol does not have the label attribute, we add
599 it. We also make sure the symbol does not refer to another
600 (active) block. A matched label is pointed to by gfc_new_block. */
603 gfc_match_label (void)
605 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
608 gfc_new_block
= NULL
;
610 m
= gfc_match (" %n :", name
);
614 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
616 gfc_error ("Label name %qs at %C is ambiguous", name
);
620 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
622 gfc_error ("Duplicate construct label %qs at %C", name
);
626 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
627 gfc_new_block
->name
, NULL
))
634 /* See if the current input looks like a name of some sort. Modifies
635 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
636 Note that options.c restricts max_identifier_length to not more
637 than GFC_MAX_SYMBOL_LEN. */
640 gfc_match_name (char *buffer
)
646 old_loc
= gfc_current_locus
;
647 gfc_gobble_whitespace ();
649 c
= gfc_next_ascii_char ();
650 if (!(ISALPHA (c
) || (c
== '_' && flag_allow_leading_underscore
)))
652 /* Special cases for unary minus and plus, which allows for a sensible
653 error message for code of the form 'c = exp(-a*b) )' where an
654 extra ')' appears at the end of statement. */
655 if (!gfc_error_flag_test () && c
!= '(' && c
!= '-' && c
!= '+')
656 gfc_error ("Invalid character in name at %C");
657 gfc_current_locus
= old_loc
;
667 if (i
> gfc_option
.max_identifier_length
)
669 gfc_error ("Name at %C is too long");
673 old_loc
= gfc_current_locus
;
674 c
= gfc_next_ascii_char ();
676 while (ISALNUM (c
) || c
== '_' || (flag_dollar_ok
&& c
== '$'));
678 if (c
== '$' && !flag_dollar_ok
)
680 gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to "
681 "allow it as an extension", &old_loc
);
686 gfc_current_locus
= old_loc
;
692 /* Match a symbol on the input. Modifies the pointer to the symbol
693 pointer if successful. */
696 gfc_match_sym_tree (gfc_symtree
**matched_symbol
, int host_assoc
)
698 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
701 m
= gfc_match_name (buffer
);
706 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
707 ? MATCH_ERROR
: MATCH_YES
;
709 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
, false))
717 gfc_match_symbol (gfc_symbol
**matched_symbol
, int host_assoc
)
722 m
= gfc_match_sym_tree (&st
, host_assoc
);
727 *matched_symbol
= st
->n
.sym
;
729 *matched_symbol
= NULL
;
732 *matched_symbol
= NULL
;
737 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
738 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
742 gfc_match_intrinsic_op (gfc_intrinsic_op
*result
)
744 locus orig_loc
= gfc_current_locus
;
747 gfc_gobble_whitespace ();
748 ch
= gfc_next_ascii_char ();
753 *result
= INTRINSIC_PLUS
;
758 *result
= INTRINSIC_MINUS
;
762 if (gfc_next_ascii_char () == '=')
765 *result
= INTRINSIC_EQ
;
771 if (gfc_peek_ascii_char () == '=')
774 gfc_next_ascii_char ();
775 *result
= INTRINSIC_LE
;
779 *result
= INTRINSIC_LT
;
783 if (gfc_peek_ascii_char () == '=')
786 gfc_next_ascii_char ();
787 *result
= INTRINSIC_GE
;
791 *result
= INTRINSIC_GT
;
795 if (gfc_peek_ascii_char () == '*')
798 gfc_next_ascii_char ();
799 *result
= INTRINSIC_POWER
;
803 *result
= INTRINSIC_TIMES
;
807 ch
= gfc_peek_ascii_char ();
811 gfc_next_ascii_char ();
812 *result
= INTRINSIC_NE
;
818 gfc_next_ascii_char ();
819 *result
= INTRINSIC_CONCAT
;
823 *result
= INTRINSIC_DIVIDE
;
827 ch
= gfc_next_ascii_char ();
831 if (gfc_next_ascii_char () == 'n'
832 && gfc_next_ascii_char () == 'd'
833 && gfc_next_ascii_char () == '.')
835 /* Matched ".and.". */
836 *result
= INTRINSIC_AND
;
842 if (gfc_next_ascii_char () == 'q')
844 ch
= gfc_next_ascii_char ();
847 /* Matched ".eq.". */
848 *result
= INTRINSIC_EQ_OS
;
853 if (gfc_next_ascii_char () == '.')
855 /* Matched ".eqv.". */
856 *result
= INTRINSIC_EQV
;
864 ch
= gfc_next_ascii_char ();
867 if (gfc_next_ascii_char () == '.')
869 /* Matched ".ge.". */
870 *result
= INTRINSIC_GE_OS
;
876 if (gfc_next_ascii_char () == '.')
878 /* Matched ".gt.". */
879 *result
= INTRINSIC_GT_OS
;
886 ch
= gfc_next_ascii_char ();
889 if (gfc_next_ascii_char () == '.')
891 /* Matched ".le.". */
892 *result
= INTRINSIC_LE_OS
;
898 if (gfc_next_ascii_char () == '.')
900 /* Matched ".lt.". */
901 *result
= INTRINSIC_LT_OS
;
908 ch
= gfc_next_ascii_char ();
911 ch
= gfc_next_ascii_char ();
914 /* Matched ".ne.". */
915 *result
= INTRINSIC_NE_OS
;
920 if (gfc_next_ascii_char () == 'v'
921 && gfc_next_ascii_char () == '.')
923 /* Matched ".neqv.". */
924 *result
= INTRINSIC_NEQV
;
931 if (gfc_next_ascii_char () == 't'
932 && gfc_next_ascii_char () == '.')
934 /* Matched ".not.". */
935 *result
= INTRINSIC_NOT
;
942 if (gfc_next_ascii_char () == 'r'
943 && gfc_next_ascii_char () == '.')
945 /* Matched ".or.". */
946 *result
= INTRINSIC_OR
;
952 if (gfc_next_ascii_char () == 'o'
953 && gfc_next_ascii_char () == 'r'
954 && gfc_next_ascii_char () == '.')
956 if (!gfc_notify_std (GFC_STD_LEGACY
, ".XOR. operator at %C"))
958 /* Matched ".xor." - equivalent to ".neqv.". */
959 *result
= INTRINSIC_NEQV
;
973 gfc_current_locus
= orig_loc
;
978 /* Match a loop control phrase:
980 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
982 If the final integer expression is not present, a constant unity
983 expression is returned. We don't return MATCH_ERROR until after
984 the equals sign is seen. */
987 gfc_match_iterator (gfc_iterator
*iter
, int init_flag
)
989 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
990 gfc_expr
*var
, *e1
, *e2
, *e3
;
996 /* Match the start of an iterator without affecting the symbol table. */
998 start
= gfc_current_locus
;
999 m
= gfc_match (" %n =", name
);
1000 gfc_current_locus
= start
;
1005 m
= gfc_match_variable (&var
, 0);
1009 if (var
->symtree
->n
.sym
->attr
.dimension
)
1011 gfc_error ("Loop variable at %C cannot be an array");
1015 /* F2008, C617 & C565. */
1016 if (var
->symtree
->n
.sym
->attr
.codimension
)
1018 gfc_error ("Loop variable at %C cannot be a coarray");
1022 if (var
->ref
!= NULL
)
1024 gfc_error ("Loop variable at %C cannot be a sub-component");
1028 gfc_match_char ('=');
1030 var
->symtree
->n
.sym
->attr
.implied_index
= 1;
1032 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
1035 if (m
== MATCH_ERROR
)
1038 if (gfc_match_char (',') != MATCH_YES
)
1041 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
1044 if (m
== MATCH_ERROR
)
1047 if (gfc_match_char (',') != MATCH_YES
)
1049 e3
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1053 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
1054 if (m
== MATCH_ERROR
)
1058 gfc_error ("Expected a step value in iterator at %C");
1070 gfc_error ("Syntax error in iterator at %C");
1081 /* Tries to match the next non-whitespace character on the input.
1082 This subroutine does not return MATCH_ERROR. */
1085 gfc_match_char (char c
)
1089 where
= gfc_current_locus
;
1090 gfc_gobble_whitespace ();
1092 if (gfc_next_ascii_char () == c
)
1095 gfc_current_locus
= where
;
1100 /* General purpose matching subroutine. The target string is a
1101 scanf-like format string in which spaces correspond to arbitrary
1102 whitespace (including no whitespace), characters correspond to
1103 themselves. The %-codes are:
1105 %% Literal percent sign
1106 %e Expression, pointer to a pointer is set
1107 %s Symbol, pointer to the symbol is set
1108 %n Name, character buffer is set to name
1109 %t Matches end of statement.
1110 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1111 %l Matches a statement label
1112 %v Matches a variable expression (an lvalue)
1113 % Matches a required space (in free form) and optional spaces. */
1116 gfc_match (const char *target
, ...)
1118 gfc_st_label
**label
;
1127 old_loc
= gfc_current_locus
;
1128 va_start (argp
, target
);
1138 gfc_gobble_whitespace ();
1149 vp
= va_arg (argp
, void **);
1150 n
= gfc_match_expr ((gfc_expr
**) vp
);
1161 vp
= va_arg (argp
, void **);
1162 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
1173 vp
= va_arg (argp
, void **);
1174 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
1185 np
= va_arg (argp
, char *);
1186 n
= gfc_match_name (np
);
1197 label
= va_arg (argp
, gfc_st_label
**);
1198 n
= gfc_match_st_label (label
);
1209 ip
= va_arg (argp
, int *);
1210 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
1221 if (gfc_match_eos () != MATCH_YES
)
1229 if (gfc_match_space () == MATCH_YES
)
1235 break; /* Fall through to character matcher. */
1238 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
1243 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1244 expect an upper case character here! */
1245 gcc_assert (TOLOWER (c
) == c
);
1247 if (c
== gfc_next_ascii_char ())
1257 /* Clean up after a failed match. */
1258 gfc_current_locus
= old_loc
;
1259 va_start (argp
, target
);
1262 for (; matches
> 0; matches
--)
1264 while (*p
++ != '%');
1272 /* Matches that don't have to be undone */
1277 (void) va_arg (argp
, void **);
1282 vp
= va_arg (argp
, void **);
1283 gfc_free_expr ((struct gfc_expr
*)*vp
);
1296 /*********************** Statement level matching **********************/
1298 /* Matches the start of a program unit, which is the program keyword
1299 followed by an obligatory symbol. */
1302 gfc_match_program (void)
1307 m
= gfc_match ("% %s%t", &sym
);
1311 gfc_error ("Invalid form of PROGRAM statement at %C");
1315 if (m
== MATCH_ERROR
)
1318 if (!gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
))
1321 gfc_new_block
= sym
;
1327 /* Match a simple assignment statement. */
1330 gfc_match_assignment (void)
1332 gfc_expr
*lvalue
, *rvalue
;
1336 old_loc
= gfc_current_locus
;
1339 m
= gfc_match (" %v =", &lvalue
);
1342 gfc_current_locus
= old_loc
;
1343 gfc_free_expr (lvalue
);
1348 m
= gfc_match (" %e%t", &rvalue
);
1351 gfc_current_locus
= old_loc
;
1352 gfc_free_expr (lvalue
);
1353 gfc_free_expr (rvalue
);
1357 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1359 new_st
.op
= EXEC_ASSIGN
;
1360 new_st
.expr1
= lvalue
;
1361 new_st
.expr2
= rvalue
;
1363 gfc_check_do_variable (lvalue
->symtree
);
1369 /* Match a pointer assignment statement. */
1372 gfc_match_pointer_assignment (void)
1374 gfc_expr
*lvalue
, *rvalue
;
1378 old_loc
= gfc_current_locus
;
1380 lvalue
= rvalue
= NULL
;
1381 gfc_matching_ptr_assignment
= 0;
1382 gfc_matching_procptr_assignment
= 0;
1384 m
= gfc_match (" %v =>", &lvalue
);
1391 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1392 || gfc_is_proc_ptr_comp (lvalue
))
1393 gfc_matching_procptr_assignment
= 1;
1395 gfc_matching_ptr_assignment
= 1;
1397 m
= gfc_match (" %e%t", &rvalue
);
1398 gfc_matching_ptr_assignment
= 0;
1399 gfc_matching_procptr_assignment
= 0;
1403 new_st
.op
= EXEC_POINTER_ASSIGN
;
1404 new_st
.expr1
= lvalue
;
1405 new_st
.expr2
= rvalue
;
1410 gfc_current_locus
= old_loc
;
1411 gfc_free_expr (lvalue
);
1412 gfc_free_expr (rvalue
);
1417 /* We try to match an easy arithmetic IF statement. This only happens
1418 when just after having encountered a simple IF statement. This code
1419 is really duplicate with parts of the gfc_match_if code, but this is
1423 match_arithmetic_if (void)
1425 gfc_st_label
*l1
, *l2
, *l3
;
1429 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1433 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1434 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1435 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1437 gfc_free_expr (expr
);
1441 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Arithmetic IF statement at %C"))
1444 new_st
.op
= EXEC_ARITHMETIC_IF
;
1445 new_st
.expr1
= expr
;
1454 /* The IF statement is a bit of a pain. First of all, there are three
1455 forms of it, the simple IF, the IF that starts a block and the
1458 There is a problem with the simple IF and that is the fact that we
1459 only have a single level of undo information on symbols. What this
1460 means is for a simple IF, we must re-match the whole IF statement
1461 multiple times in order to guarantee that the symbol table ends up
1462 in the proper state. */
1464 static match
match_simple_forall (void);
1465 static match
match_simple_where (void);
1468 gfc_match_if (gfc_statement
*if_type
)
1471 gfc_st_label
*l1
, *l2
, *l3
;
1472 locus old_loc
, old_loc2
;
1476 n
= gfc_match_label ();
1477 if (n
== MATCH_ERROR
)
1480 old_loc
= gfc_current_locus
;
1482 m
= gfc_match (" if ( %e", &expr
);
1486 old_loc2
= gfc_current_locus
;
1487 gfc_current_locus
= old_loc
;
1489 if (gfc_match_parens () == MATCH_ERROR
)
1492 gfc_current_locus
= old_loc2
;
1494 if (gfc_match_char (')') != MATCH_YES
)
1496 gfc_error ("Syntax error in IF-expression at %C");
1497 gfc_free_expr (expr
);
1501 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1507 gfc_error ("Block label not appropriate for arithmetic IF "
1509 gfc_free_expr (expr
);
1513 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1514 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1515 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1517 gfc_free_expr (expr
);
1521 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Arithmetic IF statement at %C"))
1524 new_st
.op
= EXEC_ARITHMETIC_IF
;
1525 new_st
.expr1
= expr
;
1530 *if_type
= ST_ARITHMETIC_IF
;
1534 if (gfc_match (" then%t") == MATCH_YES
)
1536 new_st
.op
= EXEC_IF
;
1537 new_st
.expr1
= expr
;
1538 *if_type
= ST_IF_BLOCK
;
1544 gfc_error ("Block label is not appropriate for IF statement at %C");
1545 gfc_free_expr (expr
);
1549 /* At this point the only thing left is a simple IF statement. At
1550 this point, n has to be MATCH_NO, so we don't have to worry about
1551 re-matching a block label. From what we've got so far, try
1552 matching an assignment. */
1554 *if_type
= ST_SIMPLE_IF
;
1556 m
= gfc_match_assignment ();
1560 gfc_free_expr (expr
);
1561 gfc_undo_symbols ();
1562 gfc_current_locus
= old_loc
;
1564 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1565 assignment was found. For MATCH_NO, continue to call the various
1567 if (m
== MATCH_ERROR
)
1570 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1572 m
= gfc_match_pointer_assignment ();
1576 gfc_free_expr (expr
);
1577 gfc_undo_symbols ();
1578 gfc_current_locus
= old_loc
;
1580 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1582 /* Look at the next keyword to see which matcher to call. Matching
1583 the keyword doesn't affect the symbol table, so we don't have to
1584 restore between tries. */
1586 #define match(string, subr, statement) \
1587 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1591 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1592 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1593 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1594 match ("call", gfc_match_call
, ST_CALL
)
1595 match ("close", gfc_match_close
, ST_CLOSE
)
1596 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1597 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1598 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1599 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1600 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
)
1601 match ("event post", gfc_match_event_post
, ST_EVENT_POST
)
1602 match ("event wait", gfc_match_event_wait
, ST_EVENT_WAIT
)
1603 match ("exit", gfc_match_exit
, ST_EXIT
)
1604 match ("flush", gfc_match_flush
, ST_FLUSH
)
1605 match ("forall", match_simple_forall
, ST_FORALL
)
1606 match ("go to", gfc_match_goto
, ST_GOTO
)
1607 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1608 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1609 match ("lock", gfc_match_lock
, ST_LOCK
)
1610 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1611 match ("open", gfc_match_open
, ST_OPEN
)
1612 match ("pause", gfc_match_pause
, ST_NONE
)
1613 match ("print", gfc_match_print
, ST_WRITE
)
1614 match ("read", gfc_match_read
, ST_READ
)
1615 match ("return", gfc_match_return
, ST_RETURN
)
1616 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1617 match ("stop", gfc_match_stop
, ST_STOP
)
1618 match ("wait", gfc_match_wait
, ST_WAIT
)
1619 match ("sync all", gfc_match_sync_all
, ST_SYNC_CALL
);
1620 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
1621 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
1622 match ("unlock", gfc_match_unlock
, ST_UNLOCK
)
1623 match ("where", match_simple_where
, ST_WHERE
)
1624 match ("write", gfc_match_write
, ST_WRITE
)
1627 match ("type", gfc_match_print
, ST_WRITE
)
1629 /* The gfc_match_assignment() above may have returned a MATCH_NO
1630 where the assignment was to a named constant. Check that
1631 special case here. */
1632 m
= gfc_match_assignment ();
1635 gfc_error ("Cannot assign to a named constant at %C");
1636 gfc_free_expr (expr
);
1637 gfc_undo_symbols ();
1638 gfc_current_locus
= old_loc
;
1642 /* All else has failed, so give up. See if any of the matchers has
1643 stored an error message of some sort. */
1644 if (!gfc_error_check ())
1645 gfc_error ("Unclassifiable statement in IF-clause at %C");
1647 gfc_free_expr (expr
);
1652 gfc_error ("Syntax error in IF-clause at %C");
1655 gfc_free_expr (expr
);
1659 /* At this point, we've matched the single IF and the action clause
1660 is in new_st. Rearrange things so that the IF statement appears
1663 p
= gfc_get_code (EXEC_IF
);
1664 p
->next
= XCNEW (gfc_code
);
1666 p
->next
->loc
= gfc_current_locus
;
1670 gfc_clear_new_st ();
1672 new_st
.op
= EXEC_IF
;
1681 /* Match an ELSE statement. */
1684 gfc_match_else (void)
1686 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1688 if (gfc_match_eos () == MATCH_YES
)
1691 if (gfc_match_name (name
) != MATCH_YES
1692 || gfc_current_block () == NULL
1693 || gfc_match_eos () != MATCH_YES
)
1695 gfc_error ("Unexpected junk after ELSE statement at %C");
1699 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1701 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1702 name
, gfc_current_block ()->name
);
1710 /* Match an ELSE IF statement. */
1713 gfc_match_elseif (void)
1715 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1719 m
= gfc_match (" ( %e ) then", &expr
);
1723 if (gfc_match_eos () == MATCH_YES
)
1726 if (gfc_match_name (name
) != MATCH_YES
1727 || gfc_current_block () == NULL
1728 || gfc_match_eos () != MATCH_YES
)
1730 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1734 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1736 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1737 name
, gfc_current_block ()->name
);
1742 new_st
.op
= EXEC_IF
;
1743 new_st
.expr1
= expr
;
1747 gfc_free_expr (expr
);
1752 /* Free a gfc_iterator structure. */
1755 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1761 gfc_free_expr (iter
->var
);
1762 gfc_free_expr (iter
->start
);
1763 gfc_free_expr (iter
->end
);
1764 gfc_free_expr (iter
->step
);
1771 /* Match a CRITICAL statement. */
1773 gfc_match_critical (void)
1775 gfc_st_label
*label
= NULL
;
1777 if (gfc_match_label () == MATCH_ERROR
)
1780 if (gfc_match (" critical") != MATCH_YES
)
1783 if (gfc_match_st_label (&label
) == MATCH_ERROR
)
1786 if (gfc_match_eos () != MATCH_YES
)
1788 gfc_syntax_error (ST_CRITICAL
);
1792 if (gfc_pure (NULL
))
1794 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1798 if (gfc_find_state (COMP_DO_CONCURRENT
))
1800 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1805 gfc_unset_implicit_pure (NULL
);
1807 if (!gfc_notify_std (GFC_STD_F2008
, "CRITICAL statement at %C"))
1810 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1812 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1817 if (gfc_find_state (COMP_CRITICAL
))
1819 gfc_error ("Nested CRITICAL block at %C");
1823 new_st
.op
= EXEC_CRITICAL
;
1826 && !gfc_reference_st_label (label
, ST_LABEL_TARGET
))
1833 /* Match a BLOCK statement. */
1836 gfc_match_block (void)
1840 if (gfc_match_label () == MATCH_ERROR
)
1843 if (gfc_match (" block") != MATCH_YES
)
1846 /* For this to be a correct BLOCK statement, the line must end now. */
1847 m
= gfc_match_eos ();
1848 if (m
== MATCH_ERROR
)
1857 /* Match an ASSOCIATE statement. */
1860 gfc_match_associate (void)
1862 if (gfc_match_label () == MATCH_ERROR
)
1865 if (gfc_match (" associate") != MATCH_YES
)
1868 /* Match the association list. */
1869 if (gfc_match_char ('(') != MATCH_YES
)
1871 gfc_error ("Expected association list at %C");
1874 new_st
.ext
.block
.assoc
= NULL
;
1877 gfc_association_list
* newAssoc
= gfc_get_association_list ();
1878 gfc_association_list
* a
;
1880 /* Match the next association. */
1881 if (gfc_match (" %n => %e", newAssoc
->name
, &newAssoc
->target
)
1884 gfc_error ("Expected association at %C");
1885 goto assocListError
;
1887 newAssoc
->where
= gfc_current_locus
;
1889 /* Check that the current name is not yet in the list. */
1890 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
1891 if (!strcmp (a
->name
, newAssoc
->name
))
1893 gfc_error ("Duplicate name %qs in association at %C",
1895 goto assocListError
;
1898 /* The target expression must not be coindexed. */
1899 if (gfc_is_coindexed (newAssoc
->target
))
1901 gfc_error ("Association target at %C must not be coindexed");
1902 goto assocListError
;
1905 /* The `variable' field is left blank for now; because the target is not
1906 yet resolved, we can't use gfc_has_vector_subscript to determine it
1907 for now. This is set during resolution. */
1909 /* Put it into the list. */
1910 newAssoc
->next
= new_st
.ext
.block
.assoc
;
1911 new_st
.ext
.block
.assoc
= newAssoc
;
1913 /* Try next one or end if closing parenthesis is found. */
1914 gfc_gobble_whitespace ();
1915 if (gfc_peek_char () == ')')
1917 if (gfc_match_char (',') != MATCH_YES
)
1919 gfc_error ("Expected %<)%> or %<,%> at %C");
1929 if (gfc_match_char (')') != MATCH_YES
)
1931 /* This should never happen as we peek above. */
1935 if (gfc_match_eos () != MATCH_YES
)
1937 gfc_error ("Junk after ASSOCIATE statement at %C");
1944 gfc_free_association_list (new_st
.ext
.block
.assoc
);
1949 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1950 an accessible derived type. */
1953 match_derived_type_spec (gfc_typespec
*ts
)
1955 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1957 gfc_symbol
*derived
;
1959 old_locus
= gfc_current_locus
;
1961 if (gfc_match ("%n", name
) != MATCH_YES
)
1963 gfc_current_locus
= old_locus
;
1967 gfc_find_symbol (name
, NULL
, 1, &derived
);
1969 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
&& derived
->attr
.generic
)
1970 derived
= gfc_find_dt_in_generic (derived
);
1972 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
1974 ts
->type
= BT_DERIVED
;
1975 ts
->u
.derived
= derived
;
1979 gfc_current_locus
= old_locus
;
1984 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
1985 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
1986 It only includes the intrinsic types from the Fortran 2003 standard
1987 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
1988 the implicit_flag is not needed, so it was removed. Derived types are
1989 identified by their name alone. */
1992 gfc_match_type_spec (gfc_typespec
*ts
)
1996 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1999 gfc_gobble_whitespace ();
2000 old_locus
= gfc_current_locus
;
2002 if (match_derived_type_spec (ts
) == MATCH_YES
)
2004 /* Enforce F03:C401. */
2005 if (ts
->u
.derived
->attr
.abstract
)
2007 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
2008 ts
->u
.derived
->name
, &old_locus
);
2014 if (gfc_match ("integer") == MATCH_YES
)
2016 ts
->type
= BT_INTEGER
;
2017 ts
->kind
= gfc_default_integer_kind
;
2021 if (gfc_match ("double precision") == MATCH_YES
)
2024 ts
->kind
= gfc_default_double_kind
;
2028 if (gfc_match ("complex") == MATCH_YES
)
2030 ts
->type
= BT_COMPLEX
;
2031 ts
->kind
= gfc_default_complex_kind
;
2035 if (gfc_match ("character") == MATCH_YES
)
2037 ts
->type
= BT_CHARACTER
;
2039 m
= gfc_match_char_spec (ts
);
2047 if (gfc_match ("logical") == MATCH_YES
)
2049 ts
->type
= BT_LOGICAL
;
2050 ts
->kind
= gfc_default_logical_kind
;
2054 /* REAL is a real pain because it can be a type, intrinsic subprogram,
2055 or list item in a type-list of an OpenMP reduction clause. Need to
2056 differentiate REAL([KIND]=scalar-int-initialization-expr) from
2057 REAL(A,[KIND]) and REAL(KIND,A). */
2059 m
= gfc_match (" %n", name
);
2060 if (m
== MATCH_YES
&& strcmp (name
, "real") == 0)
2067 ts
->kind
= gfc_default_real_kind
;
2069 gfc_gobble_whitespace ();
2071 /* Prevent REAL*4, etc. */
2072 c
= gfc_peek_ascii_char ();
2075 gfc_error ("Invalid type-spec at %C");
2079 /* Found leading colon in REAL::, a trailing ')' in for example
2080 TYPE IS (REAL), or REAL, for an OpenMP list-item. */
2081 if (c
== ':' || c
== ')' || (flag_openmp
&& c
== ','))
2084 /* Found something other than the opening '(' in REAL(... */
2088 gfc_next_char (); /* Burn the '('. */
2090 /* Look for the optional KIND=. */
2091 where
= gfc_current_locus
;
2092 m
= gfc_match ("%n", name
);
2095 gfc_gobble_whitespace ();
2096 c
= gfc_next_char ();
2099 if (strcmp(name
, "a") == 0)
2101 else if (strcmp(name
, "kind") == 0)
2107 gfc_current_locus
= where
;
2110 gfc_current_locus
= where
;
2114 m
= gfc_match_init_expr (&e
);
2115 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
2118 /* If a comma appears, it is an intrinsic subprogram. */
2119 gfc_gobble_whitespace ();
2120 c
= gfc_peek_ascii_char ();
2127 /* If ')' appears, we have REAL(initialization-expr), here check for
2128 a scalar integer initialization-expr and valid kind parameter. */
2131 if (e
->ts
.type
!= BT_INTEGER
|| e
->rank
> 0)
2137 gfc_next_char (); /* Burn the ')'. */
2138 ts
->kind
= (int) mpz_get_si (e
->value
.integer
);
2139 if (gfc_validate_kind (BT_REAL
, ts
->kind
, true) == -1)
2141 gfc_error ("Invalid type-spec at %C");
2151 /* If a type is not matched, simply return MATCH_NO. */
2152 gfc_current_locus
= old_locus
;
2157 gfc_gobble_whitespace ();
2159 /* This prevents INTEGER*4, etc. */
2160 if (gfc_peek_ascii_char () == '*')
2162 gfc_error ("Invalid type-spec at %C");
2166 m
= gfc_match_kind_spec (ts
, false);
2168 /* No kind specifier found. */
2176 /******************** FORALL subroutines ********************/
2178 /* Free a list of FORALL iterators. */
2181 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
2183 gfc_forall_iterator
*next
;
2188 gfc_free_expr (iter
->var
);
2189 gfc_free_expr (iter
->start
);
2190 gfc_free_expr (iter
->end
);
2191 gfc_free_expr (iter
->stride
);
2198 /* Match an iterator as part of a FORALL statement. The format is:
2200 <var> = <start>:<end>[:<stride>]
2202 On MATCH_NO, the caller tests for the possibility that there is a
2203 scalar mask expression. */
2206 match_forall_iterator (gfc_forall_iterator
**result
)
2208 gfc_forall_iterator
*iter
;
2212 where
= gfc_current_locus
;
2213 iter
= XCNEW (gfc_forall_iterator
);
2215 m
= gfc_match_expr (&iter
->var
);
2219 if (gfc_match_char ('=') != MATCH_YES
2220 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
2226 m
= gfc_match_expr (&iter
->start
);
2230 if (gfc_match_char (':') != MATCH_YES
)
2233 m
= gfc_match_expr (&iter
->end
);
2236 if (m
== MATCH_ERROR
)
2239 if (gfc_match_char (':') == MATCH_NO
)
2240 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2243 m
= gfc_match_expr (&iter
->stride
);
2246 if (m
== MATCH_ERROR
)
2250 /* Mark the iteration variable's symbol as used as a FORALL index. */
2251 iter
->var
->symtree
->n
.sym
->forall_index
= true;
2257 gfc_error ("Syntax error in FORALL iterator at %C");
2262 gfc_current_locus
= where
;
2263 gfc_free_forall_iterator (iter
);
2268 /* Match the header of a FORALL statement. */
2271 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
2273 gfc_forall_iterator
*head
, *tail
, *new_iter
;
2277 gfc_gobble_whitespace ();
2282 if (gfc_match_char ('(') != MATCH_YES
)
2285 m
= match_forall_iterator (&new_iter
);
2286 if (m
== MATCH_ERROR
)
2291 head
= tail
= new_iter
;
2295 if (gfc_match_char (',') != MATCH_YES
)
2298 m
= match_forall_iterator (&new_iter
);
2299 if (m
== MATCH_ERROR
)
2304 tail
->next
= new_iter
;
2309 /* Have to have a mask expression. */
2311 m
= gfc_match_expr (&msk
);
2314 if (m
== MATCH_ERROR
)
2320 if (gfc_match_char (')') == MATCH_NO
)
2328 gfc_syntax_error (ST_FORALL
);
2331 gfc_free_expr (msk
);
2332 gfc_free_forall_iterator (head
);
2337 /* Match the rest of a simple FORALL statement that follows an
2341 match_simple_forall (void)
2343 gfc_forall_iterator
*head
;
2352 m
= match_forall_header (&head
, &mask
);
2359 m
= gfc_match_assignment ();
2361 if (m
== MATCH_ERROR
)
2365 m
= gfc_match_pointer_assignment ();
2366 if (m
== MATCH_ERROR
)
2372 c
= XCNEW (gfc_code
);
2374 c
->loc
= gfc_current_locus
;
2376 if (gfc_match_eos () != MATCH_YES
)
2379 gfc_clear_new_st ();
2380 new_st
.op
= EXEC_FORALL
;
2381 new_st
.expr1
= mask
;
2382 new_st
.ext
.forall_iterator
= head
;
2383 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2384 new_st
.block
->next
= c
;
2389 gfc_syntax_error (ST_FORALL
);
2392 gfc_free_forall_iterator (head
);
2393 gfc_free_expr (mask
);
2399 /* Match a FORALL statement. */
2402 gfc_match_forall (gfc_statement
*st
)
2404 gfc_forall_iterator
*head
;
2413 m0
= gfc_match_label ();
2414 if (m0
== MATCH_ERROR
)
2417 m
= gfc_match (" forall");
2421 m
= match_forall_header (&head
, &mask
);
2422 if (m
== MATCH_ERROR
)
2427 if (gfc_match_eos () == MATCH_YES
)
2429 *st
= ST_FORALL_BLOCK
;
2430 new_st
.op
= EXEC_FORALL
;
2431 new_st
.expr1
= mask
;
2432 new_st
.ext
.forall_iterator
= head
;
2436 m
= gfc_match_assignment ();
2437 if (m
== MATCH_ERROR
)
2441 m
= gfc_match_pointer_assignment ();
2442 if (m
== MATCH_ERROR
)
2448 c
= XCNEW (gfc_code
);
2450 c
->loc
= gfc_current_locus
;
2452 gfc_clear_new_st ();
2453 new_st
.op
= EXEC_FORALL
;
2454 new_st
.expr1
= mask
;
2455 new_st
.ext
.forall_iterator
= head
;
2456 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2457 new_st
.block
->next
= c
;
2463 gfc_syntax_error (ST_FORALL
);
2466 gfc_free_forall_iterator (head
);
2467 gfc_free_expr (mask
);
2468 gfc_free_statements (c
);
2473 /* Match a DO statement. */
2478 gfc_iterator iter
, *ip
;
2480 gfc_st_label
*label
;
2483 old_loc
= gfc_current_locus
;
2486 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
2488 m
= gfc_match_label ();
2489 if (m
== MATCH_ERROR
)
2492 if (gfc_match (" do") != MATCH_YES
)
2495 m
= gfc_match_st_label (&label
);
2496 if (m
== MATCH_ERROR
)
2499 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2501 if (gfc_match_eos () == MATCH_YES
)
2503 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
2504 new_st
.op
= EXEC_DO_WHILE
;
2508 /* Match an optional comma, if no comma is found, a space is obligatory. */
2509 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
2512 /* Check for balanced parens. */
2514 if (gfc_match_parens () == MATCH_ERROR
)
2517 if (gfc_match (" concurrent") == MATCH_YES
)
2519 gfc_forall_iterator
*head
;
2522 if (!gfc_notify_std (GFC_STD_F2008
, "DO CONCURRENT construct at %C"))
2528 m
= match_forall_header (&head
, &mask
);
2532 if (m
== MATCH_ERROR
)
2533 goto concurr_cleanup
;
2535 if (gfc_match_eos () != MATCH_YES
)
2536 goto concurr_cleanup
;
2539 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2540 goto concurr_cleanup
;
2542 new_st
.label1
= label
;
2543 new_st
.op
= EXEC_DO_CONCURRENT
;
2544 new_st
.expr1
= mask
;
2545 new_st
.ext
.forall_iterator
= head
;
2550 gfc_syntax_error (ST_DO
);
2551 gfc_free_expr (mask
);
2552 gfc_free_forall_iterator (head
);
2556 /* See if we have a DO WHILE. */
2557 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
2559 new_st
.op
= EXEC_DO_WHILE
;
2563 /* The abortive DO WHILE may have done something to the symbol
2564 table, so we start over. */
2565 gfc_undo_symbols ();
2566 gfc_current_locus
= old_loc
;
2568 gfc_match_label (); /* This won't error. */
2569 gfc_match (" do "); /* This will work. */
2571 gfc_match_st_label (&label
); /* Can't error out. */
2572 gfc_match_char (','); /* Optional comma. */
2574 m
= gfc_match_iterator (&iter
, 0);
2577 if (m
== MATCH_ERROR
)
2580 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
2581 gfc_check_do_variable (iter
.var
->symtree
);
2583 if (gfc_match_eos () != MATCH_YES
)
2585 gfc_syntax_error (ST_DO
);
2589 new_st
.op
= EXEC_DO
;
2593 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2596 new_st
.label1
= label
;
2598 if (new_st
.op
== EXEC_DO_WHILE
)
2599 new_st
.expr1
= iter
.end
;
2602 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
2609 gfc_free_iterator (&iter
, 0);
2615 /* Match an EXIT or CYCLE statement. */
2618 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2620 gfc_state_data
*p
, *o
;
2625 if (gfc_match_eos () == MATCH_YES
)
2629 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2632 m
= gfc_match ("% %n%t", name
);
2633 if (m
== MATCH_ERROR
)
2637 gfc_syntax_error (st
);
2641 /* Find the corresponding symbol. If there's a BLOCK statement
2642 between here and the label, it is not in gfc_current_ns but a parent
2644 stree
= gfc_find_symtree_in_proc (name
, gfc_current_ns
);
2647 gfc_error ("Name %qs in %s statement at %C is unknown",
2648 name
, gfc_ascii_statement (st
));
2653 if (sym
->attr
.flavor
!= FL_LABEL
)
2655 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2656 name
, gfc_ascii_statement (st
));
2661 /* Find the loop specified by the label (or lack of a label). */
2662 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2663 if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2665 else if (p
->state
== COMP_CRITICAL
)
2667 gfc_error("%s statement at %C leaves CRITICAL construct",
2668 gfc_ascii_statement (st
));
2671 else if (p
->state
== COMP_DO_CONCURRENT
2672 && (op
== EXEC_EXIT
|| (sym
&& sym
!= p
->sym
)))
2674 /* F2008, C821 & C845. */
2675 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2676 gfc_ascii_statement (st
));
2679 else if ((sym
&& sym
== p
->sym
)
2680 || (!sym
&& (p
->state
== COMP_DO
2681 || p
->state
== COMP_DO_CONCURRENT
)))
2687 gfc_error ("%s statement at %C is not within a construct",
2688 gfc_ascii_statement (st
));
2690 gfc_error ("%s statement at %C is not within construct %qs",
2691 gfc_ascii_statement (st
), sym
->name
);
2696 /* Special checks for EXIT from non-loop constructs. */
2700 case COMP_DO_CONCURRENT
:
2704 /* This is already handled above. */
2707 case COMP_ASSOCIATE
:
2711 case COMP_SELECT_TYPE
:
2713 if (op
== EXEC_CYCLE
)
2715 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2716 " construct %qs", sym
->name
);
2719 gcc_assert (op
== EXEC_EXIT
);
2720 if (!gfc_notify_std (GFC_STD_F2008
, "EXIT statement with no"
2721 " do-construct-name at %C"))
2726 gfc_error ("%s statement at %C is not applicable to construct %qs",
2727 gfc_ascii_statement (st
), sym
->name
);
2733 gfc_error (is_oacc (p
)
2734 ? G_("%s statement at %C leaving OpenACC structured block")
2735 : G_("%s statement at %C leaving OpenMP structured block"),
2736 gfc_ascii_statement (st
));
2740 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2744 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
2745 && (o
->head
->op
== EXEC_OACC_LOOP
2746 || o
->head
->op
== EXEC_OACC_PARALLEL_LOOP
))
2749 gcc_assert (o
->head
->next
!= NULL
2750 && (o
->head
->next
->op
== EXEC_DO
2751 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2752 && o
->previous
!= NULL
2753 && o
->previous
->tail
->op
== o
->head
->op
);
2754 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2755 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2756 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2757 if (st
== ST_EXIT
&& cnt
<= collapse
)
2759 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2762 if (st
== ST_CYCLE
&& cnt
< collapse
)
2764 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2765 " !$ACC LOOP loop");
2771 && (o
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2772 && (o
->head
->op
== EXEC_OMP_DO
2773 || o
->head
->op
== EXEC_OMP_PARALLEL_DO
2774 || o
->head
->op
== EXEC_OMP_SIMD
2775 || o
->head
->op
== EXEC_OMP_DO_SIMD
2776 || o
->head
->op
== EXEC_OMP_PARALLEL_DO_SIMD
))
2779 gcc_assert (o
->head
->next
!= NULL
2780 && (o
->head
->next
->op
== EXEC_DO
2781 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2782 && o
->previous
!= NULL
2783 && o
->previous
->tail
->op
== o
->head
->op
);
2784 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
)
2786 if (o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2787 count
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2788 if (o
->previous
->tail
->ext
.omp_clauses
->orderedc
)
2789 count
= o
->previous
->tail
->ext
.omp_clauses
->orderedc
;
2791 if (st
== ST_EXIT
&& cnt
<= count
)
2793 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2796 if (st
== ST_CYCLE
&& cnt
< count
)
2798 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2804 /* Save the first statement in the construct - needed by the backend. */
2805 new_st
.ext
.which_construct
= p
->construct
;
2813 /* Match the EXIT statement. */
2816 gfc_match_exit (void)
2818 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2822 /* Match the CYCLE statement. */
2825 gfc_match_cycle (void)
2827 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2831 /* Match a stop-code after an (ERROR) STOP or PAUSE statement. The
2832 requirements for a stop-code differ in the standards.
2836 R840 stop-stmt is STOP [ stop-code ]
2837 R841 stop-code is scalar-char-constant
2838 or digit [ digit [ digit [ digit [ digit ] ] ] ]
2840 Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
2843 R855 stop-stmt is STOP [ stop-code ]
2844 R856 allstop-stmt is ALL STOP [ stop-code ]
2845 R857 stop-code is scalar-default-char-constant-expr
2846 or scalar-int-constant-expr
2848 For free-form source code, all standards contain a statement of the form:
2850 A blank shall be used to separate names, constants, or labels from
2851 adjacent keywords, names, constants, or labels.
2853 A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003,
2857 is valid, but it is invalid Fortran 2008. */
2860 gfc_match_stopcode (gfc_statement st
)
2866 /* Set f95 for -std=f95. */
2867 f95
= gfc_option
.allow_std
== (GFC_STD_F95_OBS
| GFC_STD_F95
| GFC_STD_F77
2868 | GFC_STD_F2008_OBS
);
2870 /* Set f03 for -std=f2003. */
2871 f03
= gfc_option
.allow_std
== (GFC_STD_F95_OBS
| GFC_STD_F95
| GFC_STD_F77
2872 | GFC_STD_F2008_OBS
| GFC_STD_F2003
);
2874 /* Look for a blank between STOP and the stop-code for F2008 or later. */
2875 if (gfc_current_form
!= FORM_FIXED
&& !(f95
|| f03
))
2877 char c
= gfc_peek_ascii_char ();
2879 /* Look for end-of-statement. There is no stop-code. */
2880 if (c
== '\n' || c
== '!' || c
== ';')
2885 gfc_error ("Blank required in %s statement near %C",
2886 gfc_ascii_statement (st
));
2891 if (gfc_match_eos () != MATCH_YES
)
2896 /* First look for the F95 or F2003 digit [...] construct. */
2897 old_locus
= gfc_current_locus
;
2898 m
= gfc_match_small_int (&stopcode
);
2899 if (m
== MATCH_YES
&& (f95
|| f03
))
2903 gfc_error ("STOP code at %C cannot be negative");
2907 if (stopcode
> 99999)
2909 gfc_error ("STOP code at %C contains too many digits");
2914 /* Reset the locus and now load gfc_expr. */
2915 gfc_current_locus
= old_locus
;
2916 m
= gfc_match_expr (&e
);
2917 if (m
== MATCH_ERROR
)
2922 if (gfc_match_eos () != MATCH_YES
)
2926 if (gfc_pure (NULL
))
2928 if (st
== ST_ERROR_STOP
)
2930 if (!gfc_notify_std (GFC_STD_F2015
, "%s statement at %C in PURE "
2931 "procedure", gfc_ascii_statement (st
)))
2936 gfc_error ("%s statement not allowed in PURE procedure at %C",
2937 gfc_ascii_statement (st
));
2942 gfc_unset_implicit_pure (NULL
);
2944 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
))
2946 gfc_error ("Image control statement STOP at %C in CRITICAL block");
2949 if (st
== ST_STOP
&& gfc_find_state (COMP_DO_CONCURRENT
))
2951 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
2957 gfc_simplify_expr (e
, 0);
2959 /* Test for F95 and F2003 style STOP stop-code. */
2960 if (e
->expr_type
!= EXPR_CONSTANT
&& (f95
|| f03
))
2962 gfc_error ("STOP code at %L must be a scalar CHARACTER constant or "
2963 "digit[digit[digit[digit[digit]]]]", &e
->where
);
2967 /* Use the machinery for an initialization expression to reduce the
2968 stop-code to a constant. */
2969 gfc_init_expr_flag
= true;
2970 gfc_reduce_init_expr (e
);
2971 gfc_init_expr_flag
= false;
2973 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
2975 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2982 gfc_error ("STOP code at %L must be scalar", &e
->where
);
2986 if (e
->ts
.type
== BT_CHARACTER
2987 && e
->ts
.kind
!= gfc_default_character_kind
)
2989 gfc_error ("STOP code at %L must be default character KIND=%d",
2990 &e
->where
, (int) gfc_default_character_kind
);
2994 if (e
->ts
.type
== BT_INTEGER
&& e
->ts
.kind
!= gfc_default_integer_kind
)
2996 gfc_error ("STOP code at %L must be default integer KIND=%d",
2997 &e
->where
, (int) gfc_default_integer_kind
);
3007 new_st
.op
= EXEC_STOP
;
3010 new_st
.op
= EXEC_ERROR_STOP
;
3013 new_st
.op
= EXEC_PAUSE
;
3020 new_st
.ext
.stop_code
= -1;
3025 gfc_syntax_error (st
);
3034 /* Match the (deprecated) PAUSE statement. */
3037 gfc_match_pause (void)
3041 m
= gfc_match_stopcode (ST_PAUSE
);
3044 if (!gfc_notify_std (GFC_STD_F95_DEL
, "PAUSE statement at %C"))
3051 /* Match the STOP statement. */
3054 gfc_match_stop (void)
3056 return gfc_match_stopcode (ST_STOP
);
3060 /* Match the ERROR STOP statement. */
3063 gfc_match_error_stop (void)
3065 if (!gfc_notify_std (GFC_STD_F2008
, "ERROR STOP statement at %C"))
3068 return gfc_match_stopcode (ST_ERROR_STOP
);
3071 /* Match EVENT POST/WAIT statement. Syntax:
3072 EVENT POST ( event-variable [, sync-stat-list] )
3073 EVENT WAIT ( event-variable [, wait-spec-list] )
3075 wait-spec-list is sync-stat-list or until-spec
3076 until-spec is UNTIL_COUNT = scalar-int-expr
3077 sync-stat is STAT= or ERRMSG=. */
3080 event_statement (gfc_statement st
)
3083 gfc_expr
*tmp
, *eventvar
, *until_count
, *stat
, *errmsg
;
3084 bool saw_until_count
, saw_stat
, saw_errmsg
;
3086 tmp
= eventvar
= until_count
= stat
= errmsg
= NULL
;
3087 saw_until_count
= saw_stat
= saw_errmsg
= false;
3089 if (gfc_pure (NULL
))
3091 gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
3092 st
== ST_EVENT_POST
? "POST" : "WAIT");
3096 gfc_unset_implicit_pure (NULL
);
3098 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3100 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3104 if (gfc_find_state (COMP_CRITICAL
))
3106 gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
3107 st
== ST_EVENT_POST
? "POST" : "WAIT");
3111 if (gfc_find_state (COMP_DO_CONCURRENT
))
3113 gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
3114 "block", st
== ST_EVENT_POST
? "POST" : "WAIT");
3118 if (gfc_match_char ('(') != MATCH_YES
)
3121 if (gfc_match ("%e", &eventvar
) != MATCH_YES
)
3123 m
= gfc_match_char (',');
3124 if (m
== MATCH_ERROR
)
3128 m
= gfc_match_char (')');
3136 m
= gfc_match (" stat = %v", &tmp
);
3137 if (m
== MATCH_ERROR
)
3143 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3149 m
= gfc_match_char (',');
3157 m
= gfc_match (" errmsg = %v", &tmp
);
3158 if (m
== MATCH_ERROR
)
3164 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3170 m
= gfc_match_char (',');
3178 m
= gfc_match (" until_count = %e", &tmp
);
3179 if (m
== MATCH_ERROR
|| st
== ST_EVENT_POST
)
3183 if (saw_until_count
)
3185 gfc_error ("Redundant UNTIL_COUNT tag found at %L ",
3190 saw_until_count
= true;
3192 m
= gfc_match_char (',');
3203 if (m
== MATCH_ERROR
)
3206 if (gfc_match (" )%t") != MATCH_YES
)
3213 new_st
.op
= EXEC_EVENT_POST
;
3216 new_st
.op
= EXEC_EVENT_WAIT
;
3222 new_st
.expr1
= eventvar
;
3223 new_st
.expr2
= stat
;
3224 new_st
.expr3
= errmsg
;
3225 new_st
.expr4
= until_count
;
3230 gfc_syntax_error (st
);
3233 if (until_count
!= tmp
)
3234 gfc_free_expr (until_count
);
3236 gfc_free_expr (errmsg
);
3238 gfc_free_expr (stat
);
3240 gfc_free_expr (tmp
);
3241 gfc_free_expr (eventvar
);
3249 gfc_match_event_post (void)
3251 if (!gfc_notify_std (GFC_STD_F2008_TS
, "EVENT POST statement at %C"))
3254 return event_statement (ST_EVENT_POST
);
3259 gfc_match_event_wait (void)
3261 if (!gfc_notify_std (GFC_STD_F2008_TS
, "EVENT WAIT statement at %C"))
3264 return event_statement (ST_EVENT_WAIT
);
3268 /* Match LOCK/UNLOCK statement. Syntax:
3269 LOCK ( lock-variable [ , lock-stat-list ] )
3270 UNLOCK ( lock-variable [ , sync-stat-list ] )
3271 where lock-stat is ACQUIRED_LOCK or sync-stat
3272 and sync-stat is STAT= or ERRMSG=. */
3275 lock_unlock_statement (gfc_statement st
)
3278 gfc_expr
*tmp
, *lockvar
, *acq_lock
, *stat
, *errmsg
;
3279 bool saw_acq_lock
, saw_stat
, saw_errmsg
;
3281 tmp
= lockvar
= acq_lock
= stat
= errmsg
= NULL
;
3282 saw_acq_lock
= saw_stat
= saw_errmsg
= false;
3284 if (gfc_pure (NULL
))
3286 gfc_error ("Image control statement %s at %C in PURE procedure",
3287 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3291 gfc_unset_implicit_pure (NULL
);
3293 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3295 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3299 if (gfc_find_state (COMP_CRITICAL
))
3301 gfc_error ("Image control statement %s at %C in CRITICAL block",
3302 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3306 if (gfc_find_state (COMP_DO_CONCURRENT
))
3308 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
3309 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3313 if (gfc_match_char ('(') != MATCH_YES
)
3316 if (gfc_match ("%e", &lockvar
) != MATCH_YES
)
3318 m
= gfc_match_char (',');
3319 if (m
== MATCH_ERROR
)
3323 m
= gfc_match_char (')');
3331 m
= gfc_match (" stat = %v", &tmp
);
3332 if (m
== MATCH_ERROR
)
3338 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3344 m
= gfc_match_char (',');
3352 m
= gfc_match (" errmsg = %v", &tmp
);
3353 if (m
== MATCH_ERROR
)
3359 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3365 m
= gfc_match_char (',');
3373 m
= gfc_match (" acquired_lock = %v", &tmp
);
3374 if (m
== MATCH_ERROR
|| st
== ST_UNLOCK
)
3380 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
3385 saw_acq_lock
= true;
3387 m
= gfc_match_char (',');
3398 if (m
== MATCH_ERROR
)
3401 if (gfc_match (" )%t") != MATCH_YES
)
3408 new_st
.op
= EXEC_LOCK
;
3411 new_st
.op
= EXEC_UNLOCK
;
3417 new_st
.expr1
= lockvar
;
3418 new_st
.expr2
= stat
;
3419 new_st
.expr3
= errmsg
;
3420 new_st
.expr4
= acq_lock
;
3425 gfc_syntax_error (st
);
3428 if (acq_lock
!= tmp
)
3429 gfc_free_expr (acq_lock
);
3431 gfc_free_expr (errmsg
);
3433 gfc_free_expr (stat
);
3435 gfc_free_expr (tmp
);
3436 gfc_free_expr (lockvar
);
3443 gfc_match_lock (void)
3445 if (!gfc_notify_std (GFC_STD_F2008
, "LOCK statement at %C"))
3448 return lock_unlock_statement (ST_LOCK
);
3453 gfc_match_unlock (void)
3455 if (!gfc_notify_std (GFC_STD_F2008
, "UNLOCK statement at %C"))
3458 return lock_unlock_statement (ST_UNLOCK
);
3462 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
3463 SYNC ALL [(sync-stat-list)]
3464 SYNC MEMORY [(sync-stat-list)]
3465 SYNC IMAGES (image-set [, sync-stat-list] )
3466 with sync-stat is int-expr or *. */
3469 sync_statement (gfc_statement st
)
3472 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
3473 bool saw_stat
, saw_errmsg
;
3475 tmp
= imageset
= stat
= errmsg
= NULL
;
3476 saw_stat
= saw_errmsg
= false;
3478 if (gfc_pure (NULL
))
3480 gfc_error ("Image control statement SYNC at %C in PURE procedure");
3484 gfc_unset_implicit_pure (NULL
);
3486 if (!gfc_notify_std (GFC_STD_F2008
, "SYNC statement at %C"))
3489 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3491 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
3496 if (gfc_find_state (COMP_CRITICAL
))
3498 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3502 if (gfc_find_state (COMP_DO_CONCURRENT
))
3504 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3508 if (gfc_match_eos () == MATCH_YES
)
3510 if (st
== ST_SYNC_IMAGES
)
3515 if (gfc_match_char ('(') != MATCH_YES
)
3518 if (st
== ST_SYNC_IMAGES
)
3520 /* Denote '*' as imageset == NULL. */
3521 m
= gfc_match_char ('*');
3522 if (m
== MATCH_ERROR
)
3526 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
3529 m
= gfc_match_char (',');
3530 if (m
== MATCH_ERROR
)
3534 m
= gfc_match_char (')');
3543 m
= gfc_match (" stat = %v", &tmp
);
3544 if (m
== MATCH_ERROR
)
3550 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3556 if (gfc_match_char (',') == MATCH_YES
)
3563 m
= gfc_match (" errmsg = %v", &tmp
);
3564 if (m
== MATCH_ERROR
)
3570 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3576 if (gfc_match_char (',') == MATCH_YES
)
3586 if (gfc_match (" )%t") != MATCH_YES
)
3593 new_st
.op
= EXEC_SYNC_ALL
;
3595 case ST_SYNC_IMAGES
:
3596 new_st
.op
= EXEC_SYNC_IMAGES
;
3598 case ST_SYNC_MEMORY
:
3599 new_st
.op
= EXEC_SYNC_MEMORY
;
3605 new_st
.expr1
= imageset
;
3606 new_st
.expr2
= stat
;
3607 new_st
.expr3
= errmsg
;
3612 gfc_syntax_error (st
);
3616 gfc_free_expr (stat
);
3618 gfc_free_expr (errmsg
);
3620 gfc_free_expr (tmp
);
3621 gfc_free_expr (imageset
);
3627 /* Match SYNC ALL statement. */
3630 gfc_match_sync_all (void)
3632 return sync_statement (ST_SYNC_ALL
);
3636 /* Match SYNC IMAGES statement. */
3639 gfc_match_sync_images (void)
3641 return sync_statement (ST_SYNC_IMAGES
);
3645 /* Match SYNC MEMORY statement. */
3648 gfc_match_sync_memory (void)
3650 return sync_statement (ST_SYNC_MEMORY
);
3654 /* Match a CONTINUE statement. */
3657 gfc_match_continue (void)
3659 if (gfc_match_eos () != MATCH_YES
)
3661 gfc_syntax_error (ST_CONTINUE
);
3665 new_st
.op
= EXEC_CONTINUE
;
3670 /* Match the (deprecated) ASSIGN statement. */
3673 gfc_match_assign (void)
3676 gfc_st_label
*label
;
3678 if (gfc_match (" %l", &label
) == MATCH_YES
)
3680 if (!gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
))
3682 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
3684 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGN statement at %C"))
3687 expr
->symtree
->n
.sym
->attr
.assign
= 1;
3689 new_st
.op
= EXEC_LABEL_ASSIGN
;
3690 new_st
.label1
= label
;
3691 new_st
.expr1
= expr
;
3699 /* Match the GO TO statement. As a computed GOTO statement is
3700 matched, it is transformed into an equivalent SELECT block. No
3701 tree is necessary, and the resulting jumps-to-jumps are
3702 specifically optimized away by the back end. */
3705 gfc_match_goto (void)
3707 gfc_code
*head
, *tail
;
3710 gfc_st_label
*label
;
3714 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
3716 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3719 new_st
.op
= EXEC_GOTO
;
3720 new_st
.label1
= label
;
3724 /* The assigned GO TO statement. */
3726 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
3728 if (!gfc_notify_std (GFC_STD_F95_DEL
, "Assigned GOTO statement at %C"))
3731 new_st
.op
= EXEC_GOTO
;
3732 new_st
.expr1
= expr
;
3734 if (gfc_match_eos () == MATCH_YES
)
3737 /* Match label list. */
3738 gfc_match_char (',');
3739 if (gfc_match_char ('(') != MATCH_YES
)
3741 gfc_syntax_error (ST_GOTO
);
3748 m
= gfc_match_st_label (&label
);
3752 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3756 head
= tail
= gfc_get_code (EXEC_GOTO
);
3759 tail
->block
= gfc_get_code (EXEC_GOTO
);
3763 tail
->label1
= label
;
3765 while (gfc_match_char (',') == MATCH_YES
);
3767 if (gfc_match (")%t") != MATCH_YES
)
3772 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3775 new_st
.block
= head
;
3780 /* Last chance is a computed GO TO statement. */
3781 if (gfc_match_char ('(') != MATCH_YES
)
3783 gfc_syntax_error (ST_GOTO
);
3792 m
= gfc_match_st_label (&label
);
3796 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3800 head
= tail
= gfc_get_code (EXEC_SELECT
);
3803 tail
->block
= gfc_get_code (EXEC_SELECT
);
3807 cp
= gfc_get_case ();
3808 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
3811 tail
->ext
.block
.case_list
= cp
;
3813 tail
->next
= gfc_get_code (EXEC_GOTO
);
3814 tail
->next
->label1
= label
;
3816 while (gfc_match_char (',') == MATCH_YES
);
3818 if (gfc_match_char (')') != MATCH_YES
)
3823 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3827 /* Get the rest of the statement. */
3828 gfc_match_char (',');
3830 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
3833 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Computed GOTO at %C"))
3836 /* At this point, a computed GOTO has been fully matched and an
3837 equivalent SELECT statement constructed. */
3839 new_st
.op
= EXEC_SELECT
;
3840 new_st
.expr1
= NULL
;
3842 /* Hack: For a "real" SELECT, the expression is in expr. We put
3843 it in expr2 so we can distinguish then and produce the correct
3845 new_st
.expr2
= expr
;
3846 new_st
.block
= head
;
3850 gfc_syntax_error (ST_GOTO
);
3852 gfc_free_statements (head
);
3857 /* Frees a list of gfc_alloc structures. */
3860 gfc_free_alloc_list (gfc_alloc
*p
)
3867 gfc_free_expr (p
->expr
);
3873 /* Match an ALLOCATE statement. */
3876 gfc_match_allocate (void)
3878 gfc_alloc
*head
, *tail
;
3879 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
3883 locus old_locus
, deferred_locus
;
3884 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, saw_deferred
, b1
, b2
, b3
;
3885 bool saw_unlimited
= false;
3888 stat
= errmsg
= source
= mold
= tmp
= NULL
;
3889 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= saw_deferred
= false;
3891 if (gfc_match_char ('(') != MATCH_YES
)
3894 /* Match an optional type-spec. */
3895 old_locus
= gfc_current_locus
;
3896 m
= gfc_match_type_spec (&ts
);
3897 if (m
== MATCH_ERROR
)
3899 else if (m
== MATCH_NO
)
3901 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
3903 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
3905 gfc_error ("Error in type-spec at %L", &old_locus
);
3909 ts
.type
= BT_UNKNOWN
;
3913 if (gfc_match (" :: ") == MATCH_YES
)
3915 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
3921 gfc_error ("Type-spec at %L cannot contain a deferred "
3922 "type parameter", &old_locus
);
3926 if (ts
.type
== BT_CHARACTER
)
3927 ts
.u
.cl
->length_from_typespec
= true;
3931 ts
.type
= BT_UNKNOWN
;
3932 gfc_current_locus
= old_locus
;
3939 head
= tail
= gfc_get_alloc ();
3942 tail
->next
= gfc_get_alloc ();
3946 m
= gfc_match_variable (&tail
->expr
, 0);
3949 if (m
== MATCH_ERROR
)
3952 if (gfc_check_do_variable (tail
->expr
->symtree
))
3955 bool impure
= gfc_impure_variable (tail
->expr
->symtree
->n
.sym
);
3956 if (impure
&& gfc_pure (NULL
))
3958 gfc_error ("Bad allocate-object at %C for a PURE procedure");
3963 gfc_unset_implicit_pure (NULL
);
3965 if (tail
->expr
->ts
.deferred
)
3967 saw_deferred
= true;
3968 deferred_locus
= tail
->expr
->where
;
3971 if (gfc_find_state (COMP_DO_CONCURRENT
)
3972 || gfc_find_state (COMP_CRITICAL
))
3975 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
3976 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
3977 if (ref
->type
== REF_COMPONENT
)
3978 coarray
= ref
->u
.c
.component
->attr
.codimension
;
3980 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
3982 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
3985 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
3987 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
3992 /* Check for F08:C628. */
3993 sym
= tail
->expr
->symtree
->n
.sym
;
3994 b1
= !(tail
->expr
->ref
3995 && (tail
->expr
->ref
->type
== REF_COMPONENT
3996 || tail
->expr
->ref
->type
== REF_ARRAY
));
3997 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
3998 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
3999 || CLASS_DATA (sym
)->attr
.class_pointer
);
4001 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4002 || sym
->attr
.proc_pointer
);
4003 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
4004 && (sym
->ns
->proc_name
->attr
.allocatable
4005 || sym
->ns
->proc_name
->attr
.pointer
4006 || sym
->ns
->proc_name
->attr
.proc_pointer
);
4007 if (b1
&& b2
&& !b3
)
4009 gfc_error ("Allocate-object at %L is neither a data pointer "
4010 "nor an allocatable variable", &tail
->expr
->where
);
4014 /* The ALLOCATE statement had an optional typespec. Check the
4016 if (ts
.type
!= BT_UNKNOWN
)
4018 /* Enforce F03:C624. */
4019 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
4021 gfc_error ("Type of entity at %L is type incompatible with "
4022 "typespec", &tail
->expr
->where
);
4026 /* Enforce F03:C627. */
4027 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
4029 gfc_error ("Kind type parameter for entity at %L differs from "
4030 "the kind type parameter of the typespec",
4031 &tail
->expr
->where
);
4036 if (tail
->expr
->ts
.type
== BT_DERIVED
)
4037 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
4039 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
4041 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
4043 gfc_error ("Shape specification for allocatable scalar at %C");
4047 if (gfc_match_char (',') != MATCH_YES
)
4052 m
= gfc_match (" stat = %v", &tmp
);
4053 if (m
== MATCH_ERROR
)
4060 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
4068 if (gfc_check_do_variable (stat
->symtree
))
4071 if (gfc_match_char (',') == MATCH_YES
)
4072 goto alloc_opt_list
;
4075 m
= gfc_match (" errmsg = %v", &tmp
);
4076 if (m
== MATCH_ERROR
)
4080 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
4086 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
4094 if (gfc_match_char (',') == MATCH_YES
)
4095 goto alloc_opt_list
;
4098 m
= gfc_match (" source = %e", &tmp
);
4099 if (m
== MATCH_ERROR
)
4103 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
4109 gfc_error ("Redundant SOURCE tag found at %L ", &tmp
->where
);
4113 /* The next 2 conditionals check C631. */
4114 if (ts
.type
!= BT_UNKNOWN
)
4116 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
4117 &tmp
->where
, &old_locus
);
4122 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
4123 " with more than a single allocate object",
4131 if (gfc_match_char (',') == MATCH_YES
)
4132 goto alloc_opt_list
;
4135 m
= gfc_match (" mold = %e", &tmp
);
4136 if (m
== MATCH_ERROR
)
4140 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
4143 /* Check F08:C636. */
4146 gfc_error ("Redundant MOLD tag found at %L ", &tmp
->where
);
4150 /* Check F08:C637. */
4151 if (ts
.type
!= BT_UNKNOWN
)
4153 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
4154 &tmp
->where
, &old_locus
);
4163 if (gfc_match_char (',') == MATCH_YES
)
4164 goto alloc_opt_list
;
4167 gfc_gobble_whitespace ();
4169 if (gfc_peek_char () == ')')
4173 if (gfc_match (" )%t") != MATCH_YES
)
4176 /* Check F08:C637. */
4179 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
4180 &mold
->where
, &source
->where
);
4184 /* Check F03:C623, */
4185 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4187 gfc_error ("Allocate-object at %L with a deferred type parameter "
4188 "requires either a type-spec or SOURCE tag or a MOLD tag",
4193 /* Check F03:C625, */
4194 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4196 for (tail
= head
; tail
; tail
= tail
->next
)
4198 if (UNLIMITED_POLY (tail
->expr
))
4199 gfc_error ("Unlimited polymorphic allocate-object at %L "
4200 "requires either a type-spec or SOURCE tag "
4201 "or a MOLD tag", &tail
->expr
->where
);
4206 new_st
.op
= EXEC_ALLOCATE
;
4207 new_st
.expr1
= stat
;
4208 new_st
.expr2
= errmsg
;
4210 new_st
.expr3
= source
;
4212 new_st
.expr3
= mold
;
4213 new_st
.ext
.alloc
.list
= head
;
4214 new_st
.ext
.alloc
.ts
= ts
;
4219 gfc_syntax_error (ST_ALLOCATE
);
4222 gfc_free_expr (errmsg
);
4223 gfc_free_expr (source
);
4224 gfc_free_expr (stat
);
4225 gfc_free_expr (mold
);
4226 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
4227 gfc_free_alloc_list (head
);
4232 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
4233 a set of pointer assignments to intrinsic NULL(). */
4236 gfc_match_nullify (void)
4244 if (gfc_match_char ('(') != MATCH_YES
)
4249 m
= gfc_match_variable (&p
, 0);
4250 if (m
== MATCH_ERROR
)
4255 if (gfc_check_do_variable (p
->symtree
))
4259 if (gfc_is_coindexed (p
))
4261 gfc_error ("Pointer object at %C shall not be coindexed");
4265 /* build ' => NULL() '. */
4266 e
= gfc_get_null_expr (&gfc_current_locus
);
4268 /* Chain to list. */
4272 tail
->op
= EXEC_POINTER_ASSIGN
;
4276 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
4283 if (gfc_match (" )%t") == MATCH_YES
)
4285 if (gfc_match_char (',') != MATCH_YES
)
4292 gfc_syntax_error (ST_NULLIFY
);
4295 gfc_free_statements (new_st
.next
);
4297 gfc_free_expr (new_st
.expr1
);
4298 new_st
.expr1
= NULL
;
4299 gfc_free_expr (new_st
.expr2
);
4300 new_st
.expr2
= NULL
;
4305 /* Match a DEALLOCATE statement. */
4308 gfc_match_deallocate (void)
4310 gfc_alloc
*head
, *tail
;
4311 gfc_expr
*stat
, *errmsg
, *tmp
;
4314 bool saw_stat
, saw_errmsg
, b1
, b2
;
4317 stat
= errmsg
= tmp
= NULL
;
4318 saw_stat
= saw_errmsg
= false;
4320 if (gfc_match_char ('(') != MATCH_YES
)
4326 head
= tail
= gfc_get_alloc ();
4329 tail
->next
= gfc_get_alloc ();
4333 m
= gfc_match_variable (&tail
->expr
, 0);
4334 if (m
== MATCH_ERROR
)
4339 if (gfc_check_do_variable (tail
->expr
->symtree
))
4342 sym
= tail
->expr
->symtree
->n
.sym
;
4344 bool impure
= gfc_impure_variable (sym
);
4345 if (impure
&& gfc_pure (NULL
))
4347 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
4352 gfc_unset_implicit_pure (NULL
);
4354 if (gfc_is_coarray (tail
->expr
)
4355 && gfc_find_state (COMP_DO_CONCURRENT
))
4357 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
4361 if (gfc_is_coarray (tail
->expr
)
4362 && gfc_find_state (COMP_CRITICAL
))
4364 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
4368 /* FIXME: disable the checking on derived types. */
4369 b1
= !(tail
->expr
->ref
4370 && (tail
->expr
->ref
->type
== REF_COMPONENT
4371 || tail
->expr
->ref
->type
== REF_ARRAY
));
4372 if (sym
&& sym
->ts
.type
== BT_CLASS
)
4373 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
4374 || CLASS_DATA (sym
)->attr
.class_pointer
);
4376 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4377 || sym
->attr
.proc_pointer
);
4380 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
4381 "nor an allocatable variable");
4385 if (gfc_match_char (',') != MATCH_YES
)
4390 m
= gfc_match (" stat = %v", &tmp
);
4391 if (m
== MATCH_ERROR
)
4397 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
4398 gfc_free_expr (tmp
);
4405 if (gfc_check_do_variable (stat
->symtree
))
4408 if (gfc_match_char (',') == MATCH_YES
)
4409 goto dealloc_opt_list
;
4412 m
= gfc_match (" errmsg = %v", &tmp
);
4413 if (m
== MATCH_ERROR
)
4417 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
4422 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
4423 gfc_free_expr (tmp
);
4430 if (gfc_match_char (',') == MATCH_YES
)
4431 goto dealloc_opt_list
;
4434 gfc_gobble_whitespace ();
4436 if (gfc_peek_char () == ')')
4440 if (gfc_match (" )%t") != MATCH_YES
)
4443 new_st
.op
= EXEC_DEALLOCATE
;
4444 new_st
.expr1
= stat
;
4445 new_st
.expr2
= errmsg
;
4446 new_st
.ext
.alloc
.list
= head
;
4451 gfc_syntax_error (ST_DEALLOCATE
);
4454 gfc_free_expr (errmsg
);
4455 gfc_free_expr (stat
);
4456 gfc_free_alloc_list (head
);
4461 /* Match a RETURN statement. */
4464 gfc_match_return (void)
4468 gfc_compile_state s
;
4472 if (gfc_find_state (COMP_CRITICAL
))
4474 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4478 if (gfc_find_state (COMP_DO_CONCURRENT
))
4480 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4484 if (gfc_match_eos () == MATCH_YES
)
4487 if (!gfc_find_state (COMP_SUBROUTINE
))
4489 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4494 if (gfc_current_form
== FORM_FREE
)
4496 /* The following are valid, so we can't require a blank after the
4500 char c
= gfc_peek_ascii_char ();
4501 if (ISALPHA (c
) || ISDIGIT (c
))
4505 m
= gfc_match (" %e%t", &e
);
4508 if (m
== MATCH_ERROR
)
4511 gfc_syntax_error (ST_RETURN
);
4518 gfc_enclosing_unit (&s
);
4519 if (s
== COMP_PROGRAM
4520 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
4521 "main program at %C"))
4524 new_st
.op
= EXEC_RETURN
;
4531 /* Match the call of a type-bound procedure, if CALL%var has already been
4532 matched and var found to be a derived-type variable. */
4535 match_typebound_call (gfc_symtree
* varst
)
4540 base
= gfc_get_expr ();
4541 base
->expr_type
= EXPR_VARIABLE
;
4542 base
->symtree
= varst
;
4543 base
->where
= gfc_current_locus
;
4544 gfc_set_sym_referenced (varst
->n
.sym
);
4546 m
= gfc_match_varspec (base
, 0, true, true);
4548 gfc_error ("Expected component reference at %C");
4551 gfc_free_expr (base
);
4555 if (gfc_match_eos () != MATCH_YES
)
4557 gfc_error ("Junk after CALL at %C");
4558 gfc_free_expr (base
);
4562 if (base
->expr_type
== EXPR_COMPCALL
)
4563 new_st
.op
= EXEC_COMPCALL
;
4564 else if (base
->expr_type
== EXPR_PPC
)
4565 new_st
.op
= EXEC_CALL_PPC
;
4568 gfc_error ("Expected type-bound procedure or procedure pointer component "
4570 gfc_free_expr (base
);
4573 new_st
.expr1
= base
;
4579 /* Match a CALL statement. The tricky part here are possible
4580 alternate return specifiers. We handle these by having all
4581 "subroutines" actually return an integer via a register that gives
4582 the return number. If the call specifies alternate returns, we
4583 generate code for a SELECT statement whose case clauses contain
4584 GOTOs to the various labels. */
4587 gfc_match_call (void)
4589 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4590 gfc_actual_arglist
*a
, *arglist
;
4600 m
= gfc_match ("% %n", name
);
4606 if (gfc_get_ha_sym_tree (name
, &st
))
4611 /* If this is a variable of derived-type, it probably starts a type-bound
4613 if ((sym
->attr
.flavor
!= FL_PROCEDURE
4614 || gfc_is_function_return_value (sym
, gfc_current_ns
))
4615 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
4616 return match_typebound_call (st
);
4618 /* If it does not seem to be callable (include functions so that the
4619 right association is made. They are thrown out in resolution.)
4621 if (!sym
->attr
.generic
4622 && !sym
->attr
.subroutine
4623 && !sym
->attr
.function
)
4625 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
4627 /* ...create a symbol in this scope... */
4628 if (sym
->ns
!= gfc_current_ns
4629 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
4632 if (sym
!= st
->n
.sym
)
4636 /* ...and then to try to make the symbol into a subroutine. */
4637 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
4641 gfc_set_sym_referenced (sym
);
4643 if (gfc_match_eos () != MATCH_YES
)
4645 m
= gfc_match_actual_arglist (1, &arglist
);
4648 if (m
== MATCH_ERROR
)
4651 if (gfc_match_eos () != MATCH_YES
)
4655 /* If any alternate return labels were found, construct a SELECT
4656 statement that will jump to the right place. */
4659 for (a
= arglist
; a
; a
= a
->next
)
4660 if (a
->expr
== NULL
)
4668 gfc_symtree
*select_st
;
4669 gfc_symbol
*select_sym
;
4670 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4672 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
4673 sprintf (name
, "_result_%s", sym
->name
);
4674 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
4676 select_sym
= select_st
->n
.sym
;
4677 select_sym
->ts
.type
= BT_INTEGER
;
4678 select_sym
->ts
.kind
= gfc_default_integer_kind
;
4679 gfc_set_sym_referenced (select_sym
);
4680 c
->expr1
= gfc_get_expr ();
4681 c
->expr1
->expr_type
= EXPR_VARIABLE
;
4682 c
->expr1
->symtree
= select_st
;
4683 c
->expr1
->ts
= select_sym
->ts
;
4684 c
->expr1
->where
= gfc_current_locus
;
4687 for (a
= arglist
; a
; a
= a
->next
)
4689 if (a
->expr
!= NULL
)
4692 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
4697 c
->block
= gfc_get_code (EXEC_SELECT
);
4700 new_case
= gfc_get_case ();
4701 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
4702 new_case
->low
= new_case
->high
;
4703 c
->ext
.block
.case_list
= new_case
;
4705 c
->next
= gfc_get_code (EXEC_GOTO
);
4706 c
->next
->label1
= a
->label
;
4710 new_st
.op
= EXEC_CALL
;
4711 new_st
.symtree
= st
;
4712 new_st
.ext
.actual
= arglist
;
4717 gfc_syntax_error (ST_CALL
);
4720 gfc_free_actual_arglist (arglist
);
4725 /* Given a name, return a pointer to the common head structure,
4726 creating it if it does not exist. If FROM_MODULE is nonzero, we
4727 mangle the name so that it doesn't interfere with commons defined
4728 in the using namespace.
4729 TODO: Add to global symbol tree. */
4732 gfc_get_common (const char *name
, int from_module
)
4735 static int serial
= 0;
4736 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
4740 /* A use associated common block is only needed to correctly layout
4741 the variables it contains. */
4742 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
4743 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
4747 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
4750 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
4753 if (st
->n
.common
== NULL
)
4755 st
->n
.common
= gfc_get_common_head ();
4756 st
->n
.common
->where
= gfc_current_locus
;
4757 strcpy (st
->n
.common
->name
, name
);
4760 return st
->n
.common
;
4764 /* Match a common block name. */
4766 match
match_common_name (char *name
)
4770 if (gfc_match_char ('/') == MATCH_NO
)
4776 if (gfc_match_char ('/') == MATCH_YES
)
4782 m
= gfc_match_name (name
);
4784 if (m
== MATCH_ERROR
)
4786 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
4789 gfc_error ("Syntax error in common block name at %C");
4794 /* Match a COMMON statement. */
4797 gfc_match_common (void)
4799 gfc_symbol
*sym
, **head
, *tail
, *other
;
4800 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4810 m
= match_common_name (name
);
4811 if (m
== MATCH_ERROR
)
4814 if (name
[0] == '\0')
4816 t
= &gfc_current_ns
->blank_common
;
4817 if (t
->head
== NULL
)
4818 t
->where
= gfc_current_locus
;
4822 t
= gfc_get_common (name
, 0);
4831 while (tail
->common_next
)
4832 tail
= tail
->common_next
;
4835 /* Grab the list of symbols. */
4838 m
= gfc_match_symbol (&sym
, 0);
4839 if (m
== MATCH_ERROR
)
4844 /* See if we know the current common block is bind(c), and if
4845 so, then see if we can check if the symbol is (which it'll
4846 need to be). This can happen if the bind(c) attr stmt was
4847 applied to the common block, and the variable(s) already
4848 defined, before declaring the common block. */
4849 if (t
->is_bind_c
== 1)
4851 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
4853 /* If we find an error, just print it and continue,
4854 cause it's just semantic, and we can see if there
4856 gfc_error_now ("Variable %qs at %L in common block %qs "
4857 "at %C must be declared with a C "
4858 "interoperable kind since common block "
4860 sym
->name
, &(sym
->declared_at
), t
->name
,
4864 if (sym
->attr
.is_bind_c
== 1)
4865 gfc_error_now ("Variable %qs in common block %qs at %C can not "
4866 "be bind(c) since it is not global", sym
->name
,
4870 if (sym
->attr
.in_common
)
4872 gfc_error ("Symbol %qs at %C is already in a COMMON block",
4877 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
4878 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
4880 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol %qs at "
4881 "%C can only be COMMON in BLOCK DATA",
4886 /* Deal with an optional array specification after the
4888 m
= gfc_match_array_spec (&as
, true, true);
4889 if (m
== MATCH_ERROR
)
4894 if (as
->type
!= AS_EXPLICIT
)
4896 gfc_error ("Array specification for symbol %qs in COMMON "
4897 "at %C must be explicit", sym
->name
);
4901 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
4904 if (sym
->attr
.pointer
)
4906 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
4907 "POINTER array", sym
->name
);
4916 /* Add the in_common attribute, but ignore the reported errors
4917 if any, and continue matching. */
4918 gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
);
4920 sym
->common_block
= t
;
4921 sym
->common_block
->refs
++;
4924 tail
->common_next
= sym
;
4930 sym
->common_head
= t
;
4932 /* Check to see if the symbol is already in an equivalence group.
4933 If it is, set the other members as being in common. */
4934 if (sym
->attr
.in_equivalence
)
4936 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
4938 for (e2
= e1
; e2
; e2
= e2
->eq
)
4939 if (e2
->expr
->symtree
->n
.sym
== sym
)
4946 for (e2
= e1
; e2
; e2
= e2
->eq
)
4948 other
= e2
->expr
->symtree
->n
.sym
;
4949 if (other
->common_head
4950 && other
->common_head
!= sym
->common_head
)
4952 gfc_error ("Symbol %qs, in COMMON block %qs at "
4953 "%C is being indirectly equivalenced to "
4954 "another COMMON block %qs",
4955 sym
->name
, sym
->common_head
->name
,
4956 other
->common_head
->name
);
4959 other
->attr
.in_common
= 1;
4960 other
->common_head
= t
;
4966 gfc_gobble_whitespace ();
4967 if (gfc_match_eos () == MATCH_YES
)
4969 if (gfc_peek_ascii_char () == '/')
4971 if (gfc_match_char (',') != MATCH_YES
)
4973 gfc_gobble_whitespace ();
4974 if (gfc_peek_ascii_char () == '/')
4983 gfc_syntax_error (ST_COMMON
);
4986 gfc_free_array_spec (as
);
4991 /* Match a BLOCK DATA program unit. */
4994 gfc_match_block_data (void)
4996 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5000 if (gfc_match_eos () == MATCH_YES
)
5002 gfc_new_block
= NULL
;
5006 m
= gfc_match ("% %n%t", name
);
5010 if (gfc_get_symbol (name
, NULL
, &sym
))
5013 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
5016 gfc_new_block
= sym
;
5022 /* Free a namelist structure. */
5025 gfc_free_namelist (gfc_namelist
*name
)
5029 for (; name
; name
= n
)
5037 /* Free an OpenMP namelist structure. */
5040 gfc_free_omp_namelist (gfc_omp_namelist
*name
)
5042 gfc_omp_namelist
*n
;
5044 for (; name
; name
= n
)
5046 gfc_free_expr (name
->expr
);
5049 if (name
->udr
->combiner
)
5050 gfc_free_statement (name
->udr
->combiner
);
5051 if (name
->udr
->initializer
)
5052 gfc_free_statement (name
->udr
->initializer
);
5061 /* Match a NAMELIST statement. */
5064 gfc_match_namelist (void)
5066 gfc_symbol
*group_name
, *sym
;
5070 m
= gfc_match (" / %s /", &group_name
);
5073 if (m
== MATCH_ERROR
)
5078 if (group_name
->ts
.type
!= BT_UNKNOWN
)
5080 gfc_error ("Namelist group name %qs at %C already has a basic "
5081 "type of %s", group_name
->name
,
5082 gfc_typename (&group_name
->ts
));
5086 if (group_name
->attr
.flavor
== FL_NAMELIST
5087 && group_name
->attr
.use_assoc
5088 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name %qs "
5089 "at %C already is USE associated and can"
5090 "not be respecified.", group_name
->name
))
5093 if (group_name
->attr
.flavor
!= FL_NAMELIST
5094 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
5095 group_name
->name
, NULL
))
5100 m
= gfc_match_symbol (&sym
, 1);
5103 if (m
== MATCH_ERROR
)
5106 if (sym
->attr
.in_namelist
== 0
5107 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
5110 /* Use gfc_error_check here, rather than goto error, so that
5111 these are the only errors for the next two lines. */
5112 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
5114 gfc_error ("Assumed size array %qs in namelist %qs at "
5115 "%C is not allowed", sym
->name
, group_name
->name
);
5119 nl
= gfc_get_namelist ();
5123 if (group_name
->namelist
== NULL
)
5124 group_name
->namelist
= group_name
->namelist_tail
= nl
;
5127 group_name
->namelist_tail
->next
= nl
;
5128 group_name
->namelist_tail
= nl
;
5131 if (gfc_match_eos () == MATCH_YES
)
5134 m
= gfc_match_char (',');
5136 if (gfc_match_char ('/') == MATCH_YES
)
5138 m2
= gfc_match (" %s /", &group_name
);
5139 if (m2
== MATCH_YES
)
5141 if (m2
== MATCH_ERROR
)
5155 gfc_syntax_error (ST_NAMELIST
);
5162 /* Match a MODULE statement. */
5165 gfc_match_module (void)
5169 m
= gfc_match (" %s%t", &gfc_new_block
);
5173 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
5174 gfc_new_block
->name
, NULL
))
5181 /* Free equivalence sets and lists. Recursively is the easiest way to
5185 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
5190 gfc_free_equiv (eq
->eq
);
5191 gfc_free_equiv_until (eq
->next
, stop
);
5192 gfc_free_expr (eq
->expr
);
5198 gfc_free_equiv (gfc_equiv
*eq
)
5200 gfc_free_equiv_until (eq
, NULL
);
5204 /* Match an EQUIVALENCE statement. */
5207 gfc_match_equivalence (void)
5209 gfc_equiv
*eq
, *set
, *tail
;
5213 gfc_common_head
*common_head
= NULL
;
5221 eq
= gfc_get_equiv ();
5225 eq
->next
= gfc_current_ns
->equiv
;
5226 gfc_current_ns
->equiv
= eq
;
5228 if (gfc_match_char ('(') != MATCH_YES
)
5232 common_flag
= FALSE
;
5237 m
= gfc_match_equiv_variable (&set
->expr
);
5238 if (m
== MATCH_ERROR
)
5243 /* count the number of objects. */
5246 if (gfc_match_char ('%') == MATCH_YES
)
5248 gfc_error ("Derived type component %C is not a "
5249 "permitted EQUIVALENCE member");
5253 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
5254 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5256 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
5257 "be an array section");
5261 sym
= set
->expr
->symtree
->n
.sym
;
5263 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
5266 if (sym
->attr
.in_common
)
5269 common_head
= sym
->common_head
;
5272 if (gfc_match_char (')') == MATCH_YES
)
5275 if (gfc_match_char (',') != MATCH_YES
)
5278 set
->eq
= gfc_get_equiv ();
5284 gfc_error ("EQUIVALENCE at %C requires two or more objects");
5288 /* If one of the members of an equivalence is in common, then
5289 mark them all as being in common. Before doing this, check
5290 that members of the equivalence group are not in different
5293 for (set
= eq
; set
; set
= set
->eq
)
5295 sym
= set
->expr
->symtree
->n
.sym
;
5296 if (sym
->common_head
&& sym
->common_head
!= common_head
)
5298 gfc_error ("Attempt to indirectly overlap COMMON "
5299 "blocks %s and %s by EQUIVALENCE at %C",
5300 sym
->common_head
->name
, common_head
->name
);
5303 sym
->attr
.in_common
= 1;
5304 sym
->common_head
= common_head
;
5307 if (gfc_match_eos () == MATCH_YES
)
5309 if (gfc_match_char (',') != MATCH_YES
)
5311 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
5319 gfc_syntax_error (ST_EQUIVALENCE
);
5325 gfc_free_equiv (gfc_current_ns
->equiv
);
5326 gfc_current_ns
->equiv
= eq
;
5332 /* Check that a statement function is not recursive. This is done by looking
5333 for the statement function symbol(sym) by looking recursively through its
5334 expression(e). If a reference to sym is found, true is returned.
5335 12.5.4 requires that any variable of function that is implicitly typed
5336 shall have that type confirmed by any subsequent type declaration. The
5337 implicit typing is conveniently done here. */
5339 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
5342 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
5348 switch (e
->expr_type
)
5351 if (e
->symtree
== NULL
)
5354 /* Check the name before testing for nested recursion! */
5355 if (sym
->name
== e
->symtree
->n
.sym
->name
)
5358 /* Catch recursion via other statement functions. */
5359 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
5360 && e
->symtree
->n
.sym
->value
5361 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
5364 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5365 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5370 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
5373 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5374 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5386 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
5388 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
5392 /* Match a statement function declaration. It is so easy to match
5393 non-statement function statements with a MATCH_ERROR as opposed to
5394 MATCH_NO that we suppress error message in most cases. */
5397 gfc_match_st_function (void)
5399 gfc_error_buffer old_error
;
5404 m
= gfc_match_symbol (&sym
, 0);
5408 gfc_push_error (&old_error
);
5410 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
5413 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
5416 m
= gfc_match (" = %e%t", &expr
);
5420 gfc_free_error (&old_error
);
5422 if (m
== MATCH_ERROR
)
5425 if (recursive_stmt_fcn (expr
, sym
))
5427 gfc_error ("Statement function at %L is recursive", &expr
->where
);
5433 if ((gfc_current_state () == COMP_FUNCTION
5434 || gfc_current_state () == COMP_SUBROUTINE
)
5435 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
5437 gfc_error ("Statement function at %L cannot appear within an INTERFACE",
5442 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
5448 gfc_pop_error (&old_error
);
5453 /* Match an assignment to a pointer function (F2008). This could, in
5454 general be ambiguous with a statement function. In this implementation
5455 it remains so if it is the first statement after the specification
5459 gfc_match_ptr_fcn_assign (void)
5461 gfc_error_buffer old_error
;
5466 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5468 old_loc
= gfc_current_locus
;
5469 m
= gfc_match_name (name
);
5473 gfc_find_symbol (name
, NULL
, 1, &sym
);
5474 if (sym
&& sym
->attr
.flavor
!= FL_PROCEDURE
)
5477 gfc_push_error (&old_error
);
5479 if (sym
&& sym
->attr
.function
)
5480 goto match_actual_arglist
;
5482 gfc_current_locus
= old_loc
;
5483 m
= gfc_match_symbol (&sym
, 0);
5487 if (!gfc_add_procedure (&sym
->attr
, PROC_UNKNOWN
, sym
->name
, NULL
))
5490 match_actual_arglist
:
5491 gfc_current_locus
= old_loc
;
5492 m
= gfc_match (" %e", &expr
);
5496 new_st
.op
= EXEC_ASSIGN
;
5497 new_st
.expr1
= expr
;
5500 m
= gfc_match (" = %e%t", &expr
);
5504 new_st
.expr2
= expr
;
5508 gfc_pop_error (&old_error
);
5513 /***************** SELECT CASE subroutines ******************/
5515 /* Free a single case structure. */
5518 free_case (gfc_case
*p
)
5520 if (p
->low
== p
->high
)
5522 gfc_free_expr (p
->low
);
5523 gfc_free_expr (p
->high
);
5528 /* Free a list of case structures. */
5531 gfc_free_case_list (gfc_case
*p
)
5543 /* Match a single case selector. Combining the requirements of F08:C830
5544 and F08:C832 (R838) means that the case-value must have either CHARACTER,
5545 INTEGER, or LOGICAL type. */
5548 match_case_selector (gfc_case
**cp
)
5553 c
= gfc_get_case ();
5554 c
->where
= gfc_current_locus
;
5556 if (gfc_match_char (':') == MATCH_YES
)
5558 m
= gfc_match_init_expr (&c
->high
);
5561 if (m
== MATCH_ERROR
)
5564 if (c
->high
->ts
.type
!= BT_LOGICAL
&& c
->high
->ts
.type
!= BT_INTEGER
5565 && c
->high
->ts
.type
!= BT_CHARACTER
)
5567 gfc_error ("Expression in CASE selector at %L cannot be %s",
5568 &c
->high
->where
, gfc_typename (&c
->high
->ts
));
5574 m
= gfc_match_init_expr (&c
->low
);
5575 if (m
== MATCH_ERROR
)
5580 if (c
->low
->ts
.type
!= BT_LOGICAL
&& c
->low
->ts
.type
!= BT_INTEGER
5581 && c
->low
->ts
.type
!= BT_CHARACTER
)
5583 gfc_error ("Expression in CASE selector at %L cannot be %s",
5584 &c
->low
->where
, gfc_typename (&c
->low
->ts
));
5588 /* If we're not looking at a ':' now, make a range out of a single
5589 target. Else get the upper bound for the case range. */
5590 if (gfc_match_char (':') != MATCH_YES
)
5594 m
= gfc_match_init_expr (&c
->high
);
5595 if (m
== MATCH_ERROR
)
5597 /* MATCH_NO is fine. It's OK if nothing is there! */
5605 gfc_error ("Expected initialization expression in CASE at %C");
5613 /* Match the end of a case statement. */
5616 match_case_eos (void)
5618 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5621 if (gfc_match_eos () == MATCH_YES
)
5624 /* If the case construct doesn't have a case-construct-name, we
5625 should have matched the EOS. */
5626 if (!gfc_current_block ())
5629 gfc_gobble_whitespace ();
5631 m
= gfc_match_name (name
);
5635 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5637 gfc_error ("Expected block name %qs of SELECT construct at %C",
5638 gfc_current_block ()->name
);
5642 return gfc_match_eos ();
5646 /* Match a SELECT statement. */
5649 gfc_match_select (void)
5654 m
= gfc_match_label ();
5655 if (m
== MATCH_ERROR
)
5658 m
= gfc_match (" select case ( %e )%t", &expr
);
5662 new_st
.op
= EXEC_SELECT
;
5663 new_st
.expr1
= expr
;
5669 /* Transfer the selector typespec to the associate name. */
5672 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
)
5675 gfc_symbol
*assoc_sym
;
5677 assoc_sym
= associate
->symtree
->n
.sym
;
5679 /* At this stage the expression rank and arrayspec dimensions have
5680 not been completely sorted out. We must get the expr2->rank
5681 right here, so that the correct class container is obtained. */
5682 ref
= selector
->ref
;
5683 while (ref
&& ref
->next
)
5686 if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
5687 && ref
&& ref
->type
== REF_ARRAY
)
5689 /* Ensure that the array reference type is set. We cannot use
5690 gfc_resolve_expr at this point, so the usable parts of
5691 resolve.c(resolve_array_ref) are employed to do it. */
5692 if (ref
->u
.ar
.type
== AR_UNKNOWN
)
5694 ref
->u
.ar
.type
= AR_ELEMENT
;
5695 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
5696 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5697 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
5698 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
5699 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
5701 ref
->u
.ar
.type
= AR_SECTION
;
5706 if (ref
->u
.ar
.type
== AR_FULL
)
5707 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
5708 else if (ref
->u
.ar
.type
== AR_SECTION
)
5709 selector
->rank
= ref
->u
.ar
.dimen
;
5716 assoc_sym
->attr
.dimension
= 1;
5717 assoc_sym
->as
= gfc_get_array_spec ();
5718 assoc_sym
->as
->rank
= selector
->rank
;
5719 assoc_sym
->as
->type
= AS_DEFERRED
;
5722 assoc_sym
->as
= NULL
;
5724 if (selector
->ts
.type
== BT_CLASS
)
5726 /* The correct class container has to be available. */
5727 assoc_sym
->ts
.type
= BT_CLASS
;
5728 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
5729 assoc_sym
->attr
.pointer
= 1;
5730 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
5735 /* Push the current selector onto the SELECT TYPE stack. */
5738 select_type_push (gfc_symbol
*sel
)
5740 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
5741 top
->selector
= sel
;
5743 top
->prev
= select_type_stack
;
5745 select_type_stack
= top
;
5749 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
5751 static gfc_symtree
*
5752 select_intrinsic_set_tmp (gfc_typespec
*ts
)
5754 char name
[GFC_MAX_SYMBOL_LEN
];
5758 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
5761 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5762 && !select_type_stack
->selector
->attr
.class_ok
)
5765 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
5766 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5767 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
5769 if (ts
->type
!= BT_CHARACTER
)
5770 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
5773 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (ts
->type
),
5776 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5777 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5779 /* Copy across the array spec to the selector. */
5780 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5781 && (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5782 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
))
5784 tmp
->n
.sym
->attr
.pointer
= 1;
5785 tmp
->n
.sym
->attr
.dimension
5786 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5787 tmp
->n
.sym
->attr
.codimension
5788 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5790 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5793 gfc_set_sym_referenced (tmp
->n
.sym
);
5794 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5795 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5801 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
5804 select_type_set_tmp (gfc_typespec
*ts
)
5806 char name
[GFC_MAX_SYMBOL_LEN
];
5807 gfc_symtree
*tmp
= NULL
;
5811 select_type_stack
->tmp
= NULL
;
5815 tmp
= select_intrinsic_set_tmp (ts
);
5822 if (ts
->type
== BT_CLASS
)
5823 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
5825 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
5826 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5827 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5829 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5830 && select_type_stack
->selector
->attr
.class_ok
)
5832 tmp
->n
.sym
->attr
.pointer
5833 = CLASS_DATA (select_type_stack
->selector
)->attr
.class_pointer
;
5835 /* Copy across the array spec to the selector. */
5836 if (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5837 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
)
5839 tmp
->n
.sym
->attr
.dimension
5840 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5841 tmp
->n
.sym
->attr
.codimension
5842 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5844 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5848 gfc_set_sym_referenced (tmp
->n
.sym
);
5849 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5850 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5852 if (ts
->type
== BT_CLASS
)
5853 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
5857 /* Add an association for it, so the rest of the parser knows it is
5858 an associate-name. The target will be set during resolution. */
5859 tmp
->n
.sym
->assoc
= gfc_get_association_list ();
5860 tmp
->n
.sym
->assoc
->dangling
= 1;
5861 tmp
->n
.sym
->assoc
->st
= tmp
;
5863 select_type_stack
->tmp
= tmp
;
5867 /* Match a SELECT TYPE statement. */
5870 gfc_match_select_type (void)
5872 gfc_expr
*expr1
, *expr2
= NULL
;
5874 char name
[GFC_MAX_SYMBOL_LEN
];
5877 gfc_namespace
*ns
= gfc_current_ns
;
5879 m
= gfc_match_label ();
5880 if (m
== MATCH_ERROR
)
5883 m
= gfc_match (" select type ( ");
5887 gfc_current_ns
= gfc_build_block_ns (ns
);
5888 m
= gfc_match (" %n => %e", name
, &expr2
);
5891 expr1
= gfc_get_expr ();
5892 expr1
->expr_type
= EXPR_VARIABLE
;
5893 expr1
->where
= expr2
->where
;
5894 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
5900 sym
= expr1
->symtree
->n
.sym
;
5901 if (expr2
->ts
.type
== BT_UNKNOWN
)
5902 sym
->attr
.untyped
= 1;
5904 copy_ts_from_selector_to_associate (expr1
, expr2
);
5906 sym
->attr
.flavor
= FL_VARIABLE
;
5907 sym
->attr
.referenced
= 1;
5908 sym
->attr
.class_ok
= 1;
5912 m
= gfc_match (" %e ", &expr1
);
5915 std::swap (ns
, gfc_current_ns
);
5916 gfc_free_namespace (ns
);
5921 m
= gfc_match (" )%t");
5924 gfc_error ("parse error in SELECT TYPE statement at %C");
5928 /* This ghastly expression seems to be needed to distinguish a CLASS
5929 array, which can have a reference, from other expressions that
5930 have references, such as derived type components, and are not
5931 allowed by the standard.
5932 TODO: see if it is sufficient to exclude component and substring
5934 class_array
= (expr1
->expr_type
== EXPR_VARIABLE
5935 && expr1
->ts
.type
== BT_CLASS
5936 && CLASS_DATA (expr1
)
5937 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
5938 && (CLASS_DATA (expr1
)->attr
.dimension
5939 || CLASS_DATA (expr1
)->attr
.codimension
)
5941 && expr1
->ref
->type
== REF_ARRAY
5942 && expr1
->ref
->next
== NULL
);
5944 /* Check for F03:C811. */
5945 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
5946 || (!class_array
&& expr1
->ref
!= NULL
)))
5948 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
5949 "use associate-name=>");
5954 new_st
.op
= EXEC_SELECT_TYPE
;
5955 new_st
.expr1
= expr1
;
5956 new_st
.expr2
= expr2
;
5957 new_st
.ext
.block
.ns
= gfc_current_ns
;
5959 select_type_push (expr1
->symtree
->n
.sym
);
5960 gfc_current_ns
= ns
;
5965 gfc_free_expr (expr1
);
5966 gfc_free_expr (expr2
);
5967 gfc_undo_symbols ();
5968 std::swap (ns
, gfc_current_ns
);
5969 gfc_free_namespace (ns
);
5974 /* Match a CASE statement. */
5977 gfc_match_case (void)
5979 gfc_case
*c
, *head
, *tail
;
5984 if (gfc_current_state () != COMP_SELECT
)
5986 gfc_error ("Unexpected CASE statement at %C");
5990 if (gfc_match ("% default") == MATCH_YES
)
5992 m
= match_case_eos ();
5995 if (m
== MATCH_ERROR
)
5998 new_st
.op
= EXEC_SELECT
;
5999 c
= gfc_get_case ();
6000 c
->where
= gfc_current_locus
;
6001 new_st
.ext
.block
.case_list
= c
;
6005 if (gfc_match_char ('(') != MATCH_YES
)
6010 if (match_case_selector (&c
) == MATCH_ERROR
)
6020 if (gfc_match_char (')') == MATCH_YES
)
6022 if (gfc_match_char (',') != MATCH_YES
)
6026 m
= match_case_eos ();
6029 if (m
== MATCH_ERROR
)
6032 new_st
.op
= EXEC_SELECT
;
6033 new_st
.ext
.block
.case_list
= head
;
6038 gfc_error ("Syntax error in CASE specification at %C");
6041 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
6046 /* Match a TYPE IS statement. */
6049 gfc_match_type_is (void)
6054 if (gfc_current_state () != COMP_SELECT_TYPE
)
6056 gfc_error ("Unexpected TYPE IS statement at %C");
6060 if (gfc_match_char ('(') != MATCH_YES
)
6063 c
= gfc_get_case ();
6064 c
->where
= gfc_current_locus
;
6066 m
= gfc_match_type_spec (&c
->ts
);
6069 if (m
== MATCH_ERROR
)
6072 if (gfc_match_char (')') != MATCH_YES
)
6075 m
= match_case_eos ();
6078 if (m
== MATCH_ERROR
)
6081 new_st
.op
= EXEC_SELECT_TYPE
;
6082 new_st
.ext
.block
.case_list
= c
;
6084 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
6085 && (c
->ts
.u
.derived
->attr
.sequence
6086 || c
->ts
.u
.derived
->attr
.is_bind_c
))
6088 gfc_error ("The type-spec shall not specify a sequence derived "
6089 "type or a type with the BIND attribute in SELECT "
6090 "TYPE at %C [F2003:C815]");
6094 /* Create temporary variable. */
6095 select_type_set_tmp (&c
->ts
);
6100 gfc_error ("Syntax error in TYPE IS specification at %C");
6104 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6109 /* Match a CLASS IS or CLASS DEFAULT statement. */
6112 gfc_match_class_is (void)
6117 if (gfc_current_state () != COMP_SELECT_TYPE
)
6120 if (gfc_match ("% default") == MATCH_YES
)
6122 m
= match_case_eos ();
6125 if (m
== MATCH_ERROR
)
6128 new_st
.op
= EXEC_SELECT_TYPE
;
6129 c
= gfc_get_case ();
6130 c
->where
= gfc_current_locus
;
6131 c
->ts
.type
= BT_UNKNOWN
;
6132 new_st
.ext
.block
.case_list
= c
;
6133 select_type_set_tmp (NULL
);
6137 m
= gfc_match ("% is");
6140 if (m
== MATCH_ERROR
)
6143 if (gfc_match_char ('(') != MATCH_YES
)
6146 c
= gfc_get_case ();
6147 c
->where
= gfc_current_locus
;
6149 m
= match_derived_type_spec (&c
->ts
);
6152 if (m
== MATCH_ERROR
)
6155 if (c
->ts
.type
== BT_DERIVED
)
6156 c
->ts
.type
= BT_CLASS
;
6158 if (gfc_match_char (')') != MATCH_YES
)
6161 m
= match_case_eos ();
6164 if (m
== MATCH_ERROR
)
6167 new_st
.op
= EXEC_SELECT_TYPE
;
6168 new_st
.ext
.block
.case_list
= c
;
6170 /* Create temporary variable. */
6171 select_type_set_tmp (&c
->ts
);
6176 gfc_error ("Syntax error in CLASS IS specification at %C");
6180 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6185 /********************* WHERE subroutines ********************/
6187 /* Match the rest of a simple WHERE statement that follows an IF statement.
6191 match_simple_where (void)
6197 m
= gfc_match (" ( %e )", &expr
);
6201 m
= gfc_match_assignment ();
6204 if (m
== MATCH_ERROR
)
6207 if (gfc_match_eos () != MATCH_YES
)
6210 c
= gfc_get_code (EXEC_WHERE
);
6213 c
->next
= XCNEW (gfc_code
);
6215 c
->next
->loc
= gfc_current_locus
;
6216 gfc_clear_new_st ();
6218 new_st
.op
= EXEC_WHERE
;
6224 gfc_syntax_error (ST_WHERE
);
6227 gfc_free_expr (expr
);
6232 /* Match a WHERE statement. */
6235 gfc_match_where (gfc_statement
*st
)
6241 m0
= gfc_match_label ();
6242 if (m0
== MATCH_ERROR
)
6245 m
= gfc_match (" where ( %e )", &expr
);
6249 if (gfc_match_eos () == MATCH_YES
)
6251 *st
= ST_WHERE_BLOCK
;
6252 new_st
.op
= EXEC_WHERE
;
6253 new_st
.expr1
= expr
;
6257 m
= gfc_match_assignment ();
6259 gfc_syntax_error (ST_WHERE
);
6263 gfc_free_expr (expr
);
6267 /* We've got a simple WHERE statement. */
6269 c
= gfc_get_code (EXEC_WHERE
);
6272 /* Put in the assignment. It will not be processed by add_statement, so we
6273 need to copy the location here. */
6275 c
->next
= XCNEW (gfc_code
);
6277 c
->next
->loc
= gfc_current_locus
;
6278 gfc_clear_new_st ();
6280 new_st
.op
= EXEC_WHERE
;
6287 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
6288 new_st if successful. */
6291 gfc_match_elsewhere (void)
6293 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6297 if (gfc_current_state () != COMP_WHERE
)
6299 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
6305 if (gfc_match_char ('(') == MATCH_YES
)
6307 m
= gfc_match_expr (&expr
);
6310 if (m
== MATCH_ERROR
)
6313 if (gfc_match_char (')') != MATCH_YES
)
6317 if (gfc_match_eos () != MATCH_YES
)
6319 /* Only makes sense if we have a where-construct-name. */
6320 if (!gfc_current_block ())
6325 /* Better be a name at this point. */
6326 m
= gfc_match_name (name
);
6329 if (m
== MATCH_ERROR
)
6332 if (gfc_match_eos () != MATCH_YES
)
6335 if (strcmp (name
, gfc_current_block ()->name
) != 0)
6337 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
6338 name
, gfc_current_block ()->name
);
6343 new_st
.op
= EXEC_WHERE
;
6344 new_st
.expr1
= expr
;
6348 gfc_syntax_error (ST_ELSEWHERE
);
6351 gfc_free_expr (expr
);