1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 2010 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
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 gfc_internal_error ("gfc_op2string(): Bad code");
111 /******************** Generic matching subroutines ************************/
113 /* This function scans the current statement counting the opened and closed
114 parenthesis to make sure they are balanced. */
117 gfc_match_parens (void)
119 locus old_loc
, where
;
123 old_loc
= gfc_current_locus
;
130 c
= gfc_next_char_literal (instring
);
133 if (quote
== ' ' && ((c
== '\'') || (c
== '"')))
139 if (quote
!= ' ' && c
== quote
)
146 if (c
== '(' && quote
== ' ')
149 where
= gfc_current_locus
;
151 if (c
== ')' && quote
== ' ')
154 where
= gfc_current_locus
;
158 gfc_current_locus
= old_loc
;
162 gfc_error ("Missing ')' in statement at or before %L", &where
);
167 gfc_error ("Missing '(' in statement at or before %L", &where
);
175 /* See if the next character is a special character that has
176 escaped by a \ via the -fbackslash option. */
179 gfc_match_special_char (gfc_char_t
*res
)
187 switch ((c
= gfc_next_char_literal (1)))
220 /* Hexadecimal form of wide characters. */
221 len
= (c
== 'x' ? 2 : (c
== 'u' ? 4 : 8));
223 for (i
= 0; i
< len
; i
++)
225 char buf
[2] = { '\0', '\0' };
227 c
= gfc_next_char_literal (1);
228 if (!gfc_wide_fits_in_byte (c
)
229 || !gfc_check_digit ((unsigned char) c
, 16))
232 buf
[0] = (unsigned char) c
;
234 n
+= strtol (buf
, NULL
, 16);
240 /* Unknown backslash codes are simply not expanded. */
249 /* In free form, match at least one space. Always matches in fixed
253 gfc_match_space (void)
258 if (gfc_current_form
== FORM_FIXED
)
261 old_loc
= gfc_current_locus
;
263 c
= gfc_next_ascii_char ();
264 if (!gfc_is_whitespace (c
))
266 gfc_current_locus
= old_loc
;
270 gfc_gobble_whitespace ();
276 /* Match an end of statement. End of statement is optional
277 whitespace, followed by a ';' or '\n' or comment '!'. If a
278 semicolon is found, we continue to eat whitespace and semicolons. */
291 old_loc
= gfc_current_locus
;
292 gfc_gobble_whitespace ();
294 c
= gfc_next_ascii_char ();
300 c
= gfc_next_ascii_char ();
317 gfc_current_locus
= old_loc
;
318 return (flag
) ? MATCH_YES
: MATCH_NO
;
322 /* Match a literal integer on the input, setting the value on
323 MATCH_YES. Literal ints occur in kind-parameters as well as
324 old-style character length specifications. If cnt is non-NULL it
325 will be set to the number of digits. */
328 gfc_match_small_literal_int (int *value
, int *cnt
)
334 old_loc
= gfc_current_locus
;
337 gfc_gobble_whitespace ();
338 c
= gfc_next_ascii_char ();
344 gfc_current_locus
= old_loc
;
353 old_loc
= gfc_current_locus
;
354 c
= gfc_next_ascii_char ();
359 i
= 10 * i
+ c
- '0';
364 gfc_error ("Integer too large at %C");
369 gfc_current_locus
= old_loc
;
378 /* Match a small, constant integer expression, like in a kind
379 statement. On MATCH_YES, 'value' is set. */
382 gfc_match_small_int (int *value
)
389 m
= gfc_match_expr (&expr
);
393 p
= gfc_extract_int (expr
, &i
);
394 gfc_free_expr (expr
);
407 /* This function is the same as the gfc_match_small_int, except that
408 we're keeping the pointer to the expr. This function could just be
409 removed and the previously mentioned one modified, though all calls
410 to it would have to be modified then (and there were a number of
411 them). Return MATCH_ERROR if fail to extract the int; otherwise,
412 return the result of gfc_match_expr(). The expr (if any) that was
413 matched is returned in the parameter expr. */
416 gfc_match_small_int_expr (int *value
, gfc_expr
**expr
)
422 m
= gfc_match_expr (expr
);
426 p
= gfc_extract_int (*expr
, &i
);
439 /* Matches a statement label. Uses gfc_match_small_literal_int() to
440 do most of the work. */
443 gfc_match_st_label (gfc_st_label
**label
)
449 old_loc
= gfc_current_locus
;
451 m
= gfc_match_small_literal_int (&i
, &cnt
);
457 gfc_error ("Too many digits in statement label at %C");
463 gfc_error ("Statement label at %C is zero");
467 *label
= gfc_get_st_label (i
);
472 gfc_current_locus
= old_loc
;
477 /* Match and validate a label associated with a named IF, DO or SELECT
478 statement. If the symbol does not have the label attribute, we add
479 it. We also make sure the symbol does not refer to another
480 (active) block. A matched label is pointed to by gfc_new_block. */
483 gfc_match_label (void)
485 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
488 gfc_new_block
= NULL
;
490 m
= gfc_match (" %n :", name
);
494 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
496 gfc_error ("Label name '%s' at %C is ambiguous", name
);
500 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
502 gfc_error ("Duplicate construct label '%s' at %C", name
);
506 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
507 gfc_new_block
->name
, NULL
) == FAILURE
)
514 /* See if the current input looks like a name of some sort. Modifies
515 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
516 Note that options.c restricts max_identifier_length to not more
517 than GFC_MAX_SYMBOL_LEN. */
520 gfc_match_name (char *buffer
)
526 old_loc
= gfc_current_locus
;
527 gfc_gobble_whitespace ();
529 c
= gfc_next_ascii_char ();
530 if (!(ISALPHA (c
) || (c
== '_' && gfc_option
.flag_allow_leading_underscore
)))
532 if (gfc_error_flag_test() == 0 && c
!= '(')
533 gfc_error ("Invalid character in name at %C");
534 gfc_current_locus
= old_loc
;
544 if (i
> gfc_option
.max_identifier_length
)
546 gfc_error ("Name at %C is too long");
550 old_loc
= gfc_current_locus
;
551 c
= gfc_next_ascii_char ();
553 while (ISALNUM (c
) || c
== '_' || (gfc_option
.flag_dollar_ok
&& c
== '$'));
555 if (c
== '$' && !gfc_option
.flag_dollar_ok
)
557 gfc_error ("Invalid character '$' at %C. Use -fdollar-ok to allow it "
563 gfc_current_locus
= old_loc
;
569 /* Match a valid name for C, which is almost the same as for Fortran,
570 except that you can start with an underscore, etc.. It could have
571 been done by modifying the gfc_match_name, but this way other
572 things C allows can be added, such as no limits on the length.
573 Right now, the length is limited to the same thing as Fortran..
574 Also, by rewriting it, we use the gfc_next_char_C() to prevent the
575 input characters from being automatically lower cased, since C is
576 case sensitive. The parameter, buffer, is used to return the name
577 that is matched. Return MATCH_ERROR if the name is too long
578 (though this is a self-imposed limit), MATCH_NO if what we're
579 seeing isn't a name, and MATCH_YES if we successfully match a C
583 gfc_match_name_C (char *buffer
)
589 old_loc
= gfc_current_locus
;
590 gfc_gobble_whitespace ();
592 /* Get the next char (first possible char of name) and see if
593 it's valid for C (either a letter or an underscore). */
594 c
= gfc_next_char_literal (1);
596 /* If the user put nothing expect spaces between the quotes, it is valid
597 and simply means there is no name= specifier and the name is the fortran
598 symbol name, all lowercase. */
599 if (c
== '"' || c
== '\'')
602 gfc_current_locus
= old_loc
;
606 if (!ISALPHA (c
) && c
!= '_')
608 gfc_error ("Invalid C name in NAME= specifier at %C");
612 /* Continue to read valid variable name characters. */
615 gcc_assert (gfc_wide_fits_in_byte (c
));
617 buffer
[i
++] = (unsigned char) c
;
619 /* C does not define a maximum length of variable names, to my
620 knowledge, but the compiler typically places a limit on them.
621 For now, i'll use the same as the fortran limit for simplicity,
622 but this may need to be changed to a dynamic buffer that can
623 be realloc'ed here if necessary, or more likely, a larger
625 if (i
> gfc_option
.max_identifier_length
)
627 gfc_error ("Name at %C is too long");
631 old_loc
= gfc_current_locus
;
633 /* Get next char; param means we're in a string. */
634 c
= gfc_next_char_literal (1);
635 } while (ISALNUM (c
) || c
== '_');
638 gfc_current_locus
= old_loc
;
640 /* See if we stopped because of whitespace. */
643 gfc_gobble_whitespace ();
644 c
= gfc_peek_ascii_char ();
645 if (c
!= '"' && c
!= '\'')
647 gfc_error ("Embedded space in NAME= specifier at %C");
652 /* If we stopped because we had an invalid character for a C name, report
653 that to the user by returning MATCH_NO. */
654 if (c
!= '"' && c
!= '\'')
656 gfc_error ("Invalid C name in NAME= specifier at %C");
664 /* Match a symbol on the input. Modifies the pointer to the symbol
665 pointer if successful. */
668 gfc_match_sym_tree (gfc_symtree
**matched_symbol
, int host_assoc
)
670 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
673 m
= gfc_match_name (buffer
);
678 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
679 ? MATCH_ERROR
: MATCH_YES
;
681 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
, false))
689 gfc_match_symbol (gfc_symbol
**matched_symbol
, int host_assoc
)
694 m
= gfc_match_sym_tree (&st
, host_assoc
);
699 *matched_symbol
= st
->n
.sym
;
701 *matched_symbol
= NULL
;
704 *matched_symbol
= NULL
;
709 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
710 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
714 gfc_match_intrinsic_op (gfc_intrinsic_op
*result
)
716 locus orig_loc
= gfc_current_locus
;
719 gfc_gobble_whitespace ();
720 ch
= gfc_next_ascii_char ();
725 *result
= INTRINSIC_PLUS
;
730 *result
= INTRINSIC_MINUS
;
734 if (gfc_next_ascii_char () == '=')
737 *result
= INTRINSIC_EQ
;
743 if (gfc_peek_ascii_char () == '=')
746 gfc_next_ascii_char ();
747 *result
= INTRINSIC_LE
;
751 *result
= INTRINSIC_LT
;
755 if (gfc_peek_ascii_char () == '=')
758 gfc_next_ascii_char ();
759 *result
= INTRINSIC_GE
;
763 *result
= INTRINSIC_GT
;
767 if (gfc_peek_ascii_char () == '*')
770 gfc_next_ascii_char ();
771 *result
= INTRINSIC_POWER
;
775 *result
= INTRINSIC_TIMES
;
779 ch
= gfc_peek_ascii_char ();
783 gfc_next_ascii_char ();
784 *result
= INTRINSIC_NE
;
790 gfc_next_ascii_char ();
791 *result
= INTRINSIC_CONCAT
;
795 *result
= INTRINSIC_DIVIDE
;
799 ch
= gfc_next_ascii_char ();
803 if (gfc_next_ascii_char () == 'n'
804 && gfc_next_ascii_char () == 'd'
805 && gfc_next_ascii_char () == '.')
807 /* Matched ".and.". */
808 *result
= INTRINSIC_AND
;
814 if (gfc_next_ascii_char () == 'q')
816 ch
= gfc_next_ascii_char ();
819 /* Matched ".eq.". */
820 *result
= INTRINSIC_EQ_OS
;
825 if (gfc_next_ascii_char () == '.')
827 /* Matched ".eqv.". */
828 *result
= INTRINSIC_EQV
;
836 ch
= gfc_next_ascii_char ();
839 if (gfc_next_ascii_char () == '.')
841 /* Matched ".ge.". */
842 *result
= INTRINSIC_GE_OS
;
848 if (gfc_next_ascii_char () == '.')
850 /* Matched ".gt.". */
851 *result
= INTRINSIC_GT_OS
;
858 ch
= gfc_next_ascii_char ();
861 if (gfc_next_ascii_char () == '.')
863 /* Matched ".le.". */
864 *result
= INTRINSIC_LE_OS
;
870 if (gfc_next_ascii_char () == '.')
872 /* Matched ".lt.". */
873 *result
= INTRINSIC_LT_OS
;
880 ch
= gfc_next_ascii_char ();
883 ch
= gfc_next_ascii_char ();
886 /* Matched ".ne.". */
887 *result
= INTRINSIC_NE_OS
;
892 if (gfc_next_ascii_char () == 'v'
893 && gfc_next_ascii_char () == '.')
895 /* Matched ".neqv.". */
896 *result
= INTRINSIC_NEQV
;
903 if (gfc_next_ascii_char () == 't'
904 && gfc_next_ascii_char () == '.')
906 /* Matched ".not.". */
907 *result
= INTRINSIC_NOT
;
914 if (gfc_next_ascii_char () == 'r'
915 && gfc_next_ascii_char () == '.')
917 /* Matched ".or.". */
918 *result
= INTRINSIC_OR
;
932 gfc_current_locus
= orig_loc
;
937 /* Match a loop control phrase:
939 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
941 If the final integer expression is not present, a constant unity
942 expression is returned. We don't return MATCH_ERROR until after
943 the equals sign is seen. */
946 gfc_match_iterator (gfc_iterator
*iter
, int init_flag
)
948 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
949 gfc_expr
*var
, *e1
, *e2
, *e3
;
955 /* Match the start of an iterator without affecting the symbol table. */
957 start
= gfc_current_locus
;
958 m
= gfc_match (" %n =", name
);
959 gfc_current_locus
= start
;
964 m
= gfc_match_variable (&var
, 0);
968 /* F2008, C617 & C565. */
969 if (var
->symtree
->n
.sym
->attr
.codimension
)
971 gfc_error ("Loop variable at %C cannot be a coarray");
975 if (var
->ref
!= NULL
)
977 gfc_error ("Loop variable at %C cannot be a sub-component");
981 if (var
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
983 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
984 var
->symtree
->n
.sym
->name
);
988 gfc_match_char ('=');
990 var
->symtree
->n
.sym
->attr
.implied_index
= 1;
992 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
995 if (m
== MATCH_ERROR
)
998 if (gfc_match_char (',') != MATCH_YES
)
1001 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
1004 if (m
== MATCH_ERROR
)
1007 if (gfc_match_char (',') != MATCH_YES
)
1009 e3
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1013 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
1014 if (m
== MATCH_ERROR
)
1018 gfc_error ("Expected a step value in iterator at %C");
1030 gfc_error ("Syntax error in iterator at %C");
1041 /* Tries to match the next non-whitespace character on the input.
1042 This subroutine does not return MATCH_ERROR. */
1045 gfc_match_char (char c
)
1049 where
= gfc_current_locus
;
1050 gfc_gobble_whitespace ();
1052 if (gfc_next_ascii_char () == c
)
1055 gfc_current_locus
= where
;
1060 /* General purpose matching subroutine. The target string is a
1061 scanf-like format string in which spaces correspond to arbitrary
1062 whitespace (including no whitespace), characters correspond to
1063 themselves. The %-codes are:
1065 %% Literal percent sign
1066 %e Expression, pointer to a pointer is set
1067 %s Symbol, pointer to the symbol is set
1068 %n Name, character buffer is set to name
1069 %t Matches end of statement.
1070 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1071 %l Matches a statement label
1072 %v Matches a variable expression (an lvalue)
1073 % Matches a required space (in free form) and optional spaces. */
1076 gfc_match (const char *target
, ...)
1078 gfc_st_label
**label
;
1087 old_loc
= gfc_current_locus
;
1088 va_start (argp
, target
);
1098 gfc_gobble_whitespace ();
1109 vp
= va_arg (argp
, void **);
1110 n
= gfc_match_expr ((gfc_expr
**) vp
);
1121 vp
= va_arg (argp
, void **);
1122 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
1133 vp
= va_arg (argp
, void **);
1134 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
1145 np
= va_arg (argp
, char *);
1146 n
= gfc_match_name (np
);
1157 label
= va_arg (argp
, gfc_st_label
**);
1158 n
= gfc_match_st_label (label
);
1169 ip
= va_arg (argp
, int *);
1170 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
1181 if (gfc_match_eos () != MATCH_YES
)
1189 if (gfc_match_space () == MATCH_YES
)
1195 break; /* Fall through to character matcher. */
1198 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
1203 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1204 expect an upper case character here! */
1205 gcc_assert (TOLOWER (c
) == c
);
1207 if (c
== gfc_next_ascii_char ())
1217 /* Clean up after a failed match. */
1218 gfc_current_locus
= old_loc
;
1219 va_start (argp
, target
);
1222 for (; matches
> 0; matches
--)
1224 while (*p
++ != '%');
1232 /* Matches that don't have to be undone */
1237 (void) va_arg (argp
, void **);
1242 vp
= va_arg (argp
, void **);
1243 gfc_free_expr ((struct gfc_expr
*)*vp
);
1256 /*********************** Statement level matching **********************/
1258 /* Matches the start of a program unit, which is the program keyword
1259 followed by an obligatory symbol. */
1262 gfc_match_program (void)
1267 m
= gfc_match ("% %s%t", &sym
);
1271 gfc_error ("Invalid form of PROGRAM statement at %C");
1275 if (m
== MATCH_ERROR
)
1278 if (gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
) == FAILURE
)
1281 gfc_new_block
= sym
;
1287 /* Match a simple assignment statement. */
1290 gfc_match_assignment (void)
1292 gfc_expr
*lvalue
, *rvalue
;
1296 old_loc
= gfc_current_locus
;
1299 m
= gfc_match (" %v =", &lvalue
);
1302 gfc_current_locus
= old_loc
;
1303 gfc_free_expr (lvalue
);
1308 m
= gfc_match (" %e%t", &rvalue
);
1311 gfc_current_locus
= old_loc
;
1312 gfc_free_expr (lvalue
);
1313 gfc_free_expr (rvalue
);
1317 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1319 new_st
.op
= EXEC_ASSIGN
;
1320 new_st
.expr1
= lvalue
;
1321 new_st
.expr2
= rvalue
;
1323 gfc_check_do_variable (lvalue
->symtree
);
1329 /* Match a pointer assignment statement. */
1332 gfc_match_pointer_assignment (void)
1334 gfc_expr
*lvalue
, *rvalue
;
1338 old_loc
= gfc_current_locus
;
1340 lvalue
= rvalue
= NULL
;
1341 gfc_matching_procptr_assignment
= 0;
1343 m
= gfc_match (" %v =>", &lvalue
);
1350 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1351 || gfc_is_proc_ptr_comp (lvalue
, NULL
))
1352 gfc_matching_procptr_assignment
= 1;
1354 m
= gfc_match (" %e%t", &rvalue
);
1355 gfc_matching_procptr_assignment
= 0;
1359 new_st
.op
= EXEC_POINTER_ASSIGN
;
1360 new_st
.expr1
= lvalue
;
1361 new_st
.expr2
= rvalue
;
1366 gfc_current_locus
= old_loc
;
1367 gfc_free_expr (lvalue
);
1368 gfc_free_expr (rvalue
);
1373 /* We try to match an easy arithmetic IF statement. This only happens
1374 when just after having encountered a simple IF statement. This code
1375 is really duplicate with parts of the gfc_match_if code, but this is
1379 match_arithmetic_if (void)
1381 gfc_st_label
*l1
, *l2
, *l3
;
1385 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1389 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
1390 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
1391 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
1393 gfc_free_expr (expr
);
1397 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: Arithmetic IF "
1398 "statement at %C") == FAILURE
)
1401 new_st
.op
= EXEC_ARITHMETIC_IF
;
1402 new_st
.expr1
= expr
;
1411 /* The IF statement is a bit of a pain. First of all, there are three
1412 forms of it, the simple IF, the IF that starts a block and the
1415 There is a problem with the simple IF and that is the fact that we
1416 only have a single level of undo information on symbols. What this
1417 means is for a simple IF, we must re-match the whole IF statement
1418 multiple times in order to guarantee that the symbol table ends up
1419 in the proper state. */
1421 static match
match_simple_forall (void);
1422 static match
match_simple_where (void);
1425 gfc_match_if (gfc_statement
*if_type
)
1428 gfc_st_label
*l1
, *l2
, *l3
;
1429 locus old_loc
, old_loc2
;
1433 n
= gfc_match_label ();
1434 if (n
== MATCH_ERROR
)
1437 old_loc
= gfc_current_locus
;
1439 m
= gfc_match (" if ( %e", &expr
);
1443 old_loc2
= gfc_current_locus
;
1444 gfc_current_locus
= old_loc
;
1446 if (gfc_match_parens () == MATCH_ERROR
)
1449 gfc_current_locus
= old_loc2
;
1451 if (gfc_match_char (')') != MATCH_YES
)
1453 gfc_error ("Syntax error in IF-expression at %C");
1454 gfc_free_expr (expr
);
1458 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1464 gfc_error ("Block label not appropriate for arithmetic IF "
1466 gfc_free_expr (expr
);
1470 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
1471 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
1472 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
1474 gfc_free_expr (expr
);
1478 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: Arithmetic IF "
1479 "statement at %C") == FAILURE
)
1482 new_st
.op
= EXEC_ARITHMETIC_IF
;
1483 new_st
.expr1
= expr
;
1488 *if_type
= ST_ARITHMETIC_IF
;
1492 if (gfc_match (" then%t") == MATCH_YES
)
1494 new_st
.op
= EXEC_IF
;
1495 new_st
.expr1
= expr
;
1496 *if_type
= ST_IF_BLOCK
;
1502 gfc_error ("Block label is not appropriate for IF statement at %C");
1503 gfc_free_expr (expr
);
1507 /* At this point the only thing left is a simple IF statement. At
1508 this point, n has to be MATCH_NO, so we don't have to worry about
1509 re-matching a block label. From what we've got so far, try
1510 matching an assignment. */
1512 *if_type
= ST_SIMPLE_IF
;
1514 m
= gfc_match_assignment ();
1518 gfc_free_expr (expr
);
1519 gfc_undo_symbols ();
1520 gfc_current_locus
= old_loc
;
1522 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1523 assignment was found. For MATCH_NO, continue to call the various
1525 if (m
== MATCH_ERROR
)
1528 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1530 m
= gfc_match_pointer_assignment ();
1534 gfc_free_expr (expr
);
1535 gfc_undo_symbols ();
1536 gfc_current_locus
= old_loc
;
1538 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1540 /* Look at the next keyword to see which matcher to call. Matching
1541 the keyword doesn't affect the symbol table, so we don't have to
1542 restore between tries. */
1544 #define match(string, subr, statement) \
1545 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1549 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1550 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1551 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1552 match ("call", gfc_match_call
, ST_CALL
)
1553 match ("close", gfc_match_close
, ST_CLOSE
)
1554 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1555 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1556 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1557 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1558 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
)
1559 match ("exit", gfc_match_exit
, ST_EXIT
)
1560 match ("flush", gfc_match_flush
, ST_FLUSH
)
1561 match ("forall", match_simple_forall
, ST_FORALL
)
1562 match ("go to", gfc_match_goto
, ST_GOTO
)
1563 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1564 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1565 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1566 match ("open", gfc_match_open
, ST_OPEN
)
1567 match ("pause", gfc_match_pause
, ST_NONE
)
1568 match ("print", gfc_match_print
, ST_WRITE
)
1569 match ("read", gfc_match_read
, ST_READ
)
1570 match ("return", gfc_match_return
, ST_RETURN
)
1571 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1572 match ("stop", gfc_match_stop
, ST_STOP
)
1573 match ("wait", gfc_match_wait
, ST_WAIT
)
1574 match ("sync all", gfc_match_sync_all
, ST_SYNC_CALL
);
1575 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
1576 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
1577 match ("where", match_simple_where
, ST_WHERE
)
1578 match ("write", gfc_match_write
, ST_WRITE
)
1580 /* The gfc_match_assignment() above may have returned a MATCH_NO
1581 where the assignment was to a named constant. Check that
1582 special case here. */
1583 m
= gfc_match_assignment ();
1586 gfc_error ("Cannot assign to a named constant at %C");
1587 gfc_free_expr (expr
);
1588 gfc_undo_symbols ();
1589 gfc_current_locus
= old_loc
;
1593 /* All else has failed, so give up. See if any of the matchers has
1594 stored an error message of some sort. */
1595 if (gfc_error_check () == 0)
1596 gfc_error ("Unclassifiable statement in IF-clause at %C");
1598 gfc_free_expr (expr
);
1603 gfc_error ("Syntax error in IF-clause at %C");
1606 gfc_free_expr (expr
);
1610 /* At this point, we've matched the single IF and the action clause
1611 is in new_st. Rearrange things so that the IF statement appears
1614 p
= gfc_get_code ();
1615 p
->next
= gfc_get_code ();
1617 p
->next
->loc
= gfc_current_locus
;
1622 gfc_clear_new_st ();
1624 new_st
.op
= EXEC_IF
;
1633 /* Match an ELSE statement. */
1636 gfc_match_else (void)
1638 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1640 if (gfc_match_eos () == MATCH_YES
)
1643 if (gfc_match_name (name
) != MATCH_YES
1644 || gfc_current_block () == NULL
1645 || gfc_match_eos () != MATCH_YES
)
1647 gfc_error ("Unexpected junk after ELSE statement at %C");
1651 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1653 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1654 name
, gfc_current_block ()->name
);
1662 /* Match an ELSE IF statement. */
1665 gfc_match_elseif (void)
1667 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1671 m
= gfc_match (" ( %e ) then", &expr
);
1675 if (gfc_match_eos () == MATCH_YES
)
1678 if (gfc_match_name (name
) != MATCH_YES
1679 || gfc_current_block () == NULL
1680 || gfc_match_eos () != MATCH_YES
)
1682 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1686 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1688 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1689 name
, gfc_current_block ()->name
);
1694 new_st
.op
= EXEC_IF
;
1695 new_st
.expr1
= expr
;
1699 gfc_free_expr (expr
);
1704 /* Free a gfc_iterator structure. */
1707 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1713 gfc_free_expr (iter
->var
);
1714 gfc_free_expr (iter
->start
);
1715 gfc_free_expr (iter
->end
);
1716 gfc_free_expr (iter
->step
);
1723 /* Match a CRITICAL statement. */
1725 gfc_match_critical (void)
1727 gfc_st_label
*label
= NULL
;
1729 if (gfc_match_label () == MATCH_ERROR
)
1732 if (gfc_match (" critical") != MATCH_YES
)
1735 if (gfc_match_st_label (&label
) == MATCH_ERROR
)
1738 if (gfc_match_eos () != MATCH_YES
)
1740 gfc_syntax_error (ST_CRITICAL
);
1744 if (gfc_pure (NULL
))
1746 gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
1750 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: CRITICAL statement at %C")
1754 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
1756 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
1760 if (gfc_find_state (COMP_CRITICAL
) == SUCCESS
)
1762 gfc_error ("Nested CRITICAL block at %C");
1766 new_st
.op
= EXEC_CRITICAL
;
1769 && gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1776 /* Match a BLOCK statement. */
1779 gfc_match_block (void)
1783 if (gfc_match_label () == MATCH_ERROR
)
1786 if (gfc_match (" block") != MATCH_YES
)
1789 /* For this to be a correct BLOCK statement, the line must end now. */
1790 m
= gfc_match_eos ();
1791 if (m
== MATCH_ERROR
)
1800 /* Match an ASSOCIATE statement. */
1803 gfc_match_associate (void)
1805 if (gfc_match_label () == MATCH_ERROR
)
1808 if (gfc_match (" associate") != MATCH_YES
)
1811 /* Match the association list. */
1812 if (gfc_match_char ('(') != MATCH_YES
)
1814 gfc_error ("Expected association list at %C");
1817 new_st
.ext
.block
.assoc
= NULL
;
1820 gfc_association_list
* newAssoc
= gfc_get_association_list ();
1821 gfc_association_list
* a
;
1823 /* Match the next association. */
1824 if (gfc_match (" %n => %e", newAssoc
->name
, &newAssoc
->target
)
1827 gfc_error ("Expected association at %C");
1828 goto assocListError
;
1831 /* Check that the current name is not yet in the list. */
1832 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
1833 if (!strcmp (a
->name
, newAssoc
->name
))
1835 gfc_error ("Duplicate name '%s' in association at %C",
1837 goto assocListError
;
1840 /* The target expression must not be coindexed. */
1841 if (gfc_is_coindexed (newAssoc
->target
))
1843 gfc_error ("Association target at %C must not be coindexed");
1844 goto assocListError
;
1847 /* The target is a variable (and may be used as lvalue) if it's an
1848 EXPR_VARIABLE and does not have vector-subscripts. */
1849 newAssoc
->variable
= (newAssoc
->target
->expr_type
== EXPR_VARIABLE
1850 && !gfc_has_vector_subscript (newAssoc
->target
));
1852 /* Put it into the list. */
1853 newAssoc
->next
= new_st
.ext
.block
.assoc
;
1854 new_st
.ext
.block
.assoc
= newAssoc
;
1856 /* Try next one or end if closing parenthesis is found. */
1857 gfc_gobble_whitespace ();
1858 if (gfc_peek_char () == ')')
1860 if (gfc_match_char (',') != MATCH_YES
)
1862 gfc_error ("Expected ')' or ',' at %C");
1869 gfc_free (newAssoc
);
1872 if (gfc_match_char (')') != MATCH_YES
)
1874 /* This should never happen as we peek above. */
1878 if (gfc_match_eos () != MATCH_YES
)
1880 gfc_error ("Junk after ASSOCIATE statement at %C");
1887 gfc_free_association_list (new_st
.ext
.block
.assoc
);
1892 /* Match a DO statement. */
1897 gfc_iterator iter
, *ip
;
1899 gfc_st_label
*label
;
1902 old_loc
= gfc_current_locus
;
1905 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
1907 m
= gfc_match_label ();
1908 if (m
== MATCH_ERROR
)
1911 if (gfc_match (" do") != MATCH_YES
)
1914 m
= gfc_match_st_label (&label
);
1915 if (m
== MATCH_ERROR
)
1918 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
1920 if (gfc_match_eos () == MATCH_YES
)
1922 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
1923 new_st
.op
= EXEC_DO_WHILE
;
1927 /* Match an optional comma, if no comma is found, a space is obligatory. */
1928 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
1931 /* Check for balanced parens. */
1933 if (gfc_match_parens () == MATCH_ERROR
)
1936 /* See if we have a DO WHILE. */
1937 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
1939 new_st
.op
= EXEC_DO_WHILE
;
1943 /* The abortive DO WHILE may have done something to the symbol
1944 table, so we start over. */
1945 gfc_undo_symbols ();
1946 gfc_current_locus
= old_loc
;
1948 gfc_match_label (); /* This won't error. */
1949 gfc_match (" do "); /* This will work. */
1951 gfc_match_st_label (&label
); /* Can't error out. */
1952 gfc_match_char (','); /* Optional comma. */
1954 m
= gfc_match_iterator (&iter
, 0);
1957 if (m
== MATCH_ERROR
)
1960 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
1961 gfc_check_do_variable (iter
.var
->symtree
);
1963 if (gfc_match_eos () != MATCH_YES
)
1965 gfc_syntax_error (ST_DO
);
1969 new_st
.op
= EXEC_DO
;
1973 && gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1976 new_st
.label1
= label
;
1978 if (new_st
.op
== EXEC_DO_WHILE
)
1979 new_st
.expr1
= iter
.end
;
1982 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
1989 gfc_free_iterator (&iter
, 0);
1995 /* Match an EXIT or CYCLE statement. */
1998 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2000 gfc_state_data
*p
, *o
;
2004 if (gfc_match_eos () == MATCH_YES
)
2008 m
= gfc_match ("% %s%t", &sym
);
2009 if (m
== MATCH_ERROR
)
2013 gfc_syntax_error (st
);
2017 if (sym
->attr
.flavor
!= FL_LABEL
)
2019 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
2020 sym
->name
, gfc_ascii_statement (st
));
2025 /* Find the loop mentioned specified by the label (or lack of a label). */
2026 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2027 if (p
->state
== COMP_DO
&& (sym
== NULL
|| sym
== p
->sym
))
2029 else if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2031 else if (p
->state
== COMP_CRITICAL
)
2033 gfc_error("%s statement at %C leaves CRITICAL construct",
2034 gfc_ascii_statement (st
));
2041 gfc_error ("%s statement at %C is not within a loop",
2042 gfc_ascii_statement (st
));
2044 gfc_error ("%s statement at %C is not within loop '%s'",
2045 gfc_ascii_statement (st
), sym
->name
);
2052 gfc_error ("%s statement at %C leaving OpenMP structured block",
2053 gfc_ascii_statement (st
));
2056 else if (st
== ST_EXIT
2057 && p
->previous
!= NULL
2058 && p
->previous
->state
== COMP_OMP_STRUCTURED_BLOCK
2059 && (p
->previous
->head
->op
== EXEC_OMP_DO
2060 || p
->previous
->head
->op
== EXEC_OMP_PARALLEL_DO
))
2062 gcc_assert (p
->previous
->head
->next
!= NULL
);
2063 gcc_assert (p
->previous
->head
->next
->op
== EXEC_DO
2064 || p
->previous
->head
->next
->op
== EXEC_DO_WHILE
);
2065 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2069 /* Save the first statement in the loop - needed by the backend. */
2070 new_st
.ext
.whichloop
= p
->head
;
2078 /* Match the EXIT statement. */
2081 gfc_match_exit (void)
2083 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2087 /* Match the CYCLE statement. */
2090 gfc_match_cycle (void)
2092 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2096 /* Match a number or character constant after an (ALL) STOP or PAUSE statement. */
2099 gfc_match_stopcode (gfc_statement st
)
2106 if (gfc_match_eos () != MATCH_YES
)
2108 m
= gfc_match_init_expr (&e
);
2109 if (m
== MATCH_ERROR
)
2114 if (gfc_match_eos () != MATCH_YES
)
2118 if (gfc_pure (NULL
))
2120 gfc_error ("%s statement not allowed in PURE procedure at %C",
2121 gfc_ascii_statement (st
));
2125 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
) == SUCCESS
)
2127 gfc_error ("Image control statement STOP at %C in CRITICAL block");
2133 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
2135 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2142 gfc_error ("STOP code at %L must be scalar",
2147 if (e
->ts
.type
== BT_CHARACTER
2148 && e
->ts
.kind
!= gfc_default_character_kind
)
2150 gfc_error ("STOP code at %L must be default character KIND=%d",
2151 &e
->where
, (int) gfc_default_character_kind
);
2155 if (e
->ts
.type
== BT_INTEGER
2156 && e
->ts
.kind
!= gfc_default_integer_kind
)
2158 gfc_error ("STOP code at %L must be default integer KIND=%d",
2159 &e
->where
, (int) gfc_default_integer_kind
);
2167 new_st
.op
= EXEC_STOP
;
2170 new_st
.op
= EXEC_ERROR_STOP
;
2173 new_st
.op
= EXEC_PAUSE
;
2180 new_st
.ext
.stop_code
= -1;
2185 gfc_syntax_error (st
);
2194 /* Match the (deprecated) PAUSE statement. */
2197 gfc_match_pause (void)
2201 m
= gfc_match_stopcode (ST_PAUSE
);
2204 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: PAUSE statement"
2213 /* Match the STOP statement. */
2216 gfc_match_stop (void)
2218 return gfc_match_stopcode (ST_STOP
);
2222 /* Match the ERROR STOP statement. */
2225 gfc_match_error_stop (void)
2227 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: ERROR STOP statement at %C")
2231 return gfc_match_stopcode (ST_ERROR_STOP
);
2235 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
2236 SYNC ALL [(sync-stat-list)]
2237 SYNC MEMORY [(sync-stat-list)]
2238 SYNC IMAGES (image-set [, sync-stat-list] )
2239 with sync-stat is int-expr or *. */
2242 sync_statement (gfc_statement st
)
2245 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
2246 bool saw_stat
, saw_errmsg
;
2248 tmp
= imageset
= stat
= errmsg
= NULL
;
2249 saw_stat
= saw_errmsg
= false;
2251 if (gfc_pure (NULL
))
2253 gfc_error ("Image control statement SYNC at %C in PURE procedure");
2257 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: SYNC statement at %C")
2261 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
2263 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2267 if (gfc_find_state (COMP_CRITICAL
) == SUCCESS
)
2269 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
2273 if (gfc_match_eos () == MATCH_YES
)
2275 if (st
== ST_SYNC_IMAGES
)
2280 if (gfc_match_char ('(') != MATCH_YES
)
2283 if (st
== ST_SYNC_IMAGES
)
2285 /* Denote '*' as imageset == NULL. */
2286 m
= gfc_match_char ('*');
2287 if (m
== MATCH_ERROR
)
2291 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
2294 m
= gfc_match_char (',');
2295 if (m
== MATCH_ERROR
)
2299 m
= gfc_match_char (')');
2308 m
= gfc_match (" stat = %v", &tmp
);
2309 if (m
== MATCH_ERROR
)
2315 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
2321 if (gfc_match_char (',') == MATCH_YES
)
2325 m
= gfc_match (" errmsg = %v", &tmp
);
2326 if (m
== MATCH_ERROR
)
2332 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
2338 if (gfc_match_char (',') == MATCH_YES
)
2342 gfc_gobble_whitespace ();
2344 if (gfc_peek_char () == ')')
2350 if (gfc_match (" )%t") != MATCH_YES
)
2357 new_st
.op
= EXEC_SYNC_ALL
;
2359 case ST_SYNC_IMAGES
:
2360 new_st
.op
= EXEC_SYNC_IMAGES
;
2362 case ST_SYNC_MEMORY
:
2363 new_st
.op
= EXEC_SYNC_MEMORY
;
2369 new_st
.expr1
= imageset
;
2370 new_st
.expr2
= stat
;
2371 new_st
.expr3
= errmsg
;
2376 gfc_syntax_error (st
);
2379 gfc_free_expr (tmp
);
2380 gfc_free_expr (imageset
);
2381 gfc_free_expr (stat
);
2382 gfc_free_expr (errmsg
);
2388 /* Match SYNC ALL statement. */
2391 gfc_match_sync_all (void)
2393 return sync_statement (ST_SYNC_ALL
);
2397 /* Match SYNC IMAGES statement. */
2400 gfc_match_sync_images (void)
2402 return sync_statement (ST_SYNC_IMAGES
);
2406 /* Match SYNC MEMORY statement. */
2409 gfc_match_sync_memory (void)
2411 return sync_statement (ST_SYNC_MEMORY
);
2415 /* Match a CONTINUE statement. */
2418 gfc_match_continue (void)
2420 if (gfc_match_eos () != MATCH_YES
)
2422 gfc_syntax_error (ST_CONTINUE
);
2426 new_st
.op
= EXEC_CONTINUE
;
2431 /* Match the (deprecated) ASSIGN statement. */
2434 gfc_match_assign (void)
2437 gfc_st_label
*label
;
2439 if (gfc_match (" %l", &label
) == MATCH_YES
)
2441 if (gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
) == FAILURE
)
2443 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
2445 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: ASSIGN "
2450 expr
->symtree
->n
.sym
->attr
.assign
= 1;
2452 new_st
.op
= EXEC_LABEL_ASSIGN
;
2453 new_st
.label1
= label
;
2454 new_st
.expr1
= expr
;
2462 /* Match the GO TO statement. As a computed GOTO statement is
2463 matched, it is transformed into an equivalent SELECT block. No
2464 tree is necessary, and the resulting jumps-to-jumps are
2465 specifically optimized away by the back end. */
2468 gfc_match_goto (void)
2470 gfc_code
*head
, *tail
;
2473 gfc_st_label
*label
;
2477 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
2479 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2482 new_st
.op
= EXEC_GOTO
;
2483 new_st
.label1
= label
;
2487 /* The assigned GO TO statement. */
2489 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
2491 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: Assigned GOTO "
2496 new_st
.op
= EXEC_GOTO
;
2497 new_st
.expr1
= expr
;
2499 if (gfc_match_eos () == MATCH_YES
)
2502 /* Match label list. */
2503 gfc_match_char (',');
2504 if (gfc_match_char ('(') != MATCH_YES
)
2506 gfc_syntax_error (ST_GOTO
);
2513 m
= gfc_match_st_label (&label
);
2517 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2521 head
= tail
= gfc_get_code ();
2524 tail
->block
= gfc_get_code ();
2528 tail
->label1
= label
;
2529 tail
->op
= EXEC_GOTO
;
2531 while (gfc_match_char (',') == MATCH_YES
);
2533 if (gfc_match (")%t") != MATCH_YES
)
2538 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2541 new_st
.block
= head
;
2546 /* Last chance is a computed GO TO statement. */
2547 if (gfc_match_char ('(') != MATCH_YES
)
2549 gfc_syntax_error (ST_GOTO
);
2558 m
= gfc_match_st_label (&label
);
2562 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2566 head
= tail
= gfc_get_code ();
2569 tail
->block
= gfc_get_code ();
2573 cp
= gfc_get_case ();
2574 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
2577 tail
->op
= EXEC_SELECT
;
2578 tail
->ext
.case_list
= cp
;
2580 tail
->next
= gfc_get_code ();
2581 tail
->next
->op
= EXEC_GOTO
;
2582 tail
->next
->label1
= label
;
2584 while (gfc_match_char (',') == MATCH_YES
);
2586 if (gfc_match_char (')') != MATCH_YES
)
2591 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2595 /* Get the rest of the statement. */
2596 gfc_match_char (',');
2598 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
2601 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: Computed GOTO "
2602 "at %C") == FAILURE
)
2605 /* At this point, a computed GOTO has been fully matched and an
2606 equivalent SELECT statement constructed. */
2608 new_st
.op
= EXEC_SELECT
;
2609 new_st
.expr1
= NULL
;
2611 /* Hack: For a "real" SELECT, the expression is in expr. We put
2612 it in expr2 so we can distinguish then and produce the correct
2614 new_st
.expr2
= expr
;
2615 new_st
.block
= head
;
2619 gfc_syntax_error (ST_GOTO
);
2621 gfc_free_statements (head
);
2626 /* Frees a list of gfc_alloc structures. */
2629 gfc_free_alloc_list (gfc_alloc
*p
)
2636 gfc_free_expr (p
->expr
);
2642 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
2643 an accessible derived type. */
2646 match_derived_type_spec (gfc_typespec
*ts
)
2649 gfc_symbol
*derived
;
2651 old_locus
= gfc_current_locus
;
2653 if (gfc_match_symbol (&derived
, 1) == MATCH_YES
)
2655 if (derived
->attr
.flavor
== FL_DERIVED
)
2657 ts
->type
= BT_DERIVED
;
2658 ts
->u
.derived
= derived
;
2663 /* Enforce F03:C476. */
2664 gfc_error ("'%s' at %L is not an accessible derived type",
2665 derived
->name
, &gfc_current_locus
);
2670 gfc_current_locus
= old_locus
;
2675 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2676 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2677 It only includes the intrinsic types from the Fortran 2003 standard
2678 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2679 the implicit_flag is not needed, so it was removed. Derived types are
2680 identified by their name alone. */
2683 match_type_spec (gfc_typespec
*ts
)
2689 old_locus
= gfc_current_locus
;
2691 if (gfc_match ("integer") == MATCH_YES
)
2693 ts
->type
= BT_INTEGER
;
2694 ts
->kind
= gfc_default_integer_kind
;
2698 if (gfc_match ("real") == MATCH_YES
)
2701 ts
->kind
= gfc_default_real_kind
;
2705 if (gfc_match ("double precision") == MATCH_YES
)
2708 ts
->kind
= gfc_default_double_kind
;
2712 if (gfc_match ("complex") == MATCH_YES
)
2714 ts
->type
= BT_COMPLEX
;
2715 ts
->kind
= gfc_default_complex_kind
;
2719 if (gfc_match ("character") == MATCH_YES
)
2721 ts
->type
= BT_CHARACTER
;
2725 if (gfc_match ("logical") == MATCH_YES
)
2727 ts
->type
= BT_LOGICAL
;
2728 ts
->kind
= gfc_default_logical_kind
;
2732 m
= match_derived_type_spec (ts
);
2735 old_locus
= gfc_current_locus
;
2736 if (gfc_match (" :: ") != MATCH_YES
)
2738 gfc_current_locus
= old_locus
;
2739 /* Enfore F03:C401. */
2740 if (ts
->u
.derived
->attr
.abstract
)
2742 gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
2743 ts
->u
.derived
->name
, &old_locus
);
2748 else if (m
== MATCH_ERROR
&& gfc_match (" :: ") == MATCH_YES
)
2751 /* If a type is not matched, simply return MATCH_NO. */
2752 gfc_current_locus
= old_locus
;
2757 gfc_gobble_whitespace ();
2758 if (gfc_peek_ascii_char () == '*')
2760 gfc_error ("Invalid type-spec at %C");
2764 m
= gfc_match_kind_spec (ts
, false);
2767 m
= MATCH_YES
; /* No kind specifier found. */
2773 m
= gfc_match_char_spec (ts
);
2776 m
= MATCH_YES
; /* No kind specifier found. */
2782 /* Match an ALLOCATE statement. */
2785 gfc_match_allocate (void)
2787 gfc_alloc
*head
, *tail
;
2788 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
2793 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, b1
, b2
, b3
;
2796 stat
= errmsg
= source
= mold
= tmp
= NULL
;
2797 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= false;
2799 if (gfc_match_char ('(') != MATCH_YES
)
2802 /* Match an optional type-spec. */
2803 old_locus
= gfc_current_locus
;
2804 m
= match_type_spec (&ts
);
2805 if (m
== MATCH_ERROR
)
2807 else if (m
== MATCH_NO
)
2808 ts
.type
= BT_UNKNOWN
;
2811 if (gfc_match (" :: ") == MATCH_YES
)
2813 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: typespec in "
2814 "ALLOCATE at %L", &old_locus
) == FAILURE
)
2819 ts
.type
= BT_UNKNOWN
;
2820 gfc_current_locus
= old_locus
;
2827 head
= tail
= gfc_get_alloc ();
2830 tail
->next
= gfc_get_alloc ();
2834 m
= gfc_match_variable (&tail
->expr
, 0);
2837 if (m
== MATCH_ERROR
)
2840 if (gfc_check_do_variable (tail
->expr
->symtree
))
2843 if (gfc_pure (NULL
) && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
2845 gfc_error ("Bad allocate-object at %C for a PURE procedure");
2849 /* The ALLOCATE statement had an optional typespec. Check the
2851 if (ts
.type
!= BT_UNKNOWN
)
2853 /* Enforce F03:C624. */
2854 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
2856 gfc_error ("Type of entity at %L is type incompatible with "
2857 "typespec", &tail
->expr
->where
);
2861 /* Enforce F03:C627. */
2862 if (ts
.kind
!= tail
->expr
->ts
.kind
)
2864 gfc_error ("Kind type parameter for entity at %L differs from "
2865 "the kind type parameter of the typespec",
2866 &tail
->expr
->where
);
2871 if (tail
->expr
->ts
.type
== BT_DERIVED
)
2872 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
2874 /* FIXME: disable the checking on derived types and arrays. */
2875 sym
= tail
->expr
->symtree
->n
.sym
;
2876 b1
= !(tail
->expr
->ref
2877 && (tail
->expr
->ref
->type
== REF_COMPONENT
2878 || tail
->expr
->ref
->type
== REF_ARRAY
));
2879 if (sym
&& sym
->ts
.type
== BT_CLASS
)
2880 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
2881 || CLASS_DATA (sym
)->attr
.pointer
);
2883 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
2884 || sym
->attr
.proc_pointer
);
2885 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
2886 && (sym
->ns
->proc_name
->attr
.allocatable
2887 || sym
->ns
->proc_name
->attr
.pointer
2888 || sym
->ns
->proc_name
->attr
.proc_pointer
);
2889 if (b1
&& b2
&& !b3
)
2891 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2892 "or an allocatable variable");
2896 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
2898 gfc_error ("Shape specification for allocatable scalar at %C");
2902 if (gfc_match_char (',') != MATCH_YES
)
2907 m
= gfc_match (" stat = %v", &tmp
);
2908 if (m
== MATCH_ERROR
)
2915 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
2922 if (gfc_check_do_variable (stat
->symtree
))
2925 if (gfc_match_char (',') == MATCH_YES
)
2926 goto alloc_opt_list
;
2929 m
= gfc_match (" errmsg = %v", &tmp
);
2930 if (m
== MATCH_ERROR
)
2934 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ERRMSG tag at %L",
2935 &tmp
->where
) == FAILURE
)
2941 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
2948 if (gfc_match_char (',') == MATCH_YES
)
2949 goto alloc_opt_list
;
2952 m
= gfc_match (" source = %e", &tmp
);
2953 if (m
== MATCH_ERROR
)
2957 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: SOURCE tag at %L",
2958 &tmp
->where
) == FAILURE
)
2964 gfc_error ("Redundant SOURCE tag found at %L ", &tmp
->where
);
2968 /* The next 2 conditionals check C631. */
2969 if (ts
.type
!= BT_UNKNOWN
)
2971 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
2972 &tmp
->where
, &old_locus
);
2978 gfc_error ("SOURCE tag at %L requires only a single entity in "
2979 "the allocation-list", &tmp
->where
);
2986 if (gfc_match_char (',') == MATCH_YES
)
2987 goto alloc_opt_list
;
2990 m
= gfc_match (" mold = %e", &tmp
);
2991 if (m
== MATCH_ERROR
)
2995 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: MOLD tag at %L",
2996 &tmp
->where
) == FAILURE
)
2999 /* Check F08:C636. */
3002 gfc_error ("Redundant MOLD tag found at %L ", &tmp
->where
);
3006 /* Check F08:C637. */
3007 if (ts
.type
!= BT_UNKNOWN
)
3009 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
3010 &tmp
->where
, &old_locus
);
3018 if (gfc_match_char (',') == MATCH_YES
)
3019 goto alloc_opt_list
;
3022 gfc_gobble_whitespace ();
3024 if (gfc_peek_char () == ')')
3029 if (gfc_match (" )%t") != MATCH_YES
)
3032 /* Check F08:C637. */
3035 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
3036 &mold
->where
, &source
->where
);
3040 new_st
.op
= EXEC_ALLOCATE
;
3041 new_st
.expr1
= stat
;
3042 new_st
.expr2
= errmsg
;
3044 new_st
.expr3
= source
;
3046 new_st
.expr3
= mold
;
3047 new_st
.ext
.alloc
.list
= head
;
3048 new_st
.ext
.alloc
.ts
= ts
;
3053 gfc_syntax_error (ST_ALLOCATE
);
3056 gfc_free_expr (errmsg
);
3057 gfc_free_expr (source
);
3058 gfc_free_expr (stat
);
3059 gfc_free_expr (mold
);
3060 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
3061 gfc_free_alloc_list (head
);
3066 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
3067 a set of pointer assignments to intrinsic NULL(). */
3070 gfc_match_nullify (void)
3078 if (gfc_match_char ('(') != MATCH_YES
)
3083 m
= gfc_match_variable (&p
, 0);
3084 if (m
== MATCH_ERROR
)
3089 if (gfc_check_do_variable (p
->symtree
))
3092 if (gfc_pure (NULL
) && gfc_impure_variable (p
->symtree
->n
.sym
))
3094 gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
3098 /* build ' => NULL() '. */
3099 e
= gfc_get_null_expr (&gfc_current_locus
);
3101 /* Chain to list. */
3106 tail
->next
= gfc_get_code ();
3110 tail
->op
= EXEC_POINTER_ASSIGN
;
3114 if (gfc_match (" )%t") == MATCH_YES
)
3116 if (gfc_match_char (',') != MATCH_YES
)
3123 gfc_syntax_error (ST_NULLIFY
);
3126 gfc_free_statements (new_st
.next
);
3128 gfc_free_expr (new_st
.expr1
);
3129 new_st
.expr1
= NULL
;
3130 gfc_free_expr (new_st
.expr2
);
3131 new_st
.expr2
= NULL
;
3136 /* Match a DEALLOCATE statement. */
3139 gfc_match_deallocate (void)
3141 gfc_alloc
*head
, *tail
;
3142 gfc_expr
*stat
, *errmsg
, *tmp
;
3145 bool saw_stat
, saw_errmsg
, b1
, b2
;
3148 stat
= errmsg
= tmp
= NULL
;
3149 saw_stat
= saw_errmsg
= false;
3151 if (gfc_match_char ('(') != MATCH_YES
)
3157 head
= tail
= gfc_get_alloc ();
3160 tail
->next
= gfc_get_alloc ();
3164 m
= gfc_match_variable (&tail
->expr
, 0);
3165 if (m
== MATCH_ERROR
)
3170 if (gfc_check_do_variable (tail
->expr
->symtree
))
3173 sym
= tail
->expr
->symtree
->n
.sym
;
3175 if (gfc_pure (NULL
) && gfc_impure_variable (sym
))
3177 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3181 /* FIXME: disable the checking on derived types. */
3182 b1
= !(tail
->expr
->ref
3183 && (tail
->expr
->ref
->type
== REF_COMPONENT
3184 || tail
->expr
->ref
->type
== REF_ARRAY
));
3185 if (sym
&& sym
->ts
.type
== BT_CLASS
)
3186 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
3187 || CLASS_DATA (sym
)->attr
.pointer
);
3189 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
3190 || sym
->attr
.proc_pointer
);
3193 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3194 "or an allocatable variable");
3198 if (gfc_match_char (',') != MATCH_YES
)
3203 m
= gfc_match (" stat = %v", &tmp
);
3204 if (m
== MATCH_ERROR
)
3210 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3211 gfc_free_expr (tmp
);
3218 if (gfc_check_do_variable (stat
->symtree
))
3221 if (gfc_match_char (',') == MATCH_YES
)
3222 goto dealloc_opt_list
;
3225 m
= gfc_match (" errmsg = %v", &tmp
);
3226 if (m
== MATCH_ERROR
)
3230 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ERRMSG at %L",
3231 &tmp
->where
) == FAILURE
)
3236 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3237 gfc_free_expr (tmp
);
3244 if (gfc_match_char (',') == MATCH_YES
)
3245 goto dealloc_opt_list
;
3248 gfc_gobble_whitespace ();
3250 if (gfc_peek_char () == ')')
3254 if (gfc_match (" )%t") != MATCH_YES
)
3257 new_st
.op
= EXEC_DEALLOCATE
;
3258 new_st
.expr1
= stat
;
3259 new_st
.expr2
= errmsg
;
3260 new_st
.ext
.alloc
.list
= head
;
3265 gfc_syntax_error (ST_DEALLOCATE
);
3268 gfc_free_expr (errmsg
);
3269 gfc_free_expr (stat
);
3270 gfc_free_alloc_list (head
);
3275 /* Match a RETURN statement. */
3278 gfc_match_return (void)
3282 gfc_compile_state s
;
3286 if (gfc_find_state (COMP_CRITICAL
) == SUCCESS
)
3288 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
3292 if (gfc_match_eos () == MATCH_YES
)
3295 if (gfc_find_state (COMP_SUBROUTINE
) == FAILURE
)
3297 gfc_error ("Alternate RETURN statement at %C is only allowed within "
3302 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: Alternate RETURN "
3303 "at %C") == FAILURE
)
3306 if (gfc_current_form
== FORM_FREE
)
3308 /* The following are valid, so we can't require a blank after the
3312 char c
= gfc_peek_ascii_char ();
3313 if (ISALPHA (c
) || ISDIGIT (c
))
3317 m
= gfc_match (" %e%t", &e
);
3320 if (m
== MATCH_ERROR
)
3323 gfc_syntax_error (ST_RETURN
);
3330 gfc_enclosing_unit (&s
);
3331 if (s
== COMP_PROGRAM
3332 && gfc_notify_std (GFC_STD_GNU
, "Extension: RETURN statement in "
3333 "main program at %C") == FAILURE
)
3336 new_st
.op
= EXEC_RETURN
;
3343 /* Match the call of a type-bound procedure, if CALL%var has already been
3344 matched and var found to be a derived-type variable. */
3347 match_typebound_call (gfc_symtree
* varst
)
3352 base
= gfc_get_expr ();
3353 base
->expr_type
= EXPR_VARIABLE
;
3354 base
->symtree
= varst
;
3355 base
->where
= gfc_current_locus
;
3356 gfc_set_sym_referenced (varst
->n
.sym
);
3358 m
= gfc_match_varspec (base
, 0, true, true);
3360 gfc_error ("Expected component reference at %C");
3364 if (gfc_match_eos () != MATCH_YES
)
3366 gfc_error ("Junk after CALL at %C");
3370 if (base
->expr_type
== EXPR_COMPCALL
)
3371 new_st
.op
= EXEC_COMPCALL
;
3372 else if (base
->expr_type
== EXPR_PPC
)
3373 new_st
.op
= EXEC_CALL_PPC
;
3376 gfc_error ("Expected type-bound procedure or procedure pointer component "
3380 new_st
.expr1
= base
;
3386 /* Match a CALL statement. The tricky part here are possible
3387 alternate return specifiers. We handle these by having all
3388 "subroutines" actually return an integer via a register that gives
3389 the return number. If the call specifies alternate returns, we
3390 generate code for a SELECT statement whose case clauses contain
3391 GOTOs to the various labels. */
3394 gfc_match_call (void)
3396 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3397 gfc_actual_arglist
*a
, *arglist
;
3407 m
= gfc_match ("% %n", name
);
3413 if (gfc_get_ha_sym_tree (name
, &st
))
3418 /* If this is a variable of derived-type, it probably starts a type-bound
3420 if ((sym
->attr
.flavor
!= FL_PROCEDURE
3421 || gfc_is_function_return_value (sym
, gfc_current_ns
))
3422 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
3423 return match_typebound_call (st
);
3425 /* If it does not seem to be callable (include functions so that the
3426 right association is made. They are thrown out in resolution.)
3428 if (!sym
->attr
.generic
3429 && !sym
->attr
.subroutine
3430 && !sym
->attr
.function
)
3432 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
3434 /* ...create a symbol in this scope... */
3435 if (sym
->ns
!= gfc_current_ns
3436 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
3439 if (sym
!= st
->n
.sym
)
3443 /* ...and then to try to make the symbol into a subroutine. */
3444 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3448 gfc_set_sym_referenced (sym
);
3450 if (gfc_match_eos () != MATCH_YES
)
3452 m
= gfc_match_actual_arglist (1, &arglist
);
3455 if (m
== MATCH_ERROR
)
3458 if (gfc_match_eos () != MATCH_YES
)
3462 /* If any alternate return labels were found, construct a SELECT
3463 statement that will jump to the right place. */
3466 for (a
= arglist
; a
; a
= a
->next
)
3467 if (a
->expr
== NULL
)
3472 gfc_symtree
*select_st
;
3473 gfc_symbol
*select_sym
;
3474 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3476 new_st
.next
= c
= gfc_get_code ();
3477 c
->op
= EXEC_SELECT
;
3478 sprintf (name
, "_result_%s", sym
->name
);
3479 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
3481 select_sym
= select_st
->n
.sym
;
3482 select_sym
->ts
.type
= BT_INTEGER
;
3483 select_sym
->ts
.kind
= gfc_default_integer_kind
;
3484 gfc_set_sym_referenced (select_sym
);
3485 c
->expr1
= gfc_get_expr ();
3486 c
->expr1
->expr_type
= EXPR_VARIABLE
;
3487 c
->expr1
->symtree
= select_st
;
3488 c
->expr1
->ts
= select_sym
->ts
;
3489 c
->expr1
->where
= gfc_current_locus
;
3492 for (a
= arglist
; a
; a
= a
->next
)
3494 if (a
->expr
!= NULL
)
3497 if (gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
) == FAILURE
)
3502 c
->block
= gfc_get_code ();
3504 c
->op
= EXEC_SELECT
;
3506 new_case
= gfc_get_case ();
3507 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
3508 new_case
->low
= new_case
->high
;
3509 c
->ext
.case_list
= new_case
;
3511 c
->next
= gfc_get_code ();
3512 c
->next
->op
= EXEC_GOTO
;
3513 c
->next
->label1
= a
->label
;
3517 new_st
.op
= EXEC_CALL
;
3518 new_st
.symtree
= st
;
3519 new_st
.ext
.actual
= arglist
;
3524 gfc_syntax_error (ST_CALL
);
3527 gfc_free_actual_arglist (arglist
);
3532 /* Given a name, return a pointer to the common head structure,
3533 creating it if it does not exist. If FROM_MODULE is nonzero, we
3534 mangle the name so that it doesn't interfere with commons defined
3535 in the using namespace.
3536 TODO: Add to global symbol tree. */
3539 gfc_get_common (const char *name
, int from_module
)
3542 static int serial
= 0;
3543 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
3547 /* A use associated common block is only needed to correctly layout
3548 the variables it contains. */
3549 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
3550 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
3554 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
3557 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
3560 if (st
->n
.common
== NULL
)
3562 st
->n
.common
= gfc_get_common_head ();
3563 st
->n
.common
->where
= gfc_current_locus
;
3564 strcpy (st
->n
.common
->name
, name
);
3567 return st
->n
.common
;
3571 /* Match a common block name. */
3573 match
match_common_name (char *name
)
3577 if (gfc_match_char ('/') == MATCH_NO
)
3583 if (gfc_match_char ('/') == MATCH_YES
)
3589 m
= gfc_match_name (name
);
3591 if (m
== MATCH_ERROR
)
3593 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
3596 gfc_error ("Syntax error in common block name at %C");
3601 /* Match a COMMON statement. */
3604 gfc_match_common (void)
3606 gfc_symbol
*sym
, **head
, *tail
, *other
, *old_blank_common
;
3607 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3614 old_blank_common
= gfc_current_ns
->blank_common
.head
;
3615 if (old_blank_common
)
3617 while (old_blank_common
->common_next
)
3618 old_blank_common
= old_blank_common
->common_next
;
3625 m
= match_common_name (name
);
3626 if (m
== MATCH_ERROR
)
3629 gsym
= gfc_get_gsymbol (name
);
3630 if (gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= GSYM_COMMON
)
3632 gfc_error ("Symbol '%s' at %C is already an external symbol that "
3633 "is not COMMON", name
);
3637 if (gsym
->type
== GSYM_UNKNOWN
)
3639 gsym
->type
= GSYM_COMMON
;
3640 gsym
->where
= gfc_current_locus
;
3646 if (name
[0] == '\0')
3648 t
= &gfc_current_ns
->blank_common
;
3649 if (t
->head
== NULL
)
3650 t
->where
= gfc_current_locus
;
3654 t
= gfc_get_common (name
, 0);
3663 while (tail
->common_next
)
3664 tail
= tail
->common_next
;
3667 /* Grab the list of symbols. */
3670 m
= gfc_match_symbol (&sym
, 0);
3671 if (m
== MATCH_ERROR
)
3676 /* Store a ref to the common block for error checking. */
3677 sym
->common_block
= t
;
3679 /* See if we know the current common block is bind(c), and if
3680 so, then see if we can check if the symbol is (which it'll
3681 need to be). This can happen if the bind(c) attr stmt was
3682 applied to the common block, and the variable(s) already
3683 defined, before declaring the common block. */
3684 if (t
->is_bind_c
== 1)
3686 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
3688 /* If we find an error, just print it and continue,
3689 cause it's just semantic, and we can see if there
3691 gfc_error_now ("Variable '%s' at %L in common block '%s' "
3692 "at %C must be declared with a C "
3693 "interoperable kind since common block "
3695 sym
->name
, &(sym
->declared_at
), t
->name
,
3699 if (sym
->attr
.is_bind_c
== 1)
3700 gfc_error_now ("Variable '%s' in common block "
3701 "'%s' at %C can not be bind(c) since "
3702 "it is not global", sym
->name
, t
->name
);
3705 if (sym
->attr
.in_common
)
3707 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
3712 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
3713 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
3715 if (gfc_notify_std (GFC_STD_GNU
, "Initialized symbol '%s' at %C "
3716 "can only be COMMON in "
3717 "BLOCK DATA", sym
->name
)
3722 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3726 tail
->common_next
= sym
;
3732 /* Deal with an optional array specification after the
3734 m
= gfc_match_array_spec (&as
, true, true);
3735 if (m
== MATCH_ERROR
)
3740 if (as
->type
!= AS_EXPLICIT
)
3742 gfc_error ("Array specification for symbol '%s' in COMMON "
3743 "at %C must be explicit", sym
->name
);
3747 if (gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3750 if (sym
->attr
.pointer
)
3752 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
3753 "POINTER array", sym
->name
);
3762 sym
->common_head
= t
;
3764 /* Check to see if the symbol is already in an equivalence group.
3765 If it is, set the other members as being in common. */
3766 if (sym
->attr
.in_equivalence
)
3768 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
3770 for (e2
= e1
; e2
; e2
= e2
->eq
)
3771 if (e2
->expr
->symtree
->n
.sym
== sym
)
3778 for (e2
= e1
; e2
; e2
= e2
->eq
)
3780 other
= e2
->expr
->symtree
->n
.sym
;
3781 if (other
->common_head
3782 && other
->common_head
!= sym
->common_head
)
3784 gfc_error ("Symbol '%s', in COMMON block '%s' at "
3785 "%C is being indirectly equivalenced to "
3786 "another COMMON block '%s'",
3787 sym
->name
, sym
->common_head
->name
,
3788 other
->common_head
->name
);
3791 other
->attr
.in_common
= 1;
3792 other
->common_head
= t
;
3798 gfc_gobble_whitespace ();
3799 if (gfc_match_eos () == MATCH_YES
)
3801 if (gfc_peek_ascii_char () == '/')
3803 if (gfc_match_char (',') != MATCH_YES
)
3805 gfc_gobble_whitespace ();
3806 if (gfc_peek_ascii_char () == '/')
3815 gfc_syntax_error (ST_COMMON
);
3818 if (old_blank_common
)
3819 old_blank_common
->common_next
= NULL
;
3821 gfc_current_ns
->blank_common
.head
= NULL
;
3822 gfc_free_array_spec (as
);
3827 /* Match a BLOCK DATA program unit. */
3830 gfc_match_block_data (void)
3832 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3836 if (gfc_match_eos () == MATCH_YES
)
3838 gfc_new_block
= NULL
;
3842 m
= gfc_match ("% %n%t", name
);
3846 if (gfc_get_symbol (name
, NULL
, &sym
))
3849 if (gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
) == FAILURE
)
3852 gfc_new_block
= sym
;
3858 /* Free a namelist structure. */
3861 gfc_free_namelist (gfc_namelist
*name
)
3865 for (; name
; name
= n
)
3873 /* Match a NAMELIST statement. */
3876 gfc_match_namelist (void)
3878 gfc_symbol
*group_name
, *sym
;
3882 m
= gfc_match (" / %s /", &group_name
);
3885 if (m
== MATCH_ERROR
)
3890 if (group_name
->ts
.type
!= BT_UNKNOWN
)
3892 gfc_error ("Namelist group name '%s' at %C already has a basic "
3893 "type of %s", group_name
->name
,
3894 gfc_typename (&group_name
->ts
));
3898 if (group_name
->attr
.flavor
== FL_NAMELIST
3899 && group_name
->attr
.use_assoc
3900 && gfc_notify_std (GFC_STD_GNU
, "Namelist group name '%s' "
3901 "at %C already is USE associated and can"
3902 "not be respecified.", group_name
->name
)
3906 if (group_name
->attr
.flavor
!= FL_NAMELIST
3907 && gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
3908 group_name
->name
, NULL
) == FAILURE
)
3913 m
= gfc_match_symbol (&sym
, 1);
3916 if (m
== MATCH_ERROR
)
3919 if (sym
->attr
.in_namelist
== 0
3920 && gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3923 /* Use gfc_error_check here, rather than goto error, so that
3924 these are the only errors for the next two lines. */
3925 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
3927 gfc_error ("Assumed size array '%s' in namelist '%s' at "
3928 "%C is not allowed", sym
->name
, group_name
->name
);
3932 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
->length
== NULL
)
3934 gfc_error ("Assumed character length '%s' in namelist '%s' at "
3935 "%C is not allowed", sym
->name
, group_name
->name
);
3939 nl
= gfc_get_namelist ();
3943 if (group_name
->namelist
== NULL
)
3944 group_name
->namelist
= group_name
->namelist_tail
= nl
;
3947 group_name
->namelist_tail
->next
= nl
;
3948 group_name
->namelist_tail
= nl
;
3951 if (gfc_match_eos () == MATCH_YES
)
3954 m
= gfc_match_char (',');
3956 if (gfc_match_char ('/') == MATCH_YES
)
3958 m2
= gfc_match (" %s /", &group_name
);
3959 if (m2
== MATCH_YES
)
3961 if (m2
== MATCH_ERROR
)
3975 gfc_syntax_error (ST_NAMELIST
);
3982 /* Match a MODULE statement. */
3985 gfc_match_module (void)
3989 m
= gfc_match (" %s%t", &gfc_new_block
);
3993 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
3994 gfc_new_block
->name
, NULL
) == FAILURE
)
4001 /* Free equivalence sets and lists. Recursively is the easiest way to
4005 gfc_free_equiv (gfc_equiv
*eq
)
4010 gfc_free_equiv (eq
->eq
);
4011 gfc_free_equiv (eq
->next
);
4012 gfc_free_expr (eq
->expr
);
4017 /* Match an EQUIVALENCE statement. */
4020 gfc_match_equivalence (void)
4022 gfc_equiv
*eq
, *set
, *tail
;
4026 gfc_common_head
*common_head
= NULL
;
4034 eq
= gfc_get_equiv ();
4038 eq
->next
= gfc_current_ns
->equiv
;
4039 gfc_current_ns
->equiv
= eq
;
4041 if (gfc_match_char ('(') != MATCH_YES
)
4045 common_flag
= FALSE
;
4050 m
= gfc_match_equiv_variable (&set
->expr
);
4051 if (m
== MATCH_ERROR
)
4056 /* count the number of objects. */
4059 if (gfc_match_char ('%') == MATCH_YES
)
4061 gfc_error ("Derived type component %C is not a "
4062 "permitted EQUIVALENCE member");
4066 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
4067 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
4069 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
4070 "be an array section");
4074 sym
= set
->expr
->symtree
->n
.sym
;
4076 if (gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
4079 if (sym
->attr
.in_common
)
4082 common_head
= sym
->common_head
;
4085 if (gfc_match_char (')') == MATCH_YES
)
4088 if (gfc_match_char (',') != MATCH_YES
)
4091 set
->eq
= gfc_get_equiv ();
4097 gfc_error ("EQUIVALENCE at %C requires two or more objects");
4101 /* If one of the members of an equivalence is in common, then
4102 mark them all as being in common. Before doing this, check
4103 that members of the equivalence group are not in different
4106 for (set
= eq
; set
; set
= set
->eq
)
4108 sym
= set
->expr
->symtree
->n
.sym
;
4109 if (sym
->common_head
&& sym
->common_head
!= common_head
)
4111 gfc_error ("Attempt to indirectly overlap COMMON "
4112 "blocks %s and %s by EQUIVALENCE at %C",
4113 sym
->common_head
->name
, common_head
->name
);
4116 sym
->attr
.in_common
= 1;
4117 sym
->common_head
= common_head
;
4120 if (gfc_match_eos () == MATCH_YES
)
4122 if (gfc_match_char (',') != MATCH_YES
)
4124 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
4132 gfc_syntax_error (ST_EQUIVALENCE
);
4138 gfc_free_equiv (gfc_current_ns
->equiv
);
4139 gfc_current_ns
->equiv
= eq
;
4145 /* Check that a statement function is not recursive. This is done by looking
4146 for the statement function symbol(sym) by looking recursively through its
4147 expression(e). If a reference to sym is found, true is returned.
4148 12.5.4 requires that any variable of function that is implicitly typed
4149 shall have that type confirmed by any subsequent type declaration. The
4150 implicit typing is conveniently done here. */
4152 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
4155 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
4161 switch (e
->expr_type
)
4164 if (e
->symtree
== NULL
)
4167 /* Check the name before testing for nested recursion! */
4168 if (sym
->name
== e
->symtree
->n
.sym
->name
)
4171 /* Catch recursion via other statement functions. */
4172 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
4173 && e
->symtree
->n
.sym
->value
4174 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
4177 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
4178 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
4183 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
4186 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
4187 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
4199 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
4201 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
4205 /* Match a statement function declaration. It is so easy to match
4206 non-statement function statements with a MATCH_ERROR as opposed to
4207 MATCH_NO that we suppress error message in most cases. */
4210 gfc_match_st_function (void)
4212 gfc_error_buf old_error
;
4217 m
= gfc_match_symbol (&sym
, 0);
4221 gfc_push_error (&old_error
);
4223 if (gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
,
4224 sym
->name
, NULL
) == FAILURE
)
4227 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
4230 m
= gfc_match (" = %e%t", &expr
);
4234 gfc_free_error (&old_error
);
4235 if (m
== MATCH_ERROR
)
4238 if (recursive_stmt_fcn (expr
, sym
))
4240 gfc_error ("Statement function at %L is recursive", &expr
->where
);
4246 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: "
4247 "Statement function at %C") == FAILURE
)
4253 gfc_pop_error (&old_error
);
4258 /***************** SELECT CASE subroutines ******************/
4260 /* Free a single case structure. */
4263 free_case (gfc_case
*p
)
4265 if (p
->low
== p
->high
)
4267 gfc_free_expr (p
->low
);
4268 gfc_free_expr (p
->high
);
4273 /* Free a list of case structures. */
4276 gfc_free_case_list (gfc_case
*p
)
4288 /* Match a single case selector. */
4291 match_case_selector (gfc_case
**cp
)
4296 c
= gfc_get_case ();
4297 c
->where
= gfc_current_locus
;
4299 if (gfc_match_char (':') == MATCH_YES
)
4301 m
= gfc_match_init_expr (&c
->high
);
4304 if (m
== MATCH_ERROR
)
4309 m
= gfc_match_init_expr (&c
->low
);
4310 if (m
== MATCH_ERROR
)
4315 /* If we're not looking at a ':' now, make a range out of a single
4316 target. Else get the upper bound for the case range. */
4317 if (gfc_match_char (':') != MATCH_YES
)
4321 m
= gfc_match_init_expr (&c
->high
);
4322 if (m
== MATCH_ERROR
)
4324 /* MATCH_NO is fine. It's OK if nothing is there! */
4332 gfc_error ("Expected initialization expression in CASE at %C");
4340 /* Match the end of a case statement. */
4343 match_case_eos (void)
4345 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4348 if (gfc_match_eos () == MATCH_YES
)
4351 /* If the case construct doesn't have a case-construct-name, we
4352 should have matched the EOS. */
4353 if (!gfc_current_block ())
4356 gfc_gobble_whitespace ();
4358 m
= gfc_match_name (name
);
4362 if (strcmp (name
, gfc_current_block ()->name
) != 0)
4364 gfc_error ("Expected block name '%s' of SELECT construct at %C",
4365 gfc_current_block ()->name
);
4369 return gfc_match_eos ();
4373 /* Match a SELECT statement. */
4376 gfc_match_select (void)
4381 m
= gfc_match_label ();
4382 if (m
== MATCH_ERROR
)
4385 m
= gfc_match (" select case ( %e )%t", &expr
);
4389 new_st
.op
= EXEC_SELECT
;
4390 new_st
.expr1
= expr
;
4396 /* Push the current selector onto the SELECT TYPE stack. */
4399 select_type_push (gfc_symbol
*sel
)
4401 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
4402 top
->selector
= sel
;
4404 top
->prev
= select_type_stack
;
4406 select_type_stack
= top
;
4410 /* Set the temporary for the current SELECT TYPE selector. */
4413 select_type_set_tmp (gfc_typespec
*ts
)
4415 char name
[GFC_MAX_SYMBOL_LEN
];
4418 if (!gfc_type_is_extensible (ts
->u
.derived
))
4421 if (ts
->type
== BT_CLASS
)
4422 sprintf (name
, "tmp$class$%s", ts
->u
.derived
->name
);
4424 sprintf (name
, "tmp$type$%s", ts
->u
.derived
->name
);
4425 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
4426 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
4427 gfc_set_sym_referenced (tmp
->n
.sym
);
4428 gfc_add_pointer (&tmp
->n
.sym
->attr
, NULL
);
4429 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
4430 if (ts
->type
== BT_CLASS
)
4432 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
4433 &tmp
->n
.sym
->as
, false);
4434 tmp
->n
.sym
->attr
.class_ok
= 1;
4437 select_type_stack
->tmp
= tmp
;
4441 /* Match a SELECT TYPE statement. */
4444 gfc_match_select_type (void)
4446 gfc_expr
*expr1
, *expr2
= NULL
;
4448 char name
[GFC_MAX_SYMBOL_LEN
];
4450 m
= gfc_match_label ();
4451 if (m
== MATCH_ERROR
)
4454 m
= gfc_match (" select type ( ");
4458 gfc_current_ns
= gfc_build_block_ns (gfc_current_ns
);
4460 m
= gfc_match (" %n => %e", name
, &expr2
);
4463 expr1
= gfc_get_expr();
4464 expr1
->expr_type
= EXPR_VARIABLE
;
4465 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
4470 if (expr2
->ts
.type
== BT_UNKNOWN
)
4471 expr1
->symtree
->n
.sym
->attr
.untyped
= 1;
4473 expr1
->symtree
->n
.sym
->ts
= expr2
->ts
;
4474 expr1
->symtree
->n
.sym
->attr
.referenced
= 1;
4475 expr1
->symtree
->n
.sym
->attr
.class_ok
= 1;
4479 m
= gfc_match (" %e ", &expr1
);
4484 m
= gfc_match (" )%t");
4488 /* Check for F03:C811. */
4489 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
|| expr1
->ref
!= NULL
))
4491 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
4492 "use associate-name=>");
4497 new_st
.op
= EXEC_SELECT_TYPE
;
4498 new_st
.expr1
= expr1
;
4499 new_st
.expr2
= expr2
;
4500 new_st
.ext
.block
.ns
= gfc_current_ns
;
4502 select_type_push (expr1
->symtree
->n
.sym
);
4507 gfc_current_ns
= gfc_current_ns
->parent
;
4512 /* Match a CASE statement. */
4515 gfc_match_case (void)
4517 gfc_case
*c
, *head
, *tail
;
4522 if (gfc_current_state () != COMP_SELECT
)
4524 gfc_error ("Unexpected CASE statement at %C");
4528 if (gfc_match ("% default") == MATCH_YES
)
4530 m
= match_case_eos ();
4533 if (m
== MATCH_ERROR
)
4536 new_st
.op
= EXEC_SELECT
;
4537 c
= gfc_get_case ();
4538 c
->where
= gfc_current_locus
;
4539 new_st
.ext
.case_list
= c
;
4543 if (gfc_match_char ('(') != MATCH_YES
)
4548 if (match_case_selector (&c
) == MATCH_ERROR
)
4558 if (gfc_match_char (')') == MATCH_YES
)
4560 if (gfc_match_char (',') != MATCH_YES
)
4564 m
= match_case_eos ();
4567 if (m
== MATCH_ERROR
)
4570 new_st
.op
= EXEC_SELECT
;
4571 new_st
.ext
.case_list
= head
;
4576 gfc_error ("Syntax error in CASE specification at %C");
4579 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
4584 /* Match a TYPE IS statement. */
4587 gfc_match_type_is (void)
4592 if (gfc_current_state () != COMP_SELECT_TYPE
)
4594 gfc_error ("Unexpected TYPE IS statement at %C");
4598 if (gfc_match_char ('(') != MATCH_YES
)
4601 c
= gfc_get_case ();
4602 c
->where
= gfc_current_locus
;
4604 /* TODO: Once unlimited polymorphism is implemented, we will need to call
4605 match_type_spec here. */
4606 if (match_derived_type_spec (&c
->ts
) == MATCH_ERROR
)
4609 if (gfc_match_char (')') != MATCH_YES
)
4612 m
= match_case_eos ();
4615 if (m
== MATCH_ERROR
)
4618 new_st
.op
= EXEC_SELECT_TYPE
;
4619 new_st
.ext
.case_list
= c
;
4621 /* Create temporary variable. */
4622 select_type_set_tmp (&c
->ts
);
4627 gfc_error ("Syntax error in TYPE IS specification at %C");
4631 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
4636 /* Match a CLASS IS or CLASS DEFAULT statement. */
4639 gfc_match_class_is (void)
4644 if (gfc_current_state () != COMP_SELECT_TYPE
)
4647 if (gfc_match ("% default") == MATCH_YES
)
4649 m
= match_case_eos ();
4652 if (m
== MATCH_ERROR
)
4655 new_st
.op
= EXEC_SELECT_TYPE
;
4656 c
= gfc_get_case ();
4657 c
->where
= gfc_current_locus
;
4658 c
->ts
.type
= BT_UNKNOWN
;
4659 new_st
.ext
.case_list
= c
;
4663 m
= gfc_match ("% is");
4666 if (m
== MATCH_ERROR
)
4669 if (gfc_match_char ('(') != MATCH_YES
)
4672 c
= gfc_get_case ();
4673 c
->where
= gfc_current_locus
;
4675 if (match_derived_type_spec (&c
->ts
) == MATCH_ERROR
)
4678 if (c
->ts
.type
== BT_DERIVED
)
4679 c
->ts
.type
= BT_CLASS
;
4681 if (gfc_match_char (')') != MATCH_YES
)
4684 m
= match_case_eos ();
4687 if (m
== MATCH_ERROR
)
4690 new_st
.op
= EXEC_SELECT_TYPE
;
4691 new_st
.ext
.case_list
= c
;
4693 /* Create temporary variable. */
4694 select_type_set_tmp (&c
->ts
);
4699 gfc_error ("Syntax error in CLASS IS specification at %C");
4703 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
4708 /********************* WHERE subroutines ********************/
4710 /* Match the rest of a simple WHERE statement that follows an IF statement.
4714 match_simple_where (void)
4720 m
= gfc_match (" ( %e )", &expr
);
4724 m
= gfc_match_assignment ();
4727 if (m
== MATCH_ERROR
)
4730 if (gfc_match_eos () != MATCH_YES
)
4733 c
= gfc_get_code ();
4737 c
->next
= gfc_get_code ();
4740 gfc_clear_new_st ();
4742 new_st
.op
= EXEC_WHERE
;
4748 gfc_syntax_error (ST_WHERE
);
4751 gfc_free_expr (expr
);
4756 /* Match a WHERE statement. */
4759 gfc_match_where (gfc_statement
*st
)
4765 m0
= gfc_match_label ();
4766 if (m0
== MATCH_ERROR
)
4769 m
= gfc_match (" where ( %e )", &expr
);
4773 if (gfc_match_eos () == MATCH_YES
)
4775 *st
= ST_WHERE_BLOCK
;
4776 new_st
.op
= EXEC_WHERE
;
4777 new_st
.expr1
= expr
;
4781 m
= gfc_match_assignment ();
4783 gfc_syntax_error (ST_WHERE
);
4787 gfc_free_expr (expr
);
4791 /* We've got a simple WHERE statement. */
4793 c
= gfc_get_code ();
4797 c
->next
= gfc_get_code ();
4800 gfc_clear_new_st ();
4802 new_st
.op
= EXEC_WHERE
;
4809 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
4810 new_st if successful. */
4813 gfc_match_elsewhere (void)
4815 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4819 if (gfc_current_state () != COMP_WHERE
)
4821 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
4827 if (gfc_match_char ('(') == MATCH_YES
)
4829 m
= gfc_match_expr (&expr
);
4832 if (m
== MATCH_ERROR
)
4835 if (gfc_match_char (')') != MATCH_YES
)
4839 if (gfc_match_eos () != MATCH_YES
)
4841 /* Only makes sense if we have a where-construct-name. */
4842 if (!gfc_current_block ())
4847 /* Better be a name at this point. */
4848 m
= gfc_match_name (name
);
4851 if (m
== MATCH_ERROR
)
4854 if (gfc_match_eos () != MATCH_YES
)
4857 if (strcmp (name
, gfc_current_block ()->name
) != 0)
4859 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
4860 name
, gfc_current_block ()->name
);
4865 new_st
.op
= EXEC_WHERE
;
4866 new_st
.expr1
= expr
;
4870 gfc_syntax_error (ST_ELSEWHERE
);
4873 gfc_free_expr (expr
);
4878 /******************** FORALL subroutines ********************/
4880 /* Free a list of FORALL iterators. */
4883 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
4885 gfc_forall_iterator
*next
;
4890 gfc_free_expr (iter
->var
);
4891 gfc_free_expr (iter
->start
);
4892 gfc_free_expr (iter
->end
);
4893 gfc_free_expr (iter
->stride
);
4900 /* Match an iterator as part of a FORALL statement. The format is:
4902 <var> = <start>:<end>[:<stride>]
4904 On MATCH_NO, the caller tests for the possibility that there is a
4905 scalar mask expression. */
4908 match_forall_iterator (gfc_forall_iterator
**result
)
4910 gfc_forall_iterator
*iter
;
4914 where
= gfc_current_locus
;
4915 iter
= XCNEW (gfc_forall_iterator
);
4917 m
= gfc_match_expr (&iter
->var
);
4921 if (gfc_match_char ('=') != MATCH_YES
4922 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
4928 m
= gfc_match_expr (&iter
->start
);
4932 if (gfc_match_char (':') != MATCH_YES
)
4935 m
= gfc_match_expr (&iter
->end
);
4938 if (m
== MATCH_ERROR
)
4941 if (gfc_match_char (':') == MATCH_NO
)
4942 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4945 m
= gfc_match_expr (&iter
->stride
);
4948 if (m
== MATCH_ERROR
)
4952 /* Mark the iteration variable's symbol as used as a FORALL index. */
4953 iter
->var
->symtree
->n
.sym
->forall_index
= true;
4959 gfc_error ("Syntax error in FORALL iterator at %C");
4964 gfc_current_locus
= where
;
4965 gfc_free_forall_iterator (iter
);
4970 /* Match the header of a FORALL statement. */
4973 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
4975 gfc_forall_iterator
*head
, *tail
, *new_iter
;
4979 gfc_gobble_whitespace ();
4984 if (gfc_match_char ('(') != MATCH_YES
)
4987 m
= match_forall_iterator (&new_iter
);
4988 if (m
== MATCH_ERROR
)
4993 head
= tail
= new_iter
;
4997 if (gfc_match_char (',') != MATCH_YES
)
5000 m
= match_forall_iterator (&new_iter
);
5001 if (m
== MATCH_ERROR
)
5006 tail
->next
= new_iter
;
5011 /* Have to have a mask expression. */
5013 m
= gfc_match_expr (&msk
);
5016 if (m
== MATCH_ERROR
)
5022 if (gfc_match_char (')') == MATCH_NO
)
5030 gfc_syntax_error (ST_FORALL
);
5033 gfc_free_expr (msk
);
5034 gfc_free_forall_iterator (head
);
5039 /* Match the rest of a simple FORALL statement that follows an
5043 match_simple_forall (void)
5045 gfc_forall_iterator
*head
;
5054 m
= match_forall_header (&head
, &mask
);
5061 m
= gfc_match_assignment ();
5063 if (m
== MATCH_ERROR
)
5067 m
= gfc_match_pointer_assignment ();
5068 if (m
== MATCH_ERROR
)
5074 c
= gfc_get_code ();
5076 c
->loc
= gfc_current_locus
;
5078 if (gfc_match_eos () != MATCH_YES
)
5081 gfc_clear_new_st ();
5082 new_st
.op
= EXEC_FORALL
;
5083 new_st
.expr1
= mask
;
5084 new_st
.ext
.forall_iterator
= head
;
5085 new_st
.block
= gfc_get_code ();
5087 new_st
.block
->op
= EXEC_FORALL
;
5088 new_st
.block
->next
= c
;
5093 gfc_syntax_error (ST_FORALL
);
5096 gfc_free_forall_iterator (head
);
5097 gfc_free_expr (mask
);
5103 /* Match a FORALL statement. */
5106 gfc_match_forall (gfc_statement
*st
)
5108 gfc_forall_iterator
*head
;
5117 m0
= gfc_match_label ();
5118 if (m0
== MATCH_ERROR
)
5121 m
= gfc_match (" forall");
5125 m
= match_forall_header (&head
, &mask
);
5126 if (m
== MATCH_ERROR
)
5131 if (gfc_match_eos () == MATCH_YES
)
5133 *st
= ST_FORALL_BLOCK
;
5134 new_st
.op
= EXEC_FORALL
;
5135 new_st
.expr1
= mask
;
5136 new_st
.ext
.forall_iterator
= head
;
5140 m
= gfc_match_assignment ();
5141 if (m
== MATCH_ERROR
)
5145 m
= gfc_match_pointer_assignment ();
5146 if (m
== MATCH_ERROR
)
5152 c
= gfc_get_code ();
5154 c
->loc
= gfc_current_locus
;
5156 gfc_clear_new_st ();
5157 new_st
.op
= EXEC_FORALL
;
5158 new_st
.expr1
= mask
;
5159 new_st
.ext
.forall_iterator
= head
;
5160 new_st
.block
= gfc_get_code ();
5161 new_st
.block
->op
= EXEC_FORALL
;
5162 new_st
.block
->next
= c
;
5168 gfc_syntax_error (ST_FORALL
);
5171 gfc_free_forall_iterator (head
);
5172 gfc_free_expr (mask
);
5173 gfc_free_statements (c
);