1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000-2016 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
)
521 m
= gfc_match_expr (&expr
);
525 p
= gfc_extract_int (expr
, &i
);
526 gfc_free_expr (expr
);
539 /* This function is the same as the gfc_match_small_int, except that
540 we're keeping the pointer to the expr. This function could just be
541 removed and the previously mentioned one modified, though all calls
542 to it would have to be modified then (and there were a number of
543 them). Return MATCH_ERROR if fail to extract the int; otherwise,
544 return the result of gfc_match_expr(). The expr (if any) that was
545 matched is returned in the parameter expr. */
548 gfc_match_small_int_expr (int *value
, gfc_expr
**expr
)
554 m
= gfc_match_expr (expr
);
558 p
= gfc_extract_int (*expr
, &i
);
571 /* Matches a statement label. Uses gfc_match_small_literal_int() to
572 do most of the work. */
575 gfc_match_st_label (gfc_st_label
**label
)
581 old_loc
= gfc_current_locus
;
583 m
= gfc_match_small_literal_int (&i
, &cnt
);
589 gfc_error ("Too many digits in statement label at %C");
595 gfc_error ("Statement label at %C is zero");
599 *label
= gfc_get_st_label (i
);
604 gfc_current_locus
= old_loc
;
609 /* Match and validate a label associated with a named IF, DO or SELECT
610 statement. If the symbol does not have the label attribute, we add
611 it. We also make sure the symbol does not refer to another
612 (active) block. A matched label is pointed to by gfc_new_block. */
615 gfc_match_label (void)
617 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
620 gfc_new_block
= NULL
;
622 m
= gfc_match (" %n :", name
);
626 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
628 gfc_error ("Label name %qs at %C is ambiguous", name
);
632 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
634 gfc_error ("Duplicate construct label %qs at %C", name
);
638 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
639 gfc_new_block
->name
, NULL
))
646 /* See if the current input looks like a name of some sort. Modifies
647 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
648 Note that options.c restricts max_identifier_length to not more
649 than GFC_MAX_SYMBOL_LEN. */
652 gfc_match_name (char *buffer
)
658 old_loc
= gfc_current_locus
;
659 gfc_gobble_whitespace ();
661 c
= gfc_next_ascii_char ();
662 if (!(ISALPHA (c
) || (c
== '_' && flag_allow_leading_underscore
)))
664 /* Special cases for unary minus and plus, which allows for a sensible
665 error message for code of the form 'c = exp(-a*b) )' where an
666 extra ')' appears at the end of statement. */
667 if (!gfc_error_flag_test () && c
!= '(' && c
!= '-' && c
!= '+')
668 gfc_error ("Invalid character in name at %C");
669 gfc_current_locus
= old_loc
;
679 if (i
> gfc_option
.max_identifier_length
)
681 gfc_error ("Name at %C is too long");
685 old_loc
= gfc_current_locus
;
686 c
= gfc_next_ascii_char ();
688 while (ISALNUM (c
) || c
== '_' || (flag_dollar_ok
&& c
== '$'));
690 if (c
== '$' && !flag_dollar_ok
)
692 gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to "
693 "allow it as an extension", &old_loc
);
698 gfc_current_locus
= old_loc
;
704 /* Match a symbol on the input. Modifies the pointer to the symbol
705 pointer if successful. */
708 gfc_match_sym_tree (gfc_symtree
**matched_symbol
, int host_assoc
)
710 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
713 m
= gfc_match_name (buffer
);
718 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
719 ? MATCH_ERROR
: MATCH_YES
;
721 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
, false))
729 gfc_match_symbol (gfc_symbol
**matched_symbol
, int host_assoc
)
734 m
= gfc_match_sym_tree (&st
, host_assoc
);
739 *matched_symbol
= st
->n
.sym
;
741 *matched_symbol
= NULL
;
744 *matched_symbol
= NULL
;
749 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
750 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
754 gfc_match_intrinsic_op (gfc_intrinsic_op
*result
)
756 locus orig_loc
= gfc_current_locus
;
759 gfc_gobble_whitespace ();
760 ch
= gfc_next_ascii_char ();
765 *result
= INTRINSIC_PLUS
;
770 *result
= INTRINSIC_MINUS
;
774 if (gfc_next_ascii_char () == '=')
777 *result
= INTRINSIC_EQ
;
783 if (gfc_peek_ascii_char () == '=')
786 gfc_next_ascii_char ();
787 *result
= INTRINSIC_LE
;
791 *result
= INTRINSIC_LT
;
795 if (gfc_peek_ascii_char () == '=')
798 gfc_next_ascii_char ();
799 *result
= INTRINSIC_GE
;
803 *result
= INTRINSIC_GT
;
807 if (gfc_peek_ascii_char () == '*')
810 gfc_next_ascii_char ();
811 *result
= INTRINSIC_POWER
;
815 *result
= INTRINSIC_TIMES
;
819 ch
= gfc_peek_ascii_char ();
823 gfc_next_ascii_char ();
824 *result
= INTRINSIC_NE
;
830 gfc_next_ascii_char ();
831 *result
= INTRINSIC_CONCAT
;
835 *result
= INTRINSIC_DIVIDE
;
839 ch
= gfc_next_ascii_char ();
843 if (gfc_next_ascii_char () == 'n'
844 && gfc_next_ascii_char () == 'd'
845 && gfc_next_ascii_char () == '.')
847 /* Matched ".and.". */
848 *result
= INTRINSIC_AND
;
854 if (gfc_next_ascii_char () == 'q')
856 ch
= gfc_next_ascii_char ();
859 /* Matched ".eq.". */
860 *result
= INTRINSIC_EQ_OS
;
865 if (gfc_next_ascii_char () == '.')
867 /* Matched ".eqv.". */
868 *result
= INTRINSIC_EQV
;
876 ch
= gfc_next_ascii_char ();
879 if (gfc_next_ascii_char () == '.')
881 /* Matched ".ge.". */
882 *result
= INTRINSIC_GE_OS
;
888 if (gfc_next_ascii_char () == '.')
890 /* Matched ".gt.". */
891 *result
= INTRINSIC_GT_OS
;
898 ch
= gfc_next_ascii_char ();
901 if (gfc_next_ascii_char () == '.')
903 /* Matched ".le.". */
904 *result
= INTRINSIC_LE_OS
;
910 if (gfc_next_ascii_char () == '.')
912 /* Matched ".lt.". */
913 *result
= INTRINSIC_LT_OS
;
920 ch
= gfc_next_ascii_char ();
923 ch
= gfc_next_ascii_char ();
926 /* Matched ".ne.". */
927 *result
= INTRINSIC_NE_OS
;
932 if (gfc_next_ascii_char () == 'v'
933 && gfc_next_ascii_char () == '.')
935 /* Matched ".neqv.". */
936 *result
= INTRINSIC_NEQV
;
943 if (gfc_next_ascii_char () == 't'
944 && gfc_next_ascii_char () == '.')
946 /* Matched ".not.". */
947 *result
= INTRINSIC_NOT
;
954 if (gfc_next_ascii_char () == 'r'
955 && gfc_next_ascii_char () == '.')
957 /* Matched ".or.". */
958 *result
= INTRINSIC_OR
;
964 if (gfc_next_ascii_char () == 'o'
965 && gfc_next_ascii_char () == 'r'
966 && gfc_next_ascii_char () == '.')
968 if (!gfc_notify_std (GFC_STD_LEGACY
, ".XOR. operator at %C"))
970 /* Matched ".xor." - equivalent to ".neqv.". */
971 *result
= INTRINSIC_NEQV
;
985 gfc_current_locus
= orig_loc
;
990 /* Match a loop control phrase:
992 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
994 If the final integer expression is not present, a constant unity
995 expression is returned. We don't return MATCH_ERROR until after
996 the equals sign is seen. */
999 gfc_match_iterator (gfc_iterator
*iter
, int init_flag
)
1001 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1002 gfc_expr
*var
, *e1
, *e2
, *e3
;
1006 e1
= e2
= e3
= NULL
;
1008 /* Match the start of an iterator without affecting the symbol table. */
1010 start
= gfc_current_locus
;
1011 m
= gfc_match (" %n =", name
);
1012 gfc_current_locus
= start
;
1017 m
= gfc_match_variable (&var
, 0);
1021 if (var
->symtree
->n
.sym
->attr
.dimension
)
1023 gfc_error ("Loop variable at %C cannot be an array");
1027 /* F2008, C617 & C565. */
1028 if (var
->symtree
->n
.sym
->attr
.codimension
)
1030 gfc_error ("Loop variable at %C cannot be a coarray");
1034 if (var
->ref
!= NULL
)
1036 gfc_error ("Loop variable at %C cannot be a sub-component");
1040 gfc_match_char ('=');
1042 var
->symtree
->n
.sym
->attr
.implied_index
= 1;
1044 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
1047 if (m
== MATCH_ERROR
)
1050 if (gfc_match_char (',') != MATCH_YES
)
1053 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
1056 if (m
== MATCH_ERROR
)
1059 if (gfc_match_char (',') != MATCH_YES
)
1061 e3
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1065 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
1066 if (m
== MATCH_ERROR
)
1070 gfc_error ("Expected a step value in iterator at %C");
1082 gfc_error ("Syntax error in iterator at %C");
1093 /* Tries to match the next non-whitespace character on the input.
1094 This subroutine does not return MATCH_ERROR. */
1097 gfc_match_char (char c
)
1101 where
= gfc_current_locus
;
1102 gfc_gobble_whitespace ();
1104 if (gfc_next_ascii_char () == c
)
1107 gfc_current_locus
= where
;
1112 /* General purpose matching subroutine. The target string is a
1113 scanf-like format string in which spaces correspond to arbitrary
1114 whitespace (including no whitespace), characters correspond to
1115 themselves. The %-codes are:
1117 %% Literal percent sign
1118 %e Expression, pointer to a pointer is set
1119 %s Symbol, pointer to the symbol is set
1120 %n Name, character buffer is set to name
1121 %t Matches end of statement.
1122 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1123 %l Matches a statement label
1124 %v Matches a variable expression (an lvalue)
1125 % Matches a required space (in free form) and optional spaces. */
1128 gfc_match (const char *target
, ...)
1130 gfc_st_label
**label
;
1139 old_loc
= gfc_current_locus
;
1140 va_start (argp
, target
);
1150 gfc_gobble_whitespace ();
1161 vp
= va_arg (argp
, void **);
1162 n
= gfc_match_expr ((gfc_expr
**) vp
);
1173 vp
= va_arg (argp
, void **);
1174 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
1185 vp
= va_arg (argp
, void **);
1186 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
1197 np
= va_arg (argp
, char *);
1198 n
= gfc_match_name (np
);
1209 label
= va_arg (argp
, gfc_st_label
**);
1210 n
= gfc_match_st_label (label
);
1221 ip
= va_arg (argp
, int *);
1222 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
1233 if (gfc_match_eos () != MATCH_YES
)
1241 if (gfc_match_space () == MATCH_YES
)
1247 break; /* Fall through to character matcher. */
1250 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
1255 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1256 expect an upper case character here! */
1257 gcc_assert (TOLOWER (c
) == c
);
1259 if (c
== gfc_next_ascii_char ())
1269 /* Clean up after a failed match. */
1270 gfc_current_locus
= old_loc
;
1271 va_start (argp
, target
);
1274 for (; matches
> 0; matches
--)
1276 while (*p
++ != '%');
1284 /* Matches that don't have to be undone */
1289 (void) va_arg (argp
, void **);
1294 vp
= va_arg (argp
, void **);
1295 gfc_free_expr ((struct gfc_expr
*)*vp
);
1308 /*********************** Statement level matching **********************/
1310 /* Matches the start of a program unit, which is the program keyword
1311 followed by an obligatory symbol. */
1314 gfc_match_program (void)
1319 m
= gfc_match ("% %s%t", &sym
);
1323 gfc_error ("Invalid form of PROGRAM statement at %C");
1327 if (m
== MATCH_ERROR
)
1330 if (!gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
))
1333 gfc_new_block
= sym
;
1339 /* Match a simple assignment statement. */
1342 gfc_match_assignment (void)
1344 gfc_expr
*lvalue
, *rvalue
;
1348 old_loc
= gfc_current_locus
;
1351 m
= gfc_match (" %v =", &lvalue
);
1354 gfc_current_locus
= old_loc
;
1355 gfc_free_expr (lvalue
);
1360 m
= gfc_match (" %e%t", &rvalue
);
1363 gfc_current_locus
= old_loc
;
1364 gfc_free_expr (lvalue
);
1365 gfc_free_expr (rvalue
);
1369 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1371 new_st
.op
= EXEC_ASSIGN
;
1372 new_st
.expr1
= lvalue
;
1373 new_st
.expr2
= rvalue
;
1375 gfc_check_do_variable (lvalue
->symtree
);
1381 /* Match a pointer assignment statement. */
1384 gfc_match_pointer_assignment (void)
1386 gfc_expr
*lvalue
, *rvalue
;
1390 old_loc
= gfc_current_locus
;
1392 lvalue
= rvalue
= NULL
;
1393 gfc_matching_ptr_assignment
= 0;
1394 gfc_matching_procptr_assignment
= 0;
1396 m
= gfc_match (" %v =>", &lvalue
);
1403 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1404 || gfc_is_proc_ptr_comp (lvalue
))
1405 gfc_matching_procptr_assignment
= 1;
1407 gfc_matching_ptr_assignment
= 1;
1409 m
= gfc_match (" %e%t", &rvalue
);
1410 gfc_matching_ptr_assignment
= 0;
1411 gfc_matching_procptr_assignment
= 0;
1415 new_st
.op
= EXEC_POINTER_ASSIGN
;
1416 new_st
.expr1
= lvalue
;
1417 new_st
.expr2
= rvalue
;
1422 gfc_current_locus
= old_loc
;
1423 gfc_free_expr (lvalue
);
1424 gfc_free_expr (rvalue
);
1429 /* We try to match an easy arithmetic IF statement. This only happens
1430 when just after having encountered a simple IF statement. This code
1431 is really duplicate with parts of the gfc_match_if code, but this is
1435 match_arithmetic_if (void)
1437 gfc_st_label
*l1
, *l2
, *l3
;
1441 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1445 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1446 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1447 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1449 gfc_free_expr (expr
);
1453 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Arithmetic IF statement at %C"))
1456 new_st
.op
= EXEC_ARITHMETIC_IF
;
1457 new_st
.expr1
= expr
;
1466 /* The IF statement is a bit of a pain. First of all, there are three
1467 forms of it, the simple IF, the IF that starts a block and the
1470 There is a problem with the simple IF and that is the fact that we
1471 only have a single level of undo information on symbols. What this
1472 means is for a simple IF, we must re-match the whole IF statement
1473 multiple times in order to guarantee that the symbol table ends up
1474 in the proper state. */
1476 static match
match_simple_forall (void);
1477 static match
match_simple_where (void);
1480 gfc_match_if (gfc_statement
*if_type
)
1483 gfc_st_label
*l1
, *l2
, *l3
;
1484 locus old_loc
, old_loc2
;
1488 n
= gfc_match_label ();
1489 if (n
== MATCH_ERROR
)
1492 old_loc
= gfc_current_locus
;
1494 m
= gfc_match (" if ( %e", &expr
);
1498 old_loc2
= gfc_current_locus
;
1499 gfc_current_locus
= old_loc
;
1501 if (gfc_match_parens () == MATCH_ERROR
)
1504 gfc_current_locus
= old_loc2
;
1506 if (gfc_match_char (')') != MATCH_YES
)
1508 gfc_error ("Syntax error in IF-expression at %C");
1509 gfc_free_expr (expr
);
1513 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1519 gfc_error ("Block label not appropriate for arithmetic IF "
1521 gfc_free_expr (expr
);
1525 if (!gfc_reference_st_label (l1
, ST_LABEL_TARGET
)
1526 || !gfc_reference_st_label (l2
, ST_LABEL_TARGET
)
1527 || !gfc_reference_st_label (l3
, ST_LABEL_TARGET
))
1529 gfc_free_expr (expr
);
1533 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Arithmetic IF statement at %C"))
1536 new_st
.op
= EXEC_ARITHMETIC_IF
;
1537 new_st
.expr1
= expr
;
1542 *if_type
= ST_ARITHMETIC_IF
;
1546 if (gfc_match (" then%t") == MATCH_YES
)
1548 new_st
.op
= EXEC_IF
;
1549 new_st
.expr1
= expr
;
1550 *if_type
= ST_IF_BLOCK
;
1556 gfc_error ("Block label is not appropriate for IF statement at %C");
1557 gfc_free_expr (expr
);
1561 /* At this point the only thing left is a simple IF statement. At
1562 this point, n has to be MATCH_NO, so we don't have to worry about
1563 re-matching a block label. From what we've got so far, try
1564 matching an assignment. */
1566 *if_type
= ST_SIMPLE_IF
;
1568 m
= gfc_match_assignment ();
1572 gfc_free_expr (expr
);
1573 gfc_undo_symbols ();
1574 gfc_current_locus
= old_loc
;
1576 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1577 assignment was found. For MATCH_NO, continue to call the various
1579 if (m
== MATCH_ERROR
)
1582 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1584 m
= gfc_match_pointer_assignment ();
1588 gfc_free_expr (expr
);
1589 gfc_undo_symbols ();
1590 gfc_current_locus
= old_loc
;
1592 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1594 /* Look at the next keyword to see which matcher to call. Matching
1595 the keyword doesn't affect the symbol table, so we don't have to
1596 restore between tries. */
1598 #define match(string, subr, statement) \
1599 if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; }
1603 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1604 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1605 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1606 match ("call", gfc_match_call
, ST_CALL
)
1607 match ("close", gfc_match_close
, ST_CLOSE
)
1608 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1609 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1610 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1611 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1612 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
)
1613 match ("event post", gfc_match_event_post
, ST_EVENT_POST
)
1614 match ("event wait", gfc_match_event_wait
, ST_EVENT_WAIT
)
1615 match ("exit", gfc_match_exit
, ST_EXIT
)
1616 match ("flush", gfc_match_flush
, ST_FLUSH
)
1617 match ("forall", match_simple_forall
, ST_FORALL
)
1618 match ("go to", gfc_match_goto
, ST_GOTO
)
1619 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1620 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1621 match ("lock", gfc_match_lock
, ST_LOCK
)
1622 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1623 match ("open", gfc_match_open
, ST_OPEN
)
1624 match ("pause", gfc_match_pause
, ST_NONE
)
1625 match ("print", gfc_match_print
, ST_WRITE
)
1626 match ("read", gfc_match_read
, ST_READ
)
1627 match ("return", gfc_match_return
, ST_RETURN
)
1628 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1629 match ("stop", gfc_match_stop
, ST_STOP
)
1630 match ("wait", gfc_match_wait
, ST_WAIT
)
1631 match ("sync all", gfc_match_sync_all
, ST_SYNC_CALL
);
1632 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
1633 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
1634 match ("unlock", gfc_match_unlock
, ST_UNLOCK
)
1635 match ("where", match_simple_where
, ST_WHERE
)
1636 match ("write", gfc_match_write
, ST_WRITE
)
1639 match ("type", gfc_match_print
, ST_WRITE
)
1641 /* The gfc_match_assignment() above may have returned a MATCH_NO
1642 where the assignment was to a named constant. Check that
1643 special case here. */
1644 m
= gfc_match_assignment ();
1647 gfc_error ("Cannot assign to a named constant at %C");
1648 gfc_free_expr (expr
);
1649 gfc_undo_symbols ();
1650 gfc_current_locus
= old_loc
;
1654 /* All else has failed, so give up. See if any of the matchers has
1655 stored an error message of some sort. */
1656 if (!gfc_error_check ())
1657 gfc_error ("Unclassifiable statement in IF-clause at %C");
1659 gfc_free_expr (expr
);
1664 gfc_error ("Syntax error in IF-clause at %C");
1667 gfc_free_expr (expr
);
1671 /* At this point, we've matched the single IF and the action clause
1672 is in new_st. Rearrange things so that the IF statement appears
1675 p
= gfc_get_code (EXEC_IF
);
1676 p
->next
= XCNEW (gfc_code
);
1678 p
->next
->loc
= gfc_current_locus
;
1682 gfc_clear_new_st ();
1684 new_st
.op
= EXEC_IF
;
1693 /* Match an ELSE statement. */
1696 gfc_match_else (void)
1698 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1700 if (gfc_match_eos () == MATCH_YES
)
1703 if (gfc_match_name (name
) != MATCH_YES
1704 || gfc_current_block () == NULL
1705 || gfc_match_eos () != MATCH_YES
)
1707 gfc_error ("Unexpected junk after ELSE statement at %C");
1711 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1713 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1714 name
, gfc_current_block ()->name
);
1722 /* Match an ELSE IF statement. */
1725 gfc_match_elseif (void)
1727 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1731 m
= gfc_match (" ( %e ) then", &expr
);
1735 if (gfc_match_eos () == MATCH_YES
)
1738 if (gfc_match_name (name
) != MATCH_YES
1739 || gfc_current_block () == NULL
1740 || gfc_match_eos () != MATCH_YES
)
1742 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1746 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1748 gfc_error ("Label %qs at %C doesn't match IF label %qs",
1749 name
, gfc_current_block ()->name
);
1754 new_st
.op
= EXEC_IF
;
1755 new_st
.expr1
= expr
;
1759 gfc_free_expr (expr
);
1764 /* Free a gfc_iterator structure. */
1767 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1773 gfc_free_expr (iter
->var
);
1774 gfc_free_expr (iter
->start
);
1775 gfc_free_expr (iter
->end
);
1776 gfc_free_expr (iter
->step
);
1783 /* Match a CRITICAL statement. */
1785 gfc_match_critical (void)
1787 gfc_st_label
*label
= NULL
;
1789 if (gfc_match_label () == MATCH_ERROR
)
1792 if (gfc_match (" critical") != MATCH_YES
)
1795 if (gfc_match_st_label (&label
) == MATCH_ERROR
)
1798 if (gfc_match_eos () != MATCH_YES
)
1800 gfc_syntax_error (ST_CRITICAL
);
1804 if (gfc_pure (NULL
))
1806 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1810 if (gfc_find_state (COMP_DO_CONCURRENT
))
1812 gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
1817 gfc_unset_implicit_pure (NULL
);
1819 if (!gfc_notify_std (GFC_STD_F2008
, "CRITICAL statement at %C"))
1822 if (flag_coarray
== GFC_FCOARRAY_NONE
)
1824 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
1829 if (gfc_find_state (COMP_CRITICAL
))
1831 gfc_error ("Nested CRITICAL block at %C");
1835 new_st
.op
= EXEC_CRITICAL
;
1838 && !gfc_reference_st_label (label
, ST_LABEL_TARGET
))
1845 /* Match a BLOCK statement. */
1848 gfc_match_block (void)
1852 if (gfc_match_label () == MATCH_ERROR
)
1855 if (gfc_match (" block") != MATCH_YES
)
1858 /* For this to be a correct BLOCK statement, the line must end now. */
1859 m
= gfc_match_eos ();
1860 if (m
== MATCH_ERROR
)
1869 /* Match an ASSOCIATE statement. */
1872 gfc_match_associate (void)
1874 if (gfc_match_label () == MATCH_ERROR
)
1877 if (gfc_match (" associate") != MATCH_YES
)
1880 /* Match the association list. */
1881 if (gfc_match_char ('(') != MATCH_YES
)
1883 gfc_error ("Expected association list at %C");
1886 new_st
.ext
.block
.assoc
= NULL
;
1889 gfc_association_list
* newAssoc
= gfc_get_association_list ();
1890 gfc_association_list
* a
;
1892 /* Match the next association. */
1893 if (gfc_match (" %n => %e", newAssoc
->name
, &newAssoc
->target
)
1896 gfc_error ("Expected association at %C");
1897 goto assocListError
;
1899 newAssoc
->where
= gfc_current_locus
;
1901 /* Check that the current name is not yet in the list. */
1902 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
1903 if (!strcmp (a
->name
, newAssoc
->name
))
1905 gfc_error ("Duplicate name %qs in association at %C",
1907 goto assocListError
;
1910 /* The target expression must not be coindexed. */
1911 if (gfc_is_coindexed (newAssoc
->target
))
1913 gfc_error ("Association target at %C must not be coindexed");
1914 goto assocListError
;
1917 /* The `variable' field is left blank for now; because the target is not
1918 yet resolved, we can't use gfc_has_vector_subscript to determine it
1919 for now. This is set during resolution. */
1921 /* Put it into the list. */
1922 newAssoc
->next
= new_st
.ext
.block
.assoc
;
1923 new_st
.ext
.block
.assoc
= newAssoc
;
1925 /* Try next one or end if closing parenthesis is found. */
1926 gfc_gobble_whitespace ();
1927 if (gfc_peek_char () == ')')
1929 if (gfc_match_char (',') != MATCH_YES
)
1931 gfc_error ("Expected %<)%> or %<,%> at %C");
1941 if (gfc_match_char (')') != MATCH_YES
)
1943 /* This should never happen as we peek above. */
1947 if (gfc_match_eos () != MATCH_YES
)
1949 gfc_error ("Junk after ASSOCIATE statement at %C");
1956 gfc_free_association_list (new_st
.ext
.block
.assoc
);
1961 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
1962 an accessible derived type. */
1965 match_derived_type_spec (gfc_typespec
*ts
)
1967 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1969 gfc_symbol
*derived
;
1971 old_locus
= gfc_current_locus
;
1973 if (gfc_match ("%n", name
) != MATCH_YES
)
1975 gfc_current_locus
= old_locus
;
1979 gfc_find_symbol (name
, NULL
, 1, &derived
);
1981 if (derived
&& derived
->attr
.flavor
== FL_PROCEDURE
&& derived
->attr
.generic
)
1982 derived
= gfc_find_dt_in_generic (derived
);
1984 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
1986 ts
->type
= BT_DERIVED
;
1987 ts
->u
.derived
= derived
;
1991 gfc_current_locus
= old_locus
;
1996 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
1997 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
1998 It only includes the intrinsic types from the Fortran 2003 standard
1999 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2000 the implicit_flag is not needed, so it was removed. Derived types are
2001 identified by their name alone. */
2004 gfc_match_type_spec (gfc_typespec
*ts
)
2008 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2011 gfc_gobble_whitespace ();
2012 old_locus
= gfc_current_locus
;
2014 if (match_derived_type_spec (ts
) == MATCH_YES
)
2016 /* Enforce F03:C401. */
2017 if (ts
->u
.derived
->attr
.abstract
)
2019 gfc_error ("Derived type %qs at %L may not be ABSTRACT",
2020 ts
->u
.derived
->name
, &old_locus
);
2026 if (gfc_match ("integer") == MATCH_YES
)
2028 ts
->type
= BT_INTEGER
;
2029 ts
->kind
= gfc_default_integer_kind
;
2033 if (gfc_match ("double precision") == MATCH_YES
)
2036 ts
->kind
= gfc_default_double_kind
;
2040 if (gfc_match ("complex") == MATCH_YES
)
2042 ts
->type
= BT_COMPLEX
;
2043 ts
->kind
= gfc_default_complex_kind
;
2047 if (gfc_match ("character") == MATCH_YES
)
2049 ts
->type
= BT_CHARACTER
;
2051 m
= gfc_match_char_spec (ts
);
2059 if (gfc_match ("logical") == MATCH_YES
)
2061 ts
->type
= BT_LOGICAL
;
2062 ts
->kind
= gfc_default_logical_kind
;
2066 /* REAL is a real pain because it can be a type, intrinsic subprogram,
2067 or list item in a type-list of an OpenMP reduction clause. Need to
2068 differentiate REAL([KIND]=scalar-int-initialization-expr) from
2069 REAL(A,[KIND]) and REAL(KIND,A). */
2071 m
= gfc_match (" %n", name
);
2072 if (m
== MATCH_YES
&& strcmp (name
, "real") == 0)
2079 ts
->kind
= gfc_default_real_kind
;
2081 gfc_gobble_whitespace ();
2083 /* Prevent REAL*4, etc. */
2084 c
= gfc_peek_ascii_char ();
2087 gfc_error ("Invalid type-spec at %C");
2091 /* Found leading colon in REAL::, a trailing ')' in for example
2092 TYPE IS (REAL), or REAL, for an OpenMP list-item. */
2093 if (c
== ':' || c
== ')' || (flag_openmp
&& c
== ','))
2096 /* Found something other than the opening '(' in REAL(... */
2100 gfc_next_char (); /* Burn the '('. */
2102 /* Look for the optional KIND=. */
2103 where
= gfc_current_locus
;
2104 m
= gfc_match ("%n", name
);
2107 gfc_gobble_whitespace ();
2108 c
= gfc_next_char ();
2111 if (strcmp(name
, "a") == 0)
2113 else if (strcmp(name
, "kind") == 0)
2119 gfc_current_locus
= where
;
2122 gfc_current_locus
= where
;
2126 m
= gfc_match_init_expr (&e
);
2127 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
2130 /* If a comma appears, it is an intrinsic subprogram. */
2131 gfc_gobble_whitespace ();
2132 c
= gfc_peek_ascii_char ();
2139 /* If ')' appears, we have REAL(initialization-expr), here check for
2140 a scalar integer initialization-expr and valid kind parameter. */
2143 if (e
->ts
.type
!= BT_INTEGER
|| e
->rank
> 0)
2149 gfc_next_char (); /* Burn the ')'. */
2150 ts
->kind
= (int) mpz_get_si (e
->value
.integer
);
2151 if (gfc_validate_kind (BT_REAL
, ts
->kind
, true) == -1)
2153 gfc_error ("Invalid type-spec at %C");
2163 /* If a type is not matched, simply return MATCH_NO. */
2164 gfc_current_locus
= old_locus
;
2169 gfc_gobble_whitespace ();
2171 /* This prevents INTEGER*4, etc. */
2172 if (gfc_peek_ascii_char () == '*')
2174 gfc_error ("Invalid type-spec at %C");
2178 m
= gfc_match_kind_spec (ts
, false);
2180 /* No kind specifier found. */
2188 /******************** FORALL subroutines ********************/
2190 /* Free a list of FORALL iterators. */
2193 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
2195 gfc_forall_iterator
*next
;
2200 gfc_free_expr (iter
->var
);
2201 gfc_free_expr (iter
->start
);
2202 gfc_free_expr (iter
->end
);
2203 gfc_free_expr (iter
->stride
);
2210 /* Match an iterator as part of a FORALL statement. The format is:
2212 <var> = <start>:<end>[:<stride>]
2214 On MATCH_NO, the caller tests for the possibility that there is a
2215 scalar mask expression. */
2218 match_forall_iterator (gfc_forall_iterator
**result
)
2220 gfc_forall_iterator
*iter
;
2224 where
= gfc_current_locus
;
2225 iter
= XCNEW (gfc_forall_iterator
);
2227 m
= gfc_match_expr (&iter
->var
);
2231 if (gfc_match_char ('=') != MATCH_YES
2232 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
2238 m
= gfc_match_expr (&iter
->start
);
2242 if (gfc_match_char (':') != MATCH_YES
)
2245 m
= gfc_match_expr (&iter
->end
);
2248 if (m
== MATCH_ERROR
)
2251 if (gfc_match_char (':') == MATCH_NO
)
2252 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2255 m
= gfc_match_expr (&iter
->stride
);
2258 if (m
== MATCH_ERROR
)
2262 /* Mark the iteration variable's symbol as used as a FORALL index. */
2263 iter
->var
->symtree
->n
.sym
->forall_index
= true;
2269 gfc_error ("Syntax error in FORALL iterator at %C");
2274 gfc_current_locus
= where
;
2275 gfc_free_forall_iterator (iter
);
2280 /* Match the header of a FORALL statement. */
2283 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
2285 gfc_forall_iterator
*head
, *tail
, *new_iter
;
2289 gfc_gobble_whitespace ();
2294 if (gfc_match_char ('(') != MATCH_YES
)
2297 m
= match_forall_iterator (&new_iter
);
2298 if (m
== MATCH_ERROR
)
2303 head
= tail
= new_iter
;
2307 if (gfc_match_char (',') != MATCH_YES
)
2310 m
= match_forall_iterator (&new_iter
);
2311 if (m
== MATCH_ERROR
)
2316 tail
->next
= new_iter
;
2321 /* Have to have a mask expression. */
2323 m
= gfc_match_expr (&msk
);
2326 if (m
== MATCH_ERROR
)
2332 if (gfc_match_char (')') == MATCH_NO
)
2340 gfc_syntax_error (ST_FORALL
);
2343 gfc_free_expr (msk
);
2344 gfc_free_forall_iterator (head
);
2349 /* Match the rest of a simple FORALL statement that follows an
2353 match_simple_forall (void)
2355 gfc_forall_iterator
*head
;
2364 m
= match_forall_header (&head
, &mask
);
2371 m
= gfc_match_assignment ();
2373 if (m
== MATCH_ERROR
)
2377 m
= gfc_match_pointer_assignment ();
2378 if (m
== MATCH_ERROR
)
2384 c
= XCNEW (gfc_code
);
2386 c
->loc
= gfc_current_locus
;
2388 if (gfc_match_eos () != MATCH_YES
)
2391 gfc_clear_new_st ();
2392 new_st
.op
= EXEC_FORALL
;
2393 new_st
.expr1
= mask
;
2394 new_st
.ext
.forall_iterator
= head
;
2395 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2396 new_st
.block
->next
= c
;
2401 gfc_syntax_error (ST_FORALL
);
2404 gfc_free_forall_iterator (head
);
2405 gfc_free_expr (mask
);
2411 /* Match a FORALL statement. */
2414 gfc_match_forall (gfc_statement
*st
)
2416 gfc_forall_iterator
*head
;
2425 m0
= gfc_match_label ();
2426 if (m0
== MATCH_ERROR
)
2429 m
= gfc_match (" forall");
2433 m
= match_forall_header (&head
, &mask
);
2434 if (m
== MATCH_ERROR
)
2439 if (gfc_match_eos () == MATCH_YES
)
2441 *st
= ST_FORALL_BLOCK
;
2442 new_st
.op
= EXEC_FORALL
;
2443 new_st
.expr1
= mask
;
2444 new_st
.ext
.forall_iterator
= head
;
2448 m
= gfc_match_assignment ();
2449 if (m
== MATCH_ERROR
)
2453 m
= gfc_match_pointer_assignment ();
2454 if (m
== MATCH_ERROR
)
2460 c
= XCNEW (gfc_code
);
2462 c
->loc
= gfc_current_locus
;
2464 gfc_clear_new_st ();
2465 new_st
.op
= EXEC_FORALL
;
2466 new_st
.expr1
= mask
;
2467 new_st
.ext
.forall_iterator
= head
;
2468 new_st
.block
= gfc_get_code (EXEC_FORALL
);
2469 new_st
.block
->next
= c
;
2475 gfc_syntax_error (ST_FORALL
);
2478 gfc_free_forall_iterator (head
);
2479 gfc_free_expr (mask
);
2480 gfc_free_statements (c
);
2485 /* Match a DO statement. */
2490 gfc_iterator iter
, *ip
;
2492 gfc_st_label
*label
;
2495 old_loc
= gfc_current_locus
;
2498 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
2500 m
= gfc_match_label ();
2501 if (m
== MATCH_ERROR
)
2504 if (gfc_match (" do") != MATCH_YES
)
2507 m
= gfc_match_st_label (&label
);
2508 if (m
== MATCH_ERROR
)
2511 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
2513 if (gfc_match_eos () == MATCH_YES
)
2515 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
2516 new_st
.op
= EXEC_DO_WHILE
;
2520 /* Match an optional comma, if no comma is found, a space is obligatory. */
2521 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
2524 /* Check for balanced parens. */
2526 if (gfc_match_parens () == MATCH_ERROR
)
2529 if (gfc_match (" concurrent") == MATCH_YES
)
2531 gfc_forall_iterator
*head
;
2534 if (!gfc_notify_std (GFC_STD_F2008
, "DO CONCURRENT construct at %C"))
2540 m
= match_forall_header (&head
, &mask
);
2544 if (m
== MATCH_ERROR
)
2545 goto concurr_cleanup
;
2547 if (gfc_match_eos () != MATCH_YES
)
2548 goto concurr_cleanup
;
2551 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2552 goto concurr_cleanup
;
2554 new_st
.label1
= label
;
2555 new_st
.op
= EXEC_DO_CONCURRENT
;
2556 new_st
.expr1
= mask
;
2557 new_st
.ext
.forall_iterator
= head
;
2562 gfc_syntax_error (ST_DO
);
2563 gfc_free_expr (mask
);
2564 gfc_free_forall_iterator (head
);
2568 /* See if we have a DO WHILE. */
2569 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
2571 new_st
.op
= EXEC_DO_WHILE
;
2575 /* The abortive DO WHILE may have done something to the symbol
2576 table, so we start over. */
2577 gfc_undo_symbols ();
2578 gfc_current_locus
= old_loc
;
2580 gfc_match_label (); /* This won't error. */
2581 gfc_match (" do "); /* This will work. */
2583 gfc_match_st_label (&label
); /* Can't error out. */
2584 gfc_match_char (','); /* Optional comma. */
2586 m
= gfc_match_iterator (&iter
, 0);
2589 if (m
== MATCH_ERROR
)
2592 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
2593 gfc_check_do_variable (iter
.var
->symtree
);
2595 if (gfc_match_eos () != MATCH_YES
)
2597 gfc_syntax_error (ST_DO
);
2601 new_st
.op
= EXEC_DO
;
2605 && !gfc_reference_st_label (label
, ST_LABEL_DO_TARGET
))
2608 new_st
.label1
= label
;
2610 if (new_st
.op
== EXEC_DO_WHILE
)
2611 new_st
.expr1
= iter
.end
;
2614 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
2621 gfc_free_iterator (&iter
, 0);
2627 /* Match an EXIT or CYCLE statement. */
2630 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2632 gfc_state_data
*p
, *o
;
2637 if (gfc_match_eos () == MATCH_YES
)
2641 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2644 m
= gfc_match ("% %n%t", name
);
2645 if (m
== MATCH_ERROR
)
2649 gfc_syntax_error (st
);
2653 /* Find the corresponding symbol. If there's a BLOCK statement
2654 between here and the label, it is not in gfc_current_ns but a parent
2656 stree
= gfc_find_symtree_in_proc (name
, gfc_current_ns
);
2659 gfc_error ("Name %qs in %s statement at %C is unknown",
2660 name
, gfc_ascii_statement (st
));
2665 if (sym
->attr
.flavor
!= FL_LABEL
)
2667 gfc_error ("Name %qs in %s statement at %C is not a construct name",
2668 name
, gfc_ascii_statement (st
));
2673 /* Find the loop specified by the label (or lack of a label). */
2674 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2675 if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2677 else if (p
->state
== COMP_CRITICAL
)
2679 gfc_error("%s statement at %C leaves CRITICAL construct",
2680 gfc_ascii_statement (st
));
2683 else if (p
->state
== COMP_DO_CONCURRENT
2684 && (op
== EXEC_EXIT
|| (sym
&& sym
!= p
->sym
)))
2686 /* F2008, C821 & C845. */
2687 gfc_error("%s statement at %C leaves DO CONCURRENT construct",
2688 gfc_ascii_statement (st
));
2691 else if ((sym
&& sym
== p
->sym
)
2692 || (!sym
&& (p
->state
== COMP_DO
2693 || p
->state
== COMP_DO_CONCURRENT
)))
2699 gfc_error ("%s statement at %C is not within a construct",
2700 gfc_ascii_statement (st
));
2702 gfc_error ("%s statement at %C is not within construct %qs",
2703 gfc_ascii_statement (st
), sym
->name
);
2708 /* Special checks for EXIT from non-loop constructs. */
2712 case COMP_DO_CONCURRENT
:
2716 /* This is already handled above. */
2719 case COMP_ASSOCIATE
:
2723 case COMP_SELECT_TYPE
:
2725 if (op
== EXEC_CYCLE
)
2727 gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2728 " construct %qs", sym
->name
);
2731 gcc_assert (op
== EXEC_EXIT
);
2732 if (!gfc_notify_std (GFC_STD_F2008
, "EXIT statement with no"
2733 " do-construct-name at %C"))
2738 gfc_error ("%s statement at %C is not applicable to construct %qs",
2739 gfc_ascii_statement (st
), sym
->name
);
2745 gfc_error (is_oacc (p
)
2746 ? "%s statement at %C leaving OpenACC structured block"
2747 : "%s statement at %C leaving OpenMP structured block",
2748 gfc_ascii_statement (st
));
2752 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2756 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
2757 && (o
->head
->op
== EXEC_OACC_LOOP
2758 || o
->head
->op
== EXEC_OACC_PARALLEL_LOOP
))
2761 gcc_assert (o
->head
->next
!= NULL
2762 && (o
->head
->next
->op
== EXEC_DO
2763 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2764 && o
->previous
!= NULL
2765 && o
->previous
->tail
->op
== o
->head
->op
);
2766 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2767 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2768 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2769 if (st
== ST_EXIT
&& cnt
<= collapse
)
2771 gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
2774 if (st
== ST_CYCLE
&& cnt
< collapse
)
2776 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2777 " !$ACC LOOP loop");
2783 && (o
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2784 && (o
->head
->op
== EXEC_OMP_DO
2785 || o
->head
->op
== EXEC_OMP_PARALLEL_DO
2786 || o
->head
->op
== EXEC_OMP_SIMD
2787 || o
->head
->op
== EXEC_OMP_DO_SIMD
2788 || o
->head
->op
== EXEC_OMP_PARALLEL_DO_SIMD
))
2791 gcc_assert (o
->head
->next
!= NULL
2792 && (o
->head
->next
->op
== EXEC_DO
2793 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2794 && o
->previous
!= NULL
2795 && o
->previous
->tail
->op
== o
->head
->op
);
2796 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2797 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2798 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2799 if (st
== ST_EXIT
&& cnt
<= collapse
)
2801 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2804 if (st
== ST_CYCLE
&& cnt
< collapse
)
2806 gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2812 /* Save the first statement in the construct - needed by the backend. */
2813 new_st
.ext
.which_construct
= p
->construct
;
2821 /* Match the EXIT statement. */
2824 gfc_match_exit (void)
2826 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2830 /* Match the CYCLE statement. */
2833 gfc_match_cycle (void)
2835 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2839 /* Match a stop-code after an (ERROR) STOP or PAUSE statement. The
2840 requirements for a stop-code differ in the standards.
2844 R840 stop-stmt is STOP [ stop-code ]
2845 R841 stop-code is scalar-char-constant
2846 or digit [ digit [ digit [ digit [ digit ] ] ] ]
2848 Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
2851 R855 stop-stmt is STOP [ stop-code ]
2852 R856 allstop-stmt is ALL STOP [ stop-code ]
2853 R857 stop-code is scalar-default-char-constant-expr
2854 or scalar-int-constant-expr
2856 For free-form source code, all standards contain a statement of the form:
2858 A blank shall be used to separate names, constants, or labels from
2859 adjacent keywords, names, constants, or labels.
2861 A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003,
2865 is valid, but it is invalid Fortran 2008. */
2868 gfc_match_stopcode (gfc_statement st
)
2874 /* Set f95 for -std=f95. */
2875 f95
= gfc_option
.allow_std
== (GFC_STD_F95_OBS
| GFC_STD_F95
| GFC_STD_F77
2876 | GFC_STD_F2008_OBS
);
2878 /* Set f03 for -std=f2003. */
2879 f03
= gfc_option
.allow_std
== (GFC_STD_F95_OBS
| GFC_STD_F95
| GFC_STD_F77
2880 | GFC_STD_F2008_OBS
| GFC_STD_F2003
);
2882 /* Look for a blank between STOP and the stop-code for F2008 or later. */
2883 if (gfc_current_form
!= FORM_FIXED
&& !(f95
|| f03
))
2885 char c
= gfc_peek_ascii_char ();
2887 /* Look for end-of-statement. There is no stop-code. */
2888 if (c
== '\n' || c
== '!' || c
== ';')
2893 gfc_error ("Blank required in %s statement near %C",
2894 gfc_ascii_statement (st
));
2899 if (gfc_match_eos () != MATCH_YES
)
2904 /* First look for the F95 or F2003 digit [...] construct. */
2905 old_locus
= gfc_current_locus
;
2906 m
= gfc_match_small_int (&stopcode
);
2907 if (m
== MATCH_YES
&& (f95
|| f03
))
2911 gfc_error ("STOP code at %C cannot be negative");
2915 if (stopcode
> 99999)
2917 gfc_error ("STOP code at %C contains too many digits");
2922 /* Reset the locus and now load gfc_expr. */
2923 gfc_current_locus
= old_locus
;
2924 m
= gfc_match_expr (&e
);
2925 if (m
== MATCH_ERROR
)
2930 if (gfc_match_eos () != MATCH_YES
)
2934 if (gfc_pure (NULL
))
2936 if (st
== ST_ERROR_STOP
)
2938 if (!gfc_notify_std (GFC_STD_F2015
, "%s statement at %C in PURE "
2939 "procedure", gfc_ascii_statement (st
)))
2944 gfc_error ("%s statement not allowed in PURE procedure at %C",
2945 gfc_ascii_statement (st
));
2950 gfc_unset_implicit_pure (NULL
);
2952 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
))
2954 gfc_error ("Image control statement STOP at %C in CRITICAL block");
2957 if (st
== ST_STOP
&& gfc_find_state (COMP_DO_CONCURRENT
))
2959 gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
2965 gfc_simplify_expr (e
, 0);
2967 /* Test for F95 and F2003 style STOP stop-code. */
2968 if (e
->expr_type
!= EXPR_CONSTANT
&& (f95
|| f03
))
2970 gfc_error ("STOP code at %L must be a scalar CHARACTER constant or "
2971 "digit[digit[digit[digit[digit]]]]", &e
->where
);
2975 /* Use the machinery for an initialization expression to reduce the
2976 stop-code to a constant. */
2977 gfc_init_expr_flag
= true;
2978 gfc_reduce_init_expr (e
);
2979 gfc_init_expr_flag
= false;
2981 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
2983 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2990 gfc_error ("STOP code at %L must be scalar", &e
->where
);
2994 if (e
->ts
.type
== BT_CHARACTER
2995 && e
->ts
.kind
!= gfc_default_character_kind
)
2997 gfc_error ("STOP code at %L must be default character KIND=%d",
2998 &e
->where
, (int) gfc_default_character_kind
);
3002 if (e
->ts
.type
== BT_INTEGER
&& e
->ts
.kind
!= gfc_default_integer_kind
)
3004 gfc_error ("STOP code at %L must be default integer KIND=%d",
3005 &e
->where
, (int) gfc_default_integer_kind
);
3015 new_st
.op
= EXEC_STOP
;
3018 new_st
.op
= EXEC_ERROR_STOP
;
3021 new_st
.op
= EXEC_PAUSE
;
3028 new_st
.ext
.stop_code
= -1;
3033 gfc_syntax_error (st
);
3042 /* Match the (deprecated) PAUSE statement. */
3045 gfc_match_pause (void)
3049 m
= gfc_match_stopcode (ST_PAUSE
);
3052 if (!gfc_notify_std (GFC_STD_F95_DEL
, "PAUSE statement at %C"))
3059 /* Match the STOP statement. */
3062 gfc_match_stop (void)
3064 return gfc_match_stopcode (ST_STOP
);
3068 /* Match the ERROR STOP statement. */
3071 gfc_match_error_stop (void)
3073 if (!gfc_notify_std (GFC_STD_F2008
, "ERROR STOP statement at %C"))
3076 return gfc_match_stopcode (ST_ERROR_STOP
);
3079 /* Match EVENT POST/WAIT statement. Syntax:
3080 EVENT POST ( event-variable [, sync-stat-list] )
3081 EVENT WAIT ( event-variable [, wait-spec-list] )
3083 wait-spec-list is sync-stat-list or until-spec
3084 until-spec is UNTIL_COUNT = scalar-int-expr
3085 sync-stat is STAT= or ERRMSG=. */
3088 event_statement (gfc_statement st
)
3091 gfc_expr
*tmp
, *eventvar
, *until_count
, *stat
, *errmsg
;
3092 bool saw_until_count
, saw_stat
, saw_errmsg
;
3094 tmp
= eventvar
= until_count
= stat
= errmsg
= NULL
;
3095 saw_until_count
= saw_stat
= saw_errmsg
= false;
3097 if (gfc_pure (NULL
))
3099 gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
3100 st
== ST_EVENT_POST
? "POST" : "WAIT");
3104 gfc_unset_implicit_pure (NULL
);
3106 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3108 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3112 if (gfc_find_state (COMP_CRITICAL
))
3114 gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
3115 st
== ST_EVENT_POST
? "POST" : "WAIT");
3119 if (gfc_find_state (COMP_DO_CONCURRENT
))
3121 gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
3122 "block", st
== ST_EVENT_POST
? "POST" : "WAIT");
3126 if (gfc_match_char ('(') != MATCH_YES
)
3129 if (gfc_match ("%e", &eventvar
) != MATCH_YES
)
3131 m
= gfc_match_char (',');
3132 if (m
== MATCH_ERROR
)
3136 m
= gfc_match_char (')');
3144 m
= gfc_match (" stat = %v", &tmp
);
3145 if (m
== MATCH_ERROR
)
3151 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3157 m
= gfc_match_char (',');
3165 m
= gfc_match (" errmsg = %v", &tmp
);
3166 if (m
== MATCH_ERROR
)
3172 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3178 m
= gfc_match_char (',');
3186 m
= gfc_match (" until_count = %e", &tmp
);
3187 if (m
== MATCH_ERROR
|| st
== ST_EVENT_POST
)
3191 if (saw_until_count
)
3193 gfc_error ("Redundant UNTIL_COUNT tag found at %L ",
3198 saw_until_count
= true;
3200 m
= gfc_match_char (',');
3211 if (m
== MATCH_ERROR
)
3214 if (gfc_match (" )%t") != MATCH_YES
)
3221 new_st
.op
= EXEC_EVENT_POST
;
3224 new_st
.op
= EXEC_EVENT_WAIT
;
3230 new_st
.expr1
= eventvar
;
3231 new_st
.expr2
= stat
;
3232 new_st
.expr3
= errmsg
;
3233 new_st
.expr4
= until_count
;
3238 gfc_syntax_error (st
);
3241 if (until_count
!= tmp
)
3242 gfc_free_expr (until_count
);
3244 gfc_free_expr (errmsg
);
3246 gfc_free_expr (stat
);
3248 gfc_free_expr (tmp
);
3249 gfc_free_expr (eventvar
);
3257 gfc_match_event_post (void)
3259 if (!gfc_notify_std (GFC_STD_F2008_TS
, "EVENT POST statement at %C"))
3262 return event_statement (ST_EVENT_POST
);
3267 gfc_match_event_wait (void)
3269 if (!gfc_notify_std (GFC_STD_F2008_TS
, "EVENT WAIT statement at %C"))
3272 return event_statement (ST_EVENT_WAIT
);
3276 /* Match LOCK/UNLOCK statement. Syntax:
3277 LOCK ( lock-variable [ , lock-stat-list ] )
3278 UNLOCK ( lock-variable [ , sync-stat-list ] )
3279 where lock-stat is ACQUIRED_LOCK or sync-stat
3280 and sync-stat is STAT= or ERRMSG=. */
3283 lock_unlock_statement (gfc_statement st
)
3286 gfc_expr
*tmp
, *lockvar
, *acq_lock
, *stat
, *errmsg
;
3287 bool saw_acq_lock
, saw_stat
, saw_errmsg
;
3289 tmp
= lockvar
= acq_lock
= stat
= errmsg
= NULL
;
3290 saw_acq_lock
= saw_stat
= saw_errmsg
= false;
3292 if (gfc_pure (NULL
))
3294 gfc_error ("Image control statement %s at %C in PURE procedure",
3295 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3299 gfc_unset_implicit_pure (NULL
);
3301 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3303 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
3307 if (gfc_find_state (COMP_CRITICAL
))
3309 gfc_error ("Image control statement %s at %C in CRITICAL block",
3310 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3314 if (gfc_find_state (COMP_DO_CONCURRENT
))
3316 gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
3317 st
== ST_LOCK
? "LOCK" : "UNLOCK");
3321 if (gfc_match_char ('(') != MATCH_YES
)
3324 if (gfc_match ("%e", &lockvar
) != MATCH_YES
)
3326 m
= gfc_match_char (',');
3327 if (m
== MATCH_ERROR
)
3331 m
= gfc_match_char (')');
3339 m
= gfc_match (" stat = %v", &tmp
);
3340 if (m
== MATCH_ERROR
)
3346 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3352 m
= gfc_match_char (',');
3360 m
= gfc_match (" errmsg = %v", &tmp
);
3361 if (m
== MATCH_ERROR
)
3367 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3373 m
= gfc_match_char (',');
3381 m
= gfc_match (" acquired_lock = %v", &tmp
);
3382 if (m
== MATCH_ERROR
|| st
== ST_UNLOCK
)
3388 gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
3393 saw_acq_lock
= true;
3395 m
= gfc_match_char (',');
3406 if (m
== MATCH_ERROR
)
3409 if (gfc_match (" )%t") != MATCH_YES
)
3416 new_st
.op
= EXEC_LOCK
;
3419 new_st
.op
= EXEC_UNLOCK
;
3425 new_st
.expr1
= lockvar
;
3426 new_st
.expr2
= stat
;
3427 new_st
.expr3
= errmsg
;
3428 new_st
.expr4
= acq_lock
;
3433 gfc_syntax_error (st
);
3436 if (acq_lock
!= tmp
)
3437 gfc_free_expr (acq_lock
);
3439 gfc_free_expr (errmsg
);
3441 gfc_free_expr (stat
);
3443 gfc_free_expr (tmp
);
3444 gfc_free_expr (lockvar
);
3451 gfc_match_lock (void)
3453 if (!gfc_notify_std (GFC_STD_F2008
, "LOCK statement at %C"))
3456 return lock_unlock_statement (ST_LOCK
);
3461 gfc_match_unlock (void)
3463 if (!gfc_notify_std (GFC_STD_F2008
, "UNLOCK statement at %C"))
3466 return lock_unlock_statement (ST_UNLOCK
);
3470 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
3471 SYNC ALL [(sync-stat-list)]
3472 SYNC MEMORY [(sync-stat-list)]
3473 SYNC IMAGES (image-set [, sync-stat-list] )
3474 with sync-stat is int-expr or *. */
3477 sync_statement (gfc_statement st
)
3480 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
3481 bool saw_stat
, saw_errmsg
;
3483 tmp
= imageset
= stat
= errmsg
= NULL
;
3484 saw_stat
= saw_errmsg
= false;
3486 if (gfc_pure (NULL
))
3488 gfc_error ("Image control statement SYNC at %C in PURE procedure");
3492 gfc_unset_implicit_pure (NULL
);
3494 if (!gfc_notify_std (GFC_STD_F2008
, "SYNC statement at %C"))
3497 if (flag_coarray
== GFC_FCOARRAY_NONE
)
3499 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
3504 if (gfc_find_state (COMP_CRITICAL
))
3506 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
3510 if (gfc_find_state (COMP_DO_CONCURRENT
))
3512 gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
3516 if (gfc_match_eos () == MATCH_YES
)
3518 if (st
== ST_SYNC_IMAGES
)
3523 if (gfc_match_char ('(') != MATCH_YES
)
3526 if (st
== ST_SYNC_IMAGES
)
3528 /* Denote '*' as imageset == NULL. */
3529 m
= gfc_match_char ('*');
3530 if (m
== MATCH_ERROR
)
3534 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
3537 m
= gfc_match_char (',');
3538 if (m
== MATCH_ERROR
)
3542 m
= gfc_match_char (')');
3551 m
= gfc_match (" stat = %v", &tmp
);
3552 if (m
== MATCH_ERROR
)
3558 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3564 if (gfc_match_char (',') == MATCH_YES
)
3571 m
= gfc_match (" errmsg = %v", &tmp
);
3572 if (m
== MATCH_ERROR
)
3578 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3584 if (gfc_match_char (',') == MATCH_YES
)
3594 if (gfc_match (" )%t") != MATCH_YES
)
3601 new_st
.op
= EXEC_SYNC_ALL
;
3603 case ST_SYNC_IMAGES
:
3604 new_st
.op
= EXEC_SYNC_IMAGES
;
3606 case ST_SYNC_MEMORY
:
3607 new_st
.op
= EXEC_SYNC_MEMORY
;
3613 new_st
.expr1
= imageset
;
3614 new_st
.expr2
= stat
;
3615 new_st
.expr3
= errmsg
;
3620 gfc_syntax_error (st
);
3624 gfc_free_expr (stat
);
3626 gfc_free_expr (errmsg
);
3628 gfc_free_expr (tmp
);
3629 gfc_free_expr (imageset
);
3635 /* Match SYNC ALL statement. */
3638 gfc_match_sync_all (void)
3640 return sync_statement (ST_SYNC_ALL
);
3644 /* Match SYNC IMAGES statement. */
3647 gfc_match_sync_images (void)
3649 return sync_statement (ST_SYNC_IMAGES
);
3653 /* Match SYNC MEMORY statement. */
3656 gfc_match_sync_memory (void)
3658 return sync_statement (ST_SYNC_MEMORY
);
3662 /* Match a CONTINUE statement. */
3665 gfc_match_continue (void)
3667 if (gfc_match_eos () != MATCH_YES
)
3669 gfc_syntax_error (ST_CONTINUE
);
3673 new_st
.op
= EXEC_CONTINUE
;
3678 /* Match the (deprecated) ASSIGN statement. */
3681 gfc_match_assign (void)
3684 gfc_st_label
*label
;
3686 if (gfc_match (" %l", &label
) == MATCH_YES
)
3688 if (!gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
))
3690 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
3692 if (!gfc_notify_std (GFC_STD_F95_DEL
, "ASSIGN statement at %C"))
3695 expr
->symtree
->n
.sym
->attr
.assign
= 1;
3697 new_st
.op
= EXEC_LABEL_ASSIGN
;
3698 new_st
.label1
= label
;
3699 new_st
.expr1
= expr
;
3707 /* Match the GO TO statement. As a computed GOTO statement is
3708 matched, it is transformed into an equivalent SELECT block. No
3709 tree is necessary, and the resulting jumps-to-jumps are
3710 specifically optimized away by the back end. */
3713 gfc_match_goto (void)
3715 gfc_code
*head
, *tail
;
3718 gfc_st_label
*label
;
3722 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
3724 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3727 new_st
.op
= EXEC_GOTO
;
3728 new_st
.label1
= label
;
3732 /* The assigned GO TO statement. */
3734 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
3736 if (!gfc_notify_std (GFC_STD_F95_DEL
, "Assigned GOTO statement at %C"))
3739 new_st
.op
= EXEC_GOTO
;
3740 new_st
.expr1
= expr
;
3742 if (gfc_match_eos () == MATCH_YES
)
3745 /* Match label list. */
3746 gfc_match_char (',');
3747 if (gfc_match_char ('(') != MATCH_YES
)
3749 gfc_syntax_error (ST_GOTO
);
3756 m
= gfc_match_st_label (&label
);
3760 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3764 head
= tail
= gfc_get_code (EXEC_GOTO
);
3767 tail
->block
= gfc_get_code (EXEC_GOTO
);
3771 tail
->label1
= label
;
3773 while (gfc_match_char (',') == MATCH_YES
);
3775 if (gfc_match (")%t") != MATCH_YES
)
3780 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3783 new_st
.block
= head
;
3788 /* Last chance is a computed GO TO statement. */
3789 if (gfc_match_char ('(') != MATCH_YES
)
3791 gfc_syntax_error (ST_GOTO
);
3800 m
= gfc_match_st_label (&label
);
3804 if (!gfc_reference_st_label (label
, ST_LABEL_TARGET
))
3808 head
= tail
= gfc_get_code (EXEC_SELECT
);
3811 tail
->block
= gfc_get_code (EXEC_SELECT
);
3815 cp
= gfc_get_case ();
3816 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
3819 tail
->ext
.block
.case_list
= cp
;
3821 tail
->next
= gfc_get_code (EXEC_GOTO
);
3822 tail
->next
->label1
= label
;
3824 while (gfc_match_char (',') == MATCH_YES
);
3826 if (gfc_match_char (')') != MATCH_YES
)
3831 gfc_error ("Statement label list in GOTO at %C cannot be empty");
3835 /* Get the rest of the statement. */
3836 gfc_match_char (',');
3838 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
3841 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Computed GOTO at %C"))
3844 /* At this point, a computed GOTO has been fully matched and an
3845 equivalent SELECT statement constructed. */
3847 new_st
.op
= EXEC_SELECT
;
3848 new_st
.expr1
= NULL
;
3850 /* Hack: For a "real" SELECT, the expression is in expr. We put
3851 it in expr2 so we can distinguish then and produce the correct
3853 new_st
.expr2
= expr
;
3854 new_st
.block
= head
;
3858 gfc_syntax_error (ST_GOTO
);
3860 gfc_free_statements (head
);
3865 /* Frees a list of gfc_alloc structures. */
3868 gfc_free_alloc_list (gfc_alloc
*p
)
3875 gfc_free_expr (p
->expr
);
3881 /* Match an ALLOCATE statement. */
3884 gfc_match_allocate (void)
3886 gfc_alloc
*head
, *tail
;
3887 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
3891 locus old_locus
, deferred_locus
;
3892 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, saw_deferred
, b1
, b2
, b3
;
3893 bool saw_unlimited
= false;
3896 stat
= errmsg
= source
= mold
= tmp
= NULL
;
3897 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= saw_deferred
= false;
3899 if (gfc_match_char ('(') != MATCH_YES
)
3902 /* Match an optional type-spec. */
3903 old_locus
= gfc_current_locus
;
3904 m
= gfc_match_type_spec (&ts
);
3905 if (m
== MATCH_ERROR
)
3907 else if (m
== MATCH_NO
)
3909 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
3911 if (gfc_match ("%n :: ", name
) == MATCH_YES
)
3913 gfc_error ("Error in type-spec at %L", &old_locus
);
3917 ts
.type
= BT_UNKNOWN
;
3921 if (gfc_match (" :: ") == MATCH_YES
)
3923 if (!gfc_notify_std (GFC_STD_F2003
, "typespec in ALLOCATE at %L",
3929 gfc_error ("Type-spec at %L cannot contain a deferred "
3930 "type parameter", &old_locus
);
3934 if (ts
.type
== BT_CHARACTER
)
3935 ts
.u
.cl
->length_from_typespec
= true;
3939 ts
.type
= BT_UNKNOWN
;
3940 gfc_current_locus
= old_locus
;
3947 head
= tail
= gfc_get_alloc ();
3950 tail
->next
= gfc_get_alloc ();
3954 m
= gfc_match_variable (&tail
->expr
, 0);
3957 if (m
== MATCH_ERROR
)
3960 if (gfc_check_do_variable (tail
->expr
->symtree
))
3963 bool impure
= gfc_impure_variable (tail
->expr
->symtree
->n
.sym
);
3964 if (impure
&& gfc_pure (NULL
))
3966 gfc_error ("Bad allocate-object at %C for a PURE procedure");
3971 gfc_unset_implicit_pure (NULL
);
3973 if (tail
->expr
->ts
.deferred
)
3975 saw_deferred
= true;
3976 deferred_locus
= tail
->expr
->where
;
3979 if (gfc_find_state (COMP_DO_CONCURRENT
)
3980 || gfc_find_state (COMP_CRITICAL
))
3983 bool coarray
= tail
->expr
->symtree
->n
.sym
->attr
.codimension
;
3984 for (ref
= tail
->expr
->ref
; ref
; ref
= ref
->next
)
3985 if (ref
->type
== REF_COMPONENT
)
3986 coarray
= ref
->u
.c
.component
->attr
.codimension
;
3988 if (coarray
&& gfc_find_state (COMP_DO_CONCURRENT
))
3990 gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
3993 if (coarray
&& gfc_find_state (COMP_CRITICAL
))
3995 gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
4000 /* Check for F08:C628. */
4001 sym
= tail
->expr
->symtree
->n
.sym
;
4002 b1
= !(tail
->expr
->ref
4003 && (tail
->expr
->ref
->type
== REF_COMPONENT
4004 || tail
->expr
->ref
->type
== REF_ARRAY
));
4005 if (sym
&& sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4006 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
4007 || CLASS_DATA (sym
)->attr
.class_pointer
);
4009 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4010 || sym
->attr
.proc_pointer
);
4011 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
4012 && (sym
->ns
->proc_name
->attr
.allocatable
4013 || sym
->ns
->proc_name
->attr
.pointer
4014 || sym
->ns
->proc_name
->attr
.proc_pointer
);
4015 if (b1
&& b2
&& !b3
)
4017 gfc_error ("Allocate-object at %L is neither a data pointer "
4018 "nor an allocatable variable", &tail
->expr
->where
);
4022 /* The ALLOCATE statement had an optional typespec. Check the
4024 if (ts
.type
!= BT_UNKNOWN
)
4026 /* Enforce F03:C624. */
4027 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
4029 gfc_error ("Type of entity at %L is type incompatible with "
4030 "typespec", &tail
->expr
->where
);
4034 /* Enforce F03:C627. */
4035 if (ts
.kind
!= tail
->expr
->ts
.kind
&& !UNLIMITED_POLY (tail
->expr
))
4037 gfc_error ("Kind type parameter for entity at %L differs from "
4038 "the kind type parameter of the typespec",
4039 &tail
->expr
->where
);
4044 if (tail
->expr
->ts
.type
== BT_DERIVED
)
4045 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
4047 saw_unlimited
= saw_unlimited
| UNLIMITED_POLY (tail
->expr
);
4049 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
4051 gfc_error ("Shape specification for allocatable scalar at %C");
4055 if (gfc_match_char (',') != MATCH_YES
)
4060 m
= gfc_match (" stat = %v", &tmp
);
4061 if (m
== MATCH_ERROR
)
4068 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
4076 if (gfc_check_do_variable (stat
->symtree
))
4079 if (gfc_match_char (',') == MATCH_YES
)
4080 goto alloc_opt_list
;
4083 m
= gfc_match (" errmsg = %v", &tmp
);
4084 if (m
== MATCH_ERROR
)
4088 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG tag at %L", &tmp
->where
))
4094 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
4102 if (gfc_match_char (',') == MATCH_YES
)
4103 goto alloc_opt_list
;
4106 m
= gfc_match (" source = %e", &tmp
);
4107 if (m
== MATCH_ERROR
)
4111 if (!gfc_notify_std (GFC_STD_F2003
, "SOURCE tag at %L", &tmp
->where
))
4117 gfc_error ("Redundant SOURCE tag found at %L ", &tmp
->where
);
4121 /* The next 2 conditionals check C631. */
4122 if (ts
.type
!= BT_UNKNOWN
)
4124 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
4125 &tmp
->where
, &old_locus
);
4130 && !gfc_notify_std (GFC_STD_F2008
, "SOURCE tag at %L"
4131 " with more than a single allocate object",
4139 if (gfc_match_char (',') == MATCH_YES
)
4140 goto alloc_opt_list
;
4143 m
= gfc_match (" mold = %e", &tmp
);
4144 if (m
== MATCH_ERROR
)
4148 if (!gfc_notify_std (GFC_STD_F2008
, "MOLD tag at %L", &tmp
->where
))
4151 /* Check F08:C636. */
4154 gfc_error ("Redundant MOLD tag found at %L ", &tmp
->where
);
4158 /* Check F08:C637. */
4159 if (ts
.type
!= BT_UNKNOWN
)
4161 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
4162 &tmp
->where
, &old_locus
);
4171 if (gfc_match_char (',') == MATCH_YES
)
4172 goto alloc_opt_list
;
4175 gfc_gobble_whitespace ();
4177 if (gfc_peek_char () == ')')
4181 if (gfc_match (" )%t") != MATCH_YES
)
4184 /* Check F08:C637. */
4187 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
4188 &mold
->where
, &source
->where
);
4192 /* Check F03:C623, */
4193 if (saw_deferred
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4195 gfc_error ("Allocate-object at %L with a deferred type parameter "
4196 "requires either a type-spec or SOURCE tag or a MOLD tag",
4201 /* Check F03:C625, */
4202 if (saw_unlimited
&& ts
.type
== BT_UNKNOWN
&& !source
&& !mold
)
4204 for (tail
= head
; tail
; tail
= tail
->next
)
4206 if (UNLIMITED_POLY (tail
->expr
))
4207 gfc_error ("Unlimited polymorphic allocate-object at %L "
4208 "requires either a type-spec or SOURCE tag "
4209 "or a MOLD tag", &tail
->expr
->where
);
4214 new_st
.op
= EXEC_ALLOCATE
;
4215 new_st
.expr1
= stat
;
4216 new_st
.expr2
= errmsg
;
4218 new_st
.expr3
= source
;
4220 new_st
.expr3
= mold
;
4221 new_st
.ext
.alloc
.list
= head
;
4222 new_st
.ext
.alloc
.ts
= ts
;
4227 gfc_syntax_error (ST_ALLOCATE
);
4230 gfc_free_expr (errmsg
);
4231 gfc_free_expr (source
);
4232 gfc_free_expr (stat
);
4233 gfc_free_expr (mold
);
4234 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
4235 gfc_free_alloc_list (head
);
4240 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
4241 a set of pointer assignments to intrinsic NULL(). */
4244 gfc_match_nullify (void)
4252 if (gfc_match_char ('(') != MATCH_YES
)
4257 m
= gfc_match_variable (&p
, 0);
4258 if (m
== MATCH_ERROR
)
4263 if (gfc_check_do_variable (p
->symtree
))
4267 if (gfc_is_coindexed (p
))
4269 gfc_error ("Pointer object at %C shall not be coindexed");
4273 /* build ' => NULL() '. */
4274 e
= gfc_get_null_expr (&gfc_current_locus
);
4276 /* Chain to list. */
4280 tail
->op
= EXEC_POINTER_ASSIGN
;
4284 tail
->next
= gfc_get_code (EXEC_POINTER_ASSIGN
);
4291 if (gfc_match (" )%t") == MATCH_YES
)
4293 if (gfc_match_char (',') != MATCH_YES
)
4300 gfc_syntax_error (ST_NULLIFY
);
4303 gfc_free_statements (new_st
.next
);
4305 gfc_free_expr (new_st
.expr1
);
4306 new_st
.expr1
= NULL
;
4307 gfc_free_expr (new_st
.expr2
);
4308 new_st
.expr2
= NULL
;
4313 /* Match a DEALLOCATE statement. */
4316 gfc_match_deallocate (void)
4318 gfc_alloc
*head
, *tail
;
4319 gfc_expr
*stat
, *errmsg
, *tmp
;
4322 bool saw_stat
, saw_errmsg
, b1
, b2
;
4325 stat
= errmsg
= tmp
= NULL
;
4326 saw_stat
= saw_errmsg
= false;
4328 if (gfc_match_char ('(') != MATCH_YES
)
4334 head
= tail
= gfc_get_alloc ();
4337 tail
->next
= gfc_get_alloc ();
4341 m
= gfc_match_variable (&tail
->expr
, 0);
4342 if (m
== MATCH_ERROR
)
4347 if (gfc_check_do_variable (tail
->expr
->symtree
))
4350 sym
= tail
->expr
->symtree
->n
.sym
;
4352 bool impure
= gfc_impure_variable (sym
);
4353 if (impure
&& gfc_pure (NULL
))
4355 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
4360 gfc_unset_implicit_pure (NULL
);
4362 if (gfc_is_coarray (tail
->expr
)
4363 && gfc_find_state (COMP_DO_CONCURRENT
))
4365 gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
4369 if (gfc_is_coarray (tail
->expr
)
4370 && gfc_find_state (COMP_CRITICAL
))
4372 gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
4376 /* FIXME: disable the checking on derived types. */
4377 b1
= !(tail
->expr
->ref
4378 && (tail
->expr
->ref
->type
== REF_COMPONENT
4379 || tail
->expr
->ref
->type
== REF_ARRAY
));
4380 if (sym
&& sym
->ts
.type
== BT_CLASS
)
4381 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
4382 || CLASS_DATA (sym
)->attr
.class_pointer
);
4384 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
4385 || sym
->attr
.proc_pointer
);
4388 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
4389 "nor an allocatable variable");
4393 if (gfc_match_char (',') != MATCH_YES
)
4398 m
= gfc_match (" stat = %v", &tmp
);
4399 if (m
== MATCH_ERROR
)
4405 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
4406 gfc_free_expr (tmp
);
4413 if (gfc_check_do_variable (stat
->symtree
))
4416 if (gfc_match_char (',') == MATCH_YES
)
4417 goto dealloc_opt_list
;
4420 m
= gfc_match (" errmsg = %v", &tmp
);
4421 if (m
== MATCH_ERROR
)
4425 if (!gfc_notify_std (GFC_STD_F2003
, "ERRMSG at %L", &tmp
->where
))
4430 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
4431 gfc_free_expr (tmp
);
4438 if (gfc_match_char (',') == MATCH_YES
)
4439 goto dealloc_opt_list
;
4442 gfc_gobble_whitespace ();
4444 if (gfc_peek_char () == ')')
4448 if (gfc_match (" )%t") != MATCH_YES
)
4451 new_st
.op
= EXEC_DEALLOCATE
;
4452 new_st
.expr1
= stat
;
4453 new_st
.expr2
= errmsg
;
4454 new_st
.ext
.alloc
.list
= head
;
4459 gfc_syntax_error (ST_DEALLOCATE
);
4462 gfc_free_expr (errmsg
);
4463 gfc_free_expr (stat
);
4464 gfc_free_alloc_list (head
);
4469 /* Match a RETURN statement. */
4472 gfc_match_return (void)
4476 gfc_compile_state s
;
4480 if (gfc_find_state (COMP_CRITICAL
))
4482 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
4486 if (gfc_find_state (COMP_DO_CONCURRENT
))
4488 gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
4492 if (gfc_match_eos () == MATCH_YES
)
4495 if (!gfc_find_state (COMP_SUBROUTINE
))
4497 gfc_error ("Alternate RETURN statement at %C is only allowed within "
4502 if (gfc_current_form
== FORM_FREE
)
4504 /* The following are valid, so we can't require a blank after the
4508 char c
= gfc_peek_ascii_char ();
4509 if (ISALPHA (c
) || ISDIGIT (c
))
4513 m
= gfc_match (" %e%t", &e
);
4516 if (m
== MATCH_ERROR
)
4519 gfc_syntax_error (ST_RETURN
);
4526 gfc_enclosing_unit (&s
);
4527 if (s
== COMP_PROGRAM
4528 && !gfc_notify_std (GFC_STD_GNU
, "RETURN statement in "
4529 "main program at %C"))
4532 new_st
.op
= EXEC_RETURN
;
4539 /* Match the call of a type-bound procedure, if CALL%var has already been
4540 matched and var found to be a derived-type variable. */
4543 match_typebound_call (gfc_symtree
* varst
)
4548 base
= gfc_get_expr ();
4549 base
->expr_type
= EXPR_VARIABLE
;
4550 base
->symtree
= varst
;
4551 base
->where
= gfc_current_locus
;
4552 gfc_set_sym_referenced (varst
->n
.sym
);
4554 m
= gfc_match_varspec (base
, 0, true, true);
4556 gfc_error ("Expected component reference at %C");
4559 gfc_free_expr (base
);
4563 if (gfc_match_eos () != MATCH_YES
)
4565 gfc_error ("Junk after CALL at %C");
4566 gfc_free_expr (base
);
4570 if (base
->expr_type
== EXPR_COMPCALL
)
4571 new_st
.op
= EXEC_COMPCALL
;
4572 else if (base
->expr_type
== EXPR_PPC
)
4573 new_st
.op
= EXEC_CALL_PPC
;
4576 gfc_error ("Expected type-bound procedure or procedure pointer component "
4578 gfc_free_expr (base
);
4581 new_st
.expr1
= base
;
4587 /* Match a CALL statement. The tricky part here are possible
4588 alternate return specifiers. We handle these by having all
4589 "subroutines" actually return an integer via a register that gives
4590 the return number. If the call specifies alternate returns, we
4591 generate code for a SELECT statement whose case clauses contain
4592 GOTOs to the various labels. */
4595 gfc_match_call (void)
4597 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4598 gfc_actual_arglist
*a
, *arglist
;
4608 m
= gfc_match ("% %n", name
);
4614 if (gfc_get_ha_sym_tree (name
, &st
))
4619 /* If this is a variable of derived-type, it probably starts a type-bound
4621 if ((sym
->attr
.flavor
!= FL_PROCEDURE
4622 || gfc_is_function_return_value (sym
, gfc_current_ns
))
4623 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
4624 return match_typebound_call (st
);
4626 /* If it does not seem to be callable (include functions so that the
4627 right association is made. They are thrown out in resolution.)
4629 if (!sym
->attr
.generic
4630 && !sym
->attr
.subroutine
4631 && !sym
->attr
.function
)
4633 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
4635 /* ...create a symbol in this scope... */
4636 if (sym
->ns
!= gfc_current_ns
4637 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
4640 if (sym
!= st
->n
.sym
)
4644 /* ...and then to try to make the symbol into a subroutine. */
4645 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
4649 gfc_set_sym_referenced (sym
);
4651 if (gfc_match_eos () != MATCH_YES
)
4653 m
= gfc_match_actual_arglist (1, &arglist
);
4656 if (m
== MATCH_ERROR
)
4659 if (gfc_match_eos () != MATCH_YES
)
4663 /* If any alternate return labels were found, construct a SELECT
4664 statement that will jump to the right place. */
4667 for (a
= arglist
; a
; a
= a
->next
)
4668 if (a
->expr
== NULL
)
4676 gfc_symtree
*select_st
;
4677 gfc_symbol
*select_sym
;
4678 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4680 new_st
.next
= c
= gfc_get_code (EXEC_SELECT
);
4681 sprintf (name
, "_result_%s", sym
->name
);
4682 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
4684 select_sym
= select_st
->n
.sym
;
4685 select_sym
->ts
.type
= BT_INTEGER
;
4686 select_sym
->ts
.kind
= gfc_default_integer_kind
;
4687 gfc_set_sym_referenced (select_sym
);
4688 c
->expr1
= gfc_get_expr ();
4689 c
->expr1
->expr_type
= EXPR_VARIABLE
;
4690 c
->expr1
->symtree
= select_st
;
4691 c
->expr1
->ts
= select_sym
->ts
;
4692 c
->expr1
->where
= gfc_current_locus
;
4695 for (a
= arglist
; a
; a
= a
->next
)
4697 if (a
->expr
!= NULL
)
4700 if (!gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
))
4705 c
->block
= gfc_get_code (EXEC_SELECT
);
4708 new_case
= gfc_get_case ();
4709 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
4710 new_case
->low
= new_case
->high
;
4711 c
->ext
.block
.case_list
= new_case
;
4713 c
->next
= gfc_get_code (EXEC_GOTO
);
4714 c
->next
->label1
= a
->label
;
4718 new_st
.op
= EXEC_CALL
;
4719 new_st
.symtree
= st
;
4720 new_st
.ext
.actual
= arglist
;
4725 gfc_syntax_error (ST_CALL
);
4728 gfc_free_actual_arglist (arglist
);
4733 /* Given a name, return a pointer to the common head structure,
4734 creating it if it does not exist. If FROM_MODULE is nonzero, we
4735 mangle the name so that it doesn't interfere with commons defined
4736 in the using namespace.
4737 TODO: Add to global symbol tree. */
4740 gfc_get_common (const char *name
, int from_module
)
4743 static int serial
= 0;
4744 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
4748 /* A use associated common block is only needed to correctly layout
4749 the variables it contains. */
4750 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
4751 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
4755 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
4758 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
4761 if (st
->n
.common
== NULL
)
4763 st
->n
.common
= gfc_get_common_head ();
4764 st
->n
.common
->where
= gfc_current_locus
;
4765 strcpy (st
->n
.common
->name
, name
);
4768 return st
->n
.common
;
4772 /* Match a common block name. */
4774 match
match_common_name (char *name
)
4778 if (gfc_match_char ('/') == MATCH_NO
)
4784 if (gfc_match_char ('/') == MATCH_YES
)
4790 m
= gfc_match_name (name
);
4792 if (m
== MATCH_ERROR
)
4794 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
4797 gfc_error ("Syntax error in common block name at %C");
4802 /* Match a COMMON statement. */
4805 gfc_match_common (void)
4807 gfc_symbol
*sym
, **head
, *tail
, *other
;
4808 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4818 m
= match_common_name (name
);
4819 if (m
== MATCH_ERROR
)
4822 if (name
[0] == '\0')
4824 t
= &gfc_current_ns
->blank_common
;
4825 if (t
->head
== NULL
)
4826 t
->where
= gfc_current_locus
;
4830 t
= gfc_get_common (name
, 0);
4839 while (tail
->common_next
)
4840 tail
= tail
->common_next
;
4843 /* Grab the list of symbols. */
4846 m
= gfc_match_symbol (&sym
, 0);
4847 if (m
== MATCH_ERROR
)
4852 /* See if we know the current common block is bind(c), and if
4853 so, then see if we can check if the symbol is (which it'll
4854 need to be). This can happen if the bind(c) attr stmt was
4855 applied to the common block, and the variable(s) already
4856 defined, before declaring the common block. */
4857 if (t
->is_bind_c
== 1)
4859 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
4861 /* If we find an error, just print it and continue,
4862 cause it's just semantic, and we can see if there
4864 gfc_error_now ("Variable %qs at %L in common block %qs "
4865 "at %C must be declared with a C "
4866 "interoperable kind since common block "
4868 sym
->name
, &(sym
->declared_at
), t
->name
,
4872 if (sym
->attr
.is_bind_c
== 1)
4873 gfc_error_now ("Variable %qs in common block %qs at %C can not "
4874 "be bind(c) since it is not global", sym
->name
,
4878 if (sym
->attr
.in_common
)
4880 gfc_error ("Symbol %qs at %C is already in a COMMON block",
4885 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
4886 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
4888 if (!gfc_notify_std (GFC_STD_GNU
, "Initialized symbol %qs at "
4889 "%C can only be COMMON in BLOCK DATA",
4894 /* Deal with an optional array specification after the
4896 m
= gfc_match_array_spec (&as
, true, true);
4897 if (m
== MATCH_ERROR
)
4902 if (as
->type
!= AS_EXPLICIT
)
4904 gfc_error ("Array specification for symbol %qs in COMMON "
4905 "at %C must be explicit", sym
->name
);
4909 if (!gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
))
4912 if (sym
->attr
.pointer
)
4914 gfc_error ("Symbol %qs in COMMON at %C cannot be a "
4915 "POINTER array", sym
->name
);
4924 /* Add the in_common attribute, but ignore the reported errors
4925 if any, and continue matching. */
4926 gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
);
4928 sym
->common_block
= t
;
4929 sym
->common_block
->refs
++;
4932 tail
->common_next
= sym
;
4938 sym
->common_head
= t
;
4940 /* Check to see if the symbol is already in an equivalence group.
4941 If it is, set the other members as being in common. */
4942 if (sym
->attr
.in_equivalence
)
4944 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
4946 for (e2
= e1
; e2
; e2
= e2
->eq
)
4947 if (e2
->expr
->symtree
->n
.sym
== sym
)
4954 for (e2
= e1
; e2
; e2
= e2
->eq
)
4956 other
= e2
->expr
->symtree
->n
.sym
;
4957 if (other
->common_head
4958 && other
->common_head
!= sym
->common_head
)
4960 gfc_error ("Symbol %qs, in COMMON block %qs at "
4961 "%C is being indirectly equivalenced to "
4962 "another COMMON block %qs",
4963 sym
->name
, sym
->common_head
->name
,
4964 other
->common_head
->name
);
4967 other
->attr
.in_common
= 1;
4968 other
->common_head
= t
;
4974 gfc_gobble_whitespace ();
4975 if (gfc_match_eos () == MATCH_YES
)
4977 if (gfc_peek_ascii_char () == '/')
4979 if (gfc_match_char (',') != MATCH_YES
)
4981 gfc_gobble_whitespace ();
4982 if (gfc_peek_ascii_char () == '/')
4991 gfc_syntax_error (ST_COMMON
);
4994 gfc_free_array_spec (as
);
4999 /* Match a BLOCK DATA program unit. */
5002 gfc_match_block_data (void)
5004 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5008 if (gfc_match_eos () == MATCH_YES
)
5010 gfc_new_block
= NULL
;
5014 m
= gfc_match ("% %n%t", name
);
5018 if (gfc_get_symbol (name
, NULL
, &sym
))
5021 if (!gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
))
5024 gfc_new_block
= sym
;
5030 /* Free a namelist structure. */
5033 gfc_free_namelist (gfc_namelist
*name
)
5037 for (; name
; name
= n
)
5045 /* Free an OpenMP namelist structure. */
5048 gfc_free_omp_namelist (gfc_omp_namelist
*name
)
5050 gfc_omp_namelist
*n
;
5052 for (; name
; name
= n
)
5054 gfc_free_expr (name
->expr
);
5057 if (name
->udr
->combiner
)
5058 gfc_free_statement (name
->udr
->combiner
);
5059 if (name
->udr
->initializer
)
5060 gfc_free_statement (name
->udr
->initializer
);
5069 /* Match a NAMELIST statement. */
5072 gfc_match_namelist (void)
5074 gfc_symbol
*group_name
, *sym
;
5078 m
= gfc_match (" / %s /", &group_name
);
5081 if (m
== MATCH_ERROR
)
5086 if (group_name
->ts
.type
!= BT_UNKNOWN
)
5088 gfc_error ("Namelist group name %qs at %C already has a basic "
5089 "type of %s", group_name
->name
,
5090 gfc_typename (&group_name
->ts
));
5094 if (group_name
->attr
.flavor
== FL_NAMELIST
5095 && group_name
->attr
.use_assoc
5096 && !gfc_notify_std (GFC_STD_GNU
, "Namelist group name %qs "
5097 "at %C already is USE associated and can"
5098 "not be respecified.", group_name
->name
))
5101 if (group_name
->attr
.flavor
!= FL_NAMELIST
5102 && !gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
5103 group_name
->name
, NULL
))
5108 m
= gfc_match_symbol (&sym
, 1);
5111 if (m
== MATCH_ERROR
)
5114 if (sym
->attr
.in_namelist
== 0
5115 && !gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
))
5118 /* Use gfc_error_check here, rather than goto error, so that
5119 these are the only errors for the next two lines. */
5120 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
5122 gfc_error ("Assumed size array %qs in namelist %qs at "
5123 "%C is not allowed", sym
->name
, group_name
->name
);
5127 nl
= gfc_get_namelist ();
5131 if (group_name
->namelist
== NULL
)
5132 group_name
->namelist
= group_name
->namelist_tail
= nl
;
5135 group_name
->namelist_tail
->next
= nl
;
5136 group_name
->namelist_tail
= nl
;
5139 if (gfc_match_eos () == MATCH_YES
)
5142 m
= gfc_match_char (',');
5144 if (gfc_match_char ('/') == MATCH_YES
)
5146 m2
= gfc_match (" %s /", &group_name
);
5147 if (m2
== MATCH_YES
)
5149 if (m2
== MATCH_ERROR
)
5163 gfc_syntax_error (ST_NAMELIST
);
5170 /* Match a MODULE statement. */
5173 gfc_match_module (void)
5177 m
= gfc_match (" %s%t", &gfc_new_block
);
5181 if (!gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
5182 gfc_new_block
->name
, NULL
))
5189 /* Free equivalence sets and lists. Recursively is the easiest way to
5193 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
5198 gfc_free_equiv (eq
->eq
);
5199 gfc_free_equiv_until (eq
->next
, stop
);
5200 gfc_free_expr (eq
->expr
);
5206 gfc_free_equiv (gfc_equiv
*eq
)
5208 gfc_free_equiv_until (eq
, NULL
);
5212 /* Match an EQUIVALENCE statement. */
5215 gfc_match_equivalence (void)
5217 gfc_equiv
*eq
, *set
, *tail
;
5221 gfc_common_head
*common_head
= NULL
;
5229 eq
= gfc_get_equiv ();
5233 eq
->next
= gfc_current_ns
->equiv
;
5234 gfc_current_ns
->equiv
= eq
;
5236 if (gfc_match_char ('(') != MATCH_YES
)
5240 common_flag
= FALSE
;
5245 m
= gfc_match_equiv_variable (&set
->expr
);
5246 if (m
== MATCH_ERROR
)
5251 /* count the number of objects. */
5254 if (gfc_match_char ('%') == MATCH_YES
)
5256 gfc_error ("Derived type component %C is not a "
5257 "permitted EQUIVALENCE member");
5261 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
5262 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5264 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
5265 "be an array section");
5269 sym
= set
->expr
->symtree
->n
.sym
;
5271 if (!gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
))
5274 if (sym
->attr
.in_common
)
5277 common_head
= sym
->common_head
;
5280 if (gfc_match_char (')') == MATCH_YES
)
5283 if (gfc_match_char (',') != MATCH_YES
)
5286 set
->eq
= gfc_get_equiv ();
5292 gfc_error ("EQUIVALENCE at %C requires two or more objects");
5296 /* If one of the members of an equivalence is in common, then
5297 mark them all as being in common. Before doing this, check
5298 that members of the equivalence group are not in different
5301 for (set
= eq
; set
; set
= set
->eq
)
5303 sym
= set
->expr
->symtree
->n
.sym
;
5304 if (sym
->common_head
&& sym
->common_head
!= common_head
)
5306 gfc_error ("Attempt to indirectly overlap COMMON "
5307 "blocks %s and %s by EQUIVALENCE at %C",
5308 sym
->common_head
->name
, common_head
->name
);
5311 sym
->attr
.in_common
= 1;
5312 sym
->common_head
= common_head
;
5315 if (gfc_match_eos () == MATCH_YES
)
5317 if (gfc_match_char (',') != MATCH_YES
)
5319 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
5327 gfc_syntax_error (ST_EQUIVALENCE
);
5333 gfc_free_equiv (gfc_current_ns
->equiv
);
5334 gfc_current_ns
->equiv
= eq
;
5340 /* Check that a statement function is not recursive. This is done by looking
5341 for the statement function symbol(sym) by looking recursively through its
5342 expression(e). If a reference to sym is found, true is returned.
5343 12.5.4 requires that any variable of function that is implicitly typed
5344 shall have that type confirmed by any subsequent type declaration. The
5345 implicit typing is conveniently done here. */
5347 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
5350 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
5356 switch (e
->expr_type
)
5359 if (e
->symtree
== NULL
)
5362 /* Check the name before testing for nested recursion! */
5363 if (sym
->name
== e
->symtree
->n
.sym
->name
)
5366 /* Catch recursion via other statement functions. */
5367 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
5368 && e
->symtree
->n
.sym
->value
5369 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
5372 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5373 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5378 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
5381 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
5382 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
5394 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
5396 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
5400 /* Match a statement function declaration. It is so easy to match
5401 non-statement function statements with a MATCH_ERROR as opposed to
5402 MATCH_NO that we suppress error message in most cases. */
5405 gfc_match_st_function (void)
5407 gfc_error_buffer old_error
;
5412 m
= gfc_match_symbol (&sym
, 0);
5416 gfc_push_error (&old_error
);
5418 if (!gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
, sym
->name
, NULL
))
5421 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
5424 m
= gfc_match (" = %e%t", &expr
);
5428 gfc_free_error (&old_error
);
5430 if (m
== MATCH_ERROR
)
5433 if (recursive_stmt_fcn (expr
, sym
))
5435 gfc_error ("Statement function at %L is recursive", &expr
->where
);
5441 if ((gfc_current_state () == COMP_FUNCTION
5442 || gfc_current_state () == COMP_SUBROUTINE
)
5443 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
5445 gfc_error ("Statement function at %L cannot appear within an INTERFACE",
5450 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Statement function at %C"))
5456 gfc_pop_error (&old_error
);
5461 /* Match an assignment to a pointer function (F2008). This could, in
5462 general be ambiguous with a statement function. In this implementation
5463 it remains so if it is the first statement after the specification
5467 gfc_match_ptr_fcn_assign (void)
5469 gfc_error_buffer old_error
;
5474 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5476 old_loc
= gfc_current_locus
;
5477 m
= gfc_match_name (name
);
5481 gfc_find_symbol (name
, NULL
, 1, &sym
);
5482 if (sym
&& sym
->attr
.flavor
!= FL_PROCEDURE
)
5485 gfc_push_error (&old_error
);
5487 if (sym
&& sym
->attr
.function
)
5488 goto match_actual_arglist
;
5490 gfc_current_locus
= old_loc
;
5491 m
= gfc_match_symbol (&sym
, 0);
5495 if (!gfc_add_procedure (&sym
->attr
, PROC_UNKNOWN
, sym
->name
, NULL
))
5498 match_actual_arglist
:
5499 gfc_current_locus
= old_loc
;
5500 m
= gfc_match (" %e", &expr
);
5504 new_st
.op
= EXEC_ASSIGN
;
5505 new_st
.expr1
= expr
;
5508 m
= gfc_match (" = %e%t", &expr
);
5512 new_st
.expr2
= expr
;
5516 gfc_pop_error (&old_error
);
5521 /***************** SELECT CASE subroutines ******************/
5523 /* Free a single case structure. */
5526 free_case (gfc_case
*p
)
5528 if (p
->low
== p
->high
)
5530 gfc_free_expr (p
->low
);
5531 gfc_free_expr (p
->high
);
5536 /* Free a list of case structures. */
5539 gfc_free_case_list (gfc_case
*p
)
5551 /* Match a single case selector. Combining the requirements of F08:C830
5552 and F08:C832 (R838) means that the case-value must have either CHARACTER,
5553 INTEGER, or LOGICAL type. */
5556 match_case_selector (gfc_case
**cp
)
5561 c
= gfc_get_case ();
5562 c
->where
= gfc_current_locus
;
5564 if (gfc_match_char (':') == MATCH_YES
)
5566 m
= gfc_match_init_expr (&c
->high
);
5569 if (m
== MATCH_ERROR
)
5572 if (c
->high
->ts
.type
!= BT_LOGICAL
&& c
->high
->ts
.type
!= BT_INTEGER
5573 && c
->high
->ts
.type
!= BT_CHARACTER
)
5575 gfc_error ("Expression in CASE selector at %L cannot be %s",
5576 &c
->high
->where
, gfc_typename (&c
->high
->ts
));
5582 m
= gfc_match_init_expr (&c
->low
);
5583 if (m
== MATCH_ERROR
)
5588 if (c
->low
->ts
.type
!= BT_LOGICAL
&& c
->low
->ts
.type
!= BT_INTEGER
5589 && c
->low
->ts
.type
!= BT_CHARACTER
)
5591 gfc_error ("Expression in CASE selector at %L cannot be %s",
5592 &c
->low
->where
, gfc_typename (&c
->low
->ts
));
5596 /* If we're not looking at a ':' now, make a range out of a single
5597 target. Else get the upper bound for the case range. */
5598 if (gfc_match_char (':') != MATCH_YES
)
5602 m
= gfc_match_init_expr (&c
->high
);
5603 if (m
== MATCH_ERROR
)
5605 /* MATCH_NO is fine. It's OK if nothing is there! */
5613 gfc_error ("Expected initialization expression in CASE at %C");
5621 /* Match the end of a case statement. */
5624 match_case_eos (void)
5626 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5629 if (gfc_match_eos () == MATCH_YES
)
5632 /* If the case construct doesn't have a case-construct-name, we
5633 should have matched the EOS. */
5634 if (!gfc_current_block ())
5637 gfc_gobble_whitespace ();
5639 m
= gfc_match_name (name
);
5643 if (strcmp (name
, gfc_current_block ()->name
) != 0)
5645 gfc_error ("Expected block name %qs of SELECT construct at %C",
5646 gfc_current_block ()->name
);
5650 return gfc_match_eos ();
5654 /* Match a SELECT statement. */
5657 gfc_match_select (void)
5662 m
= gfc_match_label ();
5663 if (m
== MATCH_ERROR
)
5666 m
= gfc_match (" select case ( %e )%t", &expr
);
5670 new_st
.op
= EXEC_SELECT
;
5671 new_st
.expr1
= expr
;
5677 /* Transfer the selector typespec to the associate name. */
5680 copy_ts_from_selector_to_associate (gfc_expr
*associate
, gfc_expr
*selector
)
5683 gfc_symbol
*assoc_sym
;
5685 assoc_sym
= associate
->symtree
->n
.sym
;
5687 /* At this stage the expression rank and arrayspec dimensions have
5688 not been completely sorted out. We must get the expr2->rank
5689 right here, so that the correct class container is obtained. */
5690 ref
= selector
->ref
;
5691 while (ref
&& ref
->next
)
5694 if (selector
->ts
.type
== BT_CLASS
&& CLASS_DATA (selector
)->as
5695 && ref
&& ref
->type
== REF_ARRAY
)
5697 /* Ensure that the array reference type is set. We cannot use
5698 gfc_resolve_expr at this point, so the usable parts of
5699 resolve.c(resolve_array_ref) are employed to do it. */
5700 if (ref
->u
.ar
.type
== AR_UNKNOWN
)
5702 ref
->u
.ar
.type
= AR_ELEMENT
;
5703 for (int i
= 0; i
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; i
++)
5704 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5705 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
5706 || (ref
->u
.ar
.dimen_type
[i
] == DIMEN_UNKNOWN
5707 && ref
->u
.ar
.start
[i
] && ref
->u
.ar
.start
[i
]->rank
))
5709 ref
->u
.ar
.type
= AR_SECTION
;
5714 if (ref
->u
.ar
.type
== AR_FULL
)
5715 selector
->rank
= CLASS_DATA (selector
)->as
->rank
;
5716 else if (ref
->u
.ar
.type
== AR_SECTION
)
5717 selector
->rank
= ref
->u
.ar
.dimen
;
5724 assoc_sym
->attr
.dimension
= 1;
5725 assoc_sym
->as
= gfc_get_array_spec ();
5726 assoc_sym
->as
->rank
= selector
->rank
;
5727 assoc_sym
->as
->type
= AS_DEFERRED
;
5730 assoc_sym
->as
= NULL
;
5732 if (selector
->ts
.type
== BT_CLASS
)
5734 /* The correct class container has to be available. */
5735 assoc_sym
->ts
.type
= BT_CLASS
;
5736 assoc_sym
->ts
.u
.derived
= CLASS_DATA (selector
)->ts
.u
.derived
;
5737 assoc_sym
->attr
.pointer
= 1;
5738 gfc_build_class_symbol (&assoc_sym
->ts
, &assoc_sym
->attr
, &assoc_sym
->as
);
5743 /* Push the current selector onto the SELECT TYPE stack. */
5746 select_type_push (gfc_symbol
*sel
)
5748 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
5749 top
->selector
= sel
;
5751 top
->prev
= select_type_stack
;
5753 select_type_stack
= top
;
5757 /* Set the temporary for the current intrinsic SELECT TYPE selector. */
5759 static gfc_symtree
*
5760 select_intrinsic_set_tmp (gfc_typespec
*ts
)
5762 char name
[GFC_MAX_SYMBOL_LEN
];
5766 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
5769 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5770 && !select_type_stack
->selector
->attr
.class_ok
)
5773 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
5774 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
5775 charlen
= mpz_get_si (ts
->u
.cl
->length
->value
.integer
);
5777 if (ts
->type
!= BT_CHARACTER
)
5778 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (ts
->type
),
5781 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (ts
->type
),
5784 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5785 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5787 /* Copy across the array spec to the selector. */
5788 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5789 && (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5790 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
))
5792 tmp
->n
.sym
->attr
.pointer
= 1;
5793 tmp
->n
.sym
->attr
.dimension
5794 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5795 tmp
->n
.sym
->attr
.codimension
5796 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5798 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5801 gfc_set_sym_referenced (tmp
->n
.sym
);
5802 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5803 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5809 /* Set up a temporary for the current TYPE IS / CLASS IS branch . */
5812 select_type_set_tmp (gfc_typespec
*ts
)
5814 char name
[GFC_MAX_SYMBOL_LEN
];
5815 gfc_symtree
*tmp
= NULL
;
5819 select_type_stack
->tmp
= NULL
;
5823 tmp
= select_intrinsic_set_tmp (ts
);
5830 if (ts
->type
== BT_CLASS
)
5831 sprintf (name
, "__tmp_class_%s", ts
->u
.derived
->name
);
5833 sprintf (name
, "__tmp_type_%s", ts
->u
.derived
->name
);
5834 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
5835 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
5837 if (select_type_stack
->selector
->ts
.type
== BT_CLASS
5838 && select_type_stack
->selector
->attr
.class_ok
)
5840 tmp
->n
.sym
->attr
.pointer
5841 = CLASS_DATA (select_type_stack
->selector
)->attr
.class_pointer
;
5843 /* Copy across the array spec to the selector. */
5844 if (CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
5845 || CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
)
5847 tmp
->n
.sym
->attr
.dimension
5848 = CLASS_DATA (select_type_stack
->selector
)->attr
.dimension
;
5849 tmp
->n
.sym
->attr
.codimension
5850 = CLASS_DATA (select_type_stack
->selector
)->attr
.codimension
;
5852 = gfc_copy_array_spec (CLASS_DATA (select_type_stack
->selector
)->as
);
5856 gfc_set_sym_referenced (tmp
->n
.sym
);
5857 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
5858 tmp
->n
.sym
->attr
.select_type_temporary
= 1;
5860 if (ts
->type
== BT_CLASS
)
5861 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
5865 /* Add an association for it, so the rest of the parser knows it is
5866 an associate-name. The target will be set during resolution. */
5867 tmp
->n
.sym
->assoc
= gfc_get_association_list ();
5868 tmp
->n
.sym
->assoc
->dangling
= 1;
5869 tmp
->n
.sym
->assoc
->st
= tmp
;
5871 select_type_stack
->tmp
= tmp
;
5875 /* Match a SELECT TYPE statement. */
5878 gfc_match_select_type (void)
5880 gfc_expr
*expr1
, *expr2
= NULL
;
5882 char name
[GFC_MAX_SYMBOL_LEN
];
5885 gfc_namespace
*ns
= gfc_current_ns
;
5887 m
= gfc_match_label ();
5888 if (m
== MATCH_ERROR
)
5891 m
= gfc_match (" select type ( ");
5895 gfc_current_ns
= gfc_build_block_ns (ns
);
5896 m
= gfc_match (" %n => %e", name
, &expr2
);
5899 expr1
= gfc_get_expr ();
5900 expr1
->expr_type
= EXPR_VARIABLE
;
5901 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
5907 sym
= expr1
->symtree
->n
.sym
;
5908 if (expr2
->ts
.type
== BT_UNKNOWN
)
5909 sym
->attr
.untyped
= 1;
5911 copy_ts_from_selector_to_associate (expr1
, expr2
);
5913 sym
->attr
.flavor
= FL_VARIABLE
;
5914 sym
->attr
.referenced
= 1;
5915 sym
->attr
.class_ok
= 1;
5919 m
= gfc_match (" %e ", &expr1
);
5922 std::swap (ns
, gfc_current_ns
);
5923 gfc_free_namespace (ns
);
5928 m
= gfc_match (" )%t");
5931 gfc_error ("parse error in SELECT TYPE statement at %C");
5935 /* This ghastly expression seems to be needed to distinguish a CLASS
5936 array, which can have a reference, from other expressions that
5937 have references, such as derived type components, and are not
5938 allowed by the standard.
5939 TODO: see if it is sufficient to exclude component and substring
5941 class_array
= (expr1
->expr_type
== EXPR_VARIABLE
5942 && expr1
->ts
.type
== BT_CLASS
5943 && CLASS_DATA (expr1
)
5944 && (strcmp (CLASS_DATA (expr1
)->name
, "_data") == 0)
5945 && (CLASS_DATA (expr1
)->attr
.dimension
5946 || CLASS_DATA (expr1
)->attr
.codimension
)
5948 && expr1
->ref
->type
== REF_ARRAY
5949 && expr1
->ref
->next
== NULL
);
5951 /* Check for F03:C811. */
5952 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
5953 || (!class_array
&& expr1
->ref
!= NULL
)))
5955 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
5956 "use associate-name=>");
5961 new_st
.op
= EXEC_SELECT_TYPE
;
5962 new_st
.expr1
= expr1
;
5963 new_st
.expr2
= expr2
;
5964 new_st
.ext
.block
.ns
= gfc_current_ns
;
5966 select_type_push (expr1
->symtree
->n
.sym
);
5967 gfc_current_ns
= ns
;
5972 gfc_free_expr (expr1
);
5973 gfc_free_expr (expr2
);
5974 gfc_undo_symbols ();
5975 std::swap (ns
, gfc_current_ns
);
5976 gfc_free_namespace (ns
);
5981 /* Match a CASE statement. */
5984 gfc_match_case (void)
5986 gfc_case
*c
, *head
, *tail
;
5991 if (gfc_current_state () != COMP_SELECT
)
5993 gfc_error ("Unexpected CASE statement at %C");
5997 if (gfc_match ("% default") == MATCH_YES
)
5999 m
= match_case_eos ();
6002 if (m
== MATCH_ERROR
)
6005 new_st
.op
= EXEC_SELECT
;
6006 c
= gfc_get_case ();
6007 c
->where
= gfc_current_locus
;
6008 new_st
.ext
.block
.case_list
= c
;
6012 if (gfc_match_char ('(') != MATCH_YES
)
6017 if (match_case_selector (&c
) == MATCH_ERROR
)
6027 if (gfc_match_char (')') == MATCH_YES
)
6029 if (gfc_match_char (',') != MATCH_YES
)
6033 m
= match_case_eos ();
6036 if (m
== MATCH_ERROR
)
6039 new_st
.op
= EXEC_SELECT
;
6040 new_st
.ext
.block
.case_list
= head
;
6045 gfc_error ("Syntax error in CASE specification at %C");
6048 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
6053 /* Match a TYPE IS statement. */
6056 gfc_match_type_is (void)
6061 if (gfc_current_state () != COMP_SELECT_TYPE
)
6063 gfc_error ("Unexpected TYPE IS statement at %C");
6067 if (gfc_match_char ('(') != MATCH_YES
)
6070 c
= gfc_get_case ();
6071 c
->where
= gfc_current_locus
;
6073 m
= gfc_match_type_spec (&c
->ts
);
6076 if (m
== MATCH_ERROR
)
6079 if (gfc_match_char (')') != MATCH_YES
)
6082 m
= match_case_eos ();
6085 if (m
== MATCH_ERROR
)
6088 new_st
.op
= EXEC_SELECT_TYPE
;
6089 new_st
.ext
.block
.case_list
= c
;
6091 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
6092 && (c
->ts
.u
.derived
->attr
.sequence
6093 || c
->ts
.u
.derived
->attr
.is_bind_c
))
6095 gfc_error ("The type-spec shall not specify a sequence derived "
6096 "type or a type with the BIND attribute in SELECT "
6097 "TYPE at %C [F2003:C815]");
6101 /* Create temporary variable. */
6102 select_type_set_tmp (&c
->ts
);
6107 gfc_error ("Syntax error in TYPE IS specification at %C");
6111 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6116 /* Match a CLASS IS or CLASS DEFAULT statement. */
6119 gfc_match_class_is (void)
6124 if (gfc_current_state () != COMP_SELECT_TYPE
)
6127 if (gfc_match ("% default") == MATCH_YES
)
6129 m
= match_case_eos ();
6132 if (m
== MATCH_ERROR
)
6135 new_st
.op
= EXEC_SELECT_TYPE
;
6136 c
= gfc_get_case ();
6137 c
->where
= gfc_current_locus
;
6138 c
->ts
.type
= BT_UNKNOWN
;
6139 new_st
.ext
.block
.case_list
= c
;
6140 select_type_set_tmp (NULL
);
6144 m
= gfc_match ("% is");
6147 if (m
== MATCH_ERROR
)
6150 if (gfc_match_char ('(') != MATCH_YES
)
6153 c
= gfc_get_case ();
6154 c
->where
= gfc_current_locus
;
6156 m
= match_derived_type_spec (&c
->ts
);
6159 if (m
== MATCH_ERROR
)
6162 if (c
->ts
.type
== BT_DERIVED
)
6163 c
->ts
.type
= BT_CLASS
;
6165 if (gfc_match_char (')') != MATCH_YES
)
6168 m
= match_case_eos ();
6171 if (m
== MATCH_ERROR
)
6174 new_st
.op
= EXEC_SELECT_TYPE
;
6175 new_st
.ext
.block
.case_list
= c
;
6177 /* Create temporary variable. */
6178 select_type_set_tmp (&c
->ts
);
6183 gfc_error ("Syntax error in CLASS IS specification at %C");
6187 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
6192 /********************* WHERE subroutines ********************/
6194 /* Match the rest of a simple WHERE statement that follows an IF statement.
6198 match_simple_where (void)
6204 m
= gfc_match (" ( %e )", &expr
);
6208 m
= gfc_match_assignment ();
6211 if (m
== MATCH_ERROR
)
6214 if (gfc_match_eos () != MATCH_YES
)
6217 c
= gfc_get_code (EXEC_WHERE
);
6220 c
->next
= XCNEW (gfc_code
);
6222 gfc_clear_new_st ();
6224 new_st
.op
= EXEC_WHERE
;
6230 gfc_syntax_error (ST_WHERE
);
6233 gfc_free_expr (expr
);
6238 /* Match a WHERE statement. */
6241 gfc_match_where (gfc_statement
*st
)
6247 m0
= gfc_match_label ();
6248 if (m0
== MATCH_ERROR
)
6251 m
= gfc_match (" where ( %e )", &expr
);
6255 if (gfc_match_eos () == MATCH_YES
)
6257 *st
= ST_WHERE_BLOCK
;
6258 new_st
.op
= EXEC_WHERE
;
6259 new_st
.expr1
= expr
;
6263 m
= gfc_match_assignment ();
6265 gfc_syntax_error (ST_WHERE
);
6269 gfc_free_expr (expr
);
6273 /* We've got a simple WHERE statement. */
6275 c
= gfc_get_code (EXEC_WHERE
);
6278 /* Put in the assignment. It will not be processed by add_statement, so we
6279 need to copy the location here. */
6281 c
->next
= XCNEW (gfc_code
);
6283 c
->next
->loc
= gfc_current_locus
;
6284 gfc_clear_new_st ();
6286 new_st
.op
= EXEC_WHERE
;
6293 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
6294 new_st if successful. */
6297 gfc_match_elsewhere (void)
6299 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6303 if (gfc_current_state () != COMP_WHERE
)
6305 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
6311 if (gfc_match_char ('(') == MATCH_YES
)
6313 m
= gfc_match_expr (&expr
);
6316 if (m
== MATCH_ERROR
)
6319 if (gfc_match_char (')') != MATCH_YES
)
6323 if (gfc_match_eos () != MATCH_YES
)
6325 /* Only makes sense if we have a where-construct-name. */
6326 if (!gfc_current_block ())
6331 /* Better be a name at this point. */
6332 m
= gfc_match_name (name
);
6335 if (m
== MATCH_ERROR
)
6338 if (gfc_match_eos () != MATCH_YES
)
6341 if (strcmp (name
, gfc_current_block ()->name
) != 0)
6343 gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
6344 name
, gfc_current_block ()->name
);
6349 new_st
.op
= EXEC_WHERE
;
6350 new_st
.expr1
= expr
;
6354 gfc_syntax_error (ST_ELSEWHERE
);
6357 gfc_free_expr (expr
);