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
;
1830 newAssoc
->where
= gfc_current_locus
;
1832 /* Check that the current name is not yet in the list. */
1833 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
1834 if (!strcmp (a
->name
, newAssoc
->name
))
1836 gfc_error ("Duplicate name '%s' in association at %C",
1838 goto assocListError
;
1841 /* The target expression must not be coindexed. */
1842 if (gfc_is_coindexed (newAssoc
->target
))
1844 gfc_error ("Association target at %C must not be coindexed");
1845 goto assocListError
;
1848 /* The `variable' field is left blank for now; because the target is not
1849 yet resolved, we can't use gfc_has_vector_subscript to determine it
1850 for now. Instead, if the symbol is matched as variable, this field
1851 is set -- and during resolution we check that. */
1852 newAssoc
->variable
= 0;
1854 /* Put it into the list. */
1855 newAssoc
->next
= new_st
.ext
.block
.assoc
;
1856 new_st
.ext
.block
.assoc
= newAssoc
;
1858 /* Try next one or end if closing parenthesis is found. */
1859 gfc_gobble_whitespace ();
1860 if (gfc_peek_char () == ')')
1862 if (gfc_match_char (',') != MATCH_YES
)
1864 gfc_error ("Expected ')' or ',' at %C");
1871 gfc_free (newAssoc
);
1874 if (gfc_match_char (')') != MATCH_YES
)
1876 /* This should never happen as we peek above. */
1880 if (gfc_match_eos () != MATCH_YES
)
1882 gfc_error ("Junk after ASSOCIATE statement at %C");
1889 gfc_free_association_list (new_st
.ext
.block
.assoc
);
1894 /* Match a DO statement. */
1899 gfc_iterator iter
, *ip
;
1901 gfc_st_label
*label
;
1904 old_loc
= gfc_current_locus
;
1907 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
1909 m
= gfc_match_label ();
1910 if (m
== MATCH_ERROR
)
1913 if (gfc_match (" do") != MATCH_YES
)
1916 m
= gfc_match_st_label (&label
);
1917 if (m
== MATCH_ERROR
)
1920 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
1922 if (gfc_match_eos () == MATCH_YES
)
1924 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
1925 new_st
.op
= EXEC_DO_WHILE
;
1929 /* Match an optional comma, if no comma is found, a space is obligatory. */
1930 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
1933 /* Check for balanced parens. */
1935 if (gfc_match_parens () == MATCH_ERROR
)
1938 /* See if we have a DO WHILE. */
1939 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
1941 new_st
.op
= EXEC_DO_WHILE
;
1945 /* The abortive DO WHILE may have done something to the symbol
1946 table, so we start over. */
1947 gfc_undo_symbols ();
1948 gfc_current_locus
= old_loc
;
1950 gfc_match_label (); /* This won't error. */
1951 gfc_match (" do "); /* This will work. */
1953 gfc_match_st_label (&label
); /* Can't error out. */
1954 gfc_match_char (','); /* Optional comma. */
1956 m
= gfc_match_iterator (&iter
, 0);
1959 if (m
== MATCH_ERROR
)
1962 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
1963 gfc_check_do_variable (iter
.var
->symtree
);
1965 if (gfc_match_eos () != MATCH_YES
)
1967 gfc_syntax_error (ST_DO
);
1971 new_st
.op
= EXEC_DO
;
1975 && gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1978 new_st
.label1
= label
;
1980 if (new_st
.op
== EXEC_DO_WHILE
)
1981 new_st
.expr1
= iter
.end
;
1984 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
1991 gfc_free_iterator (&iter
, 0);
1997 /* Match an EXIT or CYCLE statement. */
2000 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
2002 gfc_state_data
*p
, *o
;
2007 if (gfc_match_eos () == MATCH_YES
)
2011 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2014 m
= gfc_match ("% %n%t", name
);
2015 if (m
== MATCH_ERROR
)
2019 gfc_syntax_error (st
);
2023 /* Find the corresponding symbol. If there's a BLOCK statement
2024 between here and the label, it is not in gfc_current_ns but a parent
2026 stree
= gfc_find_symtree_in_proc (name
, gfc_current_ns
);
2029 gfc_error ("Name '%s' in %s statement at %C is unknown",
2030 name
, gfc_ascii_statement (st
));
2035 if (sym
->attr
.flavor
!= FL_LABEL
)
2037 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
2038 name
, gfc_ascii_statement (st
));
2043 /* Find the loop specified by the label (or lack of a label). */
2044 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
2045 if (p
->state
== COMP_DO
&& (sym
== NULL
|| sym
== p
->sym
))
2047 else if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
2049 else if (p
->state
== COMP_CRITICAL
)
2051 gfc_error("%s statement at %C leaves CRITICAL construct",
2052 gfc_ascii_statement (st
));
2059 gfc_error ("%s statement at %C is not within a loop",
2060 gfc_ascii_statement (st
));
2062 gfc_error ("%s statement at %C is not within loop '%s'",
2063 gfc_ascii_statement (st
), sym
->name
);
2070 gfc_error ("%s statement at %C leaving OpenMP structured block",
2071 gfc_ascii_statement (st
));
2075 for (o
= p
, cnt
= 0; o
->state
== COMP_DO
&& o
->previous
!= NULL
; cnt
++)
2079 && o
->state
== COMP_OMP_STRUCTURED_BLOCK
2080 && (o
->head
->op
== EXEC_OMP_DO
2081 || o
->head
->op
== EXEC_OMP_PARALLEL_DO
))
2084 gcc_assert (o
->head
->next
!= NULL
2085 && (o
->head
->next
->op
== EXEC_DO
2086 || o
->head
->next
->op
== EXEC_DO_WHILE
)
2087 && o
->previous
!= NULL
2088 && o
->previous
->tail
->op
== o
->head
->op
);
2089 if (o
->previous
->tail
->ext
.omp_clauses
!= NULL
2090 && o
->previous
->tail
->ext
.omp_clauses
->collapse
> 1)
2091 collapse
= o
->previous
->tail
->ext
.omp_clauses
->collapse
;
2092 if (st
== ST_EXIT
&& cnt
<= collapse
)
2094 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2097 if (st
== ST_CYCLE
&& cnt
< collapse
)
2099 gfc_error ("CYCLE statement at %C to non-innermost collapsed !$OMP DO loop");
2104 /* Save the first statement in the loop - needed by the backend. */
2105 new_st
.ext
.whichloop
= p
->head
;
2113 /* Match the EXIT statement. */
2116 gfc_match_exit (void)
2118 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
2122 /* Match the CYCLE statement. */
2125 gfc_match_cycle (void)
2127 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2131 /* Match a number or character constant after an (ALL) STOP or PAUSE statement. */
2134 gfc_match_stopcode (gfc_statement st
)
2141 if (gfc_match_eos () != MATCH_YES
)
2143 m
= gfc_match_init_expr (&e
);
2144 if (m
== MATCH_ERROR
)
2149 if (gfc_match_eos () != MATCH_YES
)
2153 if (gfc_pure (NULL
))
2155 gfc_error ("%s statement not allowed in PURE procedure at %C",
2156 gfc_ascii_statement (st
));
2160 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
) == SUCCESS
)
2162 gfc_error ("Image control statement STOP at %C in CRITICAL block");
2168 if (!(e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_INTEGER
))
2170 gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2177 gfc_error ("STOP code at %L must be scalar",
2182 if (e
->ts
.type
== BT_CHARACTER
2183 && e
->ts
.kind
!= gfc_default_character_kind
)
2185 gfc_error ("STOP code at %L must be default character KIND=%d",
2186 &e
->where
, (int) gfc_default_character_kind
);
2190 if (e
->ts
.type
== BT_INTEGER
2191 && e
->ts
.kind
!= gfc_default_integer_kind
)
2193 gfc_error ("STOP code at %L must be default integer KIND=%d",
2194 &e
->where
, (int) gfc_default_integer_kind
);
2202 new_st
.op
= EXEC_STOP
;
2205 new_st
.op
= EXEC_ERROR_STOP
;
2208 new_st
.op
= EXEC_PAUSE
;
2215 new_st
.ext
.stop_code
= -1;
2220 gfc_syntax_error (st
);
2229 /* Match the (deprecated) PAUSE statement. */
2232 gfc_match_pause (void)
2236 m
= gfc_match_stopcode (ST_PAUSE
);
2239 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: PAUSE statement"
2248 /* Match the STOP statement. */
2251 gfc_match_stop (void)
2253 return gfc_match_stopcode (ST_STOP
);
2257 /* Match the ERROR STOP statement. */
2260 gfc_match_error_stop (void)
2262 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: ERROR STOP statement at %C")
2266 return gfc_match_stopcode (ST_ERROR_STOP
);
2270 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
2271 SYNC ALL [(sync-stat-list)]
2272 SYNC MEMORY [(sync-stat-list)]
2273 SYNC IMAGES (image-set [, sync-stat-list] )
2274 with sync-stat is int-expr or *. */
2277 sync_statement (gfc_statement st
)
2280 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
2281 bool saw_stat
, saw_errmsg
;
2283 tmp
= imageset
= stat
= errmsg
= NULL
;
2284 saw_stat
= saw_errmsg
= false;
2286 if (gfc_pure (NULL
))
2288 gfc_error ("Image control statement SYNC at %C in PURE procedure");
2292 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: SYNC statement at %C")
2296 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
2298 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2302 if (gfc_find_state (COMP_CRITICAL
) == SUCCESS
)
2304 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
2308 if (gfc_match_eos () == MATCH_YES
)
2310 if (st
== ST_SYNC_IMAGES
)
2315 if (gfc_match_char ('(') != MATCH_YES
)
2318 if (st
== ST_SYNC_IMAGES
)
2320 /* Denote '*' as imageset == NULL. */
2321 m
= gfc_match_char ('*');
2322 if (m
== MATCH_ERROR
)
2326 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
2329 m
= gfc_match_char (',');
2330 if (m
== MATCH_ERROR
)
2334 m
= gfc_match_char (')');
2343 m
= gfc_match (" stat = %v", &tmp
);
2344 if (m
== MATCH_ERROR
)
2350 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
2356 if (gfc_match_char (',') == MATCH_YES
)
2360 m
= gfc_match (" errmsg = %v", &tmp
);
2361 if (m
== MATCH_ERROR
)
2367 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
2373 if (gfc_match_char (',') == MATCH_YES
)
2377 gfc_gobble_whitespace ();
2379 if (gfc_peek_char () == ')')
2385 if (gfc_match (" )%t") != MATCH_YES
)
2392 new_st
.op
= EXEC_SYNC_ALL
;
2394 case ST_SYNC_IMAGES
:
2395 new_st
.op
= EXEC_SYNC_IMAGES
;
2397 case ST_SYNC_MEMORY
:
2398 new_st
.op
= EXEC_SYNC_MEMORY
;
2404 new_st
.expr1
= imageset
;
2405 new_st
.expr2
= stat
;
2406 new_st
.expr3
= errmsg
;
2411 gfc_syntax_error (st
);
2414 gfc_free_expr (tmp
);
2415 gfc_free_expr (imageset
);
2416 gfc_free_expr (stat
);
2417 gfc_free_expr (errmsg
);
2423 /* Match SYNC ALL statement. */
2426 gfc_match_sync_all (void)
2428 return sync_statement (ST_SYNC_ALL
);
2432 /* Match SYNC IMAGES statement. */
2435 gfc_match_sync_images (void)
2437 return sync_statement (ST_SYNC_IMAGES
);
2441 /* Match SYNC MEMORY statement. */
2444 gfc_match_sync_memory (void)
2446 return sync_statement (ST_SYNC_MEMORY
);
2450 /* Match a CONTINUE statement. */
2453 gfc_match_continue (void)
2455 if (gfc_match_eos () != MATCH_YES
)
2457 gfc_syntax_error (ST_CONTINUE
);
2461 new_st
.op
= EXEC_CONTINUE
;
2466 /* Match the (deprecated) ASSIGN statement. */
2469 gfc_match_assign (void)
2472 gfc_st_label
*label
;
2474 if (gfc_match (" %l", &label
) == MATCH_YES
)
2476 if (gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
) == FAILURE
)
2478 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
2480 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: ASSIGN "
2485 expr
->symtree
->n
.sym
->attr
.assign
= 1;
2487 new_st
.op
= EXEC_LABEL_ASSIGN
;
2488 new_st
.label1
= label
;
2489 new_st
.expr1
= expr
;
2497 /* Match the GO TO statement. As a computed GOTO statement is
2498 matched, it is transformed into an equivalent SELECT block. No
2499 tree is necessary, and the resulting jumps-to-jumps are
2500 specifically optimized away by the back end. */
2503 gfc_match_goto (void)
2505 gfc_code
*head
, *tail
;
2508 gfc_st_label
*label
;
2512 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
2514 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2517 new_st
.op
= EXEC_GOTO
;
2518 new_st
.label1
= label
;
2522 /* The assigned GO TO statement. */
2524 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
2526 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: Assigned GOTO "
2531 new_st
.op
= EXEC_GOTO
;
2532 new_st
.expr1
= expr
;
2534 if (gfc_match_eos () == MATCH_YES
)
2537 /* Match label list. */
2538 gfc_match_char (',');
2539 if (gfc_match_char ('(') != MATCH_YES
)
2541 gfc_syntax_error (ST_GOTO
);
2548 m
= gfc_match_st_label (&label
);
2552 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2556 head
= tail
= gfc_get_code ();
2559 tail
->block
= gfc_get_code ();
2563 tail
->label1
= label
;
2564 tail
->op
= EXEC_GOTO
;
2566 while (gfc_match_char (',') == MATCH_YES
);
2568 if (gfc_match (")%t") != MATCH_YES
)
2573 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2576 new_st
.block
= head
;
2581 /* Last chance is a computed GO TO statement. */
2582 if (gfc_match_char ('(') != MATCH_YES
)
2584 gfc_syntax_error (ST_GOTO
);
2593 m
= gfc_match_st_label (&label
);
2597 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2601 head
= tail
= gfc_get_code ();
2604 tail
->block
= gfc_get_code ();
2608 cp
= gfc_get_case ();
2609 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
2612 tail
->op
= EXEC_SELECT
;
2613 tail
->ext
.case_list
= cp
;
2615 tail
->next
= gfc_get_code ();
2616 tail
->next
->op
= EXEC_GOTO
;
2617 tail
->next
->label1
= label
;
2619 while (gfc_match_char (',') == MATCH_YES
);
2621 if (gfc_match_char (')') != MATCH_YES
)
2626 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2630 /* Get the rest of the statement. */
2631 gfc_match_char (',');
2633 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
2636 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: Computed GOTO "
2637 "at %C") == FAILURE
)
2640 /* At this point, a computed GOTO has been fully matched and an
2641 equivalent SELECT statement constructed. */
2643 new_st
.op
= EXEC_SELECT
;
2644 new_st
.expr1
= NULL
;
2646 /* Hack: For a "real" SELECT, the expression is in expr. We put
2647 it in expr2 so we can distinguish then and produce the correct
2649 new_st
.expr2
= expr
;
2650 new_st
.block
= head
;
2654 gfc_syntax_error (ST_GOTO
);
2656 gfc_free_statements (head
);
2661 /* Frees a list of gfc_alloc structures. */
2664 gfc_free_alloc_list (gfc_alloc
*p
)
2671 gfc_free_expr (p
->expr
);
2677 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
2678 an accessible derived type. */
2681 match_derived_type_spec (gfc_typespec
*ts
)
2684 gfc_symbol
*derived
;
2686 old_locus
= gfc_current_locus
;
2688 if (gfc_match_symbol (&derived
, 1) == MATCH_YES
)
2690 if (derived
->attr
.flavor
== FL_DERIVED
)
2692 ts
->type
= BT_DERIVED
;
2693 ts
->u
.derived
= derived
;
2698 /* Enforce F03:C476. */
2699 gfc_error ("'%s' at %L is not an accessible derived type",
2700 derived
->name
, &gfc_current_locus
);
2705 gfc_current_locus
= old_locus
;
2710 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2711 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2712 It only includes the intrinsic types from the Fortran 2003 standard
2713 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2714 the implicit_flag is not needed, so it was removed. Derived types are
2715 identified by their name alone. */
2718 match_type_spec (gfc_typespec
*ts
)
2724 gfc_gobble_whitespace();
2725 old_locus
= gfc_current_locus
;
2727 m
= match_derived_type_spec (ts
);
2730 old_locus
= gfc_current_locus
;
2731 if (gfc_match (" :: ") != MATCH_YES
)
2733 gfc_current_locus
= old_locus
;
2734 /* Enfore F03:C401. */
2735 if (ts
->u
.derived
->attr
.abstract
)
2737 gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
2738 ts
->u
.derived
->name
, &old_locus
);
2743 else if (m
== MATCH_ERROR
&& gfc_match (" :: ") == MATCH_YES
)
2746 gfc_current_locus
= old_locus
;
2748 if (gfc_match ("integer") == MATCH_YES
)
2750 ts
->type
= BT_INTEGER
;
2751 ts
->kind
= gfc_default_integer_kind
;
2755 if (gfc_match ("real") == MATCH_YES
)
2758 ts
->kind
= gfc_default_real_kind
;
2762 if (gfc_match ("double precision") == MATCH_YES
)
2765 ts
->kind
= gfc_default_double_kind
;
2769 if (gfc_match ("complex") == MATCH_YES
)
2771 ts
->type
= BT_COMPLEX
;
2772 ts
->kind
= gfc_default_complex_kind
;
2776 if (gfc_match ("character") == MATCH_YES
)
2778 ts
->type
= BT_CHARACTER
;
2782 if (gfc_match ("logical") == MATCH_YES
)
2784 ts
->type
= BT_LOGICAL
;
2785 ts
->kind
= gfc_default_logical_kind
;
2789 /* If a type is not matched, simply return MATCH_NO. */
2790 gfc_current_locus
= old_locus
;
2795 gfc_gobble_whitespace ();
2796 if (gfc_peek_ascii_char () == '*')
2798 gfc_error ("Invalid type-spec at %C");
2802 m
= gfc_match_kind_spec (ts
, false);
2805 m
= MATCH_YES
; /* No kind specifier found. */
2811 m
= gfc_match_char_spec (ts
);
2814 m
= MATCH_YES
; /* No kind specifier found. */
2820 /* Match an ALLOCATE statement. */
2823 gfc_match_allocate (void)
2825 gfc_alloc
*head
, *tail
;
2826 gfc_expr
*stat
, *errmsg
, *tmp
, *source
, *mold
;
2831 bool saw_stat
, saw_errmsg
, saw_source
, saw_mold
, b1
, b2
, b3
;
2834 stat
= errmsg
= source
= mold
= tmp
= NULL
;
2835 saw_stat
= saw_errmsg
= saw_source
= saw_mold
= false;
2837 if (gfc_match_char ('(') != MATCH_YES
)
2840 /* Match an optional type-spec. */
2841 old_locus
= gfc_current_locus
;
2842 m
= match_type_spec (&ts
);
2843 if (m
== MATCH_ERROR
)
2845 else if (m
== MATCH_NO
)
2846 ts
.type
= BT_UNKNOWN
;
2849 if (gfc_match (" :: ") == MATCH_YES
)
2851 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: typespec in "
2852 "ALLOCATE at %L", &old_locus
) == FAILURE
)
2857 ts
.type
= BT_UNKNOWN
;
2858 gfc_current_locus
= old_locus
;
2865 head
= tail
= gfc_get_alloc ();
2868 tail
->next
= gfc_get_alloc ();
2872 m
= gfc_match_variable (&tail
->expr
, 0);
2875 if (m
== MATCH_ERROR
)
2878 if (gfc_check_do_variable (tail
->expr
->symtree
))
2881 if (gfc_pure (NULL
) && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
2883 gfc_error ("Bad allocate-object at %C for a PURE procedure");
2887 /* The ALLOCATE statement had an optional typespec. Check the
2889 if (ts
.type
!= BT_UNKNOWN
)
2891 /* Enforce F03:C624. */
2892 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
2894 gfc_error ("Type of entity at %L is type incompatible with "
2895 "typespec", &tail
->expr
->where
);
2899 /* Enforce F03:C627. */
2900 if (ts
.kind
!= tail
->expr
->ts
.kind
)
2902 gfc_error ("Kind type parameter for entity at %L differs from "
2903 "the kind type parameter of the typespec",
2904 &tail
->expr
->where
);
2909 if (tail
->expr
->ts
.type
== BT_DERIVED
)
2910 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
2912 /* FIXME: disable the checking on derived types and arrays. */
2913 sym
= tail
->expr
->symtree
->n
.sym
;
2914 b1
= !(tail
->expr
->ref
2915 && (tail
->expr
->ref
->type
== REF_COMPONENT
2916 || tail
->expr
->ref
->type
== REF_ARRAY
));
2917 if (sym
&& sym
->ts
.type
== BT_CLASS
)
2918 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
2919 || CLASS_DATA (sym
)->attr
.class_pointer
);
2921 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
2922 || sym
->attr
.proc_pointer
);
2923 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
2924 && (sym
->ns
->proc_name
->attr
.allocatable
2925 || sym
->ns
->proc_name
->attr
.pointer
2926 || sym
->ns
->proc_name
->attr
.proc_pointer
);
2927 if (b1
&& b2
&& !b3
)
2929 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2930 "or an allocatable variable");
2934 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
2936 gfc_error ("Shape specification for allocatable scalar at %C");
2940 if (gfc_match_char (',') != MATCH_YES
)
2945 m
= gfc_match (" stat = %v", &tmp
);
2946 if (m
== MATCH_ERROR
)
2953 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
2960 if (gfc_check_do_variable (stat
->symtree
))
2963 if (gfc_match_char (',') == MATCH_YES
)
2964 goto alloc_opt_list
;
2967 m
= gfc_match (" errmsg = %v", &tmp
);
2968 if (m
== MATCH_ERROR
)
2972 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ERRMSG tag at %L",
2973 &tmp
->where
) == FAILURE
)
2979 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
2986 if (gfc_match_char (',') == MATCH_YES
)
2987 goto alloc_opt_list
;
2990 m
= gfc_match (" source = %e", &tmp
);
2991 if (m
== MATCH_ERROR
)
2995 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: SOURCE tag at %L",
2996 &tmp
->where
) == FAILURE
)
3002 gfc_error ("Redundant SOURCE tag found at %L ", &tmp
->where
);
3006 /* The next 2 conditionals check C631. */
3007 if (ts
.type
!= BT_UNKNOWN
)
3009 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
3010 &tmp
->where
, &old_locus
);
3016 gfc_error ("SOURCE tag at %L requires only a single entity in "
3017 "the allocation-list", &tmp
->where
);
3024 if (gfc_match_char (',') == MATCH_YES
)
3025 goto alloc_opt_list
;
3028 m
= gfc_match (" mold = %e", &tmp
);
3029 if (m
== MATCH_ERROR
)
3033 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: MOLD tag at %L",
3034 &tmp
->where
) == FAILURE
)
3037 /* Check F08:C636. */
3040 gfc_error ("Redundant MOLD tag found at %L ", &tmp
->where
);
3044 /* Check F08:C637. */
3045 if (ts
.type
!= BT_UNKNOWN
)
3047 gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
3048 &tmp
->where
, &old_locus
);
3056 if (gfc_match_char (',') == MATCH_YES
)
3057 goto alloc_opt_list
;
3060 gfc_gobble_whitespace ();
3062 if (gfc_peek_char () == ')')
3067 if (gfc_match (" )%t") != MATCH_YES
)
3070 /* Check F08:C637. */
3073 gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
3074 &mold
->where
, &source
->where
);
3078 new_st
.op
= EXEC_ALLOCATE
;
3079 new_st
.expr1
= stat
;
3080 new_st
.expr2
= errmsg
;
3082 new_st
.expr3
= source
;
3084 new_st
.expr3
= mold
;
3085 new_st
.ext
.alloc
.list
= head
;
3086 new_st
.ext
.alloc
.ts
= ts
;
3091 gfc_syntax_error (ST_ALLOCATE
);
3094 gfc_free_expr (errmsg
);
3095 gfc_free_expr (source
);
3096 gfc_free_expr (stat
);
3097 gfc_free_expr (mold
);
3098 if (tmp
&& tmp
->expr_type
) gfc_free_expr (tmp
);
3099 gfc_free_alloc_list (head
);
3104 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
3105 a set of pointer assignments to intrinsic NULL(). */
3108 gfc_match_nullify (void)
3116 if (gfc_match_char ('(') != MATCH_YES
)
3121 m
= gfc_match_variable (&p
, 0);
3122 if (m
== MATCH_ERROR
)
3127 if (gfc_check_do_variable (p
->symtree
))
3130 if (gfc_pure (NULL
) && gfc_impure_variable (p
->symtree
->n
.sym
))
3132 gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
3136 /* build ' => NULL() '. */
3137 e
= gfc_get_null_expr (&gfc_current_locus
);
3139 /* Chain to list. */
3144 tail
->next
= gfc_get_code ();
3148 tail
->op
= EXEC_POINTER_ASSIGN
;
3152 if (gfc_match (" )%t") == MATCH_YES
)
3154 if (gfc_match_char (',') != MATCH_YES
)
3161 gfc_syntax_error (ST_NULLIFY
);
3164 gfc_free_statements (new_st
.next
);
3166 gfc_free_expr (new_st
.expr1
);
3167 new_st
.expr1
= NULL
;
3168 gfc_free_expr (new_st
.expr2
);
3169 new_st
.expr2
= NULL
;
3174 /* Match a DEALLOCATE statement. */
3177 gfc_match_deallocate (void)
3179 gfc_alloc
*head
, *tail
;
3180 gfc_expr
*stat
, *errmsg
, *tmp
;
3183 bool saw_stat
, saw_errmsg
, b1
, b2
;
3186 stat
= errmsg
= tmp
= NULL
;
3187 saw_stat
= saw_errmsg
= false;
3189 if (gfc_match_char ('(') != MATCH_YES
)
3195 head
= tail
= gfc_get_alloc ();
3198 tail
->next
= gfc_get_alloc ();
3202 m
= gfc_match_variable (&tail
->expr
, 0);
3203 if (m
== MATCH_ERROR
)
3208 if (gfc_check_do_variable (tail
->expr
->symtree
))
3211 sym
= tail
->expr
->symtree
->n
.sym
;
3213 if (gfc_pure (NULL
) && gfc_impure_variable (sym
))
3215 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3219 /* FIXME: disable the checking on derived types. */
3220 b1
= !(tail
->expr
->ref
3221 && (tail
->expr
->ref
->type
== REF_COMPONENT
3222 || tail
->expr
->ref
->type
== REF_ARRAY
));
3223 if (sym
&& sym
->ts
.type
== BT_CLASS
)
3224 b2
= !(CLASS_DATA (sym
)->attr
.allocatable
3225 || CLASS_DATA (sym
)->attr
.class_pointer
);
3227 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
3228 || sym
->attr
.proc_pointer
);
3231 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3232 "or an allocatable variable");
3236 if (gfc_match_char (',') != MATCH_YES
)
3241 m
= gfc_match (" stat = %v", &tmp
);
3242 if (m
== MATCH_ERROR
)
3248 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3249 gfc_free_expr (tmp
);
3256 if (gfc_check_do_variable (stat
->symtree
))
3259 if (gfc_match_char (',') == MATCH_YES
)
3260 goto dealloc_opt_list
;
3263 m
= gfc_match (" errmsg = %v", &tmp
);
3264 if (m
== MATCH_ERROR
)
3268 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ERRMSG at %L",
3269 &tmp
->where
) == FAILURE
)
3274 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3275 gfc_free_expr (tmp
);
3282 if (gfc_match_char (',') == MATCH_YES
)
3283 goto dealloc_opt_list
;
3286 gfc_gobble_whitespace ();
3288 if (gfc_peek_char () == ')')
3292 if (gfc_match (" )%t") != MATCH_YES
)
3295 new_st
.op
= EXEC_DEALLOCATE
;
3296 new_st
.expr1
= stat
;
3297 new_st
.expr2
= errmsg
;
3298 new_st
.ext
.alloc
.list
= head
;
3303 gfc_syntax_error (ST_DEALLOCATE
);
3306 gfc_free_expr (errmsg
);
3307 gfc_free_expr (stat
);
3308 gfc_free_alloc_list (head
);
3313 /* Match a RETURN statement. */
3316 gfc_match_return (void)
3320 gfc_compile_state s
;
3324 if (gfc_find_state (COMP_CRITICAL
) == SUCCESS
)
3326 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
3330 if (gfc_match_eos () == MATCH_YES
)
3333 if (gfc_find_state (COMP_SUBROUTINE
) == FAILURE
)
3335 gfc_error ("Alternate RETURN statement at %C is only allowed within "
3340 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: Alternate RETURN "
3341 "at %C") == FAILURE
)
3344 if (gfc_current_form
== FORM_FREE
)
3346 /* The following are valid, so we can't require a blank after the
3350 char c
= gfc_peek_ascii_char ();
3351 if (ISALPHA (c
) || ISDIGIT (c
))
3355 m
= gfc_match (" %e%t", &e
);
3358 if (m
== MATCH_ERROR
)
3361 gfc_syntax_error (ST_RETURN
);
3368 gfc_enclosing_unit (&s
);
3369 if (s
== COMP_PROGRAM
3370 && gfc_notify_std (GFC_STD_GNU
, "Extension: RETURN statement in "
3371 "main program at %C") == FAILURE
)
3374 new_st
.op
= EXEC_RETURN
;
3381 /* Match the call of a type-bound procedure, if CALL%var has already been
3382 matched and var found to be a derived-type variable. */
3385 match_typebound_call (gfc_symtree
* varst
)
3390 base
= gfc_get_expr ();
3391 base
->expr_type
= EXPR_VARIABLE
;
3392 base
->symtree
= varst
;
3393 base
->where
= gfc_current_locus
;
3394 gfc_set_sym_referenced (varst
->n
.sym
);
3396 m
= gfc_match_varspec (base
, 0, true, true);
3398 gfc_error ("Expected component reference at %C");
3402 if (gfc_match_eos () != MATCH_YES
)
3404 gfc_error ("Junk after CALL at %C");
3408 if (base
->expr_type
== EXPR_COMPCALL
)
3409 new_st
.op
= EXEC_COMPCALL
;
3410 else if (base
->expr_type
== EXPR_PPC
)
3411 new_st
.op
= EXEC_CALL_PPC
;
3414 gfc_error ("Expected type-bound procedure or procedure pointer component "
3418 new_st
.expr1
= base
;
3424 /* Match a CALL statement. The tricky part here are possible
3425 alternate return specifiers. We handle these by having all
3426 "subroutines" actually return an integer via a register that gives
3427 the return number. If the call specifies alternate returns, we
3428 generate code for a SELECT statement whose case clauses contain
3429 GOTOs to the various labels. */
3432 gfc_match_call (void)
3434 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3435 gfc_actual_arglist
*a
, *arglist
;
3445 m
= gfc_match ("% %n", name
);
3451 if (gfc_get_ha_sym_tree (name
, &st
))
3456 /* If this is a variable of derived-type, it probably starts a type-bound
3458 if ((sym
->attr
.flavor
!= FL_PROCEDURE
3459 || gfc_is_function_return_value (sym
, gfc_current_ns
))
3460 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
3461 return match_typebound_call (st
);
3463 /* If it does not seem to be callable (include functions so that the
3464 right association is made. They are thrown out in resolution.)
3466 if (!sym
->attr
.generic
3467 && !sym
->attr
.subroutine
3468 && !sym
->attr
.function
)
3470 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
3472 /* ...create a symbol in this scope... */
3473 if (sym
->ns
!= gfc_current_ns
3474 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
3477 if (sym
!= st
->n
.sym
)
3481 /* ...and then to try to make the symbol into a subroutine. */
3482 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3486 gfc_set_sym_referenced (sym
);
3488 if (gfc_match_eos () != MATCH_YES
)
3490 m
= gfc_match_actual_arglist (1, &arglist
);
3493 if (m
== MATCH_ERROR
)
3496 if (gfc_match_eos () != MATCH_YES
)
3500 /* If any alternate return labels were found, construct a SELECT
3501 statement that will jump to the right place. */
3504 for (a
= arglist
; a
; a
= a
->next
)
3505 if (a
->expr
== NULL
)
3510 gfc_symtree
*select_st
;
3511 gfc_symbol
*select_sym
;
3512 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3514 new_st
.next
= c
= gfc_get_code ();
3515 c
->op
= EXEC_SELECT
;
3516 sprintf (name
, "_result_%s", sym
->name
);
3517 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
3519 select_sym
= select_st
->n
.sym
;
3520 select_sym
->ts
.type
= BT_INTEGER
;
3521 select_sym
->ts
.kind
= gfc_default_integer_kind
;
3522 gfc_set_sym_referenced (select_sym
);
3523 c
->expr1
= gfc_get_expr ();
3524 c
->expr1
->expr_type
= EXPR_VARIABLE
;
3525 c
->expr1
->symtree
= select_st
;
3526 c
->expr1
->ts
= select_sym
->ts
;
3527 c
->expr1
->where
= gfc_current_locus
;
3530 for (a
= arglist
; a
; a
= a
->next
)
3532 if (a
->expr
!= NULL
)
3535 if (gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
) == FAILURE
)
3540 c
->block
= gfc_get_code ();
3542 c
->op
= EXEC_SELECT
;
3544 new_case
= gfc_get_case ();
3545 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
3546 new_case
->low
= new_case
->high
;
3547 c
->ext
.case_list
= new_case
;
3549 c
->next
= gfc_get_code ();
3550 c
->next
->op
= EXEC_GOTO
;
3551 c
->next
->label1
= a
->label
;
3555 new_st
.op
= EXEC_CALL
;
3556 new_st
.symtree
= st
;
3557 new_st
.ext
.actual
= arglist
;
3562 gfc_syntax_error (ST_CALL
);
3565 gfc_free_actual_arglist (arglist
);
3570 /* Given a name, return a pointer to the common head structure,
3571 creating it if it does not exist. If FROM_MODULE is nonzero, we
3572 mangle the name so that it doesn't interfere with commons defined
3573 in the using namespace.
3574 TODO: Add to global symbol tree. */
3577 gfc_get_common (const char *name
, int from_module
)
3580 static int serial
= 0;
3581 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
3585 /* A use associated common block is only needed to correctly layout
3586 the variables it contains. */
3587 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
3588 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
3592 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
3595 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
3598 if (st
->n
.common
== NULL
)
3600 st
->n
.common
= gfc_get_common_head ();
3601 st
->n
.common
->where
= gfc_current_locus
;
3602 strcpy (st
->n
.common
->name
, name
);
3605 return st
->n
.common
;
3609 /* Match a common block name. */
3611 match
match_common_name (char *name
)
3615 if (gfc_match_char ('/') == MATCH_NO
)
3621 if (gfc_match_char ('/') == MATCH_YES
)
3627 m
= gfc_match_name (name
);
3629 if (m
== MATCH_ERROR
)
3631 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
3634 gfc_error ("Syntax error in common block name at %C");
3639 /* Match a COMMON statement. */
3642 gfc_match_common (void)
3644 gfc_symbol
*sym
, **head
, *tail
, *other
, *old_blank_common
;
3645 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3652 old_blank_common
= gfc_current_ns
->blank_common
.head
;
3653 if (old_blank_common
)
3655 while (old_blank_common
->common_next
)
3656 old_blank_common
= old_blank_common
->common_next
;
3663 m
= match_common_name (name
);
3664 if (m
== MATCH_ERROR
)
3667 gsym
= gfc_get_gsymbol (name
);
3668 if (gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= GSYM_COMMON
)
3670 gfc_error ("Symbol '%s' at %C is already an external symbol that "
3671 "is not COMMON", name
);
3675 if (gsym
->type
== GSYM_UNKNOWN
)
3677 gsym
->type
= GSYM_COMMON
;
3678 gsym
->where
= gfc_current_locus
;
3684 if (name
[0] == '\0')
3686 t
= &gfc_current_ns
->blank_common
;
3687 if (t
->head
== NULL
)
3688 t
->where
= gfc_current_locus
;
3692 t
= gfc_get_common (name
, 0);
3701 while (tail
->common_next
)
3702 tail
= tail
->common_next
;
3705 /* Grab the list of symbols. */
3708 m
= gfc_match_symbol (&sym
, 0);
3709 if (m
== MATCH_ERROR
)
3714 /* Store a ref to the common block for error checking. */
3715 sym
->common_block
= t
;
3717 /* See if we know the current common block is bind(c), and if
3718 so, then see if we can check if the symbol is (which it'll
3719 need to be). This can happen if the bind(c) attr stmt was
3720 applied to the common block, and the variable(s) already
3721 defined, before declaring the common block. */
3722 if (t
->is_bind_c
== 1)
3724 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
3726 /* If we find an error, just print it and continue,
3727 cause it's just semantic, and we can see if there
3729 gfc_error_now ("Variable '%s' at %L in common block '%s' "
3730 "at %C must be declared with a C "
3731 "interoperable kind since common block "
3733 sym
->name
, &(sym
->declared_at
), t
->name
,
3737 if (sym
->attr
.is_bind_c
== 1)
3738 gfc_error_now ("Variable '%s' in common block "
3739 "'%s' at %C can not be bind(c) since "
3740 "it is not global", sym
->name
, t
->name
);
3743 if (sym
->attr
.in_common
)
3745 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
3750 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
3751 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
3753 if (gfc_notify_std (GFC_STD_GNU
, "Initialized symbol '%s' at %C "
3754 "can only be COMMON in "
3755 "BLOCK DATA", sym
->name
)
3760 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3764 tail
->common_next
= sym
;
3770 /* Deal with an optional array specification after the
3772 m
= gfc_match_array_spec (&as
, true, true);
3773 if (m
== MATCH_ERROR
)
3778 if (as
->type
!= AS_EXPLICIT
)
3780 gfc_error ("Array specification for symbol '%s' in COMMON "
3781 "at %C must be explicit", sym
->name
);
3785 if (gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3788 if (sym
->attr
.pointer
)
3790 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
3791 "POINTER array", sym
->name
);
3800 sym
->common_head
= t
;
3802 /* Check to see if the symbol is already in an equivalence group.
3803 If it is, set the other members as being in common. */
3804 if (sym
->attr
.in_equivalence
)
3806 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
3808 for (e2
= e1
; e2
; e2
= e2
->eq
)
3809 if (e2
->expr
->symtree
->n
.sym
== sym
)
3816 for (e2
= e1
; e2
; e2
= e2
->eq
)
3818 other
= e2
->expr
->symtree
->n
.sym
;
3819 if (other
->common_head
3820 && other
->common_head
!= sym
->common_head
)
3822 gfc_error ("Symbol '%s', in COMMON block '%s' at "
3823 "%C is being indirectly equivalenced to "
3824 "another COMMON block '%s'",
3825 sym
->name
, sym
->common_head
->name
,
3826 other
->common_head
->name
);
3829 other
->attr
.in_common
= 1;
3830 other
->common_head
= t
;
3836 gfc_gobble_whitespace ();
3837 if (gfc_match_eos () == MATCH_YES
)
3839 if (gfc_peek_ascii_char () == '/')
3841 if (gfc_match_char (',') != MATCH_YES
)
3843 gfc_gobble_whitespace ();
3844 if (gfc_peek_ascii_char () == '/')
3853 gfc_syntax_error (ST_COMMON
);
3856 if (old_blank_common
)
3857 old_blank_common
->common_next
= NULL
;
3859 gfc_current_ns
->blank_common
.head
= NULL
;
3860 gfc_free_array_spec (as
);
3865 /* Match a BLOCK DATA program unit. */
3868 gfc_match_block_data (void)
3870 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3874 if (gfc_match_eos () == MATCH_YES
)
3876 gfc_new_block
= NULL
;
3880 m
= gfc_match ("% %n%t", name
);
3884 if (gfc_get_symbol (name
, NULL
, &sym
))
3887 if (gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
) == FAILURE
)
3890 gfc_new_block
= sym
;
3896 /* Free a namelist structure. */
3899 gfc_free_namelist (gfc_namelist
*name
)
3903 for (; name
; name
= n
)
3911 /* Match a NAMELIST statement. */
3914 gfc_match_namelist (void)
3916 gfc_symbol
*group_name
, *sym
;
3920 m
= gfc_match (" / %s /", &group_name
);
3923 if (m
== MATCH_ERROR
)
3928 if (group_name
->ts
.type
!= BT_UNKNOWN
)
3930 gfc_error ("Namelist group name '%s' at %C already has a basic "
3931 "type of %s", group_name
->name
,
3932 gfc_typename (&group_name
->ts
));
3936 if (group_name
->attr
.flavor
== FL_NAMELIST
3937 && group_name
->attr
.use_assoc
3938 && gfc_notify_std (GFC_STD_GNU
, "Namelist group name '%s' "
3939 "at %C already is USE associated and can"
3940 "not be respecified.", group_name
->name
)
3944 if (group_name
->attr
.flavor
!= FL_NAMELIST
3945 && gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
3946 group_name
->name
, NULL
) == FAILURE
)
3951 m
= gfc_match_symbol (&sym
, 1);
3954 if (m
== MATCH_ERROR
)
3957 if (sym
->attr
.in_namelist
== 0
3958 && gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3961 /* Use gfc_error_check here, rather than goto error, so that
3962 these are the only errors for the next two lines. */
3963 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
3965 gfc_error ("Assumed size array '%s' in namelist '%s' at "
3966 "%C is not allowed", sym
->name
, group_name
->name
);
3970 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
->length
== NULL
)
3972 gfc_error ("Assumed character length '%s' in namelist '%s' at "
3973 "%C is not allowed", sym
->name
, group_name
->name
);
3977 nl
= gfc_get_namelist ();
3981 if (group_name
->namelist
== NULL
)
3982 group_name
->namelist
= group_name
->namelist_tail
= nl
;
3985 group_name
->namelist_tail
->next
= nl
;
3986 group_name
->namelist_tail
= nl
;
3989 if (gfc_match_eos () == MATCH_YES
)
3992 m
= gfc_match_char (',');
3994 if (gfc_match_char ('/') == MATCH_YES
)
3996 m2
= gfc_match (" %s /", &group_name
);
3997 if (m2
== MATCH_YES
)
3999 if (m2
== MATCH_ERROR
)
4013 gfc_syntax_error (ST_NAMELIST
);
4020 /* Match a MODULE statement. */
4023 gfc_match_module (void)
4027 m
= gfc_match (" %s%t", &gfc_new_block
);
4031 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
4032 gfc_new_block
->name
, NULL
) == FAILURE
)
4039 /* Free equivalence sets and lists. Recursively is the easiest way to
4043 gfc_free_equiv_until (gfc_equiv
*eq
, gfc_equiv
*stop
)
4048 gfc_free_equiv (eq
->eq
);
4049 gfc_free_equiv_until (eq
->next
, stop
);
4050 gfc_free_expr (eq
->expr
);
4056 gfc_free_equiv (gfc_equiv
*eq
)
4058 gfc_free_equiv_until (eq
, NULL
);
4062 /* Match an EQUIVALENCE statement. */
4065 gfc_match_equivalence (void)
4067 gfc_equiv
*eq
, *set
, *tail
;
4071 gfc_common_head
*common_head
= NULL
;
4079 eq
= gfc_get_equiv ();
4083 eq
->next
= gfc_current_ns
->equiv
;
4084 gfc_current_ns
->equiv
= eq
;
4086 if (gfc_match_char ('(') != MATCH_YES
)
4090 common_flag
= FALSE
;
4095 m
= gfc_match_equiv_variable (&set
->expr
);
4096 if (m
== MATCH_ERROR
)
4101 /* count the number of objects. */
4104 if (gfc_match_char ('%') == MATCH_YES
)
4106 gfc_error ("Derived type component %C is not a "
4107 "permitted EQUIVALENCE member");
4111 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
4112 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
4114 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
4115 "be an array section");
4119 sym
= set
->expr
->symtree
->n
.sym
;
4121 if (gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
4124 if (sym
->attr
.in_common
)
4127 common_head
= sym
->common_head
;
4130 if (gfc_match_char (')') == MATCH_YES
)
4133 if (gfc_match_char (',') != MATCH_YES
)
4136 set
->eq
= gfc_get_equiv ();
4142 gfc_error ("EQUIVALENCE at %C requires two or more objects");
4146 /* If one of the members of an equivalence is in common, then
4147 mark them all as being in common. Before doing this, check
4148 that members of the equivalence group are not in different
4151 for (set
= eq
; set
; set
= set
->eq
)
4153 sym
= set
->expr
->symtree
->n
.sym
;
4154 if (sym
->common_head
&& sym
->common_head
!= common_head
)
4156 gfc_error ("Attempt to indirectly overlap COMMON "
4157 "blocks %s and %s by EQUIVALENCE at %C",
4158 sym
->common_head
->name
, common_head
->name
);
4161 sym
->attr
.in_common
= 1;
4162 sym
->common_head
= common_head
;
4165 if (gfc_match_eos () == MATCH_YES
)
4167 if (gfc_match_char (',') != MATCH_YES
)
4169 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
4177 gfc_syntax_error (ST_EQUIVALENCE
);
4183 gfc_free_equiv (gfc_current_ns
->equiv
);
4184 gfc_current_ns
->equiv
= eq
;
4190 /* Check that a statement function is not recursive. This is done by looking
4191 for the statement function symbol(sym) by looking recursively through its
4192 expression(e). If a reference to sym is found, true is returned.
4193 12.5.4 requires that any variable of function that is implicitly typed
4194 shall have that type confirmed by any subsequent type declaration. The
4195 implicit typing is conveniently done here. */
4197 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
4200 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
4206 switch (e
->expr_type
)
4209 if (e
->symtree
== NULL
)
4212 /* Check the name before testing for nested recursion! */
4213 if (sym
->name
== e
->symtree
->n
.sym
->name
)
4216 /* Catch recursion via other statement functions. */
4217 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
4218 && e
->symtree
->n
.sym
->value
4219 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
4222 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
4223 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
4228 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
4231 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
4232 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
4244 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
4246 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
4250 /* Match a statement function declaration. It is so easy to match
4251 non-statement function statements with a MATCH_ERROR as opposed to
4252 MATCH_NO that we suppress error message in most cases. */
4255 gfc_match_st_function (void)
4257 gfc_error_buf old_error
;
4262 m
= gfc_match_symbol (&sym
, 0);
4266 gfc_push_error (&old_error
);
4268 if (gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
,
4269 sym
->name
, NULL
) == FAILURE
)
4272 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
4275 m
= gfc_match (" = %e%t", &expr
);
4279 gfc_free_error (&old_error
);
4280 if (m
== MATCH_ERROR
)
4283 if (recursive_stmt_fcn (expr
, sym
))
4285 gfc_error ("Statement function at %L is recursive", &expr
->where
);
4291 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: "
4292 "Statement function at %C") == FAILURE
)
4298 gfc_pop_error (&old_error
);
4303 /***************** SELECT CASE subroutines ******************/
4305 /* Free a single case structure. */
4308 free_case (gfc_case
*p
)
4310 if (p
->low
== p
->high
)
4312 gfc_free_expr (p
->low
);
4313 gfc_free_expr (p
->high
);
4318 /* Free a list of case structures. */
4321 gfc_free_case_list (gfc_case
*p
)
4333 /* Match a single case selector. */
4336 match_case_selector (gfc_case
**cp
)
4341 c
= gfc_get_case ();
4342 c
->where
= gfc_current_locus
;
4344 if (gfc_match_char (':') == MATCH_YES
)
4346 m
= gfc_match_init_expr (&c
->high
);
4349 if (m
== MATCH_ERROR
)
4354 m
= gfc_match_init_expr (&c
->low
);
4355 if (m
== MATCH_ERROR
)
4360 /* If we're not looking at a ':' now, make a range out of a single
4361 target. Else get the upper bound for the case range. */
4362 if (gfc_match_char (':') != MATCH_YES
)
4366 m
= gfc_match_init_expr (&c
->high
);
4367 if (m
== MATCH_ERROR
)
4369 /* MATCH_NO is fine. It's OK if nothing is there! */
4377 gfc_error ("Expected initialization expression in CASE at %C");
4385 /* Match the end of a case statement. */
4388 match_case_eos (void)
4390 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4393 if (gfc_match_eos () == MATCH_YES
)
4396 /* If the case construct doesn't have a case-construct-name, we
4397 should have matched the EOS. */
4398 if (!gfc_current_block ())
4401 gfc_gobble_whitespace ();
4403 m
= gfc_match_name (name
);
4407 if (strcmp (name
, gfc_current_block ()->name
) != 0)
4409 gfc_error ("Expected block name '%s' of SELECT construct at %C",
4410 gfc_current_block ()->name
);
4414 return gfc_match_eos ();
4418 /* Match a SELECT statement. */
4421 gfc_match_select (void)
4426 m
= gfc_match_label ();
4427 if (m
== MATCH_ERROR
)
4430 m
= gfc_match (" select case ( %e )%t", &expr
);
4434 new_st
.op
= EXEC_SELECT
;
4435 new_st
.expr1
= expr
;
4441 /* Push the current selector onto the SELECT TYPE stack. */
4444 select_type_push (gfc_symbol
*sel
)
4446 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
4447 top
->selector
= sel
;
4449 top
->prev
= select_type_stack
;
4451 select_type_stack
= top
;
4455 /* Set the temporary for the current SELECT TYPE selector. */
4458 select_type_set_tmp (gfc_typespec
*ts
)
4460 char name
[GFC_MAX_SYMBOL_LEN
];
4463 if (!gfc_type_is_extensible (ts
->u
.derived
))
4466 if (ts
->type
== BT_CLASS
)
4467 sprintf (name
, "tmp$class$%s", ts
->u
.derived
->name
);
4469 sprintf (name
, "tmp$type$%s", ts
->u
.derived
->name
);
4470 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
4471 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
4472 gfc_set_sym_referenced (tmp
->n
.sym
);
4473 gfc_add_pointer (&tmp
->n
.sym
->attr
, NULL
);
4474 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
4475 if (ts
->type
== BT_CLASS
)
4477 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
4478 &tmp
->n
.sym
->as
, false);
4479 tmp
->n
.sym
->attr
.class_ok
= 1;
4482 select_type_stack
->tmp
= tmp
;
4486 /* Match a SELECT TYPE statement. */
4489 gfc_match_select_type (void)
4491 gfc_expr
*expr1
, *expr2
= NULL
;
4493 char name
[GFC_MAX_SYMBOL_LEN
];
4495 m
= gfc_match_label ();
4496 if (m
== MATCH_ERROR
)
4499 m
= gfc_match (" select type ( ");
4503 gfc_current_ns
= gfc_build_block_ns (gfc_current_ns
);
4505 m
= gfc_match (" %n => %e", name
, &expr2
);
4508 expr1
= gfc_get_expr();
4509 expr1
->expr_type
= EXPR_VARIABLE
;
4510 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
4515 if (expr2
->ts
.type
== BT_UNKNOWN
)
4516 expr1
->symtree
->n
.sym
->attr
.untyped
= 1;
4518 expr1
->symtree
->n
.sym
->ts
= expr2
->ts
;
4519 expr1
->symtree
->n
.sym
->attr
.referenced
= 1;
4520 expr1
->symtree
->n
.sym
->attr
.class_ok
= 1;
4524 m
= gfc_match (" %e ", &expr1
);
4529 m
= gfc_match (" )%t");
4533 /* Check for F03:C811. */
4534 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
|| expr1
->ref
!= NULL
))
4536 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
4537 "use associate-name=>");
4542 new_st
.op
= EXEC_SELECT_TYPE
;
4543 new_st
.expr1
= expr1
;
4544 new_st
.expr2
= expr2
;
4545 new_st
.ext
.block
.ns
= gfc_current_ns
;
4547 select_type_push (expr1
->symtree
->n
.sym
);
4552 gfc_current_ns
= gfc_current_ns
->parent
;
4557 /* Match a CASE statement. */
4560 gfc_match_case (void)
4562 gfc_case
*c
, *head
, *tail
;
4567 if (gfc_current_state () != COMP_SELECT
)
4569 gfc_error ("Unexpected CASE statement at %C");
4573 if (gfc_match ("% default") == MATCH_YES
)
4575 m
= match_case_eos ();
4578 if (m
== MATCH_ERROR
)
4581 new_st
.op
= EXEC_SELECT
;
4582 c
= gfc_get_case ();
4583 c
->where
= gfc_current_locus
;
4584 new_st
.ext
.case_list
= c
;
4588 if (gfc_match_char ('(') != MATCH_YES
)
4593 if (match_case_selector (&c
) == MATCH_ERROR
)
4603 if (gfc_match_char (')') == MATCH_YES
)
4605 if (gfc_match_char (',') != MATCH_YES
)
4609 m
= match_case_eos ();
4612 if (m
== MATCH_ERROR
)
4615 new_st
.op
= EXEC_SELECT
;
4616 new_st
.ext
.case_list
= head
;
4621 gfc_error ("Syntax error in CASE specification at %C");
4624 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
4629 /* Match a TYPE IS statement. */
4632 gfc_match_type_is (void)
4637 if (gfc_current_state () != COMP_SELECT_TYPE
)
4639 gfc_error ("Unexpected TYPE IS statement at %C");
4643 if (gfc_match_char ('(') != MATCH_YES
)
4646 c
= gfc_get_case ();
4647 c
->where
= gfc_current_locus
;
4649 /* TODO: Once unlimited polymorphism is implemented, we will need to call
4650 match_type_spec here. */
4651 if (match_derived_type_spec (&c
->ts
) == MATCH_ERROR
)
4654 if (gfc_match_char (')') != MATCH_YES
)
4657 m
= match_case_eos ();
4660 if (m
== MATCH_ERROR
)
4663 new_st
.op
= EXEC_SELECT_TYPE
;
4664 new_st
.ext
.case_list
= c
;
4666 /* Create temporary variable. */
4667 select_type_set_tmp (&c
->ts
);
4672 gfc_error ("Syntax error in TYPE IS specification at %C");
4676 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
4681 /* Match a CLASS IS or CLASS DEFAULT statement. */
4684 gfc_match_class_is (void)
4689 if (gfc_current_state () != COMP_SELECT_TYPE
)
4692 if (gfc_match ("% default") == MATCH_YES
)
4694 m
= match_case_eos ();
4697 if (m
== MATCH_ERROR
)
4700 new_st
.op
= EXEC_SELECT_TYPE
;
4701 c
= gfc_get_case ();
4702 c
->where
= gfc_current_locus
;
4703 c
->ts
.type
= BT_UNKNOWN
;
4704 new_st
.ext
.case_list
= c
;
4708 m
= gfc_match ("% is");
4711 if (m
== MATCH_ERROR
)
4714 if (gfc_match_char ('(') != MATCH_YES
)
4717 c
= gfc_get_case ();
4718 c
->where
= gfc_current_locus
;
4720 if (match_derived_type_spec (&c
->ts
) == MATCH_ERROR
)
4723 if (c
->ts
.type
== BT_DERIVED
)
4724 c
->ts
.type
= BT_CLASS
;
4726 if (gfc_match_char (')') != MATCH_YES
)
4729 m
= match_case_eos ();
4732 if (m
== MATCH_ERROR
)
4735 new_st
.op
= EXEC_SELECT_TYPE
;
4736 new_st
.ext
.case_list
= c
;
4738 /* Create temporary variable. */
4739 select_type_set_tmp (&c
->ts
);
4744 gfc_error ("Syntax error in CLASS IS specification at %C");
4748 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
4753 /********************* WHERE subroutines ********************/
4755 /* Match the rest of a simple WHERE statement that follows an IF statement.
4759 match_simple_where (void)
4765 m
= gfc_match (" ( %e )", &expr
);
4769 m
= gfc_match_assignment ();
4772 if (m
== MATCH_ERROR
)
4775 if (gfc_match_eos () != MATCH_YES
)
4778 c
= gfc_get_code ();
4782 c
->next
= gfc_get_code ();
4785 gfc_clear_new_st ();
4787 new_st
.op
= EXEC_WHERE
;
4793 gfc_syntax_error (ST_WHERE
);
4796 gfc_free_expr (expr
);
4801 /* Match a WHERE statement. */
4804 gfc_match_where (gfc_statement
*st
)
4810 m0
= gfc_match_label ();
4811 if (m0
== MATCH_ERROR
)
4814 m
= gfc_match (" where ( %e )", &expr
);
4818 if (gfc_match_eos () == MATCH_YES
)
4820 *st
= ST_WHERE_BLOCK
;
4821 new_st
.op
= EXEC_WHERE
;
4822 new_st
.expr1
= expr
;
4826 m
= gfc_match_assignment ();
4828 gfc_syntax_error (ST_WHERE
);
4832 gfc_free_expr (expr
);
4836 /* We've got a simple WHERE statement. */
4838 c
= gfc_get_code ();
4842 c
->next
= gfc_get_code ();
4845 gfc_clear_new_st ();
4847 new_st
.op
= EXEC_WHERE
;
4854 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
4855 new_st if successful. */
4858 gfc_match_elsewhere (void)
4860 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4864 if (gfc_current_state () != COMP_WHERE
)
4866 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
4872 if (gfc_match_char ('(') == MATCH_YES
)
4874 m
= gfc_match_expr (&expr
);
4877 if (m
== MATCH_ERROR
)
4880 if (gfc_match_char (')') != MATCH_YES
)
4884 if (gfc_match_eos () != MATCH_YES
)
4886 /* Only makes sense if we have a where-construct-name. */
4887 if (!gfc_current_block ())
4892 /* Better be a name at this point. */
4893 m
= gfc_match_name (name
);
4896 if (m
== MATCH_ERROR
)
4899 if (gfc_match_eos () != MATCH_YES
)
4902 if (strcmp (name
, gfc_current_block ()->name
) != 0)
4904 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
4905 name
, gfc_current_block ()->name
);
4910 new_st
.op
= EXEC_WHERE
;
4911 new_st
.expr1
= expr
;
4915 gfc_syntax_error (ST_ELSEWHERE
);
4918 gfc_free_expr (expr
);
4923 /******************** FORALL subroutines ********************/
4925 /* Free a list of FORALL iterators. */
4928 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
4930 gfc_forall_iterator
*next
;
4935 gfc_free_expr (iter
->var
);
4936 gfc_free_expr (iter
->start
);
4937 gfc_free_expr (iter
->end
);
4938 gfc_free_expr (iter
->stride
);
4945 /* Match an iterator as part of a FORALL statement. The format is:
4947 <var> = <start>:<end>[:<stride>]
4949 On MATCH_NO, the caller tests for the possibility that there is a
4950 scalar mask expression. */
4953 match_forall_iterator (gfc_forall_iterator
**result
)
4955 gfc_forall_iterator
*iter
;
4959 where
= gfc_current_locus
;
4960 iter
= XCNEW (gfc_forall_iterator
);
4962 m
= gfc_match_expr (&iter
->var
);
4966 if (gfc_match_char ('=') != MATCH_YES
4967 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
4973 m
= gfc_match_expr (&iter
->start
);
4977 if (gfc_match_char (':') != MATCH_YES
)
4980 m
= gfc_match_expr (&iter
->end
);
4983 if (m
== MATCH_ERROR
)
4986 if (gfc_match_char (':') == MATCH_NO
)
4987 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4990 m
= gfc_match_expr (&iter
->stride
);
4993 if (m
== MATCH_ERROR
)
4997 /* Mark the iteration variable's symbol as used as a FORALL index. */
4998 iter
->var
->symtree
->n
.sym
->forall_index
= true;
5004 gfc_error ("Syntax error in FORALL iterator at %C");
5009 gfc_current_locus
= where
;
5010 gfc_free_forall_iterator (iter
);
5015 /* Match the header of a FORALL statement. */
5018 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
5020 gfc_forall_iterator
*head
, *tail
, *new_iter
;
5024 gfc_gobble_whitespace ();
5029 if (gfc_match_char ('(') != MATCH_YES
)
5032 m
= match_forall_iterator (&new_iter
);
5033 if (m
== MATCH_ERROR
)
5038 head
= tail
= new_iter
;
5042 if (gfc_match_char (',') != MATCH_YES
)
5045 m
= match_forall_iterator (&new_iter
);
5046 if (m
== MATCH_ERROR
)
5051 tail
->next
= new_iter
;
5056 /* Have to have a mask expression. */
5058 m
= gfc_match_expr (&msk
);
5061 if (m
== MATCH_ERROR
)
5067 if (gfc_match_char (')') == MATCH_NO
)
5075 gfc_syntax_error (ST_FORALL
);
5078 gfc_free_expr (msk
);
5079 gfc_free_forall_iterator (head
);
5084 /* Match the rest of a simple FORALL statement that follows an
5088 match_simple_forall (void)
5090 gfc_forall_iterator
*head
;
5099 m
= match_forall_header (&head
, &mask
);
5106 m
= gfc_match_assignment ();
5108 if (m
== MATCH_ERROR
)
5112 m
= gfc_match_pointer_assignment ();
5113 if (m
== MATCH_ERROR
)
5119 c
= gfc_get_code ();
5121 c
->loc
= gfc_current_locus
;
5123 if (gfc_match_eos () != MATCH_YES
)
5126 gfc_clear_new_st ();
5127 new_st
.op
= EXEC_FORALL
;
5128 new_st
.expr1
= mask
;
5129 new_st
.ext
.forall_iterator
= head
;
5130 new_st
.block
= gfc_get_code ();
5132 new_st
.block
->op
= EXEC_FORALL
;
5133 new_st
.block
->next
= c
;
5138 gfc_syntax_error (ST_FORALL
);
5141 gfc_free_forall_iterator (head
);
5142 gfc_free_expr (mask
);
5148 /* Match a FORALL statement. */
5151 gfc_match_forall (gfc_statement
*st
)
5153 gfc_forall_iterator
*head
;
5162 m0
= gfc_match_label ();
5163 if (m0
== MATCH_ERROR
)
5166 m
= gfc_match (" forall");
5170 m
= match_forall_header (&head
, &mask
);
5171 if (m
== MATCH_ERROR
)
5176 if (gfc_match_eos () == MATCH_YES
)
5178 *st
= ST_FORALL_BLOCK
;
5179 new_st
.op
= EXEC_FORALL
;
5180 new_st
.expr1
= mask
;
5181 new_st
.ext
.forall_iterator
= head
;
5185 m
= gfc_match_assignment ();
5186 if (m
== MATCH_ERROR
)
5190 m
= gfc_match_pointer_assignment ();
5191 if (m
== MATCH_ERROR
)
5197 c
= gfc_get_code ();
5199 c
->loc
= gfc_current_locus
;
5201 gfc_clear_new_st ();
5202 new_st
.op
= EXEC_FORALL
;
5203 new_st
.expr1
= mask
;
5204 new_st
.ext
.forall_iterator
= head
;
5205 new_st
.block
= gfc_get_code ();
5206 new_st
.block
->op
= EXEC_FORALL
;
5207 new_st
.block
->next
= c
;
5213 gfc_syntax_error (ST_FORALL
);
5216 gfc_free_forall_iterator (head
);
5217 gfc_free_expr (mask
);
5218 gfc_free_statements (c
);