1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
29 int gfc_matching_procptr_assignment
= 0;
30 bool gfc_matching_prefix
= false;
32 /* For debugging and diagnostic purposes. Return the textual representation
33 of the intrinsic operator OP. */
35 gfc_op2string (gfc_intrinsic_op op
)
43 case INTRINSIC_UMINUS
:
49 case INTRINSIC_CONCAT
:
53 case INTRINSIC_DIVIDE
:
92 case INTRINSIC_ASSIGN
:
95 case INTRINSIC_PARENTHESES
:
102 gfc_internal_error ("gfc_op2string(): Bad code");
107 /******************** Generic matching subroutines ************************/
109 /* This function scans the current statement counting the opened and closed
110 parenthesis to make sure they are balanced. */
113 gfc_match_parens (void)
115 locus old_loc
, where
;
119 old_loc
= gfc_current_locus
;
126 c
= gfc_next_char_literal (instring
);
129 if (quote
== ' ' && ((c
== '\'') || (c
== '"')))
135 if (quote
!= ' ' && c
== quote
)
142 if (c
== '(' && quote
== ' ')
145 where
= gfc_current_locus
;
147 if (c
== ')' && quote
== ' ')
150 where
= gfc_current_locus
;
154 gfc_current_locus
= old_loc
;
158 gfc_error ("Missing ')' in statement at or before %L", &where
);
163 gfc_error ("Missing '(' in statement at or before %L", &where
);
171 /* See if the next character is a special character that has
172 escaped by a \ via the -fbackslash option. */
175 gfc_match_special_char (gfc_char_t
*res
)
183 switch ((c
= gfc_next_char_literal (1)))
216 /* Hexadecimal form of wide characters. */
217 len
= (c
== 'x' ? 2 : (c
== 'u' ? 4 : 8));
219 for (i
= 0; i
< len
; i
++)
221 char buf
[2] = { '\0', '\0' };
223 c
= gfc_next_char_literal (1);
224 if (!gfc_wide_fits_in_byte (c
)
225 || !gfc_check_digit ((unsigned char) c
, 16))
228 buf
[0] = (unsigned char) c
;
230 n
+= strtol (buf
, NULL
, 16);
236 /* Unknown backslash codes are simply not expanded. */
245 /* In free form, match at least one space. Always matches in fixed
249 gfc_match_space (void)
254 if (gfc_current_form
== FORM_FIXED
)
257 old_loc
= gfc_current_locus
;
259 c
= gfc_next_ascii_char ();
260 if (!gfc_is_whitespace (c
))
262 gfc_current_locus
= old_loc
;
266 gfc_gobble_whitespace ();
272 /* Match an end of statement. End of statement is optional
273 whitespace, followed by a ';' or '\n' or comment '!'. If a
274 semicolon is found, we continue to eat whitespace and semicolons. */
287 old_loc
= gfc_current_locus
;
288 gfc_gobble_whitespace ();
290 c
= gfc_next_ascii_char ();
296 c
= gfc_next_ascii_char ();
313 gfc_current_locus
= old_loc
;
314 return (flag
) ? MATCH_YES
: MATCH_NO
;
318 /* Match a literal integer on the input, setting the value on
319 MATCH_YES. Literal ints occur in kind-parameters as well as
320 old-style character length specifications. If cnt is non-NULL it
321 will be set to the number of digits. */
324 gfc_match_small_literal_int (int *value
, int *cnt
)
330 old_loc
= gfc_current_locus
;
333 gfc_gobble_whitespace ();
334 c
= gfc_next_ascii_char ();
340 gfc_current_locus
= old_loc
;
349 old_loc
= gfc_current_locus
;
350 c
= gfc_next_ascii_char ();
355 i
= 10 * i
+ c
- '0';
360 gfc_error ("Integer too large at %C");
365 gfc_current_locus
= old_loc
;
374 /* Match a small, constant integer expression, like in a kind
375 statement. On MATCH_YES, 'value' is set. */
378 gfc_match_small_int (int *value
)
385 m
= gfc_match_expr (&expr
);
389 p
= gfc_extract_int (expr
, &i
);
390 gfc_free_expr (expr
);
403 /* This function is the same as the gfc_match_small_int, except that
404 we're keeping the pointer to the expr. This function could just be
405 removed and the previously mentioned one modified, though all calls
406 to it would have to be modified then (and there were a number of
407 them). Return MATCH_ERROR if fail to extract the int; otherwise,
408 return the result of gfc_match_expr(). The expr (if any) that was
409 matched is returned in the parameter expr. */
412 gfc_match_small_int_expr (int *value
, gfc_expr
**expr
)
418 m
= gfc_match_expr (expr
);
422 p
= gfc_extract_int (*expr
, &i
);
435 /* Matches a statement label. Uses gfc_match_small_literal_int() to
436 do most of the work. */
439 gfc_match_st_label (gfc_st_label
**label
)
445 old_loc
= gfc_current_locus
;
447 m
= gfc_match_small_literal_int (&i
, &cnt
);
453 gfc_error ("Too many digits in statement label at %C");
459 gfc_error ("Statement label at %C is zero");
463 *label
= gfc_get_st_label (i
);
468 gfc_current_locus
= old_loc
;
473 /* Match and validate a label associated with a named IF, DO or SELECT
474 statement. If the symbol does not have the label attribute, we add
475 it. We also make sure the symbol does not refer to another
476 (active) block. A matched label is pointed to by gfc_new_block. */
479 gfc_match_label (void)
481 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
484 gfc_new_block
= NULL
;
486 m
= gfc_match (" %n :", name
);
490 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
492 gfc_error ("Label name '%s' at %C is ambiguous", name
);
496 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
498 gfc_error ("Duplicate construct label '%s' at %C", name
);
502 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
503 gfc_new_block
->name
, NULL
) == FAILURE
)
510 /* See if the current input looks like a name of some sort. Modifies
511 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
512 Note that options.c restricts max_identifier_length to not more
513 than GFC_MAX_SYMBOL_LEN. */
516 gfc_match_name (char *buffer
)
522 old_loc
= gfc_current_locus
;
523 gfc_gobble_whitespace ();
525 c
= gfc_next_ascii_char ();
526 if (!(ISALPHA (c
) || (c
== '_' && gfc_option
.flag_allow_leading_underscore
)))
528 if (gfc_error_flag_test() == 0 && c
!= '(')
529 gfc_error ("Invalid character in name at %C");
530 gfc_current_locus
= old_loc
;
540 if (i
> gfc_option
.max_identifier_length
)
542 gfc_error ("Name at %C is too long");
546 old_loc
= gfc_current_locus
;
547 c
= gfc_next_ascii_char ();
549 while (ISALNUM (c
) || c
== '_' || (gfc_option
.flag_dollar_ok
&& c
== '$'));
551 if (c
== '$' && !gfc_option
.flag_dollar_ok
)
553 gfc_error ("Invalid character '$' at %C. Use -fdollar-ok to allow it "
559 gfc_current_locus
= old_loc
;
565 /* Match a valid name for C, which is almost the same as for Fortran,
566 except that you can start with an underscore, etc.. It could have
567 been done by modifying the gfc_match_name, but this way other
568 things C allows can be added, such as no limits on the length.
569 Right now, the length is limited to the same thing as Fortran..
570 Also, by rewriting it, we use the gfc_next_char_C() to prevent the
571 input characters from being automatically lower cased, since C is
572 case sensitive. The parameter, buffer, is used to return the name
573 that is matched. Return MATCH_ERROR if the name is too long
574 (though this is a self-imposed limit), MATCH_NO if what we're
575 seeing isn't a name, and MATCH_YES if we successfully match a C
579 gfc_match_name_C (char *buffer
)
585 old_loc
= gfc_current_locus
;
586 gfc_gobble_whitespace ();
588 /* Get the next char (first possible char of name) and see if
589 it's valid for C (either a letter or an underscore). */
590 c
= gfc_next_char_literal (1);
592 /* If the user put nothing expect spaces between the quotes, it is valid
593 and simply means there is no name= specifier and the name is the fortran
594 symbol name, all lowercase. */
595 if (c
== '"' || c
== '\'')
598 gfc_current_locus
= old_loc
;
602 if (!ISALPHA (c
) && c
!= '_')
604 gfc_error ("Invalid C name in NAME= specifier at %C");
608 /* Continue to read valid variable name characters. */
611 gcc_assert (gfc_wide_fits_in_byte (c
));
613 buffer
[i
++] = (unsigned char) c
;
615 /* C does not define a maximum length of variable names, to my
616 knowledge, but the compiler typically places a limit on them.
617 For now, i'll use the same as the fortran limit for simplicity,
618 but this may need to be changed to a dynamic buffer that can
619 be realloc'ed here if necessary, or more likely, a larger
621 if (i
> gfc_option
.max_identifier_length
)
623 gfc_error ("Name at %C is too long");
627 old_loc
= gfc_current_locus
;
629 /* Get next char; param means we're in a string. */
630 c
= gfc_next_char_literal (1);
631 } while (ISALNUM (c
) || c
== '_');
634 gfc_current_locus
= old_loc
;
636 /* See if we stopped because of whitespace. */
639 gfc_gobble_whitespace ();
640 c
= gfc_peek_ascii_char ();
641 if (c
!= '"' && c
!= '\'')
643 gfc_error ("Embedded space in NAME= specifier at %C");
648 /* If we stopped because we had an invalid character for a C name, report
649 that to the user by returning MATCH_NO. */
650 if (c
!= '"' && c
!= '\'')
652 gfc_error ("Invalid C name in NAME= specifier at %C");
660 /* Match a symbol on the input. Modifies the pointer to the symbol
661 pointer if successful. */
664 gfc_match_sym_tree (gfc_symtree
**matched_symbol
, int host_assoc
)
666 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
669 m
= gfc_match_name (buffer
);
674 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
675 ? MATCH_ERROR
: MATCH_YES
;
677 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
, false))
685 gfc_match_symbol (gfc_symbol
**matched_symbol
, int host_assoc
)
690 m
= gfc_match_sym_tree (&st
, host_assoc
);
695 *matched_symbol
= st
->n
.sym
;
697 *matched_symbol
= NULL
;
700 *matched_symbol
= NULL
;
705 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
706 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
710 gfc_match_intrinsic_op (gfc_intrinsic_op
*result
)
712 locus orig_loc
= gfc_current_locus
;
715 gfc_gobble_whitespace ();
716 ch
= gfc_next_ascii_char ();
721 *result
= INTRINSIC_PLUS
;
726 *result
= INTRINSIC_MINUS
;
730 if (gfc_next_ascii_char () == '=')
733 *result
= INTRINSIC_EQ
;
739 if (gfc_peek_ascii_char () == '=')
742 gfc_next_ascii_char ();
743 *result
= INTRINSIC_LE
;
747 *result
= INTRINSIC_LT
;
751 if (gfc_peek_ascii_char () == '=')
754 gfc_next_ascii_char ();
755 *result
= INTRINSIC_GE
;
759 *result
= INTRINSIC_GT
;
763 if (gfc_peek_ascii_char () == '*')
766 gfc_next_ascii_char ();
767 *result
= INTRINSIC_POWER
;
771 *result
= INTRINSIC_TIMES
;
775 ch
= gfc_peek_ascii_char ();
779 gfc_next_ascii_char ();
780 *result
= INTRINSIC_NE
;
786 gfc_next_ascii_char ();
787 *result
= INTRINSIC_CONCAT
;
791 *result
= INTRINSIC_DIVIDE
;
795 ch
= gfc_next_ascii_char ();
799 if (gfc_next_ascii_char () == 'n'
800 && gfc_next_ascii_char () == 'd'
801 && gfc_next_ascii_char () == '.')
803 /* Matched ".and.". */
804 *result
= INTRINSIC_AND
;
810 if (gfc_next_ascii_char () == 'q')
812 ch
= gfc_next_ascii_char ();
815 /* Matched ".eq.". */
816 *result
= INTRINSIC_EQ_OS
;
821 if (gfc_next_ascii_char () == '.')
823 /* Matched ".eqv.". */
824 *result
= INTRINSIC_EQV
;
832 ch
= gfc_next_ascii_char ();
835 if (gfc_next_ascii_char () == '.')
837 /* Matched ".ge.". */
838 *result
= INTRINSIC_GE_OS
;
844 if (gfc_next_ascii_char () == '.')
846 /* Matched ".gt.". */
847 *result
= INTRINSIC_GT_OS
;
854 ch
= gfc_next_ascii_char ();
857 if (gfc_next_ascii_char () == '.')
859 /* Matched ".le.". */
860 *result
= INTRINSIC_LE_OS
;
866 if (gfc_next_ascii_char () == '.')
868 /* Matched ".lt.". */
869 *result
= INTRINSIC_LT_OS
;
876 ch
= gfc_next_ascii_char ();
879 ch
= gfc_next_ascii_char ();
882 /* Matched ".ne.". */
883 *result
= INTRINSIC_NE_OS
;
888 if (gfc_next_ascii_char () == 'v'
889 && gfc_next_ascii_char () == '.')
891 /* Matched ".neqv.". */
892 *result
= INTRINSIC_NEQV
;
899 if (gfc_next_ascii_char () == 't'
900 && gfc_next_ascii_char () == '.')
902 /* Matched ".not.". */
903 *result
= INTRINSIC_NOT
;
910 if (gfc_next_ascii_char () == 'r'
911 && gfc_next_ascii_char () == '.')
913 /* Matched ".or.". */
914 *result
= INTRINSIC_OR
;
928 gfc_current_locus
= orig_loc
;
933 /* Match a loop control phrase:
935 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
937 If the final integer expression is not present, a constant unity
938 expression is returned. We don't return MATCH_ERROR until after
939 the equals sign is seen. */
942 gfc_match_iterator (gfc_iterator
*iter
, int init_flag
)
944 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
945 gfc_expr
*var
, *e1
, *e2
, *e3
;
949 /* Match the start of an iterator without affecting the symbol table. */
951 start
= gfc_current_locus
;
952 m
= gfc_match (" %n =", name
);
953 gfc_current_locus
= start
;
958 m
= gfc_match_variable (&var
, 0);
962 gfc_match_char ('=');
966 if (var
->ref
!= NULL
)
968 gfc_error ("Loop variable at %C cannot be a sub-component");
972 if (var
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
974 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
975 var
->symtree
->n
.sym
->name
);
979 var
->symtree
->n
.sym
->attr
.implied_index
= 1;
981 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
984 if (m
== MATCH_ERROR
)
987 if (gfc_match_char (',') != MATCH_YES
)
990 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
993 if (m
== MATCH_ERROR
)
996 if (gfc_match_char (',') != MATCH_YES
)
998 e3
= gfc_int_expr (1);
1002 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
1003 if (m
== MATCH_ERROR
)
1007 gfc_error ("Expected a step value in iterator at %C");
1019 gfc_error ("Syntax error in iterator at %C");
1030 /* Tries to match the next non-whitespace character on the input.
1031 This subroutine does not return MATCH_ERROR. */
1034 gfc_match_char (char c
)
1038 where
= gfc_current_locus
;
1039 gfc_gobble_whitespace ();
1041 if (gfc_next_ascii_char () == c
)
1044 gfc_current_locus
= where
;
1049 /* General purpose matching subroutine. The target string is a
1050 scanf-like format string in which spaces correspond to arbitrary
1051 whitespace (including no whitespace), characters correspond to
1052 themselves. The %-codes are:
1054 %% Literal percent sign
1055 %e Expression, pointer to a pointer is set
1056 %s Symbol, pointer to the symbol is set
1057 %n Name, character buffer is set to name
1058 %t Matches end of statement.
1059 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1060 %l Matches a statement label
1061 %v Matches a variable expression (an lvalue)
1062 % Matches a required space (in free form) and optional spaces. */
1065 gfc_match (const char *target
, ...)
1067 gfc_st_label
**label
;
1076 old_loc
= gfc_current_locus
;
1077 va_start (argp
, target
);
1087 gfc_gobble_whitespace ();
1098 vp
= va_arg (argp
, void **);
1099 n
= gfc_match_expr ((gfc_expr
**) vp
);
1110 vp
= va_arg (argp
, void **);
1111 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
1122 vp
= va_arg (argp
, void **);
1123 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
1134 np
= va_arg (argp
, char *);
1135 n
= gfc_match_name (np
);
1146 label
= va_arg (argp
, gfc_st_label
**);
1147 n
= gfc_match_st_label (label
);
1158 ip
= va_arg (argp
, int *);
1159 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
1170 if (gfc_match_eos () != MATCH_YES
)
1178 if (gfc_match_space () == MATCH_YES
)
1184 break; /* Fall through to character matcher. */
1187 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
1192 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1193 expect an upper case character here! */
1194 gcc_assert (TOLOWER (c
) == c
);
1196 if (c
== gfc_next_ascii_char ())
1206 /* Clean up after a failed match. */
1207 gfc_current_locus
= old_loc
;
1208 va_start (argp
, target
);
1211 for (; matches
> 0; matches
--)
1213 while (*p
++ != '%');
1221 /* Matches that don't have to be undone */
1226 (void) va_arg (argp
, void **);
1231 vp
= va_arg (argp
, void **);
1232 gfc_free_expr ((struct gfc_expr
*)*vp
);
1245 /*********************** Statement level matching **********************/
1247 /* Matches the start of a program unit, which is the program keyword
1248 followed by an obligatory symbol. */
1251 gfc_match_program (void)
1256 m
= gfc_match ("% %s%t", &sym
);
1260 gfc_error ("Invalid form of PROGRAM statement at %C");
1264 if (m
== MATCH_ERROR
)
1267 if (gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
) == FAILURE
)
1270 gfc_new_block
= sym
;
1276 /* Match a simple assignment statement. */
1279 gfc_match_assignment (void)
1281 gfc_expr
*lvalue
, *rvalue
;
1285 old_loc
= gfc_current_locus
;
1288 m
= gfc_match (" %v =", &lvalue
);
1291 gfc_current_locus
= old_loc
;
1292 gfc_free_expr (lvalue
);
1297 m
= gfc_match (" %e%t", &rvalue
);
1300 gfc_current_locus
= old_loc
;
1301 gfc_free_expr (lvalue
);
1302 gfc_free_expr (rvalue
);
1306 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1308 new_st
.op
= EXEC_ASSIGN
;
1309 new_st
.expr1
= lvalue
;
1310 new_st
.expr2
= rvalue
;
1312 gfc_check_do_variable (lvalue
->symtree
);
1318 /* Match a pointer assignment statement. */
1321 gfc_match_pointer_assignment (void)
1323 gfc_expr
*lvalue
, *rvalue
;
1327 old_loc
= gfc_current_locus
;
1329 lvalue
= rvalue
= NULL
;
1330 gfc_matching_procptr_assignment
= 0;
1332 m
= gfc_match (" %v =>", &lvalue
);
1339 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1340 || is_proc_ptr_comp (lvalue
, NULL
))
1341 gfc_matching_procptr_assignment
= 1;
1343 m
= gfc_match (" %e%t", &rvalue
);
1344 gfc_matching_procptr_assignment
= 0;
1348 new_st
.op
= EXEC_POINTER_ASSIGN
;
1349 new_st
.expr1
= lvalue
;
1350 new_st
.expr2
= rvalue
;
1355 gfc_current_locus
= old_loc
;
1356 gfc_free_expr (lvalue
);
1357 gfc_free_expr (rvalue
);
1362 /* We try to match an easy arithmetic IF statement. This only happens
1363 when just after having encountered a simple IF statement. This code
1364 is really duplicate with parts of the gfc_match_if code, but this is
1368 match_arithmetic_if (void)
1370 gfc_st_label
*l1
, *l2
, *l3
;
1374 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1378 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
1379 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
1380 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
1382 gfc_free_expr (expr
);
1386 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent: arithmetic IF statement "
1387 "at %C") == FAILURE
)
1390 new_st
.op
= EXEC_ARITHMETIC_IF
;
1391 new_st
.expr1
= expr
;
1400 /* The IF statement is a bit of a pain. First of all, there are three
1401 forms of it, the simple IF, the IF that starts a block and the
1404 There is a problem with the simple IF and that is the fact that we
1405 only have a single level of undo information on symbols. What this
1406 means is for a simple IF, we must re-match the whole IF statement
1407 multiple times in order to guarantee that the symbol table ends up
1408 in the proper state. */
1410 static match
match_simple_forall (void);
1411 static match
match_simple_where (void);
1414 gfc_match_if (gfc_statement
*if_type
)
1417 gfc_st_label
*l1
, *l2
, *l3
;
1418 locus old_loc
, old_loc2
;
1422 n
= gfc_match_label ();
1423 if (n
== MATCH_ERROR
)
1426 old_loc
= gfc_current_locus
;
1428 m
= gfc_match (" if ( %e", &expr
);
1432 old_loc2
= gfc_current_locus
;
1433 gfc_current_locus
= old_loc
;
1435 if (gfc_match_parens () == MATCH_ERROR
)
1438 gfc_current_locus
= old_loc2
;
1440 if (gfc_match_char (')') != MATCH_YES
)
1442 gfc_error ("Syntax error in IF-expression at %C");
1443 gfc_free_expr (expr
);
1447 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1453 gfc_error ("Block label not appropriate for arithmetic IF "
1455 gfc_free_expr (expr
);
1459 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
1460 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
1461 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
1463 gfc_free_expr (expr
);
1467 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent: arithmetic IF "
1468 "statement at %C") == FAILURE
)
1471 new_st
.op
= EXEC_ARITHMETIC_IF
;
1472 new_st
.expr1
= expr
;
1477 *if_type
= ST_ARITHMETIC_IF
;
1481 if (gfc_match (" then%t") == MATCH_YES
)
1483 new_st
.op
= EXEC_IF
;
1484 new_st
.expr1
= expr
;
1485 *if_type
= ST_IF_BLOCK
;
1491 gfc_error ("Block label is not appropriate for IF statement at %C");
1492 gfc_free_expr (expr
);
1496 /* At this point the only thing left is a simple IF statement. At
1497 this point, n has to be MATCH_NO, so we don't have to worry about
1498 re-matching a block label. From what we've got so far, try
1499 matching an assignment. */
1501 *if_type
= ST_SIMPLE_IF
;
1503 m
= gfc_match_assignment ();
1507 gfc_free_expr (expr
);
1508 gfc_undo_symbols ();
1509 gfc_current_locus
= old_loc
;
1511 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1512 assignment was found. For MATCH_NO, continue to call the various
1514 if (m
== MATCH_ERROR
)
1517 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1519 m
= gfc_match_pointer_assignment ();
1523 gfc_free_expr (expr
);
1524 gfc_undo_symbols ();
1525 gfc_current_locus
= old_loc
;
1527 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1529 /* Look at the next keyword to see which matcher to call. Matching
1530 the keyword doesn't affect the symbol table, so we don't have to
1531 restore between tries. */
1533 #define match(string, subr, statement) \
1534 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1538 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1539 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1540 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1541 match ("call", gfc_match_call
, ST_CALL
)
1542 match ("close", gfc_match_close
, ST_CLOSE
)
1543 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1544 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1545 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1546 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1547 match ("exit", gfc_match_exit
, ST_EXIT
)
1548 match ("flush", gfc_match_flush
, ST_FLUSH
)
1549 match ("forall", match_simple_forall
, ST_FORALL
)
1550 match ("go to", gfc_match_goto
, ST_GOTO
)
1551 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1552 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1553 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1554 match ("open", gfc_match_open
, ST_OPEN
)
1555 match ("pause", gfc_match_pause
, ST_NONE
)
1556 match ("print", gfc_match_print
, ST_WRITE
)
1557 match ("read", gfc_match_read
, ST_READ
)
1558 match ("return", gfc_match_return
, ST_RETURN
)
1559 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1560 match ("stop", gfc_match_stop
, ST_STOP
)
1561 match ("wait", gfc_match_wait
, ST_WAIT
)
1562 match ("where", match_simple_where
, ST_WHERE
)
1563 match ("write", gfc_match_write
, ST_WRITE
)
1565 /* The gfc_match_assignment() above may have returned a MATCH_NO
1566 where the assignment was to a named constant. Check that
1567 special case here. */
1568 m
= gfc_match_assignment ();
1571 gfc_error ("Cannot assign to a named constant at %C");
1572 gfc_free_expr (expr
);
1573 gfc_undo_symbols ();
1574 gfc_current_locus
= old_loc
;
1578 /* All else has failed, so give up. See if any of the matchers has
1579 stored an error message of some sort. */
1580 if (gfc_error_check () == 0)
1581 gfc_error ("Unclassifiable statement in IF-clause at %C");
1583 gfc_free_expr (expr
);
1588 gfc_error ("Syntax error in IF-clause at %C");
1591 gfc_free_expr (expr
);
1595 /* At this point, we've matched the single IF and the action clause
1596 is in new_st. Rearrange things so that the IF statement appears
1599 p
= gfc_get_code ();
1600 p
->next
= gfc_get_code ();
1602 p
->next
->loc
= gfc_current_locus
;
1607 gfc_clear_new_st ();
1609 new_st
.op
= EXEC_IF
;
1618 /* Match an ELSE statement. */
1621 gfc_match_else (void)
1623 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1625 if (gfc_match_eos () == MATCH_YES
)
1628 if (gfc_match_name (name
) != MATCH_YES
1629 || gfc_current_block () == NULL
1630 || gfc_match_eos () != MATCH_YES
)
1632 gfc_error ("Unexpected junk after ELSE statement at %C");
1636 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1638 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1639 name
, gfc_current_block ()->name
);
1647 /* Match an ELSE IF statement. */
1650 gfc_match_elseif (void)
1652 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1656 m
= gfc_match (" ( %e ) then", &expr
);
1660 if (gfc_match_eos () == MATCH_YES
)
1663 if (gfc_match_name (name
) != MATCH_YES
1664 || gfc_current_block () == NULL
1665 || gfc_match_eos () != MATCH_YES
)
1667 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1671 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1673 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1674 name
, gfc_current_block ()->name
);
1679 new_st
.op
= EXEC_IF
;
1680 new_st
.expr1
= expr
;
1684 gfc_free_expr (expr
);
1689 /* Free a gfc_iterator structure. */
1692 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1698 gfc_free_expr (iter
->var
);
1699 gfc_free_expr (iter
->start
);
1700 gfc_free_expr (iter
->end
);
1701 gfc_free_expr (iter
->step
);
1708 /* Match a DO statement. */
1713 gfc_iterator iter
, *ip
;
1715 gfc_st_label
*label
;
1718 old_loc
= gfc_current_locus
;
1721 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
1723 m
= gfc_match_label ();
1724 if (m
== MATCH_ERROR
)
1727 if (gfc_match (" do") != MATCH_YES
)
1730 m
= gfc_match_st_label (&label
);
1731 if (m
== MATCH_ERROR
)
1734 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
1736 if (gfc_match_eos () == MATCH_YES
)
1738 iter
.end
= gfc_logical_expr (1, NULL
);
1739 new_st
.op
= EXEC_DO_WHILE
;
1743 /* Match an optional comma, if no comma is found, a space is obligatory. */
1744 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
1747 /* Check for balanced parens. */
1749 if (gfc_match_parens () == MATCH_ERROR
)
1752 /* See if we have a DO WHILE. */
1753 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
1755 new_st
.op
= EXEC_DO_WHILE
;
1759 /* The abortive DO WHILE may have done something to the symbol
1760 table, so we start over. */
1761 gfc_undo_symbols ();
1762 gfc_current_locus
= old_loc
;
1764 gfc_match_label (); /* This won't error. */
1765 gfc_match (" do "); /* This will work. */
1767 gfc_match_st_label (&label
); /* Can't error out. */
1768 gfc_match_char (','); /* Optional comma. */
1770 m
= gfc_match_iterator (&iter
, 0);
1773 if (m
== MATCH_ERROR
)
1776 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
1777 gfc_check_do_variable (iter
.var
->symtree
);
1779 if (gfc_match_eos () != MATCH_YES
)
1781 gfc_syntax_error (ST_DO
);
1785 new_st
.op
= EXEC_DO
;
1789 && gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1792 new_st
.label1
= label
;
1794 if (new_st
.op
== EXEC_DO_WHILE
)
1795 new_st
.expr1
= iter
.end
;
1798 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
1805 gfc_free_iterator (&iter
, 0);
1811 /* Match an EXIT or CYCLE statement. */
1814 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
1816 gfc_state_data
*p
, *o
;
1820 if (gfc_match_eos () == MATCH_YES
)
1824 m
= gfc_match ("% %s%t", &sym
);
1825 if (m
== MATCH_ERROR
)
1829 gfc_syntax_error (st
);
1833 if (sym
->attr
.flavor
!= FL_LABEL
)
1835 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1836 sym
->name
, gfc_ascii_statement (st
));
1841 /* Find the loop mentioned specified by the label (or lack of a label). */
1842 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
1843 if (p
->state
== COMP_DO
&& (sym
== NULL
|| sym
== p
->sym
))
1845 else if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
1851 gfc_error ("%s statement at %C is not within a loop",
1852 gfc_ascii_statement (st
));
1854 gfc_error ("%s statement at %C is not within loop '%s'",
1855 gfc_ascii_statement (st
), sym
->name
);
1862 gfc_error ("%s statement at %C leaving OpenMP structured block",
1863 gfc_ascii_statement (st
));
1866 else if (st
== ST_EXIT
1867 && p
->previous
!= NULL
1868 && p
->previous
->state
== COMP_OMP_STRUCTURED_BLOCK
1869 && (p
->previous
->head
->op
== EXEC_OMP_DO
1870 || p
->previous
->head
->op
== EXEC_OMP_PARALLEL_DO
))
1872 gcc_assert (p
->previous
->head
->next
!= NULL
);
1873 gcc_assert (p
->previous
->head
->next
->op
== EXEC_DO
1874 || p
->previous
->head
->next
->op
== EXEC_DO_WHILE
);
1875 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1879 /* Save the first statement in the loop - needed by the backend. */
1880 new_st
.ext
.whichloop
= p
->head
;
1888 /* Match the EXIT statement. */
1891 gfc_match_exit (void)
1893 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
1897 /* Match the CYCLE statement. */
1900 gfc_match_cycle (void)
1902 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
1906 /* Match a number or character constant after a STOP or PAUSE statement. */
1909 gfc_match_stopcode (gfc_statement st
)
1919 if (gfc_match_eos () != MATCH_YES
)
1921 m
= gfc_match_small_literal_int (&stop_code
, &cnt
);
1922 if (m
== MATCH_ERROR
)
1925 if (m
== MATCH_YES
&& cnt
> 5)
1927 gfc_error ("Too many digits in STOP code at %C");
1933 /* Try a character constant. */
1934 m
= gfc_match_expr (&e
);
1935 if (m
== MATCH_ERROR
)
1939 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1943 if (gfc_match_eos () != MATCH_YES
)
1947 if (gfc_pure (NULL
))
1949 gfc_error ("%s statement not allowed in PURE procedure at %C",
1950 gfc_ascii_statement (st
));
1954 new_st
.op
= st
== ST_STOP
? EXEC_STOP
: EXEC_PAUSE
;
1956 new_st
.ext
.stop_code
= stop_code
;
1961 gfc_syntax_error (st
);
1970 /* Match the (deprecated) PAUSE statement. */
1973 gfc_match_pause (void)
1977 m
= gfc_match_stopcode (ST_PAUSE
);
1980 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: PAUSE statement"
1989 /* Match the STOP statement. */
1992 gfc_match_stop (void)
1994 return gfc_match_stopcode (ST_STOP
);
1998 /* Match a CONTINUE statement. */
2001 gfc_match_continue (void)
2003 if (gfc_match_eos () != MATCH_YES
)
2005 gfc_syntax_error (ST_CONTINUE
);
2009 new_st
.op
= EXEC_CONTINUE
;
2014 /* Match the (deprecated) ASSIGN statement. */
2017 gfc_match_assign (void)
2020 gfc_st_label
*label
;
2022 if (gfc_match (" %l", &label
) == MATCH_YES
)
2024 if (gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
) == FAILURE
)
2026 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
2028 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: ASSIGN "
2033 expr
->symtree
->n
.sym
->attr
.assign
= 1;
2035 new_st
.op
= EXEC_LABEL_ASSIGN
;
2036 new_st
.label1
= label
;
2037 new_st
.expr1
= expr
;
2045 /* Match the GO TO statement. As a computed GOTO statement is
2046 matched, it is transformed into an equivalent SELECT block. No
2047 tree is necessary, and the resulting jumps-to-jumps are
2048 specifically optimized away by the back end. */
2051 gfc_match_goto (void)
2053 gfc_code
*head
, *tail
;
2056 gfc_st_label
*label
;
2060 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
2062 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2065 new_st
.op
= EXEC_GOTO
;
2066 new_st
.label1
= label
;
2070 /* The assigned GO TO statement. */
2072 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
2074 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: Assigned GOTO "
2079 new_st
.op
= EXEC_GOTO
;
2080 new_st
.expr1
= expr
;
2082 if (gfc_match_eos () == MATCH_YES
)
2085 /* Match label list. */
2086 gfc_match_char (',');
2087 if (gfc_match_char ('(') != MATCH_YES
)
2089 gfc_syntax_error (ST_GOTO
);
2096 m
= gfc_match_st_label (&label
);
2100 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2104 head
= tail
= gfc_get_code ();
2107 tail
->block
= gfc_get_code ();
2111 tail
->label1
= label
;
2112 tail
->op
= EXEC_GOTO
;
2114 while (gfc_match_char (',') == MATCH_YES
);
2116 if (gfc_match (")%t") != MATCH_YES
)
2121 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2124 new_st
.block
= head
;
2129 /* Last chance is a computed GO TO statement. */
2130 if (gfc_match_char ('(') != MATCH_YES
)
2132 gfc_syntax_error (ST_GOTO
);
2141 m
= gfc_match_st_label (&label
);
2145 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2149 head
= tail
= gfc_get_code ();
2152 tail
->block
= gfc_get_code ();
2156 cp
= gfc_get_case ();
2157 cp
->low
= cp
->high
= gfc_int_expr (i
++);
2159 tail
->op
= EXEC_SELECT
;
2160 tail
->ext
.case_list
= cp
;
2162 tail
->next
= gfc_get_code ();
2163 tail
->next
->op
= EXEC_GOTO
;
2164 tail
->next
->label1
= label
;
2166 while (gfc_match_char (',') == MATCH_YES
);
2168 if (gfc_match_char (')') != MATCH_YES
)
2173 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2177 /* Get the rest of the statement. */
2178 gfc_match_char (',');
2180 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
2183 /* At this point, a computed GOTO has been fully matched and an
2184 equivalent SELECT statement constructed. */
2186 new_st
.op
= EXEC_SELECT
;
2187 new_st
.expr1
= NULL
;
2189 /* Hack: For a "real" SELECT, the expression is in expr. We put
2190 it in expr2 so we can distinguish then and produce the correct
2192 new_st
.expr2
= expr
;
2193 new_st
.block
= head
;
2197 gfc_syntax_error (ST_GOTO
);
2199 gfc_free_statements (head
);
2204 /* Frees a list of gfc_alloc structures. */
2207 gfc_free_alloc_list (gfc_alloc
*p
)
2214 gfc_free_expr (p
->expr
);
2220 /* Match an ALLOCATE statement. */
2223 gfc_match_allocate (void)
2225 gfc_alloc
*head
, *tail
;
2226 gfc_expr
*stat
, *errmsg
, *tmp
;
2228 bool saw_stat
, saw_errmsg
;
2231 stat
= errmsg
= tmp
= NULL
;
2232 saw_stat
= saw_errmsg
= false;
2234 if (gfc_match_char ('(') != MATCH_YES
)
2240 head
= tail
= gfc_get_alloc ();
2243 tail
->next
= gfc_get_alloc ();
2247 m
= gfc_match_variable (&tail
->expr
, 0);
2250 if (m
== MATCH_ERROR
)
2253 if (gfc_check_do_variable (tail
->expr
->symtree
))
2256 if (gfc_pure (NULL
) && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
2258 gfc_error ("Bad allocate-object at %C for a PURE procedure");
2262 if (tail
->expr
->ts
.type
== BT_DERIVED
)
2263 tail
->expr
->ts
.derived
= gfc_use_derived (tail
->expr
->ts
.derived
);
2265 /* FIXME: disable the checking on derived types and arrays. */
2266 if (!(tail
->expr
->ref
2267 && (tail
->expr
->ref
->type
== REF_COMPONENT
2268 || tail
->expr
->ref
->type
== REF_ARRAY
))
2269 && tail
->expr
->symtree
->n
.sym
2270 && !(tail
->expr
->symtree
->n
.sym
->attr
.allocatable
2271 || tail
->expr
->symtree
->n
.sym
->attr
.pointer
2272 || tail
->expr
->symtree
->n
.sym
->attr
.proc_pointer
))
2274 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2275 "or an allocatable variable");
2279 if (gfc_match_char (',') != MATCH_YES
)
2284 m
= gfc_match (" stat = %v", &tmp
);
2285 if (m
== MATCH_ERROR
)
2291 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
2292 gfc_free_expr (tmp
);
2299 if (gfc_check_do_variable (stat
->symtree
))
2302 if (gfc_match_char (',') == MATCH_YES
)
2303 goto alloc_opt_list
;
2306 m
= gfc_match (" errmsg = %v", &tmp
);
2307 if (m
== MATCH_ERROR
)
2311 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ERRMSG at %L",
2312 &tmp
->where
) == FAILURE
)
2317 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
2318 gfc_free_expr (tmp
);
2325 if (gfc_match_char (',') == MATCH_YES
)
2326 goto alloc_opt_list
;
2329 gfc_gobble_whitespace ();
2331 if (gfc_peek_char () == ')')
2336 if (gfc_match (" )%t") != MATCH_YES
)
2339 new_st
.op
= EXEC_ALLOCATE
;
2340 new_st
.expr1
= stat
;
2341 new_st
.expr2
= errmsg
;
2342 new_st
.ext
.alloc_list
= head
;
2347 gfc_syntax_error (ST_ALLOCATE
);
2350 gfc_free_expr (errmsg
);
2351 gfc_free_expr (stat
);
2352 gfc_free_alloc_list (head
);
2357 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
2358 a set of pointer assignments to intrinsic NULL(). */
2361 gfc_match_nullify (void)
2369 if (gfc_match_char ('(') != MATCH_YES
)
2374 m
= gfc_match_variable (&p
, 0);
2375 if (m
== MATCH_ERROR
)
2380 if (gfc_check_do_variable (p
->symtree
))
2383 if (gfc_pure (NULL
) && gfc_impure_variable (p
->symtree
->n
.sym
))
2385 gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
2389 /* build ' => NULL() '. */
2390 e
= gfc_get_expr ();
2391 e
->where
= gfc_current_locus
;
2392 e
->expr_type
= EXPR_NULL
;
2393 e
->ts
.type
= BT_UNKNOWN
;
2395 /* Chain to list. */
2400 tail
->next
= gfc_get_code ();
2404 tail
->op
= EXEC_POINTER_ASSIGN
;
2408 if (gfc_match (" )%t") == MATCH_YES
)
2410 if (gfc_match_char (',') != MATCH_YES
)
2417 gfc_syntax_error (ST_NULLIFY
);
2420 gfc_free_statements (new_st
.next
);
2422 gfc_free_expr (new_st
.expr1
);
2423 new_st
.expr1
= NULL
;
2424 gfc_free_expr (new_st
.expr2
);
2425 new_st
.expr2
= NULL
;
2430 /* Match a DEALLOCATE statement. */
2433 gfc_match_deallocate (void)
2435 gfc_alloc
*head
, *tail
;
2436 gfc_expr
*stat
, *errmsg
, *tmp
;
2438 bool saw_stat
, saw_errmsg
;
2441 stat
= errmsg
= tmp
= NULL
;
2442 saw_stat
= saw_errmsg
= false;
2444 if (gfc_match_char ('(') != MATCH_YES
)
2450 head
= tail
= gfc_get_alloc ();
2453 tail
->next
= gfc_get_alloc ();
2457 m
= gfc_match_variable (&tail
->expr
, 0);
2458 if (m
== MATCH_ERROR
)
2463 if (gfc_check_do_variable (tail
->expr
->symtree
))
2466 if (gfc_pure (NULL
) && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
2468 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
2472 /* FIXME: disable the checking on derived types. */
2473 if (!(tail
->expr
->ref
2474 && (tail
->expr
->ref
->type
== REF_COMPONENT
2475 || tail
->expr
->ref
->type
== REF_ARRAY
))
2476 && tail
->expr
->symtree
->n
.sym
2477 && !(tail
->expr
->symtree
->n
.sym
->attr
.allocatable
2478 || tail
->expr
->symtree
->n
.sym
->attr
.pointer
2479 || tail
->expr
->symtree
->n
.sym
->attr
.proc_pointer
))
2481 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2482 "or an allocatable variable");
2486 if (gfc_match_char (',') != MATCH_YES
)
2491 m
= gfc_match (" stat = %v", &tmp
);
2492 if (m
== MATCH_ERROR
)
2498 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
2499 gfc_free_expr (tmp
);
2506 if (gfc_check_do_variable (stat
->symtree
))
2509 if (gfc_match_char (',') == MATCH_YES
)
2510 goto dealloc_opt_list
;
2513 m
= gfc_match (" errmsg = %v", &tmp
);
2514 if (m
== MATCH_ERROR
)
2518 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ERRMSG at %L",
2519 &tmp
->where
) == FAILURE
)
2524 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
2525 gfc_free_expr (tmp
);
2532 if (gfc_match_char (',') == MATCH_YES
)
2533 goto dealloc_opt_list
;
2536 gfc_gobble_whitespace ();
2538 if (gfc_peek_char () == ')')
2542 if (gfc_match (" )%t") != MATCH_YES
)
2545 new_st
.op
= EXEC_DEALLOCATE
;
2546 new_st
.expr1
= stat
;
2547 new_st
.expr2
= errmsg
;
2548 new_st
.ext
.alloc_list
= head
;
2553 gfc_syntax_error (ST_DEALLOCATE
);
2556 gfc_free_expr (errmsg
);
2557 gfc_free_expr (stat
);
2558 gfc_free_alloc_list (head
);
2563 /* Match a RETURN statement. */
2566 gfc_match_return (void)
2570 gfc_compile_state s
;
2573 if (gfc_match_eos () == MATCH_YES
)
2576 if (gfc_find_state (COMP_SUBROUTINE
) == FAILURE
)
2578 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2583 if (gfc_current_form
== FORM_FREE
)
2585 /* The following are valid, so we can't require a blank after the
2589 char c
= gfc_peek_ascii_char ();
2590 if (ISALPHA (c
) || ISDIGIT (c
))
2594 m
= gfc_match (" %e%t", &e
);
2597 if (m
== MATCH_ERROR
)
2600 gfc_syntax_error (ST_RETURN
);
2607 gfc_enclosing_unit (&s
);
2608 if (s
== COMP_PROGRAM
2609 && gfc_notify_std (GFC_STD_GNU
, "Extension: RETURN statement in "
2610 "main program at %C") == FAILURE
)
2613 new_st
.op
= EXEC_RETURN
;
2620 /* Match the call of a type-bound procedure, if CALL%var has already been
2621 matched and var found to be a derived-type variable. */
2624 match_typebound_call (gfc_symtree
* varst
)
2632 base
= gfc_get_expr ();
2633 base
->expr_type
= EXPR_VARIABLE
;
2634 base
->symtree
= varst
;
2635 base
->where
= gfc_current_locus
;
2636 gfc_set_sym_referenced (varst
->n
.sym
);
2638 m
= gfc_match_varspec (base
, 0, true, true);
2640 gfc_error ("Expected component reference at %C");
2644 if (gfc_match_eos () != MATCH_YES
)
2646 gfc_error ("Junk after CALL at %C");
2650 if (base
->expr_type
== EXPR_COMPCALL
)
2651 new_st
.op
= EXEC_COMPCALL
;
2652 else if (base
->expr_type
== EXPR_PPC
)
2653 new_st
.op
= EXEC_CALL_PPC
;
2656 gfc_error ("Expected type-bound procedure or procedure pointer component "
2660 new_st
.expr1
= base
;
2666 /* Match a CALL statement. The tricky part here are possible
2667 alternate return specifiers. We handle these by having all
2668 "subroutines" actually return an integer via a register that gives
2669 the return number. If the call specifies alternate returns, we
2670 generate code for a SELECT statement whose case clauses contain
2671 GOTOs to the various labels. */
2674 gfc_match_call (void)
2676 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2677 gfc_actual_arglist
*a
, *arglist
;
2687 m
= gfc_match ("% %n", name
);
2693 if (gfc_get_ha_sym_tree (name
, &st
))
2698 /* If this is a variable of derived-type, it probably starts a type-bound
2700 if (sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->ts
.type
== BT_DERIVED
)
2701 return match_typebound_call (st
);
2703 /* If it does not seem to be callable (include functions so that the
2704 right association is made. They are thrown out in resolution.)
2706 if (!sym
->attr
.generic
2707 && !sym
->attr
.subroutine
2708 && !sym
->attr
.function
)
2710 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
2712 /* ...create a symbol in this scope... */
2713 if (sym
->ns
!= gfc_current_ns
2714 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
2717 if (sym
!= st
->n
.sym
)
2721 /* ...and then to try to make the symbol into a subroutine. */
2722 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2726 gfc_set_sym_referenced (sym
);
2728 if (gfc_match_eos () != MATCH_YES
)
2730 m
= gfc_match_actual_arglist (1, &arglist
);
2733 if (m
== MATCH_ERROR
)
2736 if (gfc_match_eos () != MATCH_YES
)
2740 /* If any alternate return labels were found, construct a SELECT
2741 statement that will jump to the right place. */
2744 for (a
= arglist
; a
; a
= a
->next
)
2745 if (a
->expr
== NULL
)
2750 gfc_symtree
*select_st
;
2751 gfc_symbol
*select_sym
;
2752 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2754 new_st
.next
= c
= gfc_get_code ();
2755 c
->op
= EXEC_SELECT
;
2756 sprintf (name
, "_result_%s", sym
->name
);
2757 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
2759 select_sym
= select_st
->n
.sym
;
2760 select_sym
->ts
.type
= BT_INTEGER
;
2761 select_sym
->ts
.kind
= gfc_default_integer_kind
;
2762 gfc_set_sym_referenced (select_sym
);
2763 c
->expr1
= gfc_get_expr ();
2764 c
->expr1
->expr_type
= EXPR_VARIABLE
;
2765 c
->expr1
->symtree
= select_st
;
2766 c
->expr1
->ts
= select_sym
->ts
;
2767 c
->expr1
->where
= gfc_current_locus
;
2770 for (a
= arglist
; a
; a
= a
->next
)
2772 if (a
->expr
!= NULL
)
2775 if (gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
) == FAILURE
)
2780 c
->block
= gfc_get_code ();
2782 c
->op
= EXEC_SELECT
;
2784 new_case
= gfc_get_case ();
2785 new_case
->high
= new_case
->low
= gfc_int_expr (i
);
2786 c
->ext
.case_list
= new_case
;
2788 c
->next
= gfc_get_code ();
2789 c
->next
->op
= EXEC_GOTO
;
2790 c
->next
->label1
= a
->label
;
2794 new_st
.op
= EXEC_CALL
;
2795 new_st
.symtree
= st
;
2796 new_st
.ext
.actual
= arglist
;
2801 gfc_syntax_error (ST_CALL
);
2804 gfc_free_actual_arglist (arglist
);
2809 /* Given a name, return a pointer to the common head structure,
2810 creating it if it does not exist. If FROM_MODULE is nonzero, we
2811 mangle the name so that it doesn't interfere with commons defined
2812 in the using namespace.
2813 TODO: Add to global symbol tree. */
2816 gfc_get_common (const char *name
, int from_module
)
2819 static int serial
= 0;
2820 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
2824 /* A use associated common block is only needed to correctly layout
2825 the variables it contains. */
2826 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
2827 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
2831 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
2834 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
2837 if (st
->n
.common
== NULL
)
2839 st
->n
.common
= gfc_get_common_head ();
2840 st
->n
.common
->where
= gfc_current_locus
;
2841 strcpy (st
->n
.common
->name
, name
);
2844 return st
->n
.common
;
2848 /* Match a common block name. */
2850 match
match_common_name (char *name
)
2854 if (gfc_match_char ('/') == MATCH_NO
)
2860 if (gfc_match_char ('/') == MATCH_YES
)
2866 m
= gfc_match_name (name
);
2868 if (m
== MATCH_ERROR
)
2870 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
2873 gfc_error ("Syntax error in common block name at %C");
2878 /* Match a COMMON statement. */
2881 gfc_match_common (void)
2883 gfc_symbol
*sym
, **head
, *tail
, *other
, *old_blank_common
;
2884 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2891 old_blank_common
= gfc_current_ns
->blank_common
.head
;
2892 if (old_blank_common
)
2894 while (old_blank_common
->common_next
)
2895 old_blank_common
= old_blank_common
->common_next
;
2902 m
= match_common_name (name
);
2903 if (m
== MATCH_ERROR
)
2906 gsym
= gfc_get_gsymbol (name
);
2907 if (gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= GSYM_COMMON
)
2909 gfc_error ("Symbol '%s' at %C is already an external symbol that "
2910 "is not COMMON", name
);
2914 if (gsym
->type
== GSYM_UNKNOWN
)
2916 gsym
->type
= GSYM_COMMON
;
2917 gsym
->where
= gfc_current_locus
;
2923 if (name
[0] == '\0')
2925 t
= &gfc_current_ns
->blank_common
;
2926 if (t
->head
== NULL
)
2927 t
->where
= gfc_current_locus
;
2931 t
= gfc_get_common (name
, 0);
2940 while (tail
->common_next
)
2941 tail
= tail
->common_next
;
2944 /* Grab the list of symbols. */
2947 m
= gfc_match_symbol (&sym
, 0);
2948 if (m
== MATCH_ERROR
)
2953 /* Store a ref to the common block for error checking. */
2954 sym
->common_block
= t
;
2956 /* See if we know the current common block is bind(c), and if
2957 so, then see if we can check if the symbol is (which it'll
2958 need to be). This can happen if the bind(c) attr stmt was
2959 applied to the common block, and the variable(s) already
2960 defined, before declaring the common block. */
2961 if (t
->is_bind_c
== 1)
2963 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
2965 /* If we find an error, just print it and continue,
2966 cause it's just semantic, and we can see if there
2968 gfc_error_now ("Variable '%s' at %L in common block '%s' "
2969 "at %C must be declared with a C "
2970 "interoperable kind since common block "
2972 sym
->name
, &(sym
->declared_at
), t
->name
,
2976 if (sym
->attr
.is_bind_c
== 1)
2977 gfc_error_now ("Variable '%s' in common block "
2978 "'%s' at %C can not be bind(c) since "
2979 "it is not global", sym
->name
, t
->name
);
2982 if (sym
->attr
.in_common
)
2984 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2989 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
2990 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
2992 if (gfc_notify_std (GFC_STD_GNU
, "Initialized symbol '%s' at %C "
2993 "can only be COMMON in "
2994 "BLOCK DATA", sym
->name
)
2999 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3003 tail
->common_next
= sym
;
3009 /* Deal with an optional array specification after the
3011 m
= gfc_match_array_spec (&as
);
3012 if (m
== MATCH_ERROR
)
3017 if (as
->type
!= AS_EXPLICIT
)
3019 gfc_error ("Array specification for symbol '%s' in COMMON "
3020 "at %C must be explicit", sym
->name
);
3024 if (gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3027 if (sym
->attr
.pointer
)
3029 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
3030 "POINTER array", sym
->name
);
3039 sym
->common_head
= t
;
3041 /* Check to see if the symbol is already in an equivalence group.
3042 If it is, set the other members as being in common. */
3043 if (sym
->attr
.in_equivalence
)
3045 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
3047 for (e2
= e1
; e2
; e2
= e2
->eq
)
3048 if (e2
->expr
->symtree
->n
.sym
== sym
)
3055 for (e2
= e1
; e2
; e2
= e2
->eq
)
3057 other
= e2
->expr
->symtree
->n
.sym
;
3058 if (other
->common_head
3059 && other
->common_head
!= sym
->common_head
)
3061 gfc_error ("Symbol '%s', in COMMON block '%s' at "
3062 "%C is being indirectly equivalenced to "
3063 "another COMMON block '%s'",
3064 sym
->name
, sym
->common_head
->name
,
3065 other
->common_head
->name
);
3068 other
->attr
.in_common
= 1;
3069 other
->common_head
= t
;
3075 gfc_gobble_whitespace ();
3076 if (gfc_match_eos () == MATCH_YES
)
3078 if (gfc_peek_ascii_char () == '/')
3080 if (gfc_match_char (',') != MATCH_YES
)
3082 gfc_gobble_whitespace ();
3083 if (gfc_peek_ascii_char () == '/')
3092 gfc_syntax_error (ST_COMMON
);
3095 if (old_blank_common
)
3096 old_blank_common
->common_next
= NULL
;
3098 gfc_current_ns
->blank_common
.head
= NULL
;
3099 gfc_free_array_spec (as
);
3104 /* Match a BLOCK DATA program unit. */
3107 gfc_match_block_data (void)
3109 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3113 if (gfc_match_eos () == MATCH_YES
)
3115 gfc_new_block
= NULL
;
3119 m
= gfc_match ("% %n%t", name
);
3123 if (gfc_get_symbol (name
, NULL
, &sym
))
3126 if (gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
) == FAILURE
)
3129 gfc_new_block
= sym
;
3135 /* Free a namelist structure. */
3138 gfc_free_namelist (gfc_namelist
*name
)
3142 for (; name
; name
= n
)
3150 /* Match a NAMELIST statement. */
3153 gfc_match_namelist (void)
3155 gfc_symbol
*group_name
, *sym
;
3159 m
= gfc_match (" / %s /", &group_name
);
3162 if (m
== MATCH_ERROR
)
3167 if (group_name
->ts
.type
!= BT_UNKNOWN
)
3169 gfc_error ("Namelist group name '%s' at %C already has a basic "
3170 "type of %s", group_name
->name
,
3171 gfc_typename (&group_name
->ts
));
3175 if (group_name
->attr
.flavor
== FL_NAMELIST
3176 && group_name
->attr
.use_assoc
3177 && gfc_notify_std (GFC_STD_GNU
, "Namelist group name '%s' "
3178 "at %C already is USE associated and can"
3179 "not be respecified.", group_name
->name
)
3183 if (group_name
->attr
.flavor
!= FL_NAMELIST
3184 && gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
3185 group_name
->name
, NULL
) == FAILURE
)
3190 m
= gfc_match_symbol (&sym
, 1);
3193 if (m
== MATCH_ERROR
)
3196 if (sym
->attr
.in_namelist
== 0
3197 && gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3200 /* Use gfc_error_check here, rather than goto error, so that
3201 these are the only errors for the next two lines. */
3202 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
3204 gfc_error ("Assumed size array '%s' in namelist '%s' at "
3205 "%C is not allowed", sym
->name
, group_name
->name
);
3209 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.cl
->length
== NULL
)
3211 gfc_error ("Assumed character length '%s' in namelist '%s' at "
3212 "%C is not allowed", sym
->name
, group_name
->name
);
3216 nl
= gfc_get_namelist ();
3220 if (group_name
->namelist
== NULL
)
3221 group_name
->namelist
= group_name
->namelist_tail
= nl
;
3224 group_name
->namelist_tail
->next
= nl
;
3225 group_name
->namelist_tail
= nl
;
3228 if (gfc_match_eos () == MATCH_YES
)
3231 m
= gfc_match_char (',');
3233 if (gfc_match_char ('/') == MATCH_YES
)
3235 m2
= gfc_match (" %s /", &group_name
);
3236 if (m2
== MATCH_YES
)
3238 if (m2
== MATCH_ERROR
)
3252 gfc_syntax_error (ST_NAMELIST
);
3259 /* Match a MODULE statement. */
3262 gfc_match_module (void)
3266 m
= gfc_match (" %s%t", &gfc_new_block
);
3270 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
3271 gfc_new_block
->name
, NULL
) == FAILURE
)
3278 /* Free equivalence sets and lists. Recursively is the easiest way to
3282 gfc_free_equiv (gfc_equiv
*eq
)
3287 gfc_free_equiv (eq
->eq
);
3288 gfc_free_equiv (eq
->next
);
3289 gfc_free_expr (eq
->expr
);
3294 /* Match an EQUIVALENCE statement. */
3297 gfc_match_equivalence (void)
3299 gfc_equiv
*eq
, *set
, *tail
;
3303 gfc_common_head
*common_head
= NULL
;
3311 eq
= gfc_get_equiv ();
3315 eq
->next
= gfc_current_ns
->equiv
;
3316 gfc_current_ns
->equiv
= eq
;
3318 if (gfc_match_char ('(') != MATCH_YES
)
3322 common_flag
= FALSE
;
3327 m
= gfc_match_equiv_variable (&set
->expr
);
3328 if (m
== MATCH_ERROR
)
3333 /* count the number of objects. */
3336 if (gfc_match_char ('%') == MATCH_YES
)
3338 gfc_error ("Derived type component %C is not a "
3339 "permitted EQUIVALENCE member");
3343 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
3344 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
3346 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
3347 "be an array section");
3351 sym
= set
->expr
->symtree
->n
.sym
;
3353 if (gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3356 if (sym
->attr
.in_common
)
3359 common_head
= sym
->common_head
;
3362 if (gfc_match_char (')') == MATCH_YES
)
3365 if (gfc_match_char (',') != MATCH_YES
)
3368 set
->eq
= gfc_get_equiv ();
3374 gfc_error ("EQUIVALENCE at %C requires two or more objects");
3378 /* If one of the members of an equivalence is in common, then
3379 mark them all as being in common. Before doing this, check
3380 that members of the equivalence group are not in different
3383 for (set
= eq
; set
; set
= set
->eq
)
3385 sym
= set
->expr
->symtree
->n
.sym
;
3386 if (sym
->common_head
&& sym
->common_head
!= common_head
)
3388 gfc_error ("Attempt to indirectly overlap COMMON "
3389 "blocks %s and %s by EQUIVALENCE at %C",
3390 sym
->common_head
->name
, common_head
->name
);
3393 sym
->attr
.in_common
= 1;
3394 sym
->common_head
= common_head
;
3397 if (gfc_match_eos () == MATCH_YES
)
3399 if (gfc_match_char (',') != MATCH_YES
)
3406 gfc_syntax_error (ST_EQUIVALENCE
);
3412 gfc_free_equiv (gfc_current_ns
->equiv
);
3413 gfc_current_ns
->equiv
= eq
;
3419 /* Check that a statement function is not recursive. This is done by looking
3420 for the statement function symbol(sym) by looking recursively through its
3421 expression(e). If a reference to sym is found, true is returned.
3422 12.5.4 requires that any variable of function that is implicitly typed
3423 shall have that type confirmed by any subsequent type declaration. The
3424 implicit typing is conveniently done here. */
3426 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
3429 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
3435 switch (e
->expr_type
)
3438 if (e
->symtree
== NULL
)
3441 /* Check the name before testing for nested recursion! */
3442 if (sym
->name
== e
->symtree
->n
.sym
->name
)
3445 /* Catch recursion via other statement functions. */
3446 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
3447 && e
->symtree
->n
.sym
->value
3448 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
3451 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
3452 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
3457 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
3460 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
3461 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
3473 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
3475 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
3479 /* Match a statement function declaration. It is so easy to match
3480 non-statement function statements with a MATCH_ERROR as opposed to
3481 MATCH_NO that we suppress error message in most cases. */
3484 gfc_match_st_function (void)
3486 gfc_error_buf old_error
;
3491 m
= gfc_match_symbol (&sym
, 0);
3495 gfc_push_error (&old_error
);
3497 if (gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
,
3498 sym
->name
, NULL
) == FAILURE
)
3501 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
3504 m
= gfc_match (" = %e%t", &expr
);
3508 gfc_free_error (&old_error
);
3509 if (m
== MATCH_ERROR
)
3512 if (recursive_stmt_fcn (expr
, sym
))
3514 gfc_error ("Statement function at %L is recursive", &expr
->where
);
3523 gfc_pop_error (&old_error
);
3528 /***************** SELECT CASE subroutines ******************/
3530 /* Free a single case structure. */
3533 free_case (gfc_case
*p
)
3535 if (p
->low
== p
->high
)
3537 gfc_free_expr (p
->low
);
3538 gfc_free_expr (p
->high
);
3543 /* Free a list of case structures. */
3546 gfc_free_case_list (gfc_case
*p
)
3558 /* Match a single case selector. */
3561 match_case_selector (gfc_case
**cp
)
3566 c
= gfc_get_case ();
3567 c
->where
= gfc_current_locus
;
3569 if (gfc_match_char (':') == MATCH_YES
)
3571 m
= gfc_match_init_expr (&c
->high
);
3574 if (m
== MATCH_ERROR
)
3579 m
= gfc_match_init_expr (&c
->low
);
3580 if (m
== MATCH_ERROR
)
3585 /* If we're not looking at a ':' now, make a range out of a single
3586 target. Else get the upper bound for the case range. */
3587 if (gfc_match_char (':') != MATCH_YES
)
3591 m
= gfc_match_init_expr (&c
->high
);
3592 if (m
== MATCH_ERROR
)
3594 /* MATCH_NO is fine. It's OK if nothing is there! */
3602 gfc_error ("Expected initialization expression in CASE at %C");
3610 /* Match the end of a case statement. */
3613 match_case_eos (void)
3615 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3618 if (gfc_match_eos () == MATCH_YES
)
3621 /* If the case construct doesn't have a case-construct-name, we
3622 should have matched the EOS. */
3623 if (!gfc_current_block ())
3625 gfc_error ("Expected the name of the SELECT CASE construct at %C");
3629 gfc_gobble_whitespace ();
3631 m
= gfc_match_name (name
);
3635 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3637 gfc_error ("Expected case name of '%s' at %C",
3638 gfc_current_block ()->name
);
3642 return gfc_match_eos ();
3646 /* Match a SELECT statement. */
3649 gfc_match_select (void)
3654 m
= gfc_match_label ();
3655 if (m
== MATCH_ERROR
)
3658 m
= gfc_match (" select case ( %e )%t", &expr
);
3662 new_st
.op
= EXEC_SELECT
;
3663 new_st
.expr1
= expr
;
3669 /* Match a CASE statement. */
3672 gfc_match_case (void)
3674 gfc_case
*c
, *head
, *tail
;
3679 if (gfc_current_state () != COMP_SELECT
)
3681 gfc_error ("Unexpected CASE statement at %C");
3685 if (gfc_match ("% default") == MATCH_YES
)
3687 m
= match_case_eos ();
3690 if (m
== MATCH_ERROR
)
3693 new_st
.op
= EXEC_SELECT
;
3694 c
= gfc_get_case ();
3695 c
->where
= gfc_current_locus
;
3696 new_st
.ext
.case_list
= c
;
3700 if (gfc_match_char ('(') != MATCH_YES
)
3705 if (match_case_selector (&c
) == MATCH_ERROR
)
3715 if (gfc_match_char (')') == MATCH_YES
)
3717 if (gfc_match_char (',') != MATCH_YES
)
3721 m
= match_case_eos ();
3724 if (m
== MATCH_ERROR
)
3727 new_st
.op
= EXEC_SELECT
;
3728 new_st
.ext
.case_list
= head
;
3733 gfc_error ("Syntax error in CASE-specification at %C");
3736 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
3740 /********************* WHERE subroutines ********************/
3742 /* Match the rest of a simple WHERE statement that follows an IF statement.
3746 match_simple_where (void)
3752 m
= gfc_match (" ( %e )", &expr
);
3756 m
= gfc_match_assignment ();
3759 if (m
== MATCH_ERROR
)
3762 if (gfc_match_eos () != MATCH_YES
)
3765 c
= gfc_get_code ();
3769 c
->next
= gfc_get_code ();
3772 gfc_clear_new_st ();
3774 new_st
.op
= EXEC_WHERE
;
3780 gfc_syntax_error (ST_WHERE
);
3783 gfc_free_expr (expr
);
3788 /* Match a WHERE statement. */
3791 gfc_match_where (gfc_statement
*st
)
3797 m0
= gfc_match_label ();
3798 if (m0
== MATCH_ERROR
)
3801 m
= gfc_match (" where ( %e )", &expr
);
3805 if (gfc_match_eos () == MATCH_YES
)
3807 *st
= ST_WHERE_BLOCK
;
3808 new_st
.op
= EXEC_WHERE
;
3809 new_st
.expr1
= expr
;
3813 m
= gfc_match_assignment ();
3815 gfc_syntax_error (ST_WHERE
);
3819 gfc_free_expr (expr
);
3823 /* We've got a simple WHERE statement. */
3825 c
= gfc_get_code ();
3829 c
->next
= gfc_get_code ();
3832 gfc_clear_new_st ();
3834 new_st
.op
= EXEC_WHERE
;
3841 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3842 new_st if successful. */
3845 gfc_match_elsewhere (void)
3847 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3851 if (gfc_current_state () != COMP_WHERE
)
3853 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3859 if (gfc_match_char ('(') == MATCH_YES
)
3861 m
= gfc_match_expr (&expr
);
3864 if (m
== MATCH_ERROR
)
3867 if (gfc_match_char (')') != MATCH_YES
)
3871 if (gfc_match_eos () != MATCH_YES
)
3873 /* Only makes sense if we have a where-construct-name. */
3874 if (!gfc_current_block ())
3879 /* Better be a name at this point. */
3880 m
= gfc_match_name (name
);
3883 if (m
== MATCH_ERROR
)
3886 if (gfc_match_eos () != MATCH_YES
)
3889 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3891 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3892 name
, gfc_current_block ()->name
);
3897 new_st
.op
= EXEC_WHERE
;
3898 new_st
.expr1
= expr
;
3902 gfc_syntax_error (ST_ELSEWHERE
);
3905 gfc_free_expr (expr
);
3910 /******************** FORALL subroutines ********************/
3912 /* Free a list of FORALL iterators. */
3915 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
3917 gfc_forall_iterator
*next
;
3922 gfc_free_expr (iter
->var
);
3923 gfc_free_expr (iter
->start
);
3924 gfc_free_expr (iter
->end
);
3925 gfc_free_expr (iter
->stride
);
3932 /* Match an iterator as part of a FORALL statement. The format is:
3934 <var> = <start>:<end>[:<stride>]
3936 On MATCH_NO, the caller tests for the possibility that there is a
3937 scalar mask expression. */
3940 match_forall_iterator (gfc_forall_iterator
**result
)
3942 gfc_forall_iterator
*iter
;
3946 where
= gfc_current_locus
;
3947 iter
= XCNEW (gfc_forall_iterator
);
3949 m
= gfc_match_expr (&iter
->var
);
3953 if (gfc_match_char ('=') != MATCH_YES
3954 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
3960 m
= gfc_match_expr (&iter
->start
);
3964 if (gfc_match_char (':') != MATCH_YES
)
3967 m
= gfc_match_expr (&iter
->end
);
3970 if (m
== MATCH_ERROR
)
3973 if (gfc_match_char (':') == MATCH_NO
)
3974 iter
->stride
= gfc_int_expr (1);
3977 m
= gfc_match_expr (&iter
->stride
);
3980 if (m
== MATCH_ERROR
)
3984 /* Mark the iteration variable's symbol as used as a FORALL index. */
3985 iter
->var
->symtree
->n
.sym
->forall_index
= true;
3991 gfc_error ("Syntax error in FORALL iterator at %C");
3996 gfc_current_locus
= where
;
3997 gfc_free_forall_iterator (iter
);
4002 /* Match the header of a FORALL statement. */
4005 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
4007 gfc_forall_iterator
*head
, *tail
, *new_iter
;
4011 gfc_gobble_whitespace ();
4016 if (gfc_match_char ('(') != MATCH_YES
)
4019 m
= match_forall_iterator (&new_iter
);
4020 if (m
== MATCH_ERROR
)
4025 head
= tail
= new_iter
;
4029 if (gfc_match_char (',') != MATCH_YES
)
4032 m
= match_forall_iterator (&new_iter
);
4033 if (m
== MATCH_ERROR
)
4038 tail
->next
= new_iter
;
4043 /* Have to have a mask expression. */
4045 m
= gfc_match_expr (&msk
);
4048 if (m
== MATCH_ERROR
)
4054 if (gfc_match_char (')') == MATCH_NO
)
4062 gfc_syntax_error (ST_FORALL
);
4065 gfc_free_expr (msk
);
4066 gfc_free_forall_iterator (head
);
4071 /* Match the rest of a simple FORALL statement that follows an
4075 match_simple_forall (void)
4077 gfc_forall_iterator
*head
;
4086 m
= match_forall_header (&head
, &mask
);
4093 m
= gfc_match_assignment ();
4095 if (m
== MATCH_ERROR
)
4099 m
= gfc_match_pointer_assignment ();
4100 if (m
== MATCH_ERROR
)
4106 c
= gfc_get_code ();
4108 c
->loc
= gfc_current_locus
;
4110 if (gfc_match_eos () != MATCH_YES
)
4113 gfc_clear_new_st ();
4114 new_st
.op
= EXEC_FORALL
;
4115 new_st
.expr1
= mask
;
4116 new_st
.ext
.forall_iterator
= head
;
4117 new_st
.block
= gfc_get_code ();
4119 new_st
.block
->op
= EXEC_FORALL
;
4120 new_st
.block
->next
= c
;
4125 gfc_syntax_error (ST_FORALL
);
4128 gfc_free_forall_iterator (head
);
4129 gfc_free_expr (mask
);
4135 /* Match a FORALL statement. */
4138 gfc_match_forall (gfc_statement
*st
)
4140 gfc_forall_iterator
*head
;
4149 m0
= gfc_match_label ();
4150 if (m0
== MATCH_ERROR
)
4153 m
= gfc_match (" forall");
4157 m
= match_forall_header (&head
, &mask
);
4158 if (m
== MATCH_ERROR
)
4163 if (gfc_match_eos () == MATCH_YES
)
4165 *st
= ST_FORALL_BLOCK
;
4166 new_st
.op
= EXEC_FORALL
;
4167 new_st
.expr1
= mask
;
4168 new_st
.ext
.forall_iterator
= head
;
4172 m
= gfc_match_assignment ();
4173 if (m
== MATCH_ERROR
)
4177 m
= gfc_match_pointer_assignment ();
4178 if (m
== MATCH_ERROR
)
4184 c
= gfc_get_code ();
4186 c
->loc
= gfc_current_locus
;
4188 gfc_clear_new_st ();
4189 new_st
.op
= EXEC_FORALL
;
4190 new_st
.expr1
= mask
;
4191 new_st
.ext
.forall_iterator
= head
;
4192 new_st
.block
= gfc_get_code ();
4193 new_st
.block
->op
= EXEC_FORALL
;
4194 new_st
.block
->next
= c
;
4200 gfc_syntax_error (ST_FORALL
);
4203 gfc_free_forall_iterator (head
);
4204 gfc_free_expr (mask
);
4205 gfc_free_statements (c
);