1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
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/>. */
30 /* For debugging and diagnostic purposes. Return the textual representation
31 of the intrinsic operator OP. */
33 gfc_op2string (gfc_intrinsic_op op
)
41 case INTRINSIC_UMINUS
:
47 case INTRINSIC_CONCAT
:
51 case INTRINSIC_DIVIDE
:
90 case INTRINSIC_ASSIGN
:
93 case INTRINSIC_PARENTHESES
:
100 gfc_internal_error ("gfc_op2string(): Bad code");
105 /******************** Generic matching subroutines ************************/
107 /* See if the next character is a special character that has
108 escaped by a \ via the -fbackslash option. */
111 gfc_match_special_char (int *c
)
118 switch (gfc_next_char_literal (1))
148 /* Unknown backslash codes are simply not expanded. */
157 /* In free form, match at least one space. Always matches in fixed
161 gfc_match_space (void)
166 if (gfc_current_form
== FORM_FIXED
)
169 old_loc
= gfc_current_locus
;
171 c
= gfc_next_char ();
172 if (!gfc_is_whitespace (c
))
174 gfc_current_locus
= old_loc
;
178 gfc_gobble_whitespace ();
184 /* Match an end of statement. End of statement is optional
185 whitespace, followed by a ';' or '\n' or comment '!'. If a
186 semicolon is found, we continue to eat whitespace and semicolons. */
198 old_loc
= gfc_current_locus
;
199 gfc_gobble_whitespace ();
201 c
= gfc_next_char ();
207 c
= gfc_next_char ();
224 gfc_current_locus
= old_loc
;
225 return (flag
) ? MATCH_YES
: MATCH_NO
;
229 /* Match a literal integer on the input, setting the value on
230 MATCH_YES. Literal ints occur in kind-parameters as well as
231 old-style character length specifications. If cnt is non-NULL it
232 will be set to the number of digits. */
235 gfc_match_small_literal_int (int *value
, int *cnt
)
241 old_loc
= gfc_current_locus
;
243 gfc_gobble_whitespace ();
244 c
= gfc_next_char ();
250 gfc_current_locus
= old_loc
;
259 old_loc
= gfc_current_locus
;
260 c
= gfc_next_char ();
265 i
= 10 * i
+ c
- '0';
270 gfc_error ("Integer too large at %C");
275 gfc_current_locus
= old_loc
;
284 /* Match a small, constant integer expression, like in a kind
285 statement. On MATCH_YES, 'value' is set. */
288 gfc_match_small_int (int *value
)
295 m
= gfc_match_expr (&expr
);
299 p
= gfc_extract_int (expr
, &i
);
300 gfc_free_expr (expr
);
313 /* This function is the same as the gfc_match_small_int, except that
314 we're keeping the pointer to the expr. This function could just be
315 removed and the previously mentioned one modified, though all calls
316 to it would have to be modified then (and there were a number of
317 them). Return MATCH_ERROR if fail to extract the int; otherwise,
318 return the result of gfc_match_expr(). The expr (if any) that was
319 matched is returned in the parameter expr. */
322 gfc_match_small_int_expr (int *value
, gfc_expr
**expr
)
328 m
= gfc_match_expr (expr
);
332 p
= gfc_extract_int (*expr
, &i
);
345 /* Matches a statement label. Uses gfc_match_small_literal_int() to
346 do most of the work. */
349 gfc_match_st_label (gfc_st_label
**label
)
355 old_loc
= gfc_current_locus
;
357 m
= gfc_match_small_literal_int (&i
, &cnt
);
363 gfc_error ("Too many digits in statement label at %C");
369 gfc_error ("Statement label at %C is zero");
373 *label
= gfc_get_st_label (i
);
378 gfc_current_locus
= old_loc
;
383 /* Match and validate a label associated with a named IF, DO or SELECT
384 statement. If the symbol does not have the label attribute, we add
385 it. We also make sure the symbol does not refer to another
386 (active) block. A matched label is pointed to by gfc_new_block. */
389 gfc_match_label (void)
391 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
394 gfc_new_block
= NULL
;
396 m
= gfc_match (" %n :", name
);
400 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
402 gfc_error ("Label name '%s' at %C is ambiguous", name
);
406 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
408 gfc_error ("Duplicate construct label '%s' at %C", name
);
412 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
413 gfc_new_block
->name
, NULL
) == FAILURE
)
420 /* Try and match the input against an array of possibilities. If one
421 potential matching string is a substring of another, the longest
422 match takes precedence. Spaces in the target strings are optional
423 spaces that do not necessarily have to be found in the input
424 stream. In fixed mode, spaces never appear. If whitespace is
425 matched, it matches unlimited whitespace in the input. For this
426 reason, the 'mp' member of the mstring structure is used to track
427 the progress of each potential match.
429 If there is no match we return the tag associated with the
430 terminating NULL mstring structure and leave the locus pointer
431 where it started. If there is a match we return the tag member of
432 the matched mstring and leave the locus pointer after the matched
435 A '%' character is a mandatory space. */
438 gfc_match_strings (mstring
*a
)
440 mstring
*p
, *best_match
;
441 int no_match
, c
, possibles
;
446 for (p
= a
; p
->string
!= NULL
; p
++)
455 match_loc
= gfc_current_locus
;
457 gfc_gobble_whitespace ();
459 while (possibles
> 0)
461 c
= gfc_next_char ();
463 /* Apply the next character to the current possibilities. */
464 for (p
= a
; p
->string
!= NULL
; p
++)
471 /* Space matches 1+ whitespace(s). */
472 if ((gfc_current_form
== FORM_FREE
) && gfc_is_whitespace (c
))
490 match_loc
= gfc_current_locus
;
498 gfc_current_locus
= match_loc
;
500 return (best_match
== NULL
) ? no_match
: best_match
->tag
;
504 /* See if the current input looks like a name of some sort. Modifies
505 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
506 Note that options.c restricts max_identifier_length to not more
507 than GFC_MAX_SYMBOL_LEN. */
510 gfc_match_name (char *buffer
)
515 old_loc
= gfc_current_locus
;
516 gfc_gobble_whitespace ();
518 c
= gfc_next_char ();
519 if (!(ISALPHA (c
) || (c
== '_' && gfc_option
.flag_allow_leading_underscore
)))
521 if (gfc_error_flag_test() == 0)
522 gfc_error ("Invalid character in name at %C");
523 gfc_current_locus
= old_loc
;
533 if (i
> gfc_option
.max_identifier_length
)
535 gfc_error ("Name at %C is too long");
539 old_loc
= gfc_current_locus
;
540 c
= gfc_next_char ();
542 while (ISALNUM (c
) || c
== '_' || (gfc_option
.flag_dollar_ok
&& c
== '$'));
545 gfc_current_locus
= old_loc
;
551 /* Match a valid name for C, which is almost the same as for Fortran,
552 except that you can start with an underscore, etc.. It could have
553 been done by modifying the gfc_match_name, but this way other
554 things C allows can be added, such as no limits on the length.
555 Right now, the length is limited to the same thing as Fortran..
556 Also, by rewriting it, we use the gfc_next_char_C() to prevent the
557 input characters from being automatically lower cased, since C is
558 case sensitive. The parameter, buffer, is used to return the name
559 that is matched. Return MATCH_ERROR if the name is too long
560 (though this is a self-imposed limit), MATCH_NO if what we're
561 seeing isn't a name, and MATCH_YES if we successfully match a C
565 gfc_match_name_C (char *buffer
)
571 old_loc
= gfc_current_locus
;
572 gfc_gobble_whitespace ();
574 /* Get the next char (first possible char of name) and see if
575 it's valid for C (either a letter or an underscore). */
576 c
= gfc_next_char_literal (1);
578 /* If the user put nothing expect spaces between the quotes, it is valid
579 and simply means there is no name= specifier and the name is the fortran
580 symbol name, all lowercase. */
581 if (c
== '"' || c
== '\'')
584 gfc_current_locus
= old_loc
;
588 if (!ISALPHA (c
) && c
!= '_')
590 gfc_error ("Invalid C name in NAME= specifier at %C");
594 /* Continue to read valid variable name characters. */
599 /* C does not define a maximum length of variable names, to my
600 knowledge, but the compiler typically places a limit on them.
601 For now, i'll use the same as the fortran limit for simplicity,
602 but this may need to be changed to a dynamic buffer that can
603 be realloc'ed here if necessary, or more likely, a larger
605 if (i
> gfc_option
.max_identifier_length
)
607 gfc_error ("Name at %C is too long");
611 old_loc
= gfc_current_locus
;
613 /* Get next char; param means we're in a string. */
614 c
= gfc_next_char_literal (1);
615 } while (ISALNUM (c
) || c
== '_');
618 gfc_current_locus
= old_loc
;
620 /* See if we stopped because of whitespace. */
623 gfc_gobble_whitespace ();
624 c
= gfc_peek_char ();
625 if (c
!= '"' && c
!= '\'')
627 gfc_error ("Embedded space in NAME= specifier at %C");
632 /* If we stopped because we had an invalid character for a C name, report
633 that to the user by returning MATCH_NO. */
634 if (c
!= '"' && c
!= '\'')
636 gfc_error ("Invalid C name in NAME= specifier at %C");
644 /* Match a symbol on the input. Modifies the pointer to the symbol
645 pointer if successful. */
648 gfc_match_sym_tree (gfc_symtree
**matched_symbol
, int host_assoc
)
650 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
653 m
= gfc_match_name (buffer
);
658 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
659 ? MATCH_ERROR
: MATCH_YES
;
661 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
))
669 gfc_match_symbol (gfc_symbol
**matched_symbol
, int host_assoc
)
674 m
= gfc_match_sym_tree (&st
, host_assoc
);
679 *matched_symbol
= st
->n
.sym
;
681 *matched_symbol
= NULL
;
684 *matched_symbol
= NULL
;
689 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
690 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
694 gfc_match_intrinsic_op (gfc_intrinsic_op
*result
)
696 locus orig_loc
= gfc_current_locus
;
699 gfc_gobble_whitespace ();
700 ch
= gfc_next_char ();
705 *result
= INTRINSIC_PLUS
;
710 *result
= INTRINSIC_MINUS
;
714 if (gfc_next_char () == '=')
717 *result
= INTRINSIC_EQ
;
723 if (gfc_peek_char () == '=')
727 *result
= INTRINSIC_LE
;
731 *result
= INTRINSIC_LT
;
735 if (gfc_peek_char () == '=')
739 *result
= INTRINSIC_GE
;
743 *result
= INTRINSIC_GT
;
747 if (gfc_peek_char () == '*')
751 *result
= INTRINSIC_POWER
;
755 *result
= INTRINSIC_TIMES
;
759 ch
= gfc_peek_char ();
764 *result
= INTRINSIC_NE
;
771 *result
= INTRINSIC_CONCAT
;
775 *result
= INTRINSIC_DIVIDE
;
779 ch
= gfc_next_char ();
783 if (gfc_next_char () == 'n'
784 && gfc_next_char () == 'd'
785 && gfc_next_char () == '.')
787 /* Matched ".and.". */
788 *result
= INTRINSIC_AND
;
794 if (gfc_next_char () == 'q')
796 ch
= gfc_next_char ();
799 /* Matched ".eq.". */
800 *result
= INTRINSIC_EQ_OS
;
805 if (gfc_next_char () == '.')
807 /* Matched ".eqv.". */
808 *result
= INTRINSIC_EQV
;
816 ch
= gfc_next_char ();
819 if (gfc_next_char () == '.')
821 /* Matched ".ge.". */
822 *result
= INTRINSIC_GE_OS
;
828 if (gfc_next_char () == '.')
830 /* Matched ".gt.". */
831 *result
= INTRINSIC_GT_OS
;
838 ch
= gfc_next_char ();
841 if (gfc_next_char () == '.')
843 /* Matched ".le.". */
844 *result
= INTRINSIC_LE_OS
;
850 if (gfc_next_char () == '.')
852 /* Matched ".lt.". */
853 *result
= INTRINSIC_LT_OS
;
860 ch
= gfc_next_char ();
863 ch
= gfc_next_char ();
866 /* Matched ".ne.". */
867 *result
= INTRINSIC_NE_OS
;
872 if (gfc_next_char () == 'v'
873 && gfc_next_char () == '.')
875 /* Matched ".neqv.". */
876 *result
= INTRINSIC_NEQV
;
883 if (gfc_next_char () == 't'
884 && gfc_next_char () == '.')
886 /* Matched ".not.". */
887 *result
= INTRINSIC_NOT
;
894 if (gfc_next_char () == 'r'
895 && gfc_next_char () == '.')
897 /* Matched ".or.". */
898 *result
= INTRINSIC_OR
;
912 gfc_current_locus
= orig_loc
;
917 /* Match a loop control phrase:
919 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
921 If the final integer expression is not present, a constant unity
922 expression is returned. We don't return MATCH_ERROR until after
923 the equals sign is seen. */
926 gfc_match_iterator (gfc_iterator
*iter
, int init_flag
)
928 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
929 gfc_expr
*var
, *e1
, *e2
, *e3
;
933 /* Match the start of an iterator without affecting the symbol table. */
935 start
= gfc_current_locus
;
936 m
= gfc_match (" %n =", name
);
937 gfc_current_locus
= start
;
942 m
= gfc_match_variable (&var
, 0);
946 gfc_match_char ('=');
950 if (var
->ref
!= NULL
)
952 gfc_error ("Loop variable at %C cannot be a sub-component");
956 if (var
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
958 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
959 var
->symtree
->n
.sym
->name
);
963 var
->symtree
->n
.sym
->attr
.implied_index
= 1;
965 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
968 if (m
== MATCH_ERROR
)
971 if (gfc_match_char (',') != MATCH_YES
)
974 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
977 if (m
== MATCH_ERROR
)
980 if (gfc_match_char (',') != MATCH_YES
)
982 e3
= gfc_int_expr (1);
986 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
987 if (m
== MATCH_ERROR
)
991 gfc_error ("Expected a step value in iterator at %C");
1003 gfc_error ("Syntax error in iterator at %C");
1014 /* Tries to match the next non-whitespace character on the input.
1015 This subroutine does not return MATCH_ERROR. */
1018 gfc_match_char (char c
)
1022 where
= gfc_current_locus
;
1023 gfc_gobble_whitespace ();
1025 if (gfc_next_char () == c
)
1028 gfc_current_locus
= where
;
1033 /* General purpose matching subroutine. The target string is a
1034 scanf-like format string in which spaces correspond to arbitrary
1035 whitespace (including no whitespace), characters correspond to
1036 themselves. The %-codes are:
1038 %% Literal percent sign
1039 %e Expression, pointer to a pointer is set
1040 %s Symbol, pointer to the symbol is set
1041 %n Name, character buffer is set to name
1042 %t Matches end of statement.
1043 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1044 %l Matches a statement label
1045 %v Matches a variable expression (an lvalue)
1046 % Matches a required space (in free form) and optional spaces. */
1049 gfc_match (const char *target
, ...)
1051 gfc_st_label
**label
;
1060 old_loc
= gfc_current_locus
;
1061 va_start (argp
, target
);
1071 gfc_gobble_whitespace ();
1082 vp
= va_arg (argp
, void **);
1083 n
= gfc_match_expr ((gfc_expr
**) vp
);
1094 vp
= va_arg (argp
, void **);
1095 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
1106 vp
= va_arg (argp
, void **);
1107 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
1118 np
= va_arg (argp
, char *);
1119 n
= gfc_match_name (np
);
1130 label
= va_arg (argp
, gfc_st_label
**);
1131 n
= gfc_match_st_label (label
);
1142 ip
= va_arg (argp
, int *);
1143 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
1154 if (gfc_match_eos () != MATCH_YES
)
1162 if (gfc_match_space () == MATCH_YES
)
1168 break; /* Fall through to character matcher. */
1171 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
1175 if (c
== gfc_next_char ())
1185 /* Clean up after a failed match. */
1186 gfc_current_locus
= old_loc
;
1187 va_start (argp
, target
);
1190 for (; matches
> 0; matches
--)
1192 while (*p
++ != '%');
1200 /* Matches that don't have to be undone */
1205 (void) va_arg (argp
, void **);
1210 vp
= va_arg (argp
, void **);
1211 gfc_free_expr (*vp
);
1224 /*********************** Statement level matching **********************/
1226 /* Matches the start of a program unit, which is the program keyword
1227 followed by an obligatory symbol. */
1230 gfc_match_program (void)
1235 m
= gfc_match ("% %s%t", &sym
);
1239 gfc_error ("Invalid form of PROGRAM statement at %C");
1243 if (m
== MATCH_ERROR
)
1246 if (gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
) == FAILURE
)
1249 gfc_new_block
= sym
;
1255 /* Match a simple assignment statement. */
1258 gfc_match_assignment (void)
1260 gfc_expr
*lvalue
, *rvalue
;
1264 old_loc
= gfc_current_locus
;
1267 m
= gfc_match (" %v =", &lvalue
);
1270 gfc_current_locus
= old_loc
;
1271 gfc_free_expr (lvalue
);
1275 if (lvalue
->symtree
->n
.sym
->attr
.protected
1276 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
1278 gfc_current_locus
= old_loc
;
1279 gfc_free_expr (lvalue
);
1280 gfc_error ("Setting value of PROTECTED variable at %C");
1285 m
= gfc_match (" %e%t", &rvalue
);
1288 gfc_current_locus
= old_loc
;
1289 gfc_free_expr (lvalue
);
1290 gfc_free_expr (rvalue
);
1294 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1296 new_st
.op
= EXEC_ASSIGN
;
1297 new_st
.expr
= lvalue
;
1298 new_st
.expr2
= rvalue
;
1300 gfc_check_do_variable (lvalue
->symtree
);
1306 /* Match a pointer assignment statement. */
1309 gfc_match_pointer_assignment (void)
1311 gfc_expr
*lvalue
, *rvalue
;
1315 old_loc
= gfc_current_locus
;
1317 lvalue
= rvalue
= NULL
;
1319 m
= gfc_match (" %v =>", &lvalue
);
1326 m
= gfc_match (" %e%t", &rvalue
);
1330 if (lvalue
->symtree
->n
.sym
->attr
.protected
1331 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
1333 gfc_error ("Assigning to a PROTECTED pointer at %C");
1338 new_st
.op
= EXEC_POINTER_ASSIGN
;
1339 new_st
.expr
= lvalue
;
1340 new_st
.expr2
= rvalue
;
1345 gfc_current_locus
= old_loc
;
1346 gfc_free_expr (lvalue
);
1347 gfc_free_expr (rvalue
);
1352 /* We try to match an easy arithmetic IF statement. This only happens
1353 when just after having encountered a simple IF statement. This code
1354 is really duplicate with parts of the gfc_match_if code, but this is
1358 match_arithmetic_if (void)
1360 gfc_st_label
*l1
, *l2
, *l3
;
1364 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1368 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
1369 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
1370 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
1372 gfc_free_expr (expr
);
1376 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent: arithmetic IF statement "
1377 "at %C") == FAILURE
)
1380 new_st
.op
= EXEC_ARITHMETIC_IF
;
1390 /* The IF statement is a bit of a pain. First of all, there are three
1391 forms of it, the simple IF, the IF that starts a block and the
1394 There is a problem with the simple IF and that is the fact that we
1395 only have a single level of undo information on symbols. What this
1396 means is for a simple IF, we must re-match the whole IF statement
1397 multiple times in order to guarantee that the symbol table ends up
1398 in the proper state. */
1400 static match
match_simple_forall (void);
1401 static match
match_simple_where (void);
1404 gfc_match_if (gfc_statement
*if_type
)
1407 gfc_st_label
*l1
, *l2
, *l3
;
1412 n
= gfc_match_label ();
1413 if (n
== MATCH_ERROR
)
1416 old_loc
= gfc_current_locus
;
1418 m
= gfc_match (" if ( %e", &expr
);
1422 if (gfc_match_char (')') != MATCH_YES
)
1424 gfc_error ("Syntax error in IF-expression at %C");
1425 gfc_free_expr (expr
);
1429 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1435 gfc_error ("Block label not appropriate for arithmetic IF "
1437 gfc_free_expr (expr
);
1441 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
1442 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
1443 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
1445 gfc_free_expr (expr
);
1449 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent: arithmetic IF "
1450 "statement at %C") == FAILURE
)
1453 new_st
.op
= EXEC_ARITHMETIC_IF
;
1459 *if_type
= ST_ARITHMETIC_IF
;
1463 if (gfc_match (" then%t") == MATCH_YES
)
1465 new_st
.op
= EXEC_IF
;
1467 *if_type
= ST_IF_BLOCK
;
1473 gfc_error ("Block label is not appropriate IF statement at %C");
1474 gfc_free_expr (expr
);
1478 /* At this point the only thing left is a simple IF statement. At
1479 this point, n has to be MATCH_NO, so we don't have to worry about
1480 re-matching a block label. From what we've got so far, try
1481 matching an assignment. */
1483 *if_type
= ST_SIMPLE_IF
;
1485 m
= gfc_match_assignment ();
1489 gfc_free_expr (expr
);
1490 gfc_undo_symbols ();
1491 gfc_current_locus
= old_loc
;
1493 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1494 assignment was found. For MATCH_NO, continue to call the various
1496 if (m
== MATCH_ERROR
)
1499 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1501 m
= gfc_match_pointer_assignment ();
1505 gfc_free_expr (expr
);
1506 gfc_undo_symbols ();
1507 gfc_current_locus
= old_loc
;
1509 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1511 /* Look at the next keyword to see which matcher to call. Matching
1512 the keyword doesn't affect the symbol table, so we don't have to
1513 restore between tries. */
1515 #define match(string, subr, statement) \
1516 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1520 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1521 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1522 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1523 match ("call", gfc_match_call
, ST_CALL
)
1524 match ("close", gfc_match_close
, ST_CLOSE
)
1525 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1526 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1527 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1528 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1529 match ("exit", gfc_match_exit
, ST_EXIT
)
1530 match ("flush", gfc_match_flush
, ST_FLUSH
)
1531 match ("forall", match_simple_forall
, ST_FORALL
)
1532 match ("go to", gfc_match_goto
, ST_GOTO
)
1533 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1534 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1535 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1536 match ("open", gfc_match_open
, ST_OPEN
)
1537 match ("pause", gfc_match_pause
, ST_NONE
)
1538 match ("print", gfc_match_print
, ST_WRITE
)
1539 match ("read", gfc_match_read
, ST_READ
)
1540 match ("return", gfc_match_return
, ST_RETURN
)
1541 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1542 match ("stop", gfc_match_stop
, ST_STOP
)
1543 match ("where", match_simple_where
, ST_WHERE
)
1544 match ("write", gfc_match_write
, ST_WRITE
)
1546 /* The gfc_match_assignment() above may have returned a MATCH_NO
1547 where the assignment was to a named constant. Check that
1548 special case here. */
1549 m
= gfc_match_assignment ();
1552 gfc_error ("Cannot assign to a named constant at %C");
1553 gfc_free_expr (expr
);
1554 gfc_undo_symbols ();
1555 gfc_current_locus
= old_loc
;
1559 /* All else has failed, so give up. See if any of the matchers has
1560 stored an error message of some sort. */
1561 if (gfc_error_check () == 0)
1562 gfc_error ("Unclassifiable statement in IF-clause at %C");
1564 gfc_free_expr (expr
);
1569 gfc_error ("Syntax error in IF-clause at %C");
1572 gfc_free_expr (expr
);
1576 /* At this point, we've matched the single IF and the action clause
1577 is in new_st. Rearrange things so that the IF statement appears
1580 p
= gfc_get_code ();
1581 p
->next
= gfc_get_code ();
1583 p
->next
->loc
= gfc_current_locus
;
1588 gfc_clear_new_st ();
1590 new_st
.op
= EXEC_IF
;
1599 /* Match an ELSE statement. */
1602 gfc_match_else (void)
1604 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1606 if (gfc_match_eos () == MATCH_YES
)
1609 if (gfc_match_name (name
) != MATCH_YES
1610 || gfc_current_block () == NULL
1611 || gfc_match_eos () != MATCH_YES
)
1613 gfc_error ("Unexpected junk after ELSE statement at %C");
1617 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1619 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1620 name
, gfc_current_block ()->name
);
1628 /* Match an ELSE IF statement. */
1631 gfc_match_elseif (void)
1633 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1637 m
= gfc_match (" ( %e ) then", &expr
);
1641 if (gfc_match_eos () == MATCH_YES
)
1644 if (gfc_match_name (name
) != MATCH_YES
1645 || gfc_current_block () == NULL
1646 || gfc_match_eos () != MATCH_YES
)
1648 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1652 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1654 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1655 name
, gfc_current_block ()->name
);
1660 new_st
.op
= EXEC_IF
;
1665 gfc_free_expr (expr
);
1670 /* Free a gfc_iterator structure. */
1673 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1679 gfc_free_expr (iter
->var
);
1680 gfc_free_expr (iter
->start
);
1681 gfc_free_expr (iter
->end
);
1682 gfc_free_expr (iter
->step
);
1689 /* Match a DO statement. */
1694 gfc_iterator iter
, *ip
;
1696 gfc_st_label
*label
;
1699 old_loc
= gfc_current_locus
;
1702 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
1704 m
= gfc_match_label ();
1705 if (m
== MATCH_ERROR
)
1708 if (gfc_match (" do") != MATCH_YES
)
1711 m
= gfc_match_st_label (&label
);
1712 if (m
== MATCH_ERROR
)
1715 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
1717 if (gfc_match_eos () == MATCH_YES
)
1719 iter
.end
= gfc_logical_expr (1, NULL
);
1720 new_st
.op
= EXEC_DO_WHILE
;
1724 /* Match an optional comma, if no comma is found, a space is obligatory. */
1725 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
1728 /* See if we have a DO WHILE. */
1729 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
1731 new_st
.op
= EXEC_DO_WHILE
;
1735 /* The abortive DO WHILE may have done something to the symbol
1736 table, so we start over. */
1737 gfc_undo_symbols ();
1738 gfc_current_locus
= old_loc
;
1740 gfc_match_label (); /* This won't error. */
1741 gfc_match (" do "); /* This will work. */
1743 gfc_match_st_label (&label
); /* Can't error out. */
1744 gfc_match_char (','); /* Optional comma. */
1746 m
= gfc_match_iterator (&iter
, 0);
1749 if (m
== MATCH_ERROR
)
1752 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
1753 gfc_check_do_variable (iter
.var
->symtree
);
1755 if (gfc_match_eos () != MATCH_YES
)
1757 gfc_syntax_error (ST_DO
);
1761 new_st
.op
= EXEC_DO
;
1765 && gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1768 new_st
.label
= label
;
1770 if (new_st
.op
== EXEC_DO_WHILE
)
1771 new_st
.expr
= iter
.end
;
1774 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
1781 gfc_free_iterator (&iter
, 0);
1787 /* Match an EXIT or CYCLE statement. */
1790 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
1792 gfc_state_data
*p
, *o
;
1796 if (gfc_match_eos () == MATCH_YES
)
1800 m
= gfc_match ("% %s%t", &sym
);
1801 if (m
== MATCH_ERROR
)
1805 gfc_syntax_error (st
);
1809 if (sym
->attr
.flavor
!= FL_LABEL
)
1811 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1812 sym
->name
, gfc_ascii_statement (st
));
1817 /* Find the loop mentioned specified by the label (or lack of a label). */
1818 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
1819 if (p
->state
== COMP_DO
&& (sym
== NULL
|| sym
== p
->sym
))
1821 else if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
1827 gfc_error ("%s statement at %C is not within a loop",
1828 gfc_ascii_statement (st
));
1830 gfc_error ("%s statement at %C is not within loop '%s'",
1831 gfc_ascii_statement (st
), sym
->name
);
1838 gfc_error ("%s statement at %C leaving OpenMP structured block",
1839 gfc_ascii_statement (st
));
1842 else if (st
== ST_EXIT
1843 && p
->previous
!= NULL
1844 && p
->previous
->state
== COMP_OMP_STRUCTURED_BLOCK
1845 && (p
->previous
->head
->op
== EXEC_OMP_DO
1846 || p
->previous
->head
->op
== EXEC_OMP_PARALLEL_DO
))
1848 gcc_assert (p
->previous
->head
->next
!= NULL
);
1849 gcc_assert (p
->previous
->head
->next
->op
== EXEC_DO
1850 || p
->previous
->head
->next
->op
== EXEC_DO_WHILE
);
1851 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1855 /* Save the first statement in the loop - needed by the backend. */
1856 new_st
.ext
.whichloop
= p
->head
;
1864 /* Match the EXIT statement. */
1867 gfc_match_exit (void)
1869 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
1873 /* Match the CYCLE statement. */
1876 gfc_match_cycle (void)
1878 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
1882 /* Match a number or character constant after a STOP or PAUSE statement. */
1885 gfc_match_stopcode (gfc_statement st
)
1895 if (gfc_match_eos () != MATCH_YES
)
1897 m
= gfc_match_small_literal_int (&stop_code
, &cnt
);
1898 if (m
== MATCH_ERROR
)
1901 if (m
== MATCH_YES
&& cnt
> 5)
1903 gfc_error ("Too many digits in STOP code at %C");
1909 /* Try a character constant. */
1910 m
= gfc_match_expr (&e
);
1911 if (m
== MATCH_ERROR
)
1915 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1919 if (gfc_match_eos () != MATCH_YES
)
1923 if (gfc_pure (NULL
))
1925 gfc_error ("%s statement not allowed in PURE procedure at %C",
1926 gfc_ascii_statement (st
));
1930 new_st
.op
= st
== ST_STOP
? EXEC_STOP
: EXEC_PAUSE
;
1932 new_st
.ext
.stop_code
= stop_code
;
1937 gfc_syntax_error (st
);
1946 /* Match the (deprecated) PAUSE statement. */
1949 gfc_match_pause (void)
1953 m
= gfc_match_stopcode (ST_PAUSE
);
1956 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: PAUSE statement"
1965 /* Match the STOP statement. */
1968 gfc_match_stop (void)
1970 return gfc_match_stopcode (ST_STOP
);
1974 /* Match a CONTINUE statement. */
1977 gfc_match_continue (void)
1979 if (gfc_match_eos () != MATCH_YES
)
1981 gfc_syntax_error (ST_CONTINUE
);
1985 new_st
.op
= EXEC_CONTINUE
;
1990 /* Match the (deprecated) ASSIGN statement. */
1993 gfc_match_assign (void)
1996 gfc_st_label
*label
;
1998 if (gfc_match (" %l", &label
) == MATCH_YES
)
2000 if (gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
) == FAILURE
)
2002 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
2004 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: ASSIGN "
2009 expr
->symtree
->n
.sym
->attr
.assign
= 1;
2011 new_st
.op
= EXEC_LABEL_ASSIGN
;
2012 new_st
.label
= label
;
2021 /* Match the GO TO statement. As a computed GOTO statement is
2022 matched, it is transformed into an equivalent SELECT block. No
2023 tree is necessary, and the resulting jumps-to-jumps are
2024 specifically optimized away by the back end. */
2027 gfc_match_goto (void)
2029 gfc_code
*head
, *tail
;
2032 gfc_st_label
*label
;
2036 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
2038 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2041 new_st
.op
= EXEC_GOTO
;
2042 new_st
.label
= label
;
2046 /* The assigned GO TO statement. */
2048 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
2050 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: Assigned GOTO "
2055 new_st
.op
= EXEC_GOTO
;
2058 if (gfc_match_eos () == MATCH_YES
)
2061 /* Match label list. */
2062 gfc_match_char (',');
2063 if (gfc_match_char ('(') != MATCH_YES
)
2065 gfc_syntax_error (ST_GOTO
);
2072 m
= gfc_match_st_label (&label
);
2076 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2080 head
= tail
= gfc_get_code ();
2083 tail
->block
= gfc_get_code ();
2087 tail
->label
= label
;
2088 tail
->op
= EXEC_GOTO
;
2090 while (gfc_match_char (',') == MATCH_YES
);
2092 if (gfc_match (")%t") != MATCH_YES
)
2097 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2100 new_st
.block
= head
;
2105 /* Last chance is a computed GO TO statement. */
2106 if (gfc_match_char ('(') != MATCH_YES
)
2108 gfc_syntax_error (ST_GOTO
);
2117 m
= gfc_match_st_label (&label
);
2121 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2125 head
= tail
= gfc_get_code ();
2128 tail
->block
= gfc_get_code ();
2132 cp
= gfc_get_case ();
2133 cp
->low
= cp
->high
= gfc_int_expr (i
++);
2135 tail
->op
= EXEC_SELECT
;
2136 tail
->ext
.case_list
= cp
;
2138 tail
->next
= gfc_get_code ();
2139 tail
->next
->op
= EXEC_GOTO
;
2140 tail
->next
->label
= label
;
2142 while (gfc_match_char (',') == MATCH_YES
);
2144 if (gfc_match_char (')') != MATCH_YES
)
2149 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2153 /* Get the rest of the statement. */
2154 gfc_match_char (',');
2156 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
2159 /* At this point, a computed GOTO has been fully matched and an
2160 equivalent SELECT statement constructed. */
2162 new_st
.op
= EXEC_SELECT
;
2165 /* Hack: For a "real" SELECT, the expression is in expr. We put
2166 it in expr2 so we can distinguish then and produce the correct
2168 new_st
.expr2
= expr
;
2169 new_st
.block
= head
;
2173 gfc_syntax_error (ST_GOTO
);
2175 gfc_free_statements (head
);
2180 /* Frees a list of gfc_alloc structures. */
2183 gfc_free_alloc_list (gfc_alloc
*p
)
2190 gfc_free_expr (p
->expr
);
2196 /* Match an ALLOCATE statement. */
2199 gfc_match_allocate (void)
2201 gfc_alloc
*head
, *tail
;
2208 if (gfc_match_char ('(') != MATCH_YES
)
2214 head
= tail
= gfc_get_alloc ();
2217 tail
->next
= gfc_get_alloc ();
2221 m
= gfc_match_variable (&tail
->expr
, 0);
2224 if (m
== MATCH_ERROR
)
2227 if (gfc_check_do_variable (tail
->expr
->symtree
))
2231 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
2233 gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
2238 if (tail
->expr
->ts
.type
== BT_DERIVED
)
2239 tail
->expr
->ts
.derived
= gfc_use_derived (tail
->expr
->ts
.derived
);
2241 if (gfc_match_char (',') != MATCH_YES
)
2244 m
= gfc_match (" stat = %v", &stat
);
2245 if (m
== MATCH_ERROR
)
2255 if (stat
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2257 gfc_error ("STAT variable '%s' of ALLOCATE statement at %C cannot "
2258 "be INTENT(IN)", stat
->symtree
->n
.sym
->name
);
2262 if (gfc_pure (NULL
) && gfc_impure_variable (stat
->symtree
->n
.sym
))
2264 gfc_error ("Illegal STAT variable in ALLOCATE statement at %C "
2265 "for a PURE procedure");
2269 is_variable
= false;
2270 if (stat
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
)
2272 else if (stat
->symtree
->n
.sym
->attr
.function
2273 && stat
->symtree
->n
.sym
->result
== stat
->symtree
->n
.sym
2274 && (gfc_current_ns
->proc_name
== stat
->symtree
->n
.sym
2275 || (gfc_current_ns
->parent
2276 && gfc_current_ns
->parent
->proc_name
2277 == stat
->symtree
->n
.sym
)))
2279 else if (gfc_current_ns
->entries
2280 && stat
->symtree
->n
.sym
->result
== stat
->symtree
->n
.sym
)
2283 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
2284 if (el
->sym
== stat
->symtree
->n
.sym
)
2289 else if (gfc_current_ns
->parent
&& gfc_current_ns
->parent
->entries
2290 && stat
->symtree
->n
.sym
->result
== stat
->symtree
->n
.sym
)
2293 for (el
= gfc_current_ns
->parent
->entries
; el
; el
= el
->next
)
2294 if (el
->sym
== stat
->symtree
->n
.sym
)
2302 gfc_error ("STAT expression at %C must be a variable");
2306 gfc_check_do_variable(stat
->symtree
);
2309 if (gfc_match (" )%t") != MATCH_YES
)
2312 new_st
.op
= EXEC_ALLOCATE
;
2314 new_st
.ext
.alloc_list
= head
;
2319 gfc_syntax_error (ST_ALLOCATE
);
2322 gfc_free_expr (stat
);
2323 gfc_free_alloc_list (head
);
2328 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
2329 a set of pointer assignments to intrinsic NULL(). */
2332 gfc_match_nullify (void)
2340 if (gfc_match_char ('(') != MATCH_YES
)
2345 m
= gfc_match_variable (&p
, 0);
2346 if (m
== MATCH_ERROR
)
2351 if (gfc_check_do_variable (p
->symtree
))
2354 if (gfc_pure (NULL
) && gfc_impure_variable (p
->symtree
->n
.sym
))
2356 gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
2360 /* build ' => NULL() '. */
2361 e
= gfc_get_expr ();
2362 e
->where
= gfc_current_locus
;
2363 e
->expr_type
= EXPR_NULL
;
2364 e
->ts
.type
= BT_UNKNOWN
;
2366 /* Chain to list. */
2371 tail
->next
= gfc_get_code ();
2375 tail
->op
= EXEC_POINTER_ASSIGN
;
2379 if (gfc_match (" )%t") == MATCH_YES
)
2381 if (gfc_match_char (',') != MATCH_YES
)
2388 gfc_syntax_error (ST_NULLIFY
);
2391 gfc_free_statements (new_st
.next
);
2396 /* Match a DEALLOCATE statement. */
2399 gfc_match_deallocate (void)
2401 gfc_alloc
*head
, *tail
;
2408 if (gfc_match_char ('(') != MATCH_YES
)
2414 head
= tail
= gfc_get_alloc ();
2417 tail
->next
= gfc_get_alloc ();
2421 m
= gfc_match_variable (&tail
->expr
, 0);
2422 if (m
== MATCH_ERROR
)
2427 if (gfc_check_do_variable (tail
->expr
->symtree
))
2431 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
2433 gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
2434 "for a PURE procedure");
2438 if (gfc_match_char (',') != MATCH_YES
)
2441 m
= gfc_match (" stat = %v", &stat
);
2442 if (m
== MATCH_ERROR
)
2450 if (stat
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2452 gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
2453 "cannot be INTENT(IN)", stat
->symtree
->n
.sym
->name
);
2457 if (gfc_pure(NULL
) && gfc_impure_variable (stat
->symtree
->n
.sym
))
2459 gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
2460 "for a PURE procedure");
2464 if (stat
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
)
2466 gfc_error ("STAT expression at %C must be a variable");
2470 gfc_check_do_variable(stat
->symtree
);
2473 if (gfc_match (" )%t") != MATCH_YES
)
2476 new_st
.op
= EXEC_DEALLOCATE
;
2478 new_st
.ext
.alloc_list
= head
;
2483 gfc_syntax_error (ST_DEALLOCATE
);
2486 gfc_free_expr (stat
);
2487 gfc_free_alloc_list (head
);
2492 /* Match a RETURN statement. */
2495 gfc_match_return (void)
2499 gfc_compile_state s
;
2503 if (gfc_match_eos () == MATCH_YES
)
2506 if (gfc_find_state (COMP_SUBROUTINE
) == FAILURE
)
2508 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2513 if (gfc_current_form
== FORM_FREE
)
2515 /* The following are valid, so we can't require a blank after the
2519 c
= gfc_peek_char ();
2520 if (ISALPHA (c
) || ISDIGIT (c
))
2524 m
= gfc_match (" %e%t", &e
);
2527 if (m
== MATCH_ERROR
)
2530 gfc_syntax_error (ST_RETURN
);
2537 gfc_enclosing_unit (&s
);
2538 if (s
== COMP_PROGRAM
2539 && gfc_notify_std (GFC_STD_GNU
, "Extension: RETURN statement in "
2540 "main program at %C") == FAILURE
)
2543 new_st
.op
= EXEC_RETURN
;
2550 /* Match a CALL statement. The tricky part here are possible
2551 alternate return specifiers. We handle these by having all
2552 "subroutines" actually return an integer via a register that gives
2553 the return number. If the call specifies alternate returns, we
2554 generate code for a SELECT statement whose case clauses contain
2555 GOTOs to the various labels. */
2558 gfc_match_call (void)
2560 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2561 gfc_actual_arglist
*a
, *arglist
;
2571 m
= gfc_match ("% %n", name
);
2577 if (gfc_get_ha_sym_tree (name
, &st
))
2582 /* If it does not seem to be callable... */
2583 if (!sym
->attr
.generic
2584 && !sym
->attr
.subroutine
)
2586 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
2588 /* ...create a symbol in this scope... */
2589 if (sym
->ns
!= gfc_current_ns
2590 && gfc_get_sym_tree (name
, NULL
, &st
) == 1)
2593 if (sym
!= st
->n
.sym
)
2597 /* ...and then to try to make the symbol into a subroutine. */
2598 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2602 gfc_set_sym_referenced (sym
);
2604 if (gfc_match_eos () != MATCH_YES
)
2606 m
= gfc_match_actual_arglist (1, &arglist
);
2609 if (m
== MATCH_ERROR
)
2612 if (gfc_match_eos () != MATCH_YES
)
2616 /* If any alternate return labels were found, construct a SELECT
2617 statement that will jump to the right place. */
2620 for (a
= arglist
; a
; a
= a
->next
)
2621 if (a
->expr
== NULL
)
2626 gfc_symtree
*select_st
;
2627 gfc_symbol
*select_sym
;
2628 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2630 new_st
.next
= c
= gfc_get_code ();
2631 c
->op
= EXEC_SELECT
;
2632 sprintf (name
, "_result_%s", sym
->name
);
2633 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
2635 select_sym
= select_st
->n
.sym
;
2636 select_sym
->ts
.type
= BT_INTEGER
;
2637 select_sym
->ts
.kind
= gfc_default_integer_kind
;
2638 gfc_set_sym_referenced (select_sym
);
2639 c
->expr
= gfc_get_expr ();
2640 c
->expr
->expr_type
= EXPR_VARIABLE
;
2641 c
->expr
->symtree
= select_st
;
2642 c
->expr
->ts
= select_sym
->ts
;
2643 c
->expr
->where
= gfc_current_locus
;
2646 for (a
= arglist
; a
; a
= a
->next
)
2648 if (a
->expr
!= NULL
)
2651 if (gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
) == FAILURE
)
2656 c
->block
= gfc_get_code ();
2658 c
->op
= EXEC_SELECT
;
2660 new_case
= gfc_get_case ();
2661 new_case
->high
= new_case
->low
= gfc_int_expr (i
);
2662 c
->ext
.case_list
= new_case
;
2664 c
->next
= gfc_get_code ();
2665 c
->next
->op
= EXEC_GOTO
;
2666 c
->next
->label
= a
->label
;
2670 new_st
.op
= EXEC_CALL
;
2671 new_st
.symtree
= st
;
2672 new_st
.ext
.actual
= arglist
;
2677 gfc_syntax_error (ST_CALL
);
2680 gfc_free_actual_arglist (arglist
);
2685 /* Given a name, return a pointer to the common head structure,
2686 creating it if it does not exist. If FROM_MODULE is nonzero, we
2687 mangle the name so that it doesn't interfere with commons defined
2688 in the using namespace.
2689 TODO: Add to global symbol tree. */
2692 gfc_get_common (const char *name
, int from_module
)
2695 static int serial
= 0;
2696 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
2700 /* A use associated common block is only needed to correctly layout
2701 the variables it contains. */
2702 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
2703 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
2707 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
2710 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
2713 if (st
->n
.common
== NULL
)
2715 st
->n
.common
= gfc_get_common_head ();
2716 st
->n
.common
->where
= gfc_current_locus
;
2717 strcpy (st
->n
.common
->name
, name
);
2720 return st
->n
.common
;
2724 /* Match a common block name. */
2726 match
match_common_name (char *name
)
2730 if (gfc_match_char ('/') == MATCH_NO
)
2736 if (gfc_match_char ('/') == MATCH_YES
)
2742 m
= gfc_match_name (name
);
2744 if (m
== MATCH_ERROR
)
2746 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
2749 gfc_error ("Syntax error in common block name at %C");
2754 /* Match a COMMON statement. */
2757 gfc_match_common (void)
2759 gfc_symbol
*sym
, **head
, *tail
, *other
, *old_blank_common
;
2760 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2767 old_blank_common
= gfc_current_ns
->blank_common
.head
;
2768 if (old_blank_common
)
2770 while (old_blank_common
->common_next
)
2771 old_blank_common
= old_blank_common
->common_next
;
2778 m
= match_common_name (name
);
2779 if (m
== MATCH_ERROR
)
2782 gsym
= gfc_get_gsymbol (name
);
2783 if (gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= GSYM_COMMON
)
2785 gfc_error ("Symbol '%s' at %C is already an external symbol that "
2786 "is not COMMON", name
);
2790 if (gsym
->type
== GSYM_UNKNOWN
)
2792 gsym
->type
= GSYM_COMMON
;
2793 gsym
->where
= gfc_current_locus
;
2799 if (name
[0] == '\0')
2801 if (gfc_current_ns
->is_block_data
)
2803 gfc_warning ("BLOCK DATA unit cannot contain blank COMMON "
2806 t
= &gfc_current_ns
->blank_common
;
2807 if (t
->head
== NULL
)
2808 t
->where
= gfc_current_locus
;
2812 t
= gfc_get_common (name
, 0);
2821 while (tail
->common_next
)
2822 tail
= tail
->common_next
;
2825 /* Grab the list of symbols. */
2828 m
= gfc_match_symbol (&sym
, 0);
2829 if (m
== MATCH_ERROR
)
2834 /* Store a ref to the common block for error checking. */
2835 sym
->common_block
= t
;
2837 /* See if we know the current common block is bind(c), and if
2838 so, then see if we can check if the symbol is (which it'll
2839 need to be). This can happen if the bind(c) attr stmt was
2840 applied to the common block, and the variable(s) already
2841 defined, before declaring the common block. */
2842 if (t
->is_bind_c
== 1)
2844 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
2846 /* If we find an error, just print it and continue,
2847 cause it's just semantic, and we can see if there
2849 gfc_error_now ("Variable '%s' at %L in common block '%s' "
2850 "at %C must be declared with a C "
2851 "interoperable kind since common block "
2853 sym
->name
, &(sym
->declared_at
), t
->name
,
2857 if (sym
->attr
.is_bind_c
== 1)
2858 gfc_error_now ("Variable '%s' in common block "
2859 "'%s' at %C can not be bind(c) since "
2860 "it is not global", sym
->name
, t
->name
);
2863 if (sym
->attr
.in_common
)
2865 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2870 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2873 if (sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
2874 && (name
[0] == '\0' || !sym
->attr
.data
))
2876 if (name
[0] == '\0')
2877 gfc_error ("Previously initialized symbol '%s' in "
2878 "blank COMMON block at %C", sym
->name
);
2880 gfc_error ("Previously initialized symbol '%s' in "
2881 "COMMON block '%s' at %C", sym
->name
, name
);
2885 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2888 /* Derived type names must have the SEQUENCE attribute. */
2889 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.sequence
)
2891 gfc_error ("Derived type variable in COMMON at %C does not "
2892 "have the SEQUENCE attribute");
2897 tail
->common_next
= sym
;
2903 /* Deal with an optional array specification after the
2905 m
= gfc_match_array_spec (&as
);
2906 if (m
== MATCH_ERROR
)
2911 if (as
->type
!= AS_EXPLICIT
)
2913 gfc_error ("Array specification for symbol '%s' in COMMON "
2914 "at %C must be explicit", sym
->name
);
2918 if (gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2921 if (sym
->attr
.pointer
)
2923 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
2924 "POINTER array", sym
->name
);
2933 sym
->common_head
= t
;
2935 /* Check to see if the symbol is already in an equivalence group.
2936 If it is, set the other members as being in common. */
2937 if (sym
->attr
.in_equivalence
)
2939 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
2941 for (e2
= e1
; e2
; e2
= e2
->eq
)
2942 if (e2
->expr
->symtree
->n
.sym
== sym
)
2949 for (e2
= e1
; e2
; e2
= e2
->eq
)
2951 other
= e2
->expr
->symtree
->n
.sym
;
2952 if (other
->common_head
2953 && other
->common_head
!= sym
->common_head
)
2955 gfc_error ("Symbol '%s', in COMMON block '%s' at "
2956 "%C is being indirectly equivalenced to "
2957 "another COMMON block '%s'",
2958 sym
->name
, sym
->common_head
->name
,
2959 other
->common_head
->name
);
2962 other
->attr
.in_common
= 1;
2963 other
->common_head
= t
;
2969 gfc_gobble_whitespace ();
2970 if (gfc_match_eos () == MATCH_YES
)
2972 if (gfc_peek_char () == '/')
2974 if (gfc_match_char (',') != MATCH_YES
)
2976 gfc_gobble_whitespace ();
2977 if (gfc_peek_char () == '/')
2986 gfc_syntax_error (ST_COMMON
);
2989 if (old_blank_common
)
2990 old_blank_common
->common_next
= NULL
;
2992 gfc_current_ns
->blank_common
.head
= NULL
;
2993 gfc_free_array_spec (as
);
2998 /* Match a BLOCK DATA program unit. */
3001 gfc_match_block_data (void)
3003 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3007 if (gfc_match_eos () == MATCH_YES
)
3009 gfc_new_block
= NULL
;
3013 m
= gfc_match ("% %n%t", name
);
3017 if (gfc_get_symbol (name
, NULL
, &sym
))
3020 if (gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
) == FAILURE
)
3023 gfc_new_block
= sym
;
3029 /* Free a namelist structure. */
3032 gfc_free_namelist (gfc_namelist
*name
)
3036 for (; name
; name
= n
)
3044 /* Match a NAMELIST statement. */
3047 gfc_match_namelist (void)
3049 gfc_symbol
*group_name
, *sym
;
3053 m
= gfc_match (" / %s /", &group_name
);
3056 if (m
== MATCH_ERROR
)
3061 if (group_name
->ts
.type
!= BT_UNKNOWN
)
3063 gfc_error ("Namelist group name '%s' at %C already has a basic "
3064 "type of %s", group_name
->name
,
3065 gfc_typename (&group_name
->ts
));
3069 if (group_name
->attr
.flavor
== FL_NAMELIST
3070 && group_name
->attr
.use_assoc
3071 && gfc_notify_std (GFC_STD_GNU
, "Namelist group name '%s' "
3072 "at %C already is USE associated and can"
3073 "not be respecified.", group_name
->name
)
3077 if (group_name
->attr
.flavor
!= FL_NAMELIST
3078 && gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
3079 group_name
->name
, NULL
) == FAILURE
)
3084 m
= gfc_match_symbol (&sym
, 1);
3087 if (m
== MATCH_ERROR
)
3090 if (sym
->attr
.in_namelist
== 0
3091 && gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3094 /* Use gfc_error_check here, rather than goto error, so that
3095 these are the only errors for the next two lines. */
3096 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
3098 gfc_error ("Assumed size array '%s' in namelist '%s' at "
3099 "%C is not allowed", sym
->name
, group_name
->name
);
3103 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.cl
->length
== NULL
)
3105 gfc_error ("Assumed character length '%s' in namelist '%s' at "
3106 "%C is not allowed", sym
->name
, group_name
->name
);
3110 nl
= gfc_get_namelist ();
3114 if (group_name
->namelist
== NULL
)
3115 group_name
->namelist
= group_name
->namelist_tail
= nl
;
3118 group_name
->namelist_tail
->next
= nl
;
3119 group_name
->namelist_tail
= nl
;
3122 if (gfc_match_eos () == MATCH_YES
)
3125 m
= gfc_match_char (',');
3127 if (gfc_match_char ('/') == MATCH_YES
)
3129 m2
= gfc_match (" %s /", &group_name
);
3130 if (m2
== MATCH_YES
)
3132 if (m2
== MATCH_ERROR
)
3146 gfc_syntax_error (ST_NAMELIST
);
3153 /* Match a MODULE statement. */
3156 gfc_match_module (void)
3160 m
= gfc_match (" %s%t", &gfc_new_block
);
3164 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
3165 gfc_new_block
->name
, NULL
) == FAILURE
)
3172 /* Free equivalence sets and lists. Recursively is the easiest way to
3176 gfc_free_equiv (gfc_equiv
*eq
)
3181 gfc_free_equiv (eq
->eq
);
3182 gfc_free_equiv (eq
->next
);
3183 gfc_free_expr (eq
->expr
);
3188 /* Match an EQUIVALENCE statement. */
3191 gfc_match_equivalence (void)
3193 gfc_equiv
*eq
, *set
, *tail
;
3197 gfc_common_head
*common_head
= NULL
;
3205 eq
= gfc_get_equiv ();
3209 eq
->next
= gfc_current_ns
->equiv
;
3210 gfc_current_ns
->equiv
= eq
;
3212 if (gfc_match_char ('(') != MATCH_YES
)
3216 common_flag
= FALSE
;
3221 m
= gfc_match_equiv_variable (&set
->expr
);
3222 if (m
== MATCH_ERROR
)
3227 /* count the number of objects. */
3230 if (gfc_match_char ('%') == MATCH_YES
)
3232 gfc_error ("Derived type component %C is not a "
3233 "permitted EQUIVALENCE member");
3237 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
3238 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
3240 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
3241 "be an array section");
3245 sym
= set
->expr
->symtree
->n
.sym
;
3247 if (gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3250 if (sym
->attr
.in_common
)
3253 common_head
= sym
->common_head
;
3256 if (gfc_match_char (')') == MATCH_YES
)
3259 if (gfc_match_char (',') != MATCH_YES
)
3262 set
->eq
= gfc_get_equiv ();
3268 gfc_error ("EQUIVALENCE at %C requires two or more objects");
3272 /* If one of the members of an equivalence is in common, then
3273 mark them all as being in common. Before doing this, check
3274 that members of the equivalence group are not in different
3277 for (set
= eq
; set
; set
= set
->eq
)
3279 sym
= set
->expr
->symtree
->n
.sym
;
3280 if (sym
->common_head
&& sym
->common_head
!= common_head
)
3282 gfc_error ("Attempt to indirectly overlap COMMON "
3283 "blocks %s and %s by EQUIVALENCE at %C",
3284 sym
->common_head
->name
, common_head
->name
);
3287 sym
->attr
.in_common
= 1;
3288 sym
->common_head
= common_head
;
3291 if (gfc_match_eos () == MATCH_YES
)
3293 if (gfc_match_char (',') != MATCH_YES
)
3300 gfc_syntax_error (ST_EQUIVALENCE
);
3306 gfc_free_equiv (gfc_current_ns
->equiv
);
3307 gfc_current_ns
->equiv
= eq
;
3313 /* Check that a statement function is not recursive. This is done by looking
3314 for the statement function symbol(sym) by looking recursively through its
3315 expression(e). If a reference to sym is found, true is returned.
3316 12.5.4 requires that any variable of function that is implicitly typed
3317 shall have that type confirmed by any subsequent type declaration. The
3318 implicit typing is conveniently done here. */
3321 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
3323 gfc_actual_arglist
*arg
;
3330 switch (e
->expr_type
)
3333 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
3335 if (sym
->name
== arg
->name
|| recursive_stmt_fcn (arg
->expr
, sym
))
3339 if (e
->symtree
== NULL
)
3342 /* Check the name before testing for nested recursion! */
3343 if (sym
->name
== e
->symtree
->n
.sym
->name
)
3346 /* Catch recursion via other statement functions. */
3347 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
3348 && e
->symtree
->n
.sym
->value
3349 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
3352 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
3353 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
3358 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
3361 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
3362 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
3366 if (recursive_stmt_fcn (e
->value
.op
.op1
, sym
)
3367 || recursive_stmt_fcn (e
->value
.op
.op2
, sym
))
3375 /* Component references do not need to be checked. */
3378 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3383 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
3385 if (recursive_stmt_fcn (ref
->u
.ar
.start
[i
], sym
)
3386 || recursive_stmt_fcn (ref
->u
.ar
.end
[i
], sym
)
3387 || recursive_stmt_fcn (ref
->u
.ar
.stride
[i
], sym
))
3393 if (recursive_stmt_fcn (ref
->u
.ss
.start
, sym
)
3394 || recursive_stmt_fcn (ref
->u
.ss
.end
, sym
))
3408 /* Match a statement function declaration. It is so easy to match
3409 non-statement function statements with a MATCH_ERROR as opposed to
3410 MATCH_NO that we suppress error message in most cases. */
3413 gfc_match_st_function (void)
3415 gfc_error_buf old_error
;
3420 m
= gfc_match_symbol (&sym
, 0);
3424 gfc_push_error (&old_error
);
3426 if (gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
,
3427 sym
->name
, NULL
) == FAILURE
)
3430 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
3433 m
= gfc_match (" = %e%t", &expr
);
3437 gfc_free_error (&old_error
);
3438 if (m
== MATCH_ERROR
)
3441 if (recursive_stmt_fcn (expr
, sym
))
3443 gfc_error ("Statement function at %L is recursive", &expr
->where
);
3452 gfc_pop_error (&old_error
);
3457 /***************** SELECT CASE subroutines ******************/
3459 /* Free a single case structure. */
3462 free_case (gfc_case
*p
)
3464 if (p
->low
== p
->high
)
3466 gfc_free_expr (p
->low
);
3467 gfc_free_expr (p
->high
);
3472 /* Free a list of case structures. */
3475 gfc_free_case_list (gfc_case
*p
)
3487 /* Match a single case selector. */
3490 match_case_selector (gfc_case
**cp
)
3495 c
= gfc_get_case ();
3496 c
->where
= gfc_current_locus
;
3498 if (gfc_match_char (':') == MATCH_YES
)
3500 m
= gfc_match_init_expr (&c
->high
);
3503 if (m
== MATCH_ERROR
)
3508 m
= gfc_match_init_expr (&c
->low
);
3509 if (m
== MATCH_ERROR
)
3514 /* If we're not looking at a ':' now, make a range out of a single
3515 target. Else get the upper bound for the case range. */
3516 if (gfc_match_char (':') != MATCH_YES
)
3520 m
= gfc_match_init_expr (&c
->high
);
3521 if (m
== MATCH_ERROR
)
3523 /* MATCH_NO is fine. It's OK if nothing is there! */
3531 gfc_error ("Expected initialization expression in CASE at %C");
3539 /* Match the end of a case statement. */
3542 match_case_eos (void)
3544 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3547 if (gfc_match_eos () == MATCH_YES
)
3550 /* If the case construct doesn't have a case-construct-name, we
3551 should have matched the EOS. */
3552 if (!gfc_current_block ())
3554 gfc_error ("Expected the name of the SELECT CASE construct at %C");
3558 gfc_gobble_whitespace ();
3560 m
= gfc_match_name (name
);
3564 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3566 gfc_error ("Expected case name of '%s' at %C",
3567 gfc_current_block ()->name
);
3571 return gfc_match_eos ();
3575 /* Match a SELECT statement. */
3578 gfc_match_select (void)
3583 m
= gfc_match_label ();
3584 if (m
== MATCH_ERROR
)
3587 m
= gfc_match (" select case ( %e )%t", &expr
);
3591 new_st
.op
= EXEC_SELECT
;
3598 /* Match a CASE statement. */
3601 gfc_match_case (void)
3603 gfc_case
*c
, *head
, *tail
;
3608 if (gfc_current_state () != COMP_SELECT
)
3610 gfc_error ("Unexpected CASE statement at %C");
3614 if (gfc_match ("% default") == MATCH_YES
)
3616 m
= match_case_eos ();
3619 if (m
== MATCH_ERROR
)
3622 new_st
.op
= EXEC_SELECT
;
3623 c
= gfc_get_case ();
3624 c
->where
= gfc_current_locus
;
3625 new_st
.ext
.case_list
= c
;
3629 if (gfc_match_char ('(') != MATCH_YES
)
3634 if (match_case_selector (&c
) == MATCH_ERROR
)
3644 if (gfc_match_char (')') == MATCH_YES
)
3646 if (gfc_match_char (',') != MATCH_YES
)
3650 m
= match_case_eos ();
3653 if (m
== MATCH_ERROR
)
3656 new_st
.op
= EXEC_SELECT
;
3657 new_st
.ext
.case_list
= head
;
3662 gfc_error ("Syntax error in CASE-specification at %C");
3665 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
3669 /********************* WHERE subroutines ********************/
3671 /* Match the rest of a simple WHERE statement that follows an IF statement.
3675 match_simple_where (void)
3681 m
= gfc_match (" ( %e )", &expr
);
3685 m
= gfc_match_assignment ();
3688 if (m
== MATCH_ERROR
)
3691 if (gfc_match_eos () != MATCH_YES
)
3694 c
= gfc_get_code ();
3698 c
->next
= gfc_get_code ();
3701 gfc_clear_new_st ();
3703 new_st
.op
= EXEC_WHERE
;
3709 gfc_syntax_error (ST_WHERE
);
3712 gfc_free_expr (expr
);
3717 /* Match a WHERE statement. */
3720 gfc_match_where (gfc_statement
*st
)
3726 m0
= gfc_match_label ();
3727 if (m0
== MATCH_ERROR
)
3730 m
= gfc_match (" where ( %e )", &expr
);
3734 if (gfc_match_eos () == MATCH_YES
)
3736 *st
= ST_WHERE_BLOCK
;
3737 new_st
.op
= EXEC_WHERE
;
3742 m
= gfc_match_assignment ();
3744 gfc_syntax_error (ST_WHERE
);
3748 gfc_free_expr (expr
);
3752 /* We've got a simple WHERE statement. */
3754 c
= gfc_get_code ();
3758 c
->next
= gfc_get_code ();
3761 gfc_clear_new_st ();
3763 new_st
.op
= EXEC_WHERE
;
3770 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3771 new_st if successful. */
3774 gfc_match_elsewhere (void)
3776 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3780 if (gfc_current_state () != COMP_WHERE
)
3782 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3788 if (gfc_match_char ('(') == MATCH_YES
)
3790 m
= gfc_match_expr (&expr
);
3793 if (m
== MATCH_ERROR
)
3796 if (gfc_match_char (')') != MATCH_YES
)
3800 if (gfc_match_eos () != MATCH_YES
)
3802 /* Only makes sense if we have a where-construct-name. */
3803 if (!gfc_current_block ())
3808 /* Better be a name at this point. */
3809 m
= gfc_match_name (name
);
3812 if (m
== MATCH_ERROR
)
3815 if (gfc_match_eos () != MATCH_YES
)
3818 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3820 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3821 name
, gfc_current_block ()->name
);
3826 new_st
.op
= EXEC_WHERE
;
3831 gfc_syntax_error (ST_ELSEWHERE
);
3834 gfc_free_expr (expr
);
3839 /******************** FORALL subroutines ********************/
3841 /* Free a list of FORALL iterators. */
3844 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
3846 gfc_forall_iterator
*next
;
3851 gfc_free_expr (iter
->var
);
3852 gfc_free_expr (iter
->start
);
3853 gfc_free_expr (iter
->end
);
3854 gfc_free_expr (iter
->stride
);
3861 /* Match an iterator as part of a FORALL statement. The format is:
3863 <var> = <start>:<end>[:<stride>]
3865 On MATCH_NO, the caller tests for the possibility that there is a
3866 scalar mask expression. */
3869 match_forall_iterator (gfc_forall_iterator
**result
)
3871 gfc_forall_iterator
*iter
;
3875 where
= gfc_current_locus
;
3876 iter
= gfc_getmem (sizeof (gfc_forall_iterator
));
3878 m
= gfc_match_expr (&iter
->var
);
3882 if (gfc_match_char ('=') != MATCH_YES
3883 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
3889 m
= gfc_match_expr (&iter
->start
);
3893 if (gfc_match_char (':') != MATCH_YES
)
3896 m
= gfc_match_expr (&iter
->end
);
3899 if (m
== MATCH_ERROR
)
3902 if (gfc_match_char (':') == MATCH_NO
)
3903 iter
->stride
= gfc_int_expr (1);
3906 m
= gfc_match_expr (&iter
->stride
);
3909 if (m
== MATCH_ERROR
)
3913 /* Mark the iteration variable's symbol as used as a FORALL index. */
3914 iter
->var
->symtree
->n
.sym
->forall_index
= true;
3920 gfc_error ("Syntax error in FORALL iterator at %C");
3925 gfc_current_locus
= where
;
3926 gfc_free_forall_iterator (iter
);
3931 /* Match the header of a FORALL statement. */
3934 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
3936 gfc_forall_iterator
*head
, *tail
, *new;
3940 gfc_gobble_whitespace ();
3945 if (gfc_match_char ('(') != MATCH_YES
)
3948 m
= match_forall_iterator (&new);
3949 if (m
== MATCH_ERROR
)
3958 if (gfc_match_char (',') != MATCH_YES
)
3961 m
= match_forall_iterator (&new);
3962 if (m
== MATCH_ERROR
)
3972 /* Have to have a mask expression. */
3974 m
= gfc_match_expr (&msk
);
3977 if (m
== MATCH_ERROR
)
3983 if (gfc_match_char (')') == MATCH_NO
)
3991 gfc_syntax_error (ST_FORALL
);
3994 gfc_free_expr (msk
);
3995 gfc_free_forall_iterator (head
);
4000 /* Match the rest of a simple FORALL statement that follows an
4004 match_simple_forall (void)
4006 gfc_forall_iterator
*head
;
4015 m
= match_forall_header (&head
, &mask
);
4022 m
= gfc_match_assignment ();
4024 if (m
== MATCH_ERROR
)
4028 m
= gfc_match_pointer_assignment ();
4029 if (m
== MATCH_ERROR
)
4035 c
= gfc_get_code ();
4037 c
->loc
= gfc_current_locus
;
4039 if (gfc_match_eos () != MATCH_YES
)
4042 gfc_clear_new_st ();
4043 new_st
.op
= EXEC_FORALL
;
4045 new_st
.ext
.forall_iterator
= head
;
4046 new_st
.block
= gfc_get_code ();
4048 new_st
.block
->op
= EXEC_FORALL
;
4049 new_st
.block
->next
= c
;
4054 gfc_syntax_error (ST_FORALL
);
4057 gfc_free_forall_iterator (head
);
4058 gfc_free_expr (mask
);
4064 /* Match a FORALL statement. */
4067 gfc_match_forall (gfc_statement
*st
)
4069 gfc_forall_iterator
*head
;
4078 m0
= gfc_match_label ();
4079 if (m0
== MATCH_ERROR
)
4082 m
= gfc_match (" forall");
4086 m
= match_forall_header (&head
, &mask
);
4087 if (m
== MATCH_ERROR
)
4092 if (gfc_match_eos () == MATCH_YES
)
4094 *st
= ST_FORALL_BLOCK
;
4095 new_st
.op
= EXEC_FORALL
;
4097 new_st
.ext
.forall_iterator
= head
;
4101 m
= gfc_match_assignment ();
4102 if (m
== MATCH_ERROR
)
4106 m
= gfc_match_pointer_assignment ();
4107 if (m
== MATCH_ERROR
)
4113 c
= gfc_get_code ();
4115 c
->loc
= gfc_current_locus
;
4117 gfc_clear_new_st ();
4118 new_st
.op
= EXEC_FORALL
;
4120 new_st
.ext
.forall_iterator
= head
;
4121 new_st
.block
= gfc_get_code ();
4122 new_st
.block
->op
= EXEC_FORALL
;
4123 new_st
.block
->next
= c
;
4129 gfc_syntax_error (ST_FORALL
);
4132 gfc_free_forall_iterator (head
);
4133 gfc_free_expr (mask
);
4134 gfc_free_statements (c
);