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 a DO statement. */
1805 gfc_iterator iter
, *ip
;
1807 gfc_st_label
*label
;
1810 old_loc
= gfc_current_locus
;
1813 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
1815 m
= gfc_match_label ();
1816 if (m
== MATCH_ERROR
)
1819 if (gfc_match (" do") != MATCH_YES
)
1822 m
= gfc_match_st_label (&label
);
1823 if (m
== MATCH_ERROR
)
1826 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
1828 if (gfc_match_eos () == MATCH_YES
)
1830 iter
.end
= gfc_get_logical_expr (gfc_default_logical_kind
, NULL
, true);
1831 new_st
.op
= EXEC_DO_WHILE
;
1835 /* Match an optional comma, if no comma is found, a space is obligatory. */
1836 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
1839 /* Check for balanced parens. */
1841 if (gfc_match_parens () == MATCH_ERROR
)
1844 /* See if we have a DO WHILE. */
1845 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
1847 new_st
.op
= EXEC_DO_WHILE
;
1851 /* The abortive DO WHILE may have done something to the symbol
1852 table, so we start over. */
1853 gfc_undo_symbols ();
1854 gfc_current_locus
= old_loc
;
1856 gfc_match_label (); /* This won't error. */
1857 gfc_match (" do "); /* This will work. */
1859 gfc_match_st_label (&label
); /* Can't error out. */
1860 gfc_match_char (','); /* Optional comma. */
1862 m
= gfc_match_iterator (&iter
, 0);
1865 if (m
== MATCH_ERROR
)
1868 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
1869 gfc_check_do_variable (iter
.var
->symtree
);
1871 if (gfc_match_eos () != MATCH_YES
)
1873 gfc_syntax_error (ST_DO
);
1877 new_st
.op
= EXEC_DO
;
1881 && gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1884 new_st
.label1
= label
;
1886 if (new_st
.op
== EXEC_DO_WHILE
)
1887 new_st
.expr1
= iter
.end
;
1890 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
1897 gfc_free_iterator (&iter
, 0);
1903 /* Match an EXIT or CYCLE statement. */
1906 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
1908 gfc_state_data
*p
, *o
;
1912 if (gfc_match_eos () == MATCH_YES
)
1916 m
= gfc_match ("% %s%t", &sym
);
1917 if (m
== MATCH_ERROR
)
1921 gfc_syntax_error (st
);
1925 if (sym
->attr
.flavor
!= FL_LABEL
)
1927 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1928 sym
->name
, gfc_ascii_statement (st
));
1933 /* Find the loop mentioned specified by the label (or lack of a label). */
1934 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
1935 if (p
->state
== COMP_DO
&& (sym
== NULL
|| sym
== p
->sym
))
1937 else if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
1939 else if (p
->state
== COMP_CRITICAL
)
1941 gfc_error("%s statement at %C leaves CRITICAL construct",
1942 gfc_ascii_statement (st
));
1949 gfc_error ("%s statement at %C is not within a loop",
1950 gfc_ascii_statement (st
));
1952 gfc_error ("%s statement at %C is not within loop '%s'",
1953 gfc_ascii_statement (st
), sym
->name
);
1960 gfc_error ("%s statement at %C leaving OpenMP structured block",
1961 gfc_ascii_statement (st
));
1964 else if (st
== ST_EXIT
1965 && p
->previous
!= NULL
1966 && p
->previous
->state
== COMP_OMP_STRUCTURED_BLOCK
1967 && (p
->previous
->head
->op
== EXEC_OMP_DO
1968 || p
->previous
->head
->op
== EXEC_OMP_PARALLEL_DO
))
1970 gcc_assert (p
->previous
->head
->next
!= NULL
);
1971 gcc_assert (p
->previous
->head
->next
->op
== EXEC_DO
1972 || p
->previous
->head
->next
->op
== EXEC_DO_WHILE
);
1973 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1977 /* Save the first statement in the loop - needed by the backend. */
1978 new_st
.ext
.whichloop
= p
->head
;
1986 /* Match the EXIT statement. */
1989 gfc_match_exit (void)
1991 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
1995 /* Match the CYCLE statement. */
1998 gfc_match_cycle (void)
2000 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
2004 /* Match a number or character constant after an (ALL) STOP or PAUSE statement. */
2007 gfc_match_stopcode (gfc_statement st
)
2017 if (gfc_match_eos () != MATCH_YES
)
2019 m
= gfc_match_small_literal_int (&stop_code
, &cnt
);
2020 if (m
== MATCH_ERROR
)
2023 if (m
== MATCH_YES
&& cnt
> 5)
2025 gfc_error ("Too many digits in STOP code at %C");
2031 /* Try a character constant. */
2032 m
= gfc_match_expr (&e
);
2033 if (m
== MATCH_ERROR
)
2037 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
2041 if (gfc_match_eos () != MATCH_YES
)
2045 if (gfc_pure (NULL
))
2047 gfc_error ("%s statement not allowed in PURE procedure at %C",
2048 gfc_ascii_statement (st
));
2052 if (st
== ST_STOP
&& gfc_find_state (COMP_CRITICAL
) == SUCCESS
)
2054 gfc_error ("Image control statement STOP at %C in CRITICAL block");
2061 new_st
.op
= EXEC_STOP
;
2064 new_st
.op
= EXEC_ERROR_STOP
;
2067 new_st
.op
= EXEC_PAUSE
;
2074 new_st
.ext
.stop_code
= stop_code
;
2079 gfc_syntax_error (st
);
2088 /* Match the (deprecated) PAUSE statement. */
2091 gfc_match_pause (void)
2095 m
= gfc_match_stopcode (ST_PAUSE
);
2098 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: PAUSE statement"
2107 /* Match the STOP statement. */
2110 gfc_match_stop (void)
2112 return gfc_match_stopcode (ST_STOP
);
2116 /* Match the ERROR STOP statement. */
2119 gfc_match_error_stop (void)
2121 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: ERROR STOP statement at %C")
2125 return gfc_match_stopcode (ST_ERROR_STOP
);
2129 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
2130 SYNC ALL [(sync-stat-list)]
2131 SYNC MEMORY [(sync-stat-list)]
2132 SYNC IMAGES (image-set [, sync-stat-list] )
2133 with sync-stat is int-expr or *. */
2136 sync_statement (gfc_statement st
)
2139 gfc_expr
*tmp
, *imageset
, *stat
, *errmsg
;
2140 bool saw_stat
, saw_errmsg
;
2142 tmp
= imageset
= stat
= errmsg
= NULL
;
2143 saw_stat
= saw_errmsg
= false;
2145 if (gfc_pure (NULL
))
2147 gfc_error ("Image control statement SYNC at %C in PURE procedure");
2151 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: SYNC statement at %C")
2155 if (gfc_option
.coarray
== GFC_FCOARRAY_NONE
)
2157 gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2161 if (gfc_find_state (COMP_CRITICAL
) == SUCCESS
)
2163 gfc_error ("Image control statement SYNC at %C in CRITICAL block");
2167 if (gfc_match_eos () == MATCH_YES
)
2169 if (st
== ST_SYNC_IMAGES
)
2174 if (gfc_match_char ('(') != MATCH_YES
)
2177 if (st
== ST_SYNC_IMAGES
)
2179 /* Denote '*' as imageset == NULL. */
2180 m
= gfc_match_char ('*');
2181 if (m
== MATCH_ERROR
)
2185 if (gfc_match ("%e", &imageset
) != MATCH_YES
)
2188 m
= gfc_match_char (',');
2189 if (m
== MATCH_ERROR
)
2193 m
= gfc_match_char (')');
2202 m
= gfc_match (" stat = %v", &tmp
);
2203 if (m
== MATCH_ERROR
)
2209 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
2215 if (gfc_match_char (',') == MATCH_YES
)
2219 m
= gfc_match (" errmsg = %v", &tmp
);
2220 if (m
== MATCH_ERROR
)
2226 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
2232 if (gfc_match_char (',') == MATCH_YES
)
2236 gfc_gobble_whitespace ();
2238 if (gfc_peek_char () == ')')
2244 if (gfc_match (" )%t") != MATCH_YES
)
2251 new_st
.op
= EXEC_SYNC_ALL
;
2253 case ST_SYNC_IMAGES
:
2254 new_st
.op
= EXEC_SYNC_IMAGES
;
2256 case ST_SYNC_MEMORY
:
2257 new_st
.op
= EXEC_SYNC_MEMORY
;
2263 new_st
.expr1
= imageset
;
2264 new_st
.expr2
= stat
;
2265 new_st
.expr3
= errmsg
;
2270 gfc_syntax_error (st
);
2273 gfc_free_expr (tmp
);
2274 gfc_free_expr (imageset
);
2275 gfc_free_expr (stat
);
2276 gfc_free_expr (errmsg
);
2282 /* Match SYNC ALL statement. */
2285 gfc_match_sync_all (void)
2287 return sync_statement (ST_SYNC_ALL
);
2291 /* Match SYNC IMAGES statement. */
2294 gfc_match_sync_images (void)
2296 return sync_statement (ST_SYNC_IMAGES
);
2300 /* Match SYNC MEMORY statement. */
2303 gfc_match_sync_memory (void)
2305 return sync_statement (ST_SYNC_MEMORY
);
2309 /* Match a CONTINUE statement. */
2312 gfc_match_continue (void)
2314 if (gfc_match_eos () != MATCH_YES
)
2316 gfc_syntax_error (ST_CONTINUE
);
2320 new_st
.op
= EXEC_CONTINUE
;
2325 /* Match the (deprecated) ASSIGN statement. */
2328 gfc_match_assign (void)
2331 gfc_st_label
*label
;
2333 if (gfc_match (" %l", &label
) == MATCH_YES
)
2335 if (gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
) == FAILURE
)
2337 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
2339 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: ASSIGN "
2344 expr
->symtree
->n
.sym
->attr
.assign
= 1;
2346 new_st
.op
= EXEC_LABEL_ASSIGN
;
2347 new_st
.label1
= label
;
2348 new_st
.expr1
= expr
;
2356 /* Match the GO TO statement. As a computed GOTO statement is
2357 matched, it is transformed into an equivalent SELECT block. No
2358 tree is necessary, and the resulting jumps-to-jumps are
2359 specifically optimized away by the back end. */
2362 gfc_match_goto (void)
2364 gfc_code
*head
, *tail
;
2367 gfc_st_label
*label
;
2371 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
2373 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2376 new_st
.op
= EXEC_GOTO
;
2377 new_st
.label1
= label
;
2381 /* The assigned GO TO statement. */
2383 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
2385 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: Assigned GOTO "
2390 new_st
.op
= EXEC_GOTO
;
2391 new_st
.expr1
= expr
;
2393 if (gfc_match_eos () == MATCH_YES
)
2396 /* Match label list. */
2397 gfc_match_char (',');
2398 if (gfc_match_char ('(') != MATCH_YES
)
2400 gfc_syntax_error (ST_GOTO
);
2407 m
= gfc_match_st_label (&label
);
2411 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2415 head
= tail
= gfc_get_code ();
2418 tail
->block
= gfc_get_code ();
2422 tail
->label1
= label
;
2423 tail
->op
= EXEC_GOTO
;
2425 while (gfc_match_char (',') == MATCH_YES
);
2427 if (gfc_match (")%t") != MATCH_YES
)
2432 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2435 new_st
.block
= head
;
2440 /* Last chance is a computed GO TO statement. */
2441 if (gfc_match_char ('(') != MATCH_YES
)
2443 gfc_syntax_error (ST_GOTO
);
2452 m
= gfc_match_st_label (&label
);
2456 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2460 head
= tail
= gfc_get_code ();
2463 tail
->block
= gfc_get_code ();
2467 cp
= gfc_get_case ();
2468 cp
->low
= cp
->high
= gfc_get_int_expr (gfc_default_integer_kind
,
2471 tail
->op
= EXEC_SELECT
;
2472 tail
->ext
.case_list
= cp
;
2474 tail
->next
= gfc_get_code ();
2475 tail
->next
->op
= EXEC_GOTO
;
2476 tail
->next
->label1
= label
;
2478 while (gfc_match_char (',') == MATCH_YES
);
2480 if (gfc_match_char (')') != MATCH_YES
)
2485 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2489 /* Get the rest of the statement. */
2490 gfc_match_char (',');
2492 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
2495 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: Computed GOTO "
2496 "at %C") == FAILURE
)
2499 /* At this point, a computed GOTO has been fully matched and an
2500 equivalent SELECT statement constructed. */
2502 new_st
.op
= EXEC_SELECT
;
2503 new_st
.expr1
= NULL
;
2505 /* Hack: For a "real" SELECT, the expression is in expr. We put
2506 it in expr2 so we can distinguish then and produce the correct
2508 new_st
.expr2
= expr
;
2509 new_st
.block
= head
;
2513 gfc_syntax_error (ST_GOTO
);
2515 gfc_free_statements (head
);
2520 /* Frees a list of gfc_alloc structures. */
2523 gfc_free_alloc_list (gfc_alloc
*p
)
2530 gfc_free_expr (p
->expr
);
2536 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
2537 an accessible derived type. */
2540 match_derived_type_spec (gfc_typespec
*ts
)
2543 gfc_symbol
*derived
;
2545 old_locus
= gfc_current_locus
;
2547 if (gfc_match_symbol (&derived
, 1) == MATCH_YES
)
2549 if (derived
->attr
.flavor
== FL_DERIVED
)
2551 ts
->type
= BT_DERIVED
;
2552 ts
->u
.derived
= derived
;
2557 /* Enforce F03:C476. */
2558 gfc_error ("'%s' at %L is not an accessible derived type",
2559 derived
->name
, &gfc_current_locus
);
2564 gfc_current_locus
= old_locus
;
2569 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2570 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2571 It only includes the intrinsic types from the Fortran 2003 standard
2572 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2573 the implicit_flag is not needed, so it was removed. Derived types are
2574 identified by their name alone. */
2577 match_type_spec (gfc_typespec
*ts
)
2583 old_locus
= gfc_current_locus
;
2585 if (gfc_match ("integer") == MATCH_YES
)
2587 ts
->type
= BT_INTEGER
;
2588 ts
->kind
= gfc_default_integer_kind
;
2592 if (gfc_match ("real") == MATCH_YES
)
2595 ts
->kind
= gfc_default_real_kind
;
2599 if (gfc_match ("double precision") == MATCH_YES
)
2602 ts
->kind
= gfc_default_double_kind
;
2606 if (gfc_match ("complex") == MATCH_YES
)
2608 ts
->type
= BT_COMPLEX
;
2609 ts
->kind
= gfc_default_complex_kind
;
2613 if (gfc_match ("character") == MATCH_YES
)
2615 ts
->type
= BT_CHARACTER
;
2619 if (gfc_match ("logical") == MATCH_YES
)
2621 ts
->type
= BT_LOGICAL
;
2622 ts
->kind
= gfc_default_logical_kind
;
2626 m
= match_derived_type_spec (ts
);
2629 old_locus
= gfc_current_locus
;
2630 if (gfc_match (" :: ") != MATCH_YES
)
2632 gfc_current_locus
= old_locus
;
2633 /* Enfore F03:C401. */
2634 if (ts
->u
.derived
->attr
.abstract
)
2636 gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
2637 ts
->u
.derived
->name
, &old_locus
);
2642 else if (m
== MATCH_ERROR
&& gfc_match (" :: ") == MATCH_YES
)
2645 /* If a type is not matched, simply return MATCH_NO. */
2646 gfc_current_locus
= old_locus
;
2651 gfc_gobble_whitespace ();
2652 if (gfc_peek_ascii_char () == '*')
2654 gfc_error ("Invalid type-spec at %C");
2658 m
= gfc_match_kind_spec (ts
, false);
2661 m
= MATCH_YES
; /* No kind specifier found. */
2667 m
= gfc_match_char_spec (ts
);
2670 m
= MATCH_YES
; /* No kind specifier found. */
2676 /* Match an ALLOCATE statement. */
2679 gfc_match_allocate (void)
2681 gfc_alloc
*head
, *tail
;
2682 gfc_expr
*stat
, *errmsg
, *tmp
, *source
;
2687 bool saw_stat
, saw_errmsg
, saw_source
, b1
, b2
, b3
;
2690 stat
= errmsg
= source
= tmp
= NULL
;
2691 saw_stat
= saw_errmsg
= saw_source
= false;
2693 if (gfc_match_char ('(') != MATCH_YES
)
2696 /* Match an optional type-spec. */
2697 old_locus
= gfc_current_locus
;
2698 m
= match_type_spec (&ts
);
2699 if (m
== MATCH_ERROR
)
2701 else if (m
== MATCH_NO
)
2702 ts
.type
= BT_UNKNOWN
;
2705 if (gfc_match (" :: ") == MATCH_YES
)
2707 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: typespec in "
2708 "ALLOCATE at %L", &old_locus
) == FAILURE
)
2713 ts
.type
= BT_UNKNOWN
;
2714 gfc_current_locus
= old_locus
;
2721 head
= tail
= gfc_get_alloc ();
2724 tail
->next
= gfc_get_alloc ();
2728 m
= gfc_match_variable (&tail
->expr
, 0);
2731 if (m
== MATCH_ERROR
)
2734 if (gfc_check_do_variable (tail
->expr
->symtree
))
2737 if (gfc_pure (NULL
) && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
2739 gfc_error ("Bad allocate-object at %C for a PURE procedure");
2743 /* The ALLOCATE statement had an optional typespec. Check the
2745 if (ts
.type
!= BT_UNKNOWN
)
2747 /* Enforce F03:C624. */
2748 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
2750 gfc_error ("Type of entity at %L is type incompatible with "
2751 "typespec", &tail
->expr
->where
);
2755 /* Enforce F03:C627. */
2756 if (ts
.kind
!= tail
->expr
->ts
.kind
)
2758 gfc_error ("Kind type parameter for entity at %L differs from "
2759 "the kind type parameter of the typespec",
2760 &tail
->expr
->where
);
2765 if (tail
->expr
->ts
.type
== BT_DERIVED
)
2766 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
2768 /* FIXME: disable the checking on derived types and arrays. */
2769 sym
= tail
->expr
->symtree
->n
.sym
;
2770 b1
= !(tail
->expr
->ref
2771 && (tail
->expr
->ref
->type
== REF_COMPONENT
2772 || tail
->expr
->ref
->type
== REF_ARRAY
));
2773 if (sym
&& sym
->ts
.type
== BT_CLASS
)
2774 b2
= !(sym
->ts
.u
.derived
->components
->attr
.allocatable
2775 || sym
->ts
.u
.derived
->components
->attr
.pointer
);
2777 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
2778 || sym
->attr
.proc_pointer
);
2779 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
2780 && (sym
->ns
->proc_name
->attr
.allocatable
2781 || sym
->ns
->proc_name
->attr
.pointer
2782 || sym
->ns
->proc_name
->attr
.proc_pointer
);
2783 if (b1
&& b2
&& !b3
)
2785 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2786 "or an allocatable variable");
2790 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
2792 gfc_error ("Shape specification for allocatable scalar at %C");
2796 if (gfc_match_char (',') != MATCH_YES
)
2801 m
= gfc_match (" stat = %v", &tmp
);
2802 if (m
== MATCH_ERROR
)
2809 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
2816 if (gfc_check_do_variable (stat
->symtree
))
2819 if (gfc_match_char (',') == MATCH_YES
)
2820 goto alloc_opt_list
;
2823 m
= gfc_match (" errmsg = %v", &tmp
);
2824 if (m
== MATCH_ERROR
)
2828 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ERRMSG tag at %L",
2829 &tmp
->where
) == FAILURE
)
2835 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
2842 if (gfc_match_char (',') == MATCH_YES
)
2843 goto alloc_opt_list
;
2846 m
= gfc_match (" source = %e", &tmp
);
2847 if (m
== MATCH_ERROR
)
2851 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: SOURCE tag at %L",
2852 &tmp
->where
) == FAILURE
)
2858 gfc_error ("Redundant SOURCE tag found at %L ", &tmp
->where
);
2862 /* The next 2 conditionals check C631. */
2863 if (ts
.type
!= BT_UNKNOWN
)
2865 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
2866 &tmp
->where
, &old_locus
);
2872 gfc_error ("SOURCE tag at %L requires only a single entity in "
2873 "the allocation-list", &tmp
->where
);
2880 if (gfc_match_char (',') == MATCH_YES
)
2881 goto alloc_opt_list
;
2884 gfc_gobble_whitespace ();
2886 if (gfc_peek_char () == ')')
2891 if (gfc_match (" )%t") != MATCH_YES
)
2894 new_st
.op
= EXEC_ALLOCATE
;
2895 new_st
.expr1
= stat
;
2896 new_st
.expr2
= errmsg
;
2897 new_st
.expr3
= source
;
2898 new_st
.ext
.alloc
.list
= head
;
2899 new_st
.ext
.alloc
.ts
= ts
;
2904 gfc_syntax_error (ST_ALLOCATE
);
2907 gfc_free_expr (errmsg
);
2908 gfc_free_expr (source
);
2909 gfc_free_expr (stat
);
2910 gfc_free_expr (tmp
);
2911 gfc_free_alloc_list (head
);
2916 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
2917 a set of pointer assignments to intrinsic NULL(). */
2920 gfc_match_nullify (void)
2928 if (gfc_match_char ('(') != MATCH_YES
)
2933 m
= gfc_match_variable (&p
, 0);
2934 if (m
== MATCH_ERROR
)
2939 if (gfc_check_do_variable (p
->symtree
))
2942 if (gfc_pure (NULL
) && gfc_impure_variable (p
->symtree
->n
.sym
))
2944 gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
2948 /* build ' => NULL() '. */
2949 e
= gfc_get_null_expr (&gfc_current_locus
);
2951 /* Chain to list. */
2956 tail
->next
= gfc_get_code ();
2960 tail
->op
= EXEC_POINTER_ASSIGN
;
2964 if (gfc_match (" )%t") == MATCH_YES
)
2966 if (gfc_match_char (',') != MATCH_YES
)
2973 gfc_syntax_error (ST_NULLIFY
);
2976 gfc_free_statements (new_st
.next
);
2978 gfc_free_expr (new_st
.expr1
);
2979 new_st
.expr1
= NULL
;
2980 gfc_free_expr (new_st
.expr2
);
2981 new_st
.expr2
= NULL
;
2986 /* Match a DEALLOCATE statement. */
2989 gfc_match_deallocate (void)
2991 gfc_alloc
*head
, *tail
;
2992 gfc_expr
*stat
, *errmsg
, *tmp
;
2995 bool saw_stat
, saw_errmsg
, b1
, b2
;
2998 stat
= errmsg
= tmp
= NULL
;
2999 saw_stat
= saw_errmsg
= false;
3001 if (gfc_match_char ('(') != MATCH_YES
)
3007 head
= tail
= gfc_get_alloc ();
3010 tail
->next
= gfc_get_alloc ();
3014 m
= gfc_match_variable (&tail
->expr
, 0);
3015 if (m
== MATCH_ERROR
)
3020 if (gfc_check_do_variable (tail
->expr
->symtree
))
3023 sym
= tail
->expr
->symtree
->n
.sym
;
3025 if (gfc_pure (NULL
) && gfc_impure_variable (sym
))
3027 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3031 /* FIXME: disable the checking on derived types. */
3032 b1
= !(tail
->expr
->ref
3033 && (tail
->expr
->ref
->type
== REF_COMPONENT
3034 || tail
->expr
->ref
->type
== REF_ARRAY
));
3035 if (sym
&& sym
->ts
.type
== BT_CLASS
)
3036 b2
= !(sym
->ts
.u
.derived
->components
->attr
.allocatable
3037 || sym
->ts
.u
.derived
->components
->attr
.pointer
);
3039 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
3040 || sym
->attr
.proc_pointer
);
3043 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3044 "or an allocatable variable");
3048 if (gfc_match_char (',') != MATCH_YES
)
3053 m
= gfc_match (" stat = %v", &tmp
);
3054 if (m
== MATCH_ERROR
)
3060 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
3061 gfc_free_expr (tmp
);
3068 if (gfc_check_do_variable (stat
->symtree
))
3071 if (gfc_match_char (',') == MATCH_YES
)
3072 goto dealloc_opt_list
;
3075 m
= gfc_match (" errmsg = %v", &tmp
);
3076 if (m
== MATCH_ERROR
)
3080 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ERRMSG at %L",
3081 &tmp
->where
) == FAILURE
)
3086 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
3087 gfc_free_expr (tmp
);
3094 if (gfc_match_char (',') == MATCH_YES
)
3095 goto dealloc_opt_list
;
3098 gfc_gobble_whitespace ();
3100 if (gfc_peek_char () == ')')
3104 if (gfc_match (" )%t") != MATCH_YES
)
3107 new_st
.op
= EXEC_DEALLOCATE
;
3108 new_st
.expr1
= stat
;
3109 new_st
.expr2
= errmsg
;
3110 new_st
.ext
.alloc
.list
= head
;
3115 gfc_syntax_error (ST_DEALLOCATE
);
3118 gfc_free_expr (errmsg
);
3119 gfc_free_expr (stat
);
3120 gfc_free_alloc_list (head
);
3125 /* Match a RETURN statement. */
3128 gfc_match_return (void)
3132 gfc_compile_state s
;
3136 if (gfc_find_state (COMP_CRITICAL
) == SUCCESS
)
3138 gfc_error ("Image control statement RETURN at %C in CRITICAL block");
3142 if (gfc_match_eos () == MATCH_YES
)
3145 if (gfc_find_state (COMP_SUBROUTINE
) == FAILURE
)
3147 gfc_error ("Alternate RETURN statement at %C is only allowed within "
3152 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: Alternate RETURN "
3153 "at %C") == FAILURE
)
3156 if (gfc_current_form
== FORM_FREE
)
3158 /* The following are valid, so we can't require a blank after the
3162 char c
= gfc_peek_ascii_char ();
3163 if (ISALPHA (c
) || ISDIGIT (c
))
3167 m
= gfc_match (" %e%t", &e
);
3170 if (m
== MATCH_ERROR
)
3173 gfc_syntax_error (ST_RETURN
);
3180 gfc_enclosing_unit (&s
);
3181 if (s
== COMP_PROGRAM
3182 && gfc_notify_std (GFC_STD_GNU
, "Extension: RETURN statement in "
3183 "main program at %C") == FAILURE
)
3186 new_st
.op
= EXEC_RETURN
;
3193 /* Match the call of a type-bound procedure, if CALL%var has already been
3194 matched and var found to be a derived-type variable. */
3197 match_typebound_call (gfc_symtree
* varst
)
3202 base
= gfc_get_expr ();
3203 base
->expr_type
= EXPR_VARIABLE
;
3204 base
->symtree
= varst
;
3205 base
->where
= gfc_current_locus
;
3206 gfc_set_sym_referenced (varst
->n
.sym
);
3208 m
= gfc_match_varspec (base
, 0, true, true);
3210 gfc_error ("Expected component reference at %C");
3214 if (gfc_match_eos () != MATCH_YES
)
3216 gfc_error ("Junk after CALL at %C");
3220 if (base
->expr_type
== EXPR_COMPCALL
)
3221 new_st
.op
= EXEC_COMPCALL
;
3222 else if (base
->expr_type
== EXPR_PPC
)
3223 new_st
.op
= EXEC_CALL_PPC
;
3226 gfc_error ("Expected type-bound procedure or procedure pointer component "
3230 new_st
.expr1
= base
;
3236 /* Match a CALL statement. The tricky part here are possible
3237 alternate return specifiers. We handle these by having all
3238 "subroutines" actually return an integer via a register that gives
3239 the return number. If the call specifies alternate returns, we
3240 generate code for a SELECT statement whose case clauses contain
3241 GOTOs to the various labels. */
3244 gfc_match_call (void)
3246 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3247 gfc_actual_arglist
*a
, *arglist
;
3257 m
= gfc_match ("% %n", name
);
3263 if (gfc_get_ha_sym_tree (name
, &st
))
3268 /* If this is a variable of derived-type, it probably starts a type-bound
3270 if ((sym
->attr
.flavor
!= FL_PROCEDURE
3271 || gfc_is_function_return_value (sym
, gfc_current_ns
))
3272 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
3273 return match_typebound_call (st
);
3275 /* If it does not seem to be callable (include functions so that the
3276 right association is made. They are thrown out in resolution.)
3278 if (!sym
->attr
.generic
3279 && !sym
->attr
.subroutine
3280 && !sym
->attr
.function
)
3282 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
3284 /* ...create a symbol in this scope... */
3285 if (sym
->ns
!= gfc_current_ns
3286 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
3289 if (sym
!= st
->n
.sym
)
3293 /* ...and then to try to make the symbol into a subroutine. */
3294 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3298 gfc_set_sym_referenced (sym
);
3300 if (gfc_match_eos () != MATCH_YES
)
3302 m
= gfc_match_actual_arglist (1, &arglist
);
3305 if (m
== MATCH_ERROR
)
3308 if (gfc_match_eos () != MATCH_YES
)
3312 /* If any alternate return labels were found, construct a SELECT
3313 statement that will jump to the right place. */
3316 for (a
= arglist
; a
; a
= a
->next
)
3317 if (a
->expr
== NULL
)
3322 gfc_symtree
*select_st
;
3323 gfc_symbol
*select_sym
;
3324 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3326 new_st
.next
= c
= gfc_get_code ();
3327 c
->op
= EXEC_SELECT
;
3328 sprintf (name
, "_result_%s", sym
->name
);
3329 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
3331 select_sym
= select_st
->n
.sym
;
3332 select_sym
->ts
.type
= BT_INTEGER
;
3333 select_sym
->ts
.kind
= gfc_default_integer_kind
;
3334 gfc_set_sym_referenced (select_sym
);
3335 c
->expr1
= gfc_get_expr ();
3336 c
->expr1
->expr_type
= EXPR_VARIABLE
;
3337 c
->expr1
->symtree
= select_st
;
3338 c
->expr1
->ts
= select_sym
->ts
;
3339 c
->expr1
->where
= gfc_current_locus
;
3342 for (a
= arglist
; a
; a
= a
->next
)
3344 if (a
->expr
!= NULL
)
3347 if (gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
) == FAILURE
)
3352 c
->block
= gfc_get_code ();
3354 c
->op
= EXEC_SELECT
;
3356 new_case
= gfc_get_case ();
3357 new_case
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, i
);
3358 new_case
->low
= new_case
->high
;
3359 c
->ext
.case_list
= new_case
;
3361 c
->next
= gfc_get_code ();
3362 c
->next
->op
= EXEC_GOTO
;
3363 c
->next
->label1
= a
->label
;
3367 new_st
.op
= EXEC_CALL
;
3368 new_st
.symtree
= st
;
3369 new_st
.ext
.actual
= arglist
;
3374 gfc_syntax_error (ST_CALL
);
3377 gfc_free_actual_arglist (arglist
);
3382 /* Given a name, return a pointer to the common head structure,
3383 creating it if it does not exist. If FROM_MODULE is nonzero, we
3384 mangle the name so that it doesn't interfere with commons defined
3385 in the using namespace.
3386 TODO: Add to global symbol tree. */
3389 gfc_get_common (const char *name
, int from_module
)
3392 static int serial
= 0;
3393 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
3397 /* A use associated common block is only needed to correctly layout
3398 the variables it contains. */
3399 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
3400 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
3404 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
3407 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
3410 if (st
->n
.common
== NULL
)
3412 st
->n
.common
= gfc_get_common_head ();
3413 st
->n
.common
->where
= gfc_current_locus
;
3414 strcpy (st
->n
.common
->name
, name
);
3417 return st
->n
.common
;
3421 /* Match a common block name. */
3423 match
match_common_name (char *name
)
3427 if (gfc_match_char ('/') == MATCH_NO
)
3433 if (gfc_match_char ('/') == MATCH_YES
)
3439 m
= gfc_match_name (name
);
3441 if (m
== MATCH_ERROR
)
3443 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
3446 gfc_error ("Syntax error in common block name at %C");
3451 /* Match a COMMON statement. */
3454 gfc_match_common (void)
3456 gfc_symbol
*sym
, **head
, *tail
, *other
, *old_blank_common
;
3457 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3464 old_blank_common
= gfc_current_ns
->blank_common
.head
;
3465 if (old_blank_common
)
3467 while (old_blank_common
->common_next
)
3468 old_blank_common
= old_blank_common
->common_next
;
3475 m
= match_common_name (name
);
3476 if (m
== MATCH_ERROR
)
3479 gsym
= gfc_get_gsymbol (name
);
3480 if (gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= GSYM_COMMON
)
3482 gfc_error ("Symbol '%s' at %C is already an external symbol that "
3483 "is not COMMON", name
);
3487 if (gsym
->type
== GSYM_UNKNOWN
)
3489 gsym
->type
= GSYM_COMMON
;
3490 gsym
->where
= gfc_current_locus
;
3496 if (name
[0] == '\0')
3498 t
= &gfc_current_ns
->blank_common
;
3499 if (t
->head
== NULL
)
3500 t
->where
= gfc_current_locus
;
3504 t
= gfc_get_common (name
, 0);
3513 while (tail
->common_next
)
3514 tail
= tail
->common_next
;
3517 /* Grab the list of symbols. */
3520 m
= gfc_match_symbol (&sym
, 0);
3521 if (m
== MATCH_ERROR
)
3526 /* Store a ref to the common block for error checking. */
3527 sym
->common_block
= t
;
3529 /* See if we know the current common block is bind(c), and if
3530 so, then see if we can check if the symbol is (which it'll
3531 need to be). This can happen if the bind(c) attr stmt was
3532 applied to the common block, and the variable(s) already
3533 defined, before declaring the common block. */
3534 if (t
->is_bind_c
== 1)
3536 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
3538 /* If we find an error, just print it and continue,
3539 cause it's just semantic, and we can see if there
3541 gfc_error_now ("Variable '%s' at %L in common block '%s' "
3542 "at %C must be declared with a C "
3543 "interoperable kind since common block "
3545 sym
->name
, &(sym
->declared_at
), t
->name
,
3549 if (sym
->attr
.is_bind_c
== 1)
3550 gfc_error_now ("Variable '%s' in common block "
3551 "'%s' at %C can not be bind(c) since "
3552 "it is not global", sym
->name
, t
->name
);
3555 if (sym
->attr
.in_common
)
3557 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
3562 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
3563 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
3565 if (gfc_notify_std (GFC_STD_GNU
, "Initialized symbol '%s' at %C "
3566 "can only be COMMON in "
3567 "BLOCK DATA", sym
->name
)
3572 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3576 tail
->common_next
= sym
;
3582 /* Deal with an optional array specification after the
3584 m
= gfc_match_array_spec (&as
, true, true);
3585 if (m
== MATCH_ERROR
)
3590 if (as
->type
!= AS_EXPLICIT
)
3592 gfc_error ("Array specification for symbol '%s' in COMMON "
3593 "at %C must be explicit", sym
->name
);
3597 if (gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3600 if (sym
->attr
.pointer
)
3602 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
3603 "POINTER array", sym
->name
);
3612 sym
->common_head
= t
;
3614 /* Check to see if the symbol is already in an equivalence group.
3615 If it is, set the other members as being in common. */
3616 if (sym
->attr
.in_equivalence
)
3618 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
3620 for (e2
= e1
; e2
; e2
= e2
->eq
)
3621 if (e2
->expr
->symtree
->n
.sym
== sym
)
3628 for (e2
= e1
; e2
; e2
= e2
->eq
)
3630 other
= e2
->expr
->symtree
->n
.sym
;
3631 if (other
->common_head
3632 && other
->common_head
!= sym
->common_head
)
3634 gfc_error ("Symbol '%s', in COMMON block '%s' at "
3635 "%C is being indirectly equivalenced to "
3636 "another COMMON block '%s'",
3637 sym
->name
, sym
->common_head
->name
,
3638 other
->common_head
->name
);
3641 other
->attr
.in_common
= 1;
3642 other
->common_head
= t
;
3648 gfc_gobble_whitespace ();
3649 if (gfc_match_eos () == MATCH_YES
)
3651 if (gfc_peek_ascii_char () == '/')
3653 if (gfc_match_char (',') != MATCH_YES
)
3655 gfc_gobble_whitespace ();
3656 if (gfc_peek_ascii_char () == '/')
3665 gfc_syntax_error (ST_COMMON
);
3668 if (old_blank_common
)
3669 old_blank_common
->common_next
= NULL
;
3671 gfc_current_ns
->blank_common
.head
= NULL
;
3672 gfc_free_array_spec (as
);
3677 /* Match a BLOCK DATA program unit. */
3680 gfc_match_block_data (void)
3682 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3686 if (gfc_match_eos () == MATCH_YES
)
3688 gfc_new_block
= NULL
;
3692 m
= gfc_match ("% %n%t", name
);
3696 if (gfc_get_symbol (name
, NULL
, &sym
))
3699 if (gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
) == FAILURE
)
3702 gfc_new_block
= sym
;
3708 /* Free a namelist structure. */
3711 gfc_free_namelist (gfc_namelist
*name
)
3715 for (; name
; name
= n
)
3723 /* Match a NAMELIST statement. */
3726 gfc_match_namelist (void)
3728 gfc_symbol
*group_name
, *sym
;
3732 m
= gfc_match (" / %s /", &group_name
);
3735 if (m
== MATCH_ERROR
)
3740 if (group_name
->ts
.type
!= BT_UNKNOWN
)
3742 gfc_error ("Namelist group name '%s' at %C already has a basic "
3743 "type of %s", group_name
->name
,
3744 gfc_typename (&group_name
->ts
));
3748 if (group_name
->attr
.flavor
== FL_NAMELIST
3749 && group_name
->attr
.use_assoc
3750 && gfc_notify_std (GFC_STD_GNU
, "Namelist group name '%s' "
3751 "at %C already is USE associated and can"
3752 "not be respecified.", group_name
->name
)
3756 if (group_name
->attr
.flavor
!= FL_NAMELIST
3757 && gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
3758 group_name
->name
, NULL
) == FAILURE
)
3763 m
= gfc_match_symbol (&sym
, 1);
3766 if (m
== MATCH_ERROR
)
3769 if (sym
->attr
.in_namelist
== 0
3770 && gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3773 /* Use gfc_error_check here, rather than goto error, so that
3774 these are the only errors for the next two lines. */
3775 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
3777 gfc_error ("Assumed size array '%s' in namelist '%s' at "
3778 "%C is not allowed", sym
->name
, group_name
->name
);
3782 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
->length
== NULL
)
3784 gfc_error ("Assumed character length '%s' in namelist '%s' at "
3785 "%C is not allowed", sym
->name
, group_name
->name
);
3789 nl
= gfc_get_namelist ();
3793 if (group_name
->namelist
== NULL
)
3794 group_name
->namelist
= group_name
->namelist_tail
= nl
;
3797 group_name
->namelist_tail
->next
= nl
;
3798 group_name
->namelist_tail
= nl
;
3801 if (gfc_match_eos () == MATCH_YES
)
3804 m
= gfc_match_char (',');
3806 if (gfc_match_char ('/') == MATCH_YES
)
3808 m2
= gfc_match (" %s /", &group_name
);
3809 if (m2
== MATCH_YES
)
3811 if (m2
== MATCH_ERROR
)
3825 gfc_syntax_error (ST_NAMELIST
);
3832 /* Match a MODULE statement. */
3835 gfc_match_module (void)
3839 m
= gfc_match (" %s%t", &gfc_new_block
);
3843 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
3844 gfc_new_block
->name
, NULL
) == FAILURE
)
3851 /* Free equivalence sets and lists. Recursively is the easiest way to
3855 gfc_free_equiv (gfc_equiv
*eq
)
3860 gfc_free_equiv (eq
->eq
);
3861 gfc_free_equiv (eq
->next
);
3862 gfc_free_expr (eq
->expr
);
3867 /* Match an EQUIVALENCE statement. */
3870 gfc_match_equivalence (void)
3872 gfc_equiv
*eq
, *set
, *tail
;
3876 gfc_common_head
*common_head
= NULL
;
3884 eq
= gfc_get_equiv ();
3888 eq
->next
= gfc_current_ns
->equiv
;
3889 gfc_current_ns
->equiv
= eq
;
3891 if (gfc_match_char ('(') != MATCH_YES
)
3895 common_flag
= FALSE
;
3900 m
= gfc_match_equiv_variable (&set
->expr
);
3901 if (m
== MATCH_ERROR
)
3906 /* count the number of objects. */
3909 if (gfc_match_char ('%') == MATCH_YES
)
3911 gfc_error ("Derived type component %C is not a "
3912 "permitted EQUIVALENCE member");
3916 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
3917 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
3919 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
3920 "be an array section");
3924 sym
= set
->expr
->symtree
->n
.sym
;
3926 if (gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3929 if (sym
->attr
.in_common
)
3932 common_head
= sym
->common_head
;
3935 if (gfc_match_char (')') == MATCH_YES
)
3938 if (gfc_match_char (',') != MATCH_YES
)
3941 set
->eq
= gfc_get_equiv ();
3947 gfc_error ("EQUIVALENCE at %C requires two or more objects");
3951 /* If one of the members of an equivalence is in common, then
3952 mark them all as being in common. Before doing this, check
3953 that members of the equivalence group are not in different
3956 for (set
= eq
; set
; set
= set
->eq
)
3958 sym
= set
->expr
->symtree
->n
.sym
;
3959 if (sym
->common_head
&& sym
->common_head
!= common_head
)
3961 gfc_error ("Attempt to indirectly overlap COMMON "
3962 "blocks %s and %s by EQUIVALENCE at %C",
3963 sym
->common_head
->name
, common_head
->name
);
3966 sym
->attr
.in_common
= 1;
3967 sym
->common_head
= common_head
;
3970 if (gfc_match_eos () == MATCH_YES
)
3972 if (gfc_match_char (',') != MATCH_YES
)
3974 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
3982 gfc_syntax_error (ST_EQUIVALENCE
);
3988 gfc_free_equiv (gfc_current_ns
->equiv
);
3989 gfc_current_ns
->equiv
= eq
;
3995 /* Check that a statement function is not recursive. This is done by looking
3996 for the statement function symbol(sym) by looking recursively through its
3997 expression(e). If a reference to sym is found, true is returned.
3998 12.5.4 requires that any variable of function that is implicitly typed
3999 shall have that type confirmed by any subsequent type declaration. The
4000 implicit typing is conveniently done here. */
4002 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
4005 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
4011 switch (e
->expr_type
)
4014 if (e
->symtree
== NULL
)
4017 /* Check the name before testing for nested recursion! */
4018 if (sym
->name
== e
->symtree
->n
.sym
->name
)
4021 /* Catch recursion via other statement functions. */
4022 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
4023 && e
->symtree
->n
.sym
->value
4024 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
4027 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
4028 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
4033 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
4036 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
4037 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
4049 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
4051 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
4055 /* Match a statement function declaration. It is so easy to match
4056 non-statement function statements with a MATCH_ERROR as opposed to
4057 MATCH_NO that we suppress error message in most cases. */
4060 gfc_match_st_function (void)
4062 gfc_error_buf old_error
;
4067 m
= gfc_match_symbol (&sym
, 0);
4071 gfc_push_error (&old_error
);
4073 if (gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
,
4074 sym
->name
, NULL
) == FAILURE
)
4077 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
4080 m
= gfc_match (" = %e%t", &expr
);
4084 gfc_free_error (&old_error
);
4085 if (m
== MATCH_ERROR
)
4088 if (recursive_stmt_fcn (expr
, sym
))
4090 gfc_error ("Statement function at %L is recursive", &expr
->where
);
4096 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: "
4097 "Statement function at %C") == FAILURE
)
4103 gfc_pop_error (&old_error
);
4108 /***************** SELECT CASE subroutines ******************/
4110 /* Free a single case structure. */
4113 free_case (gfc_case
*p
)
4115 if (p
->low
== p
->high
)
4117 gfc_free_expr (p
->low
);
4118 gfc_free_expr (p
->high
);
4123 /* Free a list of case structures. */
4126 gfc_free_case_list (gfc_case
*p
)
4138 /* Match a single case selector. */
4141 match_case_selector (gfc_case
**cp
)
4146 c
= gfc_get_case ();
4147 c
->where
= gfc_current_locus
;
4149 if (gfc_match_char (':') == MATCH_YES
)
4151 m
= gfc_match_init_expr (&c
->high
);
4154 if (m
== MATCH_ERROR
)
4159 m
= gfc_match_init_expr (&c
->low
);
4160 if (m
== MATCH_ERROR
)
4165 /* If we're not looking at a ':' now, make a range out of a single
4166 target. Else get the upper bound for the case range. */
4167 if (gfc_match_char (':') != MATCH_YES
)
4171 m
= gfc_match_init_expr (&c
->high
);
4172 if (m
== MATCH_ERROR
)
4174 /* MATCH_NO is fine. It's OK if nothing is there! */
4182 gfc_error ("Expected initialization expression in CASE at %C");
4190 /* Match the end of a case statement. */
4193 match_case_eos (void)
4195 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4198 if (gfc_match_eos () == MATCH_YES
)
4201 /* If the case construct doesn't have a case-construct-name, we
4202 should have matched the EOS. */
4203 if (!gfc_current_block ())
4206 gfc_gobble_whitespace ();
4208 m
= gfc_match_name (name
);
4212 if (strcmp (name
, gfc_current_block ()->name
) != 0)
4214 gfc_error ("Expected block name '%s' of SELECT construct at %C",
4215 gfc_current_block ()->name
);
4219 return gfc_match_eos ();
4223 /* Match a SELECT statement. */
4226 gfc_match_select (void)
4231 m
= gfc_match_label ();
4232 if (m
== MATCH_ERROR
)
4235 m
= gfc_match (" select case ( %e )%t", &expr
);
4239 new_st
.op
= EXEC_SELECT
;
4240 new_st
.expr1
= expr
;
4246 /* Push the current selector onto the SELECT TYPE stack. */
4249 select_type_push (gfc_symbol
*sel
)
4251 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
4252 top
->selector
= sel
;
4254 top
->prev
= select_type_stack
;
4256 select_type_stack
= top
;
4260 /* Set the temporary for the current SELECT TYPE selector. */
4263 select_type_set_tmp (gfc_typespec
*ts
)
4265 char name
[GFC_MAX_SYMBOL_LEN
];
4268 if (!gfc_type_is_extensible (ts
->u
.derived
))
4271 if (ts
->type
== BT_CLASS
)
4272 sprintf (name
, "tmp$class$%s", ts
->u
.derived
->name
);
4274 sprintf (name
, "tmp$type$%s", ts
->u
.derived
->name
);
4275 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
4276 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
4277 gfc_set_sym_referenced (tmp
->n
.sym
);
4278 gfc_add_pointer (&tmp
->n
.sym
->attr
, NULL
);
4279 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
4280 if (ts
->type
== BT_CLASS
)
4282 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
4283 &tmp
->n
.sym
->as
, false);
4284 tmp
->n
.sym
->attr
.class_ok
= 1;
4287 select_type_stack
->tmp
= tmp
;
4291 /* Match a SELECT TYPE statement. */
4294 gfc_match_select_type (void)
4296 gfc_expr
*expr1
, *expr2
= NULL
;
4298 char name
[GFC_MAX_SYMBOL_LEN
];
4300 m
= gfc_match_label ();
4301 if (m
== MATCH_ERROR
)
4304 m
= gfc_match (" select type ( ");
4308 gfc_current_ns
= gfc_build_block_ns (gfc_current_ns
);
4310 m
= gfc_match (" %n => %e", name
, &expr2
);
4313 expr1
= gfc_get_expr();
4314 expr1
->expr_type
= EXPR_VARIABLE
;
4315 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
4317 if (expr2
->ts
.type
== BT_UNKNOWN
)
4318 expr1
->symtree
->n
.sym
->attr
.untyped
= 1;
4320 expr1
->symtree
->n
.sym
->ts
= expr2
->ts
;
4321 expr1
->symtree
->n
.sym
->attr
.referenced
= 1;
4322 expr1
->symtree
->n
.sym
->attr
.class_ok
= 1;
4326 m
= gfc_match (" %e ", &expr1
);
4331 m
= gfc_match (" )%t");
4335 /* Check for F03:C811. */
4336 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
|| expr1
->ref
!= NULL
))
4338 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
4339 "use associate-name=>");
4343 new_st
.op
= EXEC_SELECT_TYPE
;
4344 new_st
.expr1
= expr1
;
4345 new_st
.expr2
= expr2
;
4346 new_st
.ext
.ns
= gfc_current_ns
;
4348 select_type_push (expr1
->symtree
->n
.sym
);
4354 /* Match a CASE statement. */
4357 gfc_match_case (void)
4359 gfc_case
*c
, *head
, *tail
;
4364 if (gfc_current_state () != COMP_SELECT
)
4366 gfc_error ("Unexpected CASE statement at %C");
4370 if (gfc_match ("% default") == MATCH_YES
)
4372 m
= match_case_eos ();
4375 if (m
== MATCH_ERROR
)
4378 new_st
.op
= EXEC_SELECT
;
4379 c
= gfc_get_case ();
4380 c
->where
= gfc_current_locus
;
4381 new_st
.ext
.case_list
= c
;
4385 if (gfc_match_char ('(') != MATCH_YES
)
4390 if (match_case_selector (&c
) == MATCH_ERROR
)
4400 if (gfc_match_char (')') == MATCH_YES
)
4402 if (gfc_match_char (',') != MATCH_YES
)
4406 m
= match_case_eos ();
4409 if (m
== MATCH_ERROR
)
4412 new_st
.op
= EXEC_SELECT
;
4413 new_st
.ext
.case_list
= head
;
4418 gfc_error ("Syntax error in CASE specification at %C");
4421 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
4426 /* Match a TYPE IS statement. */
4429 gfc_match_type_is (void)
4434 if (gfc_current_state () != COMP_SELECT_TYPE
)
4436 gfc_error ("Unexpected TYPE IS statement at %C");
4440 if (gfc_match_char ('(') != MATCH_YES
)
4443 c
= gfc_get_case ();
4444 c
->where
= gfc_current_locus
;
4446 /* TODO: Once unlimited polymorphism is implemented, we will need to call
4447 match_type_spec here. */
4448 if (match_derived_type_spec (&c
->ts
) == MATCH_ERROR
)
4451 if (gfc_match_char (')') != MATCH_YES
)
4454 m
= match_case_eos ();
4457 if (m
== MATCH_ERROR
)
4460 new_st
.op
= EXEC_SELECT_TYPE
;
4461 new_st
.ext
.case_list
= c
;
4463 /* Create temporary variable. */
4464 select_type_set_tmp (&c
->ts
);
4469 gfc_error ("Syntax error in TYPE IS specification at %C");
4473 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
4478 /* Match a CLASS IS or CLASS DEFAULT statement. */
4481 gfc_match_class_is (void)
4486 if (gfc_current_state () != COMP_SELECT_TYPE
)
4489 if (gfc_match ("% default") == MATCH_YES
)
4491 m
= match_case_eos ();
4494 if (m
== MATCH_ERROR
)
4497 new_st
.op
= EXEC_SELECT_TYPE
;
4498 c
= gfc_get_case ();
4499 c
->where
= gfc_current_locus
;
4500 c
->ts
.type
= BT_UNKNOWN
;
4501 new_st
.ext
.case_list
= c
;
4505 m
= gfc_match ("% is");
4508 if (m
== MATCH_ERROR
)
4511 if (gfc_match_char ('(') != MATCH_YES
)
4514 c
= gfc_get_case ();
4515 c
->where
= gfc_current_locus
;
4517 if (match_derived_type_spec (&c
->ts
) == MATCH_ERROR
)
4520 if (c
->ts
.type
== BT_DERIVED
)
4521 c
->ts
.type
= BT_CLASS
;
4523 if (gfc_match_char (')') != MATCH_YES
)
4526 m
= match_case_eos ();
4529 if (m
== MATCH_ERROR
)
4532 new_st
.op
= EXEC_SELECT_TYPE
;
4533 new_st
.ext
.case_list
= c
;
4535 /* Create temporary variable. */
4536 select_type_set_tmp (&c
->ts
);
4541 gfc_error ("Syntax error in CLASS IS specification at %C");
4545 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
4550 /********************* WHERE subroutines ********************/
4552 /* Match the rest of a simple WHERE statement that follows an IF statement.
4556 match_simple_where (void)
4562 m
= gfc_match (" ( %e )", &expr
);
4566 m
= gfc_match_assignment ();
4569 if (m
== MATCH_ERROR
)
4572 if (gfc_match_eos () != MATCH_YES
)
4575 c
= gfc_get_code ();
4579 c
->next
= gfc_get_code ();
4582 gfc_clear_new_st ();
4584 new_st
.op
= EXEC_WHERE
;
4590 gfc_syntax_error (ST_WHERE
);
4593 gfc_free_expr (expr
);
4598 /* Match a WHERE statement. */
4601 gfc_match_where (gfc_statement
*st
)
4607 m0
= gfc_match_label ();
4608 if (m0
== MATCH_ERROR
)
4611 m
= gfc_match (" where ( %e )", &expr
);
4615 if (gfc_match_eos () == MATCH_YES
)
4617 *st
= ST_WHERE_BLOCK
;
4618 new_st
.op
= EXEC_WHERE
;
4619 new_st
.expr1
= expr
;
4623 m
= gfc_match_assignment ();
4625 gfc_syntax_error (ST_WHERE
);
4629 gfc_free_expr (expr
);
4633 /* We've got a simple WHERE statement. */
4635 c
= gfc_get_code ();
4639 c
->next
= gfc_get_code ();
4642 gfc_clear_new_st ();
4644 new_st
.op
= EXEC_WHERE
;
4651 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
4652 new_st if successful. */
4655 gfc_match_elsewhere (void)
4657 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4661 if (gfc_current_state () != COMP_WHERE
)
4663 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
4669 if (gfc_match_char ('(') == MATCH_YES
)
4671 m
= gfc_match_expr (&expr
);
4674 if (m
== MATCH_ERROR
)
4677 if (gfc_match_char (')') != MATCH_YES
)
4681 if (gfc_match_eos () != MATCH_YES
)
4683 /* Only makes sense if we have a where-construct-name. */
4684 if (!gfc_current_block ())
4689 /* Better be a name at this point. */
4690 m
= gfc_match_name (name
);
4693 if (m
== MATCH_ERROR
)
4696 if (gfc_match_eos () != MATCH_YES
)
4699 if (strcmp (name
, gfc_current_block ()->name
) != 0)
4701 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
4702 name
, gfc_current_block ()->name
);
4707 new_st
.op
= EXEC_WHERE
;
4708 new_st
.expr1
= expr
;
4712 gfc_syntax_error (ST_ELSEWHERE
);
4715 gfc_free_expr (expr
);
4720 /******************** FORALL subroutines ********************/
4722 /* Free a list of FORALL iterators. */
4725 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
4727 gfc_forall_iterator
*next
;
4732 gfc_free_expr (iter
->var
);
4733 gfc_free_expr (iter
->start
);
4734 gfc_free_expr (iter
->end
);
4735 gfc_free_expr (iter
->stride
);
4742 /* Match an iterator as part of a FORALL statement. The format is:
4744 <var> = <start>:<end>[:<stride>]
4746 On MATCH_NO, the caller tests for the possibility that there is a
4747 scalar mask expression. */
4750 match_forall_iterator (gfc_forall_iterator
**result
)
4752 gfc_forall_iterator
*iter
;
4756 where
= gfc_current_locus
;
4757 iter
= XCNEW (gfc_forall_iterator
);
4759 m
= gfc_match_expr (&iter
->var
);
4763 if (gfc_match_char ('=') != MATCH_YES
4764 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
4770 m
= gfc_match_expr (&iter
->start
);
4774 if (gfc_match_char (':') != MATCH_YES
)
4777 m
= gfc_match_expr (&iter
->end
);
4780 if (m
== MATCH_ERROR
)
4783 if (gfc_match_char (':') == MATCH_NO
)
4784 iter
->stride
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4787 m
= gfc_match_expr (&iter
->stride
);
4790 if (m
== MATCH_ERROR
)
4794 /* Mark the iteration variable's symbol as used as a FORALL index. */
4795 iter
->var
->symtree
->n
.sym
->forall_index
= true;
4801 gfc_error ("Syntax error in FORALL iterator at %C");
4806 gfc_current_locus
= where
;
4807 gfc_free_forall_iterator (iter
);
4812 /* Match the header of a FORALL statement. */
4815 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
4817 gfc_forall_iterator
*head
, *tail
, *new_iter
;
4821 gfc_gobble_whitespace ();
4826 if (gfc_match_char ('(') != MATCH_YES
)
4829 m
= match_forall_iterator (&new_iter
);
4830 if (m
== MATCH_ERROR
)
4835 head
= tail
= new_iter
;
4839 if (gfc_match_char (',') != MATCH_YES
)
4842 m
= match_forall_iterator (&new_iter
);
4843 if (m
== MATCH_ERROR
)
4848 tail
->next
= new_iter
;
4853 /* Have to have a mask expression. */
4855 m
= gfc_match_expr (&msk
);
4858 if (m
== MATCH_ERROR
)
4864 if (gfc_match_char (')') == MATCH_NO
)
4872 gfc_syntax_error (ST_FORALL
);
4875 gfc_free_expr (msk
);
4876 gfc_free_forall_iterator (head
);
4881 /* Match the rest of a simple FORALL statement that follows an
4885 match_simple_forall (void)
4887 gfc_forall_iterator
*head
;
4896 m
= match_forall_header (&head
, &mask
);
4903 m
= gfc_match_assignment ();
4905 if (m
== MATCH_ERROR
)
4909 m
= gfc_match_pointer_assignment ();
4910 if (m
== MATCH_ERROR
)
4916 c
= gfc_get_code ();
4918 c
->loc
= gfc_current_locus
;
4920 if (gfc_match_eos () != MATCH_YES
)
4923 gfc_clear_new_st ();
4924 new_st
.op
= EXEC_FORALL
;
4925 new_st
.expr1
= mask
;
4926 new_st
.ext
.forall_iterator
= head
;
4927 new_st
.block
= gfc_get_code ();
4929 new_st
.block
->op
= EXEC_FORALL
;
4930 new_st
.block
->next
= c
;
4935 gfc_syntax_error (ST_FORALL
);
4938 gfc_free_forall_iterator (head
);
4939 gfc_free_expr (mask
);
4945 /* Match a FORALL statement. */
4948 gfc_match_forall (gfc_statement
*st
)
4950 gfc_forall_iterator
*head
;
4959 m0
= gfc_match_label ();
4960 if (m0
== MATCH_ERROR
)
4963 m
= gfc_match (" forall");
4967 m
= match_forall_header (&head
, &mask
);
4968 if (m
== MATCH_ERROR
)
4973 if (gfc_match_eos () == MATCH_YES
)
4975 *st
= ST_FORALL_BLOCK
;
4976 new_st
.op
= EXEC_FORALL
;
4977 new_st
.expr1
= mask
;
4978 new_st
.ext
.forall_iterator
= head
;
4982 m
= gfc_match_assignment ();
4983 if (m
== MATCH_ERROR
)
4987 m
= gfc_match_pointer_assignment ();
4988 if (m
== MATCH_ERROR
)
4994 c
= gfc_get_code ();
4996 c
->loc
= gfc_current_locus
;
4998 gfc_clear_new_st ();
4999 new_st
.op
= EXEC_FORALL
;
5000 new_st
.expr1
= mask
;
5001 new_st
.ext
.forall_iterator
= head
;
5002 new_st
.block
= gfc_get_code ();
5003 new_st
.block
->op
= EXEC_FORALL
;
5004 new_st
.block
->next
= c
;
5010 gfc_syntax_error (ST_FORALL
);
5013 gfc_free_forall_iterator (head
);
5014 gfc_free_expr (mask
);
5015 gfc_free_statements (c
);