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;
31 /* For debugging and diagnostic purposes. Return the textual representation
32 of the intrinsic operator OP. */
34 gfc_op2string (gfc_intrinsic_op op
)
42 case INTRINSIC_UMINUS
:
48 case INTRINSIC_CONCAT
:
52 case INTRINSIC_DIVIDE
:
91 case INTRINSIC_ASSIGN
:
94 case INTRINSIC_PARENTHESES
:
101 gfc_internal_error ("gfc_op2string(): Bad code");
106 /******************** Generic matching subroutines ************************/
108 /* This function scans the current statement counting the opened and closed
109 parenthesis to make sure they are balanced. */
112 gfc_match_parens (void)
114 locus old_loc
, where
;
118 old_loc
= gfc_current_locus
;
125 c
= gfc_next_char_literal (instring
);
128 if (quote
== ' ' && ((c
== '\'') || (c
== '"')))
134 if (quote
!= ' ' && c
== quote
)
141 if (c
== '(' && quote
== ' ')
144 where
= gfc_current_locus
;
146 if (c
== ')' && quote
== ' ')
149 where
= gfc_current_locus
;
153 gfc_current_locus
= old_loc
;
157 gfc_error ("Missing ')' in statement at or before %L", &where
);
162 gfc_error ("Missing '(' in statement at or before %L", &where
);
170 /* See if the next character is a special character that has
171 escaped by a \ via the -fbackslash option. */
174 gfc_match_special_char (gfc_char_t
*res
)
182 switch ((c
= gfc_next_char_literal (1)))
215 /* Hexadecimal form of wide characters. */
216 len
= (c
== 'x' ? 2 : (c
== 'u' ? 4 : 8));
218 for (i
= 0; i
< len
; i
++)
220 char buf
[2] = { '\0', '\0' };
222 c
= gfc_next_char_literal (1);
223 if (!gfc_wide_fits_in_byte (c
)
224 || !gfc_check_digit ((unsigned char) c
, 16))
227 buf
[0] = (unsigned char) c
;
229 n
+= strtol (buf
, NULL
, 16);
235 /* Unknown backslash codes are simply not expanded. */
244 /* In free form, match at least one space. Always matches in fixed
248 gfc_match_space (void)
253 if (gfc_current_form
== FORM_FIXED
)
256 old_loc
= gfc_current_locus
;
258 c
= gfc_next_ascii_char ();
259 if (!gfc_is_whitespace (c
))
261 gfc_current_locus
= old_loc
;
265 gfc_gobble_whitespace ();
271 /* Match an end of statement. End of statement is optional
272 whitespace, followed by a ';' or '\n' or comment '!'. If a
273 semicolon is found, we continue to eat whitespace and semicolons. */
286 old_loc
= gfc_current_locus
;
287 gfc_gobble_whitespace ();
289 c
= gfc_next_ascii_char ();
295 c
= gfc_next_ascii_char ();
312 gfc_current_locus
= old_loc
;
313 return (flag
) ? MATCH_YES
: MATCH_NO
;
317 /* Match a literal integer on the input, setting the value on
318 MATCH_YES. Literal ints occur in kind-parameters as well as
319 old-style character length specifications. If cnt is non-NULL it
320 will be set to the number of digits. */
323 gfc_match_small_literal_int (int *value
, int *cnt
)
329 old_loc
= gfc_current_locus
;
332 gfc_gobble_whitespace ();
333 c
= gfc_next_ascii_char ();
339 gfc_current_locus
= old_loc
;
348 old_loc
= gfc_current_locus
;
349 c
= gfc_next_ascii_char ();
354 i
= 10 * i
+ c
- '0';
359 gfc_error ("Integer too large at %C");
364 gfc_current_locus
= old_loc
;
373 /* Match a small, constant integer expression, like in a kind
374 statement. On MATCH_YES, 'value' is set. */
377 gfc_match_small_int (int *value
)
384 m
= gfc_match_expr (&expr
);
388 p
= gfc_extract_int (expr
, &i
);
389 gfc_free_expr (expr
);
402 /* This function is the same as the gfc_match_small_int, except that
403 we're keeping the pointer to the expr. This function could just be
404 removed and the previously mentioned one modified, though all calls
405 to it would have to be modified then (and there were a number of
406 them). Return MATCH_ERROR if fail to extract the int; otherwise,
407 return the result of gfc_match_expr(). The expr (if any) that was
408 matched is returned in the parameter expr. */
411 gfc_match_small_int_expr (int *value
, gfc_expr
**expr
)
417 m
= gfc_match_expr (expr
);
421 p
= gfc_extract_int (*expr
, &i
);
434 /* Matches a statement label. Uses gfc_match_small_literal_int() to
435 do most of the work. */
438 gfc_match_st_label (gfc_st_label
**label
)
444 old_loc
= gfc_current_locus
;
446 m
= gfc_match_small_literal_int (&i
, &cnt
);
452 gfc_error ("Too many digits in statement label at %C");
458 gfc_error ("Statement label at %C is zero");
462 *label
= gfc_get_st_label (i
);
467 gfc_current_locus
= old_loc
;
472 /* Match and validate a label associated with a named IF, DO or SELECT
473 statement. If the symbol does not have the label attribute, we add
474 it. We also make sure the symbol does not refer to another
475 (active) block. A matched label is pointed to by gfc_new_block. */
478 gfc_match_label (void)
480 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
483 gfc_new_block
= NULL
;
485 m
= gfc_match (" %n :", name
);
489 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
491 gfc_error ("Label name '%s' at %C is ambiguous", name
);
495 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
497 gfc_error ("Duplicate construct label '%s' at %C", name
);
501 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
502 gfc_new_block
->name
, NULL
) == FAILURE
)
509 /* See if the current input looks like a name of some sort. Modifies
510 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
511 Note that options.c restricts max_identifier_length to not more
512 than GFC_MAX_SYMBOL_LEN. */
515 gfc_match_name (char *buffer
)
521 old_loc
= gfc_current_locus
;
522 gfc_gobble_whitespace ();
524 c
= gfc_next_ascii_char ();
525 if (!(ISALPHA (c
) || (c
== '_' && gfc_option
.flag_allow_leading_underscore
)))
527 if (gfc_error_flag_test() == 0 && c
!= '(')
528 gfc_error ("Invalid character in name at %C");
529 gfc_current_locus
= old_loc
;
539 if (i
> gfc_option
.max_identifier_length
)
541 gfc_error ("Name at %C is too long");
545 old_loc
= gfc_current_locus
;
546 c
= gfc_next_ascii_char ();
548 while (ISALNUM (c
) || c
== '_' || (gfc_option
.flag_dollar_ok
&& c
== '$'));
550 if (c
== '$' && !gfc_option
.flag_dollar_ok
)
552 gfc_error ("Invalid character '$' at %C. Use -fdollar-ok to allow it "
558 gfc_current_locus
= old_loc
;
564 /* Match a valid name for C, which is almost the same as for Fortran,
565 except that you can start with an underscore, etc.. It could have
566 been done by modifying the gfc_match_name, but this way other
567 things C allows can be added, such as no limits on the length.
568 Right now, the length is limited to the same thing as Fortran..
569 Also, by rewriting it, we use the gfc_next_char_C() to prevent the
570 input characters from being automatically lower cased, since C is
571 case sensitive. The parameter, buffer, is used to return the name
572 that is matched. Return MATCH_ERROR if the name is too long
573 (though this is a self-imposed limit), MATCH_NO if what we're
574 seeing isn't a name, and MATCH_YES if we successfully match a C
578 gfc_match_name_C (char *buffer
)
584 old_loc
= gfc_current_locus
;
585 gfc_gobble_whitespace ();
587 /* Get the next char (first possible char of name) and see if
588 it's valid for C (either a letter or an underscore). */
589 c
= gfc_next_char_literal (1);
591 /* If the user put nothing expect spaces between the quotes, it is valid
592 and simply means there is no name= specifier and the name is the fortran
593 symbol name, all lowercase. */
594 if (c
== '"' || c
== '\'')
597 gfc_current_locus
= old_loc
;
601 if (!ISALPHA (c
) && c
!= '_')
603 gfc_error ("Invalid C name in NAME= specifier at %C");
607 /* Continue to read valid variable name characters. */
610 gcc_assert (gfc_wide_fits_in_byte (c
));
612 buffer
[i
++] = (unsigned char) c
;
614 /* C does not define a maximum length of variable names, to my
615 knowledge, but the compiler typically places a limit on them.
616 For now, i'll use the same as the fortran limit for simplicity,
617 but this may need to be changed to a dynamic buffer that can
618 be realloc'ed here if necessary, or more likely, a larger
620 if (i
> gfc_option
.max_identifier_length
)
622 gfc_error ("Name at %C is too long");
626 old_loc
= gfc_current_locus
;
628 /* Get next char; param means we're in a string. */
629 c
= gfc_next_char_literal (1);
630 } while (ISALNUM (c
) || c
== '_');
633 gfc_current_locus
= old_loc
;
635 /* See if we stopped because of whitespace. */
638 gfc_gobble_whitespace ();
639 c
= gfc_peek_ascii_char ();
640 if (c
!= '"' && c
!= '\'')
642 gfc_error ("Embedded space in NAME= specifier at %C");
647 /* If we stopped because we had an invalid character for a C name, report
648 that to the user by returning MATCH_NO. */
649 if (c
!= '"' && c
!= '\'')
651 gfc_error ("Invalid C name in NAME= specifier at %C");
659 /* Match a symbol on the input. Modifies the pointer to the symbol
660 pointer if successful. */
663 gfc_match_sym_tree (gfc_symtree
**matched_symbol
, int host_assoc
)
665 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
668 m
= gfc_match_name (buffer
);
673 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
674 ? MATCH_ERROR
: MATCH_YES
;
676 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
))
684 gfc_match_symbol (gfc_symbol
**matched_symbol
, int host_assoc
)
689 m
= gfc_match_sym_tree (&st
, host_assoc
);
694 *matched_symbol
= st
->n
.sym
;
696 *matched_symbol
= NULL
;
699 *matched_symbol
= NULL
;
704 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
705 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
709 gfc_match_intrinsic_op (gfc_intrinsic_op
*result
)
711 locus orig_loc
= gfc_current_locus
;
714 gfc_gobble_whitespace ();
715 ch
= gfc_next_ascii_char ();
720 *result
= INTRINSIC_PLUS
;
725 *result
= INTRINSIC_MINUS
;
729 if (gfc_next_ascii_char () == '=')
732 *result
= INTRINSIC_EQ
;
738 if (gfc_peek_ascii_char () == '=')
741 gfc_next_ascii_char ();
742 *result
= INTRINSIC_LE
;
746 *result
= INTRINSIC_LT
;
750 if (gfc_peek_ascii_char () == '=')
753 gfc_next_ascii_char ();
754 *result
= INTRINSIC_GE
;
758 *result
= INTRINSIC_GT
;
762 if (gfc_peek_ascii_char () == '*')
765 gfc_next_ascii_char ();
766 *result
= INTRINSIC_POWER
;
770 *result
= INTRINSIC_TIMES
;
774 ch
= gfc_peek_ascii_char ();
778 gfc_next_ascii_char ();
779 *result
= INTRINSIC_NE
;
785 gfc_next_ascii_char ();
786 *result
= INTRINSIC_CONCAT
;
790 *result
= INTRINSIC_DIVIDE
;
794 ch
= gfc_next_ascii_char ();
798 if (gfc_next_ascii_char () == 'n'
799 && gfc_next_ascii_char () == 'd'
800 && gfc_next_ascii_char () == '.')
802 /* Matched ".and.". */
803 *result
= INTRINSIC_AND
;
809 if (gfc_next_ascii_char () == 'q')
811 ch
= gfc_next_ascii_char ();
814 /* Matched ".eq.". */
815 *result
= INTRINSIC_EQ_OS
;
820 if (gfc_next_ascii_char () == '.')
822 /* Matched ".eqv.". */
823 *result
= INTRINSIC_EQV
;
831 ch
= gfc_next_ascii_char ();
834 if (gfc_next_ascii_char () == '.')
836 /* Matched ".ge.". */
837 *result
= INTRINSIC_GE_OS
;
843 if (gfc_next_ascii_char () == '.')
845 /* Matched ".gt.". */
846 *result
= INTRINSIC_GT_OS
;
853 ch
= gfc_next_ascii_char ();
856 if (gfc_next_ascii_char () == '.')
858 /* Matched ".le.". */
859 *result
= INTRINSIC_LE_OS
;
865 if (gfc_next_ascii_char () == '.')
867 /* Matched ".lt.". */
868 *result
= INTRINSIC_LT_OS
;
875 ch
= gfc_next_ascii_char ();
878 ch
= gfc_next_ascii_char ();
881 /* Matched ".ne.". */
882 *result
= INTRINSIC_NE_OS
;
887 if (gfc_next_ascii_char () == 'v'
888 && gfc_next_ascii_char () == '.')
890 /* Matched ".neqv.". */
891 *result
= INTRINSIC_NEQV
;
898 if (gfc_next_ascii_char () == 't'
899 && gfc_next_ascii_char () == '.')
901 /* Matched ".not.". */
902 *result
= INTRINSIC_NOT
;
909 if (gfc_next_ascii_char () == 'r'
910 && gfc_next_ascii_char () == '.')
912 /* Matched ".or.". */
913 *result
= INTRINSIC_OR
;
927 gfc_current_locus
= orig_loc
;
932 /* Match a loop control phrase:
934 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
936 If the final integer expression is not present, a constant unity
937 expression is returned. We don't return MATCH_ERROR until after
938 the equals sign is seen. */
941 gfc_match_iterator (gfc_iterator
*iter
, int init_flag
)
943 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
944 gfc_expr
*var
, *e1
, *e2
, *e3
;
948 /* Match the start of an iterator without affecting the symbol table. */
950 start
= gfc_current_locus
;
951 m
= gfc_match (" %n =", name
);
952 gfc_current_locus
= start
;
957 m
= gfc_match_variable (&var
, 0);
961 gfc_match_char ('=');
965 if (var
->ref
!= NULL
)
967 gfc_error ("Loop variable at %C cannot be a sub-component");
971 if (var
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
973 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
974 var
->symtree
->n
.sym
->name
);
978 var
->symtree
->n
.sym
->attr
.implied_index
= 1;
980 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
983 if (m
== MATCH_ERROR
)
986 if (gfc_match_char (',') != MATCH_YES
)
989 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
992 if (m
== MATCH_ERROR
)
995 if (gfc_match_char (',') != MATCH_YES
)
997 e3
= gfc_int_expr (1);
1001 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
1002 if (m
== MATCH_ERROR
)
1006 gfc_error ("Expected a step value in iterator at %C");
1018 gfc_error ("Syntax error in iterator at %C");
1029 /* Tries to match the next non-whitespace character on the input.
1030 This subroutine does not return MATCH_ERROR. */
1033 gfc_match_char (char c
)
1037 where
= gfc_current_locus
;
1038 gfc_gobble_whitespace ();
1040 if (gfc_next_ascii_char () == c
)
1043 gfc_current_locus
= where
;
1048 /* General purpose matching subroutine. The target string is a
1049 scanf-like format string in which spaces correspond to arbitrary
1050 whitespace (including no whitespace), characters correspond to
1051 themselves. The %-codes are:
1053 %% Literal percent sign
1054 %e Expression, pointer to a pointer is set
1055 %s Symbol, pointer to the symbol is set
1056 %n Name, character buffer is set to name
1057 %t Matches end of statement.
1058 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1059 %l Matches a statement label
1060 %v Matches a variable expression (an lvalue)
1061 % Matches a required space (in free form) and optional spaces. */
1064 gfc_match (const char *target
, ...)
1066 gfc_st_label
**label
;
1075 old_loc
= gfc_current_locus
;
1076 va_start (argp
, target
);
1086 gfc_gobble_whitespace ();
1097 vp
= va_arg (argp
, void **);
1098 n
= gfc_match_expr ((gfc_expr
**) vp
);
1109 vp
= va_arg (argp
, void **);
1110 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
1121 vp
= va_arg (argp
, void **);
1122 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
1133 np
= va_arg (argp
, char *);
1134 n
= gfc_match_name (np
);
1145 label
= va_arg (argp
, gfc_st_label
**);
1146 n
= gfc_match_st_label (label
);
1157 ip
= va_arg (argp
, int *);
1158 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
1169 if (gfc_match_eos () != MATCH_YES
)
1177 if (gfc_match_space () == MATCH_YES
)
1183 break; /* Fall through to character matcher. */
1186 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
1191 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1192 expect an upper case character here! */
1193 gcc_assert (TOLOWER (c
) == c
);
1195 if (c
== gfc_next_ascii_char ())
1205 /* Clean up after a failed match. */
1206 gfc_current_locus
= old_loc
;
1207 va_start (argp
, target
);
1210 for (; matches
> 0; matches
--)
1212 while (*p
++ != '%');
1220 /* Matches that don't have to be undone */
1225 (void) va_arg (argp
, void **);
1230 vp
= va_arg (argp
, void **);
1231 gfc_free_expr ((struct gfc_expr
*)*vp
);
1244 /*********************** Statement level matching **********************/
1246 /* Matches the start of a program unit, which is the program keyword
1247 followed by an obligatory symbol. */
1250 gfc_match_program (void)
1255 m
= gfc_match ("% %s%t", &sym
);
1259 gfc_error ("Invalid form of PROGRAM statement at %C");
1263 if (m
== MATCH_ERROR
)
1266 if (gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
) == FAILURE
)
1269 gfc_new_block
= sym
;
1275 /* Match a simple assignment statement. */
1278 gfc_match_assignment (void)
1280 gfc_expr
*lvalue
, *rvalue
;
1284 old_loc
= gfc_current_locus
;
1287 m
= gfc_match (" %v =", &lvalue
);
1290 gfc_current_locus
= old_loc
;
1291 gfc_free_expr (lvalue
);
1295 if (lvalue
->symtree
->n
.sym
->attr
.is_protected
1296 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
1298 gfc_current_locus
= old_loc
;
1299 gfc_free_expr (lvalue
);
1300 gfc_error ("Setting value of PROTECTED variable at %C");
1305 m
= gfc_match (" %e%t", &rvalue
);
1308 gfc_current_locus
= old_loc
;
1309 gfc_free_expr (lvalue
);
1310 gfc_free_expr (rvalue
);
1314 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1316 new_st
.op
= EXEC_ASSIGN
;
1317 new_st
.expr
= lvalue
;
1318 new_st
.expr2
= rvalue
;
1320 gfc_check_do_variable (lvalue
->symtree
);
1326 /* Match a pointer assignment statement. */
1329 gfc_match_pointer_assignment (void)
1331 gfc_expr
*lvalue
, *rvalue
;
1335 old_loc
= gfc_current_locus
;
1337 lvalue
= rvalue
= NULL
;
1338 gfc_matching_procptr_assignment
= 0;
1340 m
= gfc_match (" %v =>", &lvalue
);
1347 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
1348 gfc_matching_procptr_assignment
= 1;
1350 m
= gfc_match (" %e%t", &rvalue
);
1351 gfc_matching_procptr_assignment
= 0;
1355 if (lvalue
->symtree
->n
.sym
->attr
.is_protected
1356 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
1358 gfc_error ("Assigning to a PROTECTED pointer at %C");
1363 new_st
.op
= EXEC_POINTER_ASSIGN
;
1364 new_st
.expr
= lvalue
;
1365 new_st
.expr2
= rvalue
;
1370 gfc_current_locus
= old_loc
;
1371 gfc_free_expr (lvalue
);
1372 gfc_free_expr (rvalue
);
1377 /* We try to match an easy arithmetic IF statement. This only happens
1378 when just after having encountered a simple IF statement. This code
1379 is really duplicate with parts of the gfc_match_if code, but this is
1383 match_arithmetic_if (void)
1385 gfc_st_label
*l1
, *l2
, *l3
;
1389 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1393 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
1394 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
1395 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
1397 gfc_free_expr (expr
);
1401 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent: arithmetic IF statement "
1402 "at %C") == FAILURE
)
1405 new_st
.op
= EXEC_ARITHMETIC_IF
;
1415 /* The IF statement is a bit of a pain. First of all, there are three
1416 forms of it, the simple IF, the IF that starts a block and the
1419 There is a problem with the simple IF and that is the fact that we
1420 only have a single level of undo information on symbols. What this
1421 means is for a simple IF, we must re-match the whole IF statement
1422 multiple times in order to guarantee that the symbol table ends up
1423 in the proper state. */
1425 static match
match_simple_forall (void);
1426 static match
match_simple_where (void);
1429 gfc_match_if (gfc_statement
*if_type
)
1432 gfc_st_label
*l1
, *l2
, *l3
;
1433 locus old_loc
, old_loc2
;
1437 n
= gfc_match_label ();
1438 if (n
== MATCH_ERROR
)
1441 old_loc
= gfc_current_locus
;
1443 m
= gfc_match (" if ( %e", &expr
);
1447 old_loc2
= gfc_current_locus
;
1448 gfc_current_locus
= old_loc
;
1450 if (gfc_match_parens () == MATCH_ERROR
)
1453 gfc_current_locus
= old_loc2
;
1455 if (gfc_match_char (')') != MATCH_YES
)
1457 gfc_error ("Syntax error in IF-expression at %C");
1458 gfc_free_expr (expr
);
1462 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1468 gfc_error ("Block label not appropriate for arithmetic IF "
1470 gfc_free_expr (expr
);
1474 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
1475 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
1476 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
1478 gfc_free_expr (expr
);
1482 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent: arithmetic IF "
1483 "statement at %C") == FAILURE
)
1486 new_st
.op
= EXEC_ARITHMETIC_IF
;
1492 *if_type
= ST_ARITHMETIC_IF
;
1496 if (gfc_match (" then%t") == MATCH_YES
)
1498 new_st
.op
= EXEC_IF
;
1500 *if_type
= ST_IF_BLOCK
;
1506 gfc_error ("Block label is not appropriate for IF statement at %C");
1507 gfc_free_expr (expr
);
1511 /* At this point the only thing left is a simple IF statement. At
1512 this point, n has to be MATCH_NO, so we don't have to worry about
1513 re-matching a block label. From what we've got so far, try
1514 matching an assignment. */
1516 *if_type
= ST_SIMPLE_IF
;
1518 m
= gfc_match_assignment ();
1522 gfc_free_expr (expr
);
1523 gfc_undo_symbols ();
1524 gfc_current_locus
= old_loc
;
1526 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1527 assignment was found. For MATCH_NO, continue to call the various
1529 if (m
== MATCH_ERROR
)
1532 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1534 m
= gfc_match_pointer_assignment ();
1538 gfc_free_expr (expr
);
1539 gfc_undo_symbols ();
1540 gfc_current_locus
= old_loc
;
1542 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1544 /* Look at the next keyword to see which matcher to call. Matching
1545 the keyword doesn't affect the symbol table, so we don't have to
1546 restore between tries. */
1548 #define match(string, subr, statement) \
1549 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1553 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1554 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1555 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1556 match ("call", gfc_match_call
, ST_CALL
)
1557 match ("close", gfc_match_close
, ST_CLOSE
)
1558 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1559 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1560 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1561 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1562 match ("exit", gfc_match_exit
, ST_EXIT
)
1563 match ("flush", gfc_match_flush
, ST_FLUSH
)
1564 match ("forall", match_simple_forall
, ST_FORALL
)
1565 match ("go to", gfc_match_goto
, ST_GOTO
)
1566 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1567 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1568 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1569 match ("open", gfc_match_open
, ST_OPEN
)
1570 match ("pause", gfc_match_pause
, ST_NONE
)
1571 match ("print", gfc_match_print
, ST_WRITE
)
1572 match ("read", gfc_match_read
, ST_READ
)
1573 match ("return", gfc_match_return
, ST_RETURN
)
1574 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1575 match ("stop", gfc_match_stop
, ST_STOP
)
1576 match ("wait", gfc_match_wait
, ST_WAIT
)
1577 match ("where", match_simple_where
, ST_WHERE
)
1578 match ("write", gfc_match_write
, ST_WRITE
)
1580 /* The gfc_match_assignment() above may have returned a MATCH_NO
1581 where the assignment was to a named constant. Check that
1582 special case here. */
1583 m
= gfc_match_assignment ();
1586 gfc_error ("Cannot assign to a named constant at %C");
1587 gfc_free_expr (expr
);
1588 gfc_undo_symbols ();
1589 gfc_current_locus
= old_loc
;
1593 /* All else has failed, so give up. See if any of the matchers has
1594 stored an error message of some sort. */
1595 if (gfc_error_check () == 0)
1596 gfc_error ("Unclassifiable statement in IF-clause at %C");
1598 gfc_free_expr (expr
);
1603 gfc_error ("Syntax error in IF-clause at %C");
1606 gfc_free_expr (expr
);
1610 /* At this point, we've matched the single IF and the action clause
1611 is in new_st. Rearrange things so that the IF statement appears
1614 p
= gfc_get_code ();
1615 p
->next
= gfc_get_code ();
1617 p
->next
->loc
= gfc_current_locus
;
1622 gfc_clear_new_st ();
1624 new_st
.op
= EXEC_IF
;
1633 /* Match an ELSE statement. */
1636 gfc_match_else (void)
1638 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1640 if (gfc_match_eos () == MATCH_YES
)
1643 if (gfc_match_name (name
) != MATCH_YES
1644 || gfc_current_block () == NULL
1645 || gfc_match_eos () != MATCH_YES
)
1647 gfc_error ("Unexpected junk after ELSE statement at %C");
1651 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1653 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1654 name
, gfc_current_block ()->name
);
1662 /* Match an ELSE IF statement. */
1665 gfc_match_elseif (void)
1667 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1671 m
= gfc_match (" ( %e ) then", &expr
);
1675 if (gfc_match_eos () == MATCH_YES
)
1678 if (gfc_match_name (name
) != MATCH_YES
1679 || gfc_current_block () == NULL
1680 || gfc_match_eos () != MATCH_YES
)
1682 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1686 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1688 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1689 name
, gfc_current_block ()->name
);
1694 new_st
.op
= EXEC_IF
;
1699 gfc_free_expr (expr
);
1704 /* Free a gfc_iterator structure. */
1707 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1713 gfc_free_expr (iter
->var
);
1714 gfc_free_expr (iter
->start
);
1715 gfc_free_expr (iter
->end
);
1716 gfc_free_expr (iter
->step
);
1723 /* Match a DO statement. */
1728 gfc_iterator iter
, *ip
;
1730 gfc_st_label
*label
;
1733 old_loc
= gfc_current_locus
;
1736 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
1738 m
= gfc_match_label ();
1739 if (m
== MATCH_ERROR
)
1742 if (gfc_match (" do") != MATCH_YES
)
1745 m
= gfc_match_st_label (&label
);
1746 if (m
== MATCH_ERROR
)
1749 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
1751 if (gfc_match_eos () == MATCH_YES
)
1753 iter
.end
= gfc_logical_expr (1, NULL
);
1754 new_st
.op
= EXEC_DO_WHILE
;
1758 /* Match an optional comma, if no comma is found, a space is obligatory. */
1759 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
1762 /* Check for balanced parens. */
1764 if (gfc_match_parens () == MATCH_ERROR
)
1767 /* See if we have a DO WHILE. */
1768 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
1770 new_st
.op
= EXEC_DO_WHILE
;
1774 /* The abortive DO WHILE may have done something to the symbol
1775 table, so we start over. */
1776 gfc_undo_symbols ();
1777 gfc_current_locus
= old_loc
;
1779 gfc_match_label (); /* This won't error. */
1780 gfc_match (" do "); /* This will work. */
1782 gfc_match_st_label (&label
); /* Can't error out. */
1783 gfc_match_char (','); /* Optional comma. */
1785 m
= gfc_match_iterator (&iter
, 0);
1788 if (m
== MATCH_ERROR
)
1791 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
1792 gfc_check_do_variable (iter
.var
->symtree
);
1794 if (gfc_match_eos () != MATCH_YES
)
1796 gfc_syntax_error (ST_DO
);
1800 new_st
.op
= EXEC_DO
;
1804 && gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1807 new_st
.label
= label
;
1809 if (new_st
.op
== EXEC_DO_WHILE
)
1810 new_st
.expr
= iter
.end
;
1813 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
1820 gfc_free_iterator (&iter
, 0);
1826 /* Match an EXIT or CYCLE statement. */
1829 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
1831 gfc_state_data
*p
, *o
;
1835 if (gfc_match_eos () == MATCH_YES
)
1839 m
= gfc_match ("% %s%t", &sym
);
1840 if (m
== MATCH_ERROR
)
1844 gfc_syntax_error (st
);
1848 if (sym
->attr
.flavor
!= FL_LABEL
)
1850 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1851 sym
->name
, gfc_ascii_statement (st
));
1856 /* Find the loop mentioned specified by the label (or lack of a label). */
1857 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
1858 if (p
->state
== COMP_DO
&& (sym
== NULL
|| sym
== p
->sym
))
1860 else if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
1866 gfc_error ("%s statement at %C is not within a loop",
1867 gfc_ascii_statement (st
));
1869 gfc_error ("%s statement at %C is not within loop '%s'",
1870 gfc_ascii_statement (st
), sym
->name
);
1877 gfc_error ("%s statement at %C leaving OpenMP structured block",
1878 gfc_ascii_statement (st
));
1881 else if (st
== ST_EXIT
1882 && p
->previous
!= NULL
1883 && p
->previous
->state
== COMP_OMP_STRUCTURED_BLOCK
1884 && (p
->previous
->head
->op
== EXEC_OMP_DO
1885 || p
->previous
->head
->op
== EXEC_OMP_PARALLEL_DO
))
1887 gcc_assert (p
->previous
->head
->next
!= NULL
);
1888 gcc_assert (p
->previous
->head
->next
->op
== EXEC_DO
1889 || p
->previous
->head
->next
->op
== EXEC_DO_WHILE
);
1890 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1894 /* Save the first statement in the loop - needed by the backend. */
1895 new_st
.ext
.whichloop
= p
->head
;
1903 /* Match the EXIT statement. */
1906 gfc_match_exit (void)
1908 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
1912 /* Match the CYCLE statement. */
1915 gfc_match_cycle (void)
1917 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
1921 /* Match a number or character constant after a STOP or PAUSE statement. */
1924 gfc_match_stopcode (gfc_statement st
)
1934 if (gfc_match_eos () != MATCH_YES
)
1936 m
= gfc_match_small_literal_int (&stop_code
, &cnt
);
1937 if (m
== MATCH_ERROR
)
1940 if (m
== MATCH_YES
&& cnt
> 5)
1942 gfc_error ("Too many digits in STOP code at %C");
1948 /* Try a character constant. */
1949 m
= gfc_match_expr (&e
);
1950 if (m
== MATCH_ERROR
)
1954 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1958 if (gfc_match_eos () != MATCH_YES
)
1962 if (gfc_pure (NULL
))
1964 gfc_error ("%s statement not allowed in PURE procedure at %C",
1965 gfc_ascii_statement (st
));
1969 new_st
.op
= st
== ST_STOP
? EXEC_STOP
: EXEC_PAUSE
;
1971 new_st
.ext
.stop_code
= stop_code
;
1976 gfc_syntax_error (st
);
1985 /* Match the (deprecated) PAUSE statement. */
1988 gfc_match_pause (void)
1992 m
= gfc_match_stopcode (ST_PAUSE
);
1995 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: PAUSE statement"
2004 /* Match the STOP statement. */
2007 gfc_match_stop (void)
2009 return gfc_match_stopcode (ST_STOP
);
2013 /* Match a CONTINUE statement. */
2016 gfc_match_continue (void)
2018 if (gfc_match_eos () != MATCH_YES
)
2020 gfc_syntax_error (ST_CONTINUE
);
2024 new_st
.op
= EXEC_CONTINUE
;
2029 /* Match the (deprecated) ASSIGN statement. */
2032 gfc_match_assign (void)
2035 gfc_st_label
*label
;
2037 if (gfc_match (" %l", &label
) == MATCH_YES
)
2039 if (gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
) == FAILURE
)
2041 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
2043 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: ASSIGN "
2048 expr
->symtree
->n
.sym
->attr
.assign
= 1;
2050 new_st
.op
= EXEC_LABEL_ASSIGN
;
2051 new_st
.label
= label
;
2060 /* Match the GO TO statement. As a computed GOTO statement is
2061 matched, it is transformed into an equivalent SELECT block. No
2062 tree is necessary, and the resulting jumps-to-jumps are
2063 specifically optimized away by the back end. */
2066 gfc_match_goto (void)
2068 gfc_code
*head
, *tail
;
2071 gfc_st_label
*label
;
2075 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
2077 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2080 new_st
.op
= EXEC_GOTO
;
2081 new_st
.label
= label
;
2085 /* The assigned GO TO statement. */
2087 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
2089 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: Assigned GOTO "
2094 new_st
.op
= EXEC_GOTO
;
2097 if (gfc_match_eos () == MATCH_YES
)
2100 /* Match label list. */
2101 gfc_match_char (',');
2102 if (gfc_match_char ('(') != MATCH_YES
)
2104 gfc_syntax_error (ST_GOTO
);
2111 m
= gfc_match_st_label (&label
);
2115 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2119 head
= tail
= gfc_get_code ();
2122 tail
->block
= gfc_get_code ();
2126 tail
->label
= label
;
2127 tail
->op
= EXEC_GOTO
;
2129 while (gfc_match_char (',') == MATCH_YES
);
2131 if (gfc_match (")%t") != MATCH_YES
)
2136 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2139 new_st
.block
= head
;
2144 /* Last chance is a computed GO TO statement. */
2145 if (gfc_match_char ('(') != MATCH_YES
)
2147 gfc_syntax_error (ST_GOTO
);
2156 m
= gfc_match_st_label (&label
);
2160 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2164 head
= tail
= gfc_get_code ();
2167 tail
->block
= gfc_get_code ();
2171 cp
= gfc_get_case ();
2172 cp
->low
= cp
->high
= gfc_int_expr (i
++);
2174 tail
->op
= EXEC_SELECT
;
2175 tail
->ext
.case_list
= cp
;
2177 tail
->next
= gfc_get_code ();
2178 tail
->next
->op
= EXEC_GOTO
;
2179 tail
->next
->label
= label
;
2181 while (gfc_match_char (',') == MATCH_YES
);
2183 if (gfc_match_char (')') != MATCH_YES
)
2188 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2192 /* Get the rest of the statement. */
2193 gfc_match_char (',');
2195 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
2198 /* At this point, a computed GOTO has been fully matched and an
2199 equivalent SELECT statement constructed. */
2201 new_st
.op
= EXEC_SELECT
;
2204 /* Hack: For a "real" SELECT, the expression is in expr. We put
2205 it in expr2 so we can distinguish then and produce the correct
2207 new_st
.expr2
= expr
;
2208 new_st
.block
= head
;
2212 gfc_syntax_error (ST_GOTO
);
2214 gfc_free_statements (head
);
2219 /* Frees a list of gfc_alloc structures. */
2222 gfc_free_alloc_list (gfc_alloc
*p
)
2229 gfc_free_expr (p
->expr
);
2235 /* Match an ALLOCATE statement. */
2238 gfc_match_allocate (void)
2240 gfc_alloc
*head
, *tail
;
2247 if (gfc_match_char ('(') != MATCH_YES
)
2253 head
= tail
= gfc_get_alloc ();
2256 tail
->next
= gfc_get_alloc ();
2260 m
= gfc_match_variable (&tail
->expr
, 0);
2263 if (m
== MATCH_ERROR
)
2266 if (gfc_check_do_variable (tail
->expr
->symtree
))
2270 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
2272 gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
2277 if (tail
->expr
->ts
.type
== BT_DERIVED
)
2278 tail
->expr
->ts
.derived
= gfc_use_derived (tail
->expr
->ts
.derived
);
2280 if (gfc_match_char (',') != MATCH_YES
)
2283 m
= gfc_match (" stat = %v", &stat
);
2284 if (m
== MATCH_ERROR
)
2291 gfc_check_do_variable(stat
->symtree
);
2293 if (gfc_match (" )%t") != MATCH_YES
)
2296 new_st
.op
= EXEC_ALLOCATE
;
2298 new_st
.ext
.alloc_list
= head
;
2303 gfc_syntax_error (ST_ALLOCATE
);
2306 gfc_free_expr (stat
);
2307 gfc_free_alloc_list (head
);
2312 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
2313 a set of pointer assignments to intrinsic NULL(). */
2316 gfc_match_nullify (void)
2324 if (gfc_match_char ('(') != MATCH_YES
)
2329 m
= gfc_match_variable (&p
, 0);
2330 if (m
== MATCH_ERROR
)
2335 if (gfc_check_do_variable (p
->symtree
))
2338 if (gfc_pure (NULL
) && gfc_impure_variable (p
->symtree
->n
.sym
))
2340 gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
2344 /* build ' => NULL() '. */
2345 e
= gfc_get_expr ();
2346 e
->where
= gfc_current_locus
;
2347 e
->expr_type
= EXPR_NULL
;
2348 e
->ts
.type
= BT_UNKNOWN
;
2350 /* Chain to list. */
2355 tail
->next
= gfc_get_code ();
2359 tail
->op
= EXEC_POINTER_ASSIGN
;
2363 if (gfc_match (" )%t") == MATCH_YES
)
2365 if (gfc_match_char (',') != MATCH_YES
)
2372 gfc_syntax_error (ST_NULLIFY
);
2375 gfc_free_statements (new_st
.next
);
2380 /* Match a DEALLOCATE statement. */
2383 gfc_match_deallocate (void)
2385 gfc_alloc
*head
, *tail
;
2392 if (gfc_match_char ('(') != MATCH_YES
)
2398 head
= tail
= gfc_get_alloc ();
2401 tail
->next
= gfc_get_alloc ();
2405 m
= gfc_match_variable (&tail
->expr
, 0);
2406 if (m
== MATCH_ERROR
)
2411 if (gfc_check_do_variable (tail
->expr
->symtree
))
2415 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
2417 gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
2418 "for a PURE procedure");
2422 if (gfc_match_char (',') != MATCH_YES
)
2425 m
= gfc_match (" stat = %v", &stat
);
2426 if (m
== MATCH_ERROR
)
2433 gfc_check_do_variable(stat
->symtree
);
2435 if (gfc_match (" )%t") != MATCH_YES
)
2438 new_st
.op
= EXEC_DEALLOCATE
;
2440 new_st
.ext
.alloc_list
= head
;
2445 gfc_syntax_error (ST_DEALLOCATE
);
2448 gfc_free_expr (stat
);
2449 gfc_free_alloc_list (head
);
2454 /* Match a RETURN statement. */
2457 gfc_match_return (void)
2461 gfc_compile_state s
;
2464 if (gfc_match_eos () == MATCH_YES
)
2467 if (gfc_find_state (COMP_SUBROUTINE
) == FAILURE
)
2469 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2474 if (gfc_current_form
== FORM_FREE
)
2476 /* The following are valid, so we can't require a blank after the
2480 char c
= gfc_peek_ascii_char ();
2481 if (ISALPHA (c
) || ISDIGIT (c
))
2485 m
= gfc_match (" %e%t", &e
);
2488 if (m
== MATCH_ERROR
)
2491 gfc_syntax_error (ST_RETURN
);
2498 gfc_enclosing_unit (&s
);
2499 if (s
== COMP_PROGRAM
2500 && gfc_notify_std (GFC_STD_GNU
, "Extension: RETURN statement in "
2501 "main program at %C") == FAILURE
)
2504 new_st
.op
= EXEC_RETURN
;
2511 /* Match a CALL statement. The tricky part here are possible
2512 alternate return specifiers. We handle these by having all
2513 "subroutines" actually return an integer via a register that gives
2514 the return number. If the call specifies alternate returns, we
2515 generate code for a SELECT statement whose case clauses contain
2516 GOTOs to the various labels. */
2519 gfc_match_call (void)
2521 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2522 gfc_actual_arglist
*a
, *arglist
;
2532 m
= gfc_match ("% %n", name
);
2538 if (gfc_get_ha_sym_tree (name
, &st
))
2543 /* If it does not seem to be callable... */
2544 if (!sym
->attr
.generic
2545 && !sym
->attr
.subroutine
)
2547 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
2549 /* ...create a symbol in this scope... */
2550 if (sym
->ns
!= gfc_current_ns
2551 && gfc_get_sym_tree (name
, NULL
, &st
) == 1)
2554 if (sym
!= st
->n
.sym
)
2558 /* ...and then to try to make the symbol into a subroutine. */
2559 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2563 gfc_set_sym_referenced (sym
);
2565 if (gfc_match_eos () != MATCH_YES
)
2567 m
= gfc_match_actual_arglist (1, &arglist
);
2570 if (m
== MATCH_ERROR
)
2573 if (gfc_match_eos () != MATCH_YES
)
2577 /* If any alternate return labels were found, construct a SELECT
2578 statement that will jump to the right place. */
2581 for (a
= arglist
; a
; a
= a
->next
)
2582 if (a
->expr
== NULL
)
2587 gfc_symtree
*select_st
;
2588 gfc_symbol
*select_sym
;
2589 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2591 new_st
.next
= c
= gfc_get_code ();
2592 c
->op
= EXEC_SELECT
;
2593 sprintf (name
, "_result_%s", sym
->name
);
2594 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
2596 select_sym
= select_st
->n
.sym
;
2597 select_sym
->ts
.type
= BT_INTEGER
;
2598 select_sym
->ts
.kind
= gfc_default_integer_kind
;
2599 gfc_set_sym_referenced (select_sym
);
2600 c
->expr
= gfc_get_expr ();
2601 c
->expr
->expr_type
= EXPR_VARIABLE
;
2602 c
->expr
->symtree
= select_st
;
2603 c
->expr
->ts
= select_sym
->ts
;
2604 c
->expr
->where
= gfc_current_locus
;
2607 for (a
= arglist
; a
; a
= a
->next
)
2609 if (a
->expr
!= NULL
)
2612 if (gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
) == FAILURE
)
2617 c
->block
= gfc_get_code ();
2619 c
->op
= EXEC_SELECT
;
2621 new_case
= gfc_get_case ();
2622 new_case
->high
= new_case
->low
= gfc_int_expr (i
);
2623 c
->ext
.case_list
= new_case
;
2625 c
->next
= gfc_get_code ();
2626 c
->next
->op
= EXEC_GOTO
;
2627 c
->next
->label
= a
->label
;
2631 new_st
.op
= EXEC_CALL
;
2632 new_st
.symtree
= st
;
2633 new_st
.ext
.actual
= arglist
;
2638 gfc_syntax_error (ST_CALL
);
2641 gfc_free_actual_arglist (arglist
);
2646 /* Given a name, return a pointer to the common head structure,
2647 creating it if it does not exist. If FROM_MODULE is nonzero, we
2648 mangle the name so that it doesn't interfere with commons defined
2649 in the using namespace.
2650 TODO: Add to global symbol tree. */
2653 gfc_get_common (const char *name
, int from_module
)
2656 static int serial
= 0;
2657 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
2661 /* A use associated common block is only needed to correctly layout
2662 the variables it contains. */
2663 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
2664 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
2668 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
2671 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
2674 if (st
->n
.common
== NULL
)
2676 st
->n
.common
= gfc_get_common_head ();
2677 st
->n
.common
->where
= gfc_current_locus
;
2678 strcpy (st
->n
.common
->name
, name
);
2681 return st
->n
.common
;
2685 /* Match a common block name. */
2687 match
match_common_name (char *name
)
2691 if (gfc_match_char ('/') == MATCH_NO
)
2697 if (gfc_match_char ('/') == MATCH_YES
)
2703 m
= gfc_match_name (name
);
2705 if (m
== MATCH_ERROR
)
2707 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
2710 gfc_error ("Syntax error in common block name at %C");
2715 /* Match a COMMON statement. */
2718 gfc_match_common (void)
2720 gfc_symbol
*sym
, **head
, *tail
, *other
, *old_blank_common
;
2721 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2728 old_blank_common
= gfc_current_ns
->blank_common
.head
;
2729 if (old_blank_common
)
2731 while (old_blank_common
->common_next
)
2732 old_blank_common
= old_blank_common
->common_next
;
2739 m
= match_common_name (name
);
2740 if (m
== MATCH_ERROR
)
2743 gsym
= gfc_get_gsymbol (name
);
2744 if (gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= GSYM_COMMON
)
2746 gfc_error ("Symbol '%s' at %C is already an external symbol that "
2747 "is not COMMON", name
);
2751 if (gsym
->type
== GSYM_UNKNOWN
)
2753 gsym
->type
= GSYM_COMMON
;
2754 gsym
->where
= gfc_current_locus
;
2760 if (name
[0] == '\0')
2762 t
= &gfc_current_ns
->blank_common
;
2763 if (t
->head
== NULL
)
2764 t
->where
= gfc_current_locus
;
2768 t
= gfc_get_common (name
, 0);
2777 while (tail
->common_next
)
2778 tail
= tail
->common_next
;
2781 /* Grab the list of symbols. */
2784 m
= gfc_match_symbol (&sym
, 0);
2785 if (m
== MATCH_ERROR
)
2790 /* Store a ref to the common block for error checking. */
2791 sym
->common_block
= t
;
2793 /* See if we know the current common block is bind(c), and if
2794 so, then see if we can check if the symbol is (which it'll
2795 need to be). This can happen if the bind(c) attr stmt was
2796 applied to the common block, and the variable(s) already
2797 defined, before declaring the common block. */
2798 if (t
->is_bind_c
== 1)
2800 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
2802 /* If we find an error, just print it and continue,
2803 cause it's just semantic, and we can see if there
2805 gfc_error_now ("Variable '%s' at %L in common block '%s' "
2806 "at %C must be declared with a C "
2807 "interoperable kind since common block "
2809 sym
->name
, &(sym
->declared_at
), t
->name
,
2813 if (sym
->attr
.is_bind_c
== 1)
2814 gfc_error_now ("Variable '%s' in common block "
2815 "'%s' at %C can not be bind(c) since "
2816 "it is not global", sym
->name
, t
->name
);
2819 if (sym
->attr
.in_common
)
2821 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2826 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
2827 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
2829 if (gfc_notify_std (GFC_STD_GNU
, "Initialized symbol '%s' at %C "
2830 "can only be COMMON in "
2831 "BLOCK DATA", sym
->name
)
2836 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2840 tail
->common_next
= sym
;
2846 /* Deal with an optional array specification after the
2848 m
= gfc_match_array_spec (&as
);
2849 if (m
== MATCH_ERROR
)
2854 if (as
->type
!= AS_EXPLICIT
)
2856 gfc_error ("Array specification for symbol '%s' in COMMON "
2857 "at %C must be explicit", sym
->name
);
2861 if (gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2864 if (sym
->attr
.pointer
)
2866 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
2867 "POINTER array", sym
->name
);
2876 sym
->common_head
= t
;
2878 /* Check to see if the symbol is already in an equivalence group.
2879 If it is, set the other members as being in common. */
2880 if (sym
->attr
.in_equivalence
)
2882 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
2884 for (e2
= e1
; e2
; e2
= e2
->eq
)
2885 if (e2
->expr
->symtree
->n
.sym
== sym
)
2892 for (e2
= e1
; e2
; e2
= e2
->eq
)
2894 other
= e2
->expr
->symtree
->n
.sym
;
2895 if (other
->common_head
2896 && other
->common_head
!= sym
->common_head
)
2898 gfc_error ("Symbol '%s', in COMMON block '%s' at "
2899 "%C is being indirectly equivalenced to "
2900 "another COMMON block '%s'",
2901 sym
->name
, sym
->common_head
->name
,
2902 other
->common_head
->name
);
2905 other
->attr
.in_common
= 1;
2906 other
->common_head
= t
;
2912 gfc_gobble_whitespace ();
2913 if (gfc_match_eos () == MATCH_YES
)
2915 if (gfc_peek_ascii_char () == '/')
2917 if (gfc_match_char (',') != MATCH_YES
)
2919 gfc_gobble_whitespace ();
2920 if (gfc_peek_ascii_char () == '/')
2929 gfc_syntax_error (ST_COMMON
);
2932 if (old_blank_common
)
2933 old_blank_common
->common_next
= NULL
;
2935 gfc_current_ns
->blank_common
.head
= NULL
;
2936 gfc_free_array_spec (as
);
2941 /* Match a BLOCK DATA program unit. */
2944 gfc_match_block_data (void)
2946 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2950 if (gfc_match_eos () == MATCH_YES
)
2952 gfc_new_block
= NULL
;
2956 m
= gfc_match ("% %n%t", name
);
2960 if (gfc_get_symbol (name
, NULL
, &sym
))
2963 if (gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
) == FAILURE
)
2966 gfc_new_block
= sym
;
2972 /* Free a namelist structure. */
2975 gfc_free_namelist (gfc_namelist
*name
)
2979 for (; name
; name
= n
)
2987 /* Match a NAMELIST statement. */
2990 gfc_match_namelist (void)
2992 gfc_symbol
*group_name
, *sym
;
2996 m
= gfc_match (" / %s /", &group_name
);
2999 if (m
== MATCH_ERROR
)
3004 if (group_name
->ts
.type
!= BT_UNKNOWN
)
3006 gfc_error ("Namelist group name '%s' at %C already has a basic "
3007 "type of %s", group_name
->name
,
3008 gfc_typename (&group_name
->ts
));
3012 if (group_name
->attr
.flavor
== FL_NAMELIST
3013 && group_name
->attr
.use_assoc
3014 && gfc_notify_std (GFC_STD_GNU
, "Namelist group name '%s' "
3015 "at %C already is USE associated and can"
3016 "not be respecified.", group_name
->name
)
3020 if (group_name
->attr
.flavor
!= FL_NAMELIST
3021 && gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
3022 group_name
->name
, NULL
) == FAILURE
)
3027 m
= gfc_match_symbol (&sym
, 1);
3030 if (m
== MATCH_ERROR
)
3033 if (sym
->attr
.in_namelist
== 0
3034 && gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3037 /* Use gfc_error_check here, rather than goto error, so that
3038 these are the only errors for the next two lines. */
3039 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
3041 gfc_error ("Assumed size array '%s' in namelist '%s' at "
3042 "%C is not allowed", sym
->name
, group_name
->name
);
3046 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.cl
->length
== NULL
)
3048 gfc_error ("Assumed character length '%s' in namelist '%s' at "
3049 "%C is not allowed", sym
->name
, group_name
->name
);
3053 nl
= gfc_get_namelist ();
3057 if (group_name
->namelist
== NULL
)
3058 group_name
->namelist
= group_name
->namelist_tail
= nl
;
3061 group_name
->namelist_tail
->next
= nl
;
3062 group_name
->namelist_tail
= nl
;
3065 if (gfc_match_eos () == MATCH_YES
)
3068 m
= gfc_match_char (',');
3070 if (gfc_match_char ('/') == MATCH_YES
)
3072 m2
= gfc_match (" %s /", &group_name
);
3073 if (m2
== MATCH_YES
)
3075 if (m2
== MATCH_ERROR
)
3089 gfc_syntax_error (ST_NAMELIST
);
3096 /* Match a MODULE statement. */
3099 gfc_match_module (void)
3103 m
= gfc_match (" %s%t", &gfc_new_block
);
3107 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
3108 gfc_new_block
->name
, NULL
) == FAILURE
)
3115 /* Free equivalence sets and lists. Recursively is the easiest way to
3119 gfc_free_equiv (gfc_equiv
*eq
)
3124 gfc_free_equiv (eq
->eq
);
3125 gfc_free_equiv (eq
->next
);
3126 gfc_free_expr (eq
->expr
);
3131 /* Match an EQUIVALENCE statement. */
3134 gfc_match_equivalence (void)
3136 gfc_equiv
*eq
, *set
, *tail
;
3140 gfc_common_head
*common_head
= NULL
;
3148 eq
= gfc_get_equiv ();
3152 eq
->next
= gfc_current_ns
->equiv
;
3153 gfc_current_ns
->equiv
= eq
;
3155 if (gfc_match_char ('(') != MATCH_YES
)
3159 common_flag
= FALSE
;
3164 m
= gfc_match_equiv_variable (&set
->expr
);
3165 if (m
== MATCH_ERROR
)
3170 /* count the number of objects. */
3173 if (gfc_match_char ('%') == MATCH_YES
)
3175 gfc_error ("Derived type component %C is not a "
3176 "permitted EQUIVALENCE member");
3180 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
3181 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
3183 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
3184 "be an array section");
3188 sym
= set
->expr
->symtree
->n
.sym
;
3190 if (gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3193 if (sym
->attr
.in_common
)
3196 common_head
= sym
->common_head
;
3199 if (gfc_match_char (')') == MATCH_YES
)
3202 if (gfc_match_char (',') != MATCH_YES
)
3205 set
->eq
= gfc_get_equiv ();
3211 gfc_error ("EQUIVALENCE at %C requires two or more objects");
3215 /* If one of the members of an equivalence is in common, then
3216 mark them all as being in common. Before doing this, check
3217 that members of the equivalence group are not in different
3220 for (set
= eq
; set
; set
= set
->eq
)
3222 sym
= set
->expr
->symtree
->n
.sym
;
3223 if (sym
->common_head
&& sym
->common_head
!= common_head
)
3225 gfc_error ("Attempt to indirectly overlap COMMON "
3226 "blocks %s and %s by EQUIVALENCE at %C",
3227 sym
->common_head
->name
, common_head
->name
);
3230 sym
->attr
.in_common
= 1;
3231 sym
->common_head
= common_head
;
3234 if (gfc_match_eos () == MATCH_YES
)
3236 if (gfc_match_char (',') != MATCH_YES
)
3243 gfc_syntax_error (ST_EQUIVALENCE
);
3249 gfc_free_equiv (gfc_current_ns
->equiv
);
3250 gfc_current_ns
->equiv
= eq
;
3256 /* Check that a statement function is not recursive. This is done by looking
3257 for the statement function symbol(sym) by looking recursively through its
3258 expression(e). If a reference to sym is found, true is returned.
3259 12.5.4 requires that any variable of function that is implicitly typed
3260 shall have that type confirmed by any subsequent type declaration. The
3261 implicit typing is conveniently done here. */
3263 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
3266 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
3272 switch (e
->expr_type
)
3275 if (e
->symtree
== NULL
)
3278 /* Check the name before testing for nested recursion! */
3279 if (sym
->name
== e
->symtree
->n
.sym
->name
)
3282 /* Catch recursion via other statement functions. */
3283 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
3284 && e
->symtree
->n
.sym
->value
3285 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
3288 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
3289 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
3294 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
3297 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
3298 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
3310 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
3312 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
3316 /* Match a statement function declaration. It is so easy to match
3317 non-statement function statements with a MATCH_ERROR as opposed to
3318 MATCH_NO that we suppress error message in most cases. */
3321 gfc_match_st_function (void)
3323 gfc_error_buf old_error
;
3328 m
= gfc_match_symbol (&sym
, 0);
3332 gfc_push_error (&old_error
);
3334 if (gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
,
3335 sym
->name
, NULL
) == FAILURE
)
3338 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
3341 m
= gfc_match (" = %e%t", &expr
);
3345 gfc_free_error (&old_error
);
3346 if (m
== MATCH_ERROR
)
3349 if (recursive_stmt_fcn (expr
, sym
))
3351 gfc_error ("Statement function at %L is recursive", &expr
->where
);
3360 gfc_pop_error (&old_error
);
3365 /***************** SELECT CASE subroutines ******************/
3367 /* Free a single case structure. */
3370 free_case (gfc_case
*p
)
3372 if (p
->low
== p
->high
)
3374 gfc_free_expr (p
->low
);
3375 gfc_free_expr (p
->high
);
3380 /* Free a list of case structures. */
3383 gfc_free_case_list (gfc_case
*p
)
3395 /* Match a single case selector. */
3398 match_case_selector (gfc_case
**cp
)
3403 c
= gfc_get_case ();
3404 c
->where
= gfc_current_locus
;
3406 if (gfc_match_char (':') == MATCH_YES
)
3408 m
= gfc_match_init_expr (&c
->high
);
3411 if (m
== MATCH_ERROR
)
3416 m
= gfc_match_init_expr (&c
->low
);
3417 if (m
== MATCH_ERROR
)
3422 /* If we're not looking at a ':' now, make a range out of a single
3423 target. Else get the upper bound for the case range. */
3424 if (gfc_match_char (':') != MATCH_YES
)
3428 m
= gfc_match_init_expr (&c
->high
);
3429 if (m
== MATCH_ERROR
)
3431 /* MATCH_NO is fine. It's OK if nothing is there! */
3439 gfc_error ("Expected initialization expression in CASE at %C");
3447 /* Match the end of a case statement. */
3450 match_case_eos (void)
3452 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3455 if (gfc_match_eos () == MATCH_YES
)
3458 /* If the case construct doesn't have a case-construct-name, we
3459 should have matched the EOS. */
3460 if (!gfc_current_block ())
3462 gfc_error ("Expected the name of the SELECT CASE construct at %C");
3466 gfc_gobble_whitespace ();
3468 m
= gfc_match_name (name
);
3472 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3474 gfc_error ("Expected case name of '%s' at %C",
3475 gfc_current_block ()->name
);
3479 return gfc_match_eos ();
3483 /* Match a SELECT statement. */
3486 gfc_match_select (void)
3491 m
= gfc_match_label ();
3492 if (m
== MATCH_ERROR
)
3495 m
= gfc_match (" select case ( %e )%t", &expr
);
3499 new_st
.op
= EXEC_SELECT
;
3506 /* Match a CASE statement. */
3509 gfc_match_case (void)
3511 gfc_case
*c
, *head
, *tail
;
3516 if (gfc_current_state () != COMP_SELECT
)
3518 gfc_error ("Unexpected CASE statement at %C");
3522 if (gfc_match ("% default") == MATCH_YES
)
3524 m
= match_case_eos ();
3527 if (m
== MATCH_ERROR
)
3530 new_st
.op
= EXEC_SELECT
;
3531 c
= gfc_get_case ();
3532 c
->where
= gfc_current_locus
;
3533 new_st
.ext
.case_list
= c
;
3537 if (gfc_match_char ('(') != MATCH_YES
)
3542 if (match_case_selector (&c
) == MATCH_ERROR
)
3552 if (gfc_match_char (')') == MATCH_YES
)
3554 if (gfc_match_char (',') != MATCH_YES
)
3558 m
= match_case_eos ();
3561 if (m
== MATCH_ERROR
)
3564 new_st
.op
= EXEC_SELECT
;
3565 new_st
.ext
.case_list
= head
;
3570 gfc_error ("Syntax error in CASE-specification at %C");
3573 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
3577 /********************* WHERE subroutines ********************/
3579 /* Match the rest of a simple WHERE statement that follows an IF statement.
3583 match_simple_where (void)
3589 m
= gfc_match (" ( %e )", &expr
);
3593 m
= gfc_match_assignment ();
3596 if (m
== MATCH_ERROR
)
3599 if (gfc_match_eos () != MATCH_YES
)
3602 c
= gfc_get_code ();
3606 c
->next
= gfc_get_code ();
3609 gfc_clear_new_st ();
3611 new_st
.op
= EXEC_WHERE
;
3617 gfc_syntax_error (ST_WHERE
);
3620 gfc_free_expr (expr
);
3625 /* Match a WHERE statement. */
3628 gfc_match_where (gfc_statement
*st
)
3634 m0
= gfc_match_label ();
3635 if (m0
== MATCH_ERROR
)
3638 m
= gfc_match (" where ( %e )", &expr
);
3642 if (gfc_match_eos () == MATCH_YES
)
3644 *st
= ST_WHERE_BLOCK
;
3645 new_st
.op
= EXEC_WHERE
;
3650 m
= gfc_match_assignment ();
3652 gfc_syntax_error (ST_WHERE
);
3656 gfc_free_expr (expr
);
3660 /* We've got a simple WHERE statement. */
3662 c
= gfc_get_code ();
3666 c
->next
= gfc_get_code ();
3669 gfc_clear_new_st ();
3671 new_st
.op
= EXEC_WHERE
;
3678 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3679 new_st if successful. */
3682 gfc_match_elsewhere (void)
3684 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3688 if (gfc_current_state () != COMP_WHERE
)
3690 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3696 if (gfc_match_char ('(') == MATCH_YES
)
3698 m
= gfc_match_expr (&expr
);
3701 if (m
== MATCH_ERROR
)
3704 if (gfc_match_char (')') != MATCH_YES
)
3708 if (gfc_match_eos () != MATCH_YES
)
3710 /* Only makes sense if we have a where-construct-name. */
3711 if (!gfc_current_block ())
3716 /* Better be a name at this point. */
3717 m
= gfc_match_name (name
);
3720 if (m
== MATCH_ERROR
)
3723 if (gfc_match_eos () != MATCH_YES
)
3726 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3728 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3729 name
, gfc_current_block ()->name
);
3734 new_st
.op
= EXEC_WHERE
;
3739 gfc_syntax_error (ST_ELSEWHERE
);
3742 gfc_free_expr (expr
);
3747 /******************** FORALL subroutines ********************/
3749 /* Free a list of FORALL iterators. */
3752 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
3754 gfc_forall_iterator
*next
;
3759 gfc_free_expr (iter
->var
);
3760 gfc_free_expr (iter
->start
);
3761 gfc_free_expr (iter
->end
);
3762 gfc_free_expr (iter
->stride
);
3769 /* Match an iterator as part of a FORALL statement. The format is:
3771 <var> = <start>:<end>[:<stride>]
3773 On MATCH_NO, the caller tests for the possibility that there is a
3774 scalar mask expression. */
3777 match_forall_iterator (gfc_forall_iterator
**result
)
3779 gfc_forall_iterator
*iter
;
3783 where
= gfc_current_locus
;
3784 iter
= XCNEW (gfc_forall_iterator
);
3786 m
= gfc_match_expr (&iter
->var
);
3790 if (gfc_match_char ('=') != MATCH_YES
3791 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
3797 m
= gfc_match_expr (&iter
->start
);
3801 if (gfc_match_char (':') != MATCH_YES
)
3804 m
= gfc_match_expr (&iter
->end
);
3807 if (m
== MATCH_ERROR
)
3810 if (gfc_match_char (':') == MATCH_NO
)
3811 iter
->stride
= gfc_int_expr (1);
3814 m
= gfc_match_expr (&iter
->stride
);
3817 if (m
== MATCH_ERROR
)
3821 /* Mark the iteration variable's symbol as used as a FORALL index. */
3822 iter
->var
->symtree
->n
.sym
->forall_index
= true;
3828 gfc_error ("Syntax error in FORALL iterator at %C");
3833 gfc_current_locus
= where
;
3834 gfc_free_forall_iterator (iter
);
3839 /* Match the header of a FORALL statement. */
3842 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
3844 gfc_forall_iterator
*head
, *tail
, *new_iter
;
3848 gfc_gobble_whitespace ();
3853 if (gfc_match_char ('(') != MATCH_YES
)
3856 m
= match_forall_iterator (&new_iter
);
3857 if (m
== MATCH_ERROR
)
3862 head
= tail
= new_iter
;
3866 if (gfc_match_char (',') != MATCH_YES
)
3869 m
= match_forall_iterator (&new_iter
);
3870 if (m
== MATCH_ERROR
)
3875 tail
->next
= new_iter
;
3880 /* Have to have a mask expression. */
3882 m
= gfc_match_expr (&msk
);
3885 if (m
== MATCH_ERROR
)
3891 if (gfc_match_char (')') == MATCH_NO
)
3899 gfc_syntax_error (ST_FORALL
);
3902 gfc_free_expr (msk
);
3903 gfc_free_forall_iterator (head
);
3908 /* Match the rest of a simple FORALL statement that follows an
3912 match_simple_forall (void)
3914 gfc_forall_iterator
*head
;
3923 m
= match_forall_header (&head
, &mask
);
3930 m
= gfc_match_assignment ();
3932 if (m
== MATCH_ERROR
)
3936 m
= gfc_match_pointer_assignment ();
3937 if (m
== MATCH_ERROR
)
3943 c
= gfc_get_code ();
3945 c
->loc
= gfc_current_locus
;
3947 if (gfc_match_eos () != MATCH_YES
)
3950 gfc_clear_new_st ();
3951 new_st
.op
= EXEC_FORALL
;
3953 new_st
.ext
.forall_iterator
= head
;
3954 new_st
.block
= gfc_get_code ();
3956 new_st
.block
->op
= EXEC_FORALL
;
3957 new_st
.block
->next
= c
;
3962 gfc_syntax_error (ST_FORALL
);
3965 gfc_free_forall_iterator (head
);
3966 gfc_free_expr (mask
);
3972 /* Match a FORALL statement. */
3975 gfc_match_forall (gfc_statement
*st
)
3977 gfc_forall_iterator
*head
;
3986 m0
= gfc_match_label ();
3987 if (m0
== MATCH_ERROR
)
3990 m
= gfc_match (" forall");
3994 m
= match_forall_header (&head
, &mask
);
3995 if (m
== MATCH_ERROR
)
4000 if (gfc_match_eos () == MATCH_YES
)
4002 *st
= ST_FORALL_BLOCK
;
4003 new_st
.op
= EXEC_FORALL
;
4005 new_st
.ext
.forall_iterator
= head
;
4009 m
= gfc_match_assignment ();
4010 if (m
== MATCH_ERROR
)
4014 m
= gfc_match_pointer_assignment ();
4015 if (m
== MATCH_ERROR
)
4021 c
= gfc_get_code ();
4023 c
->loc
= gfc_current_locus
;
4025 gfc_clear_new_st ();
4026 new_st
.op
= EXEC_FORALL
;
4028 new_st
.ext
.forall_iterator
= head
;
4029 new_st
.block
= gfc_get_code ();
4030 new_st
.block
->op
= EXEC_FORALL
;
4031 new_st
.block
->next
= c
;
4037 gfc_syntax_error (ST_FORALL
);
4040 gfc_free_forall_iterator (head
);
4041 gfc_free_expr (mask
);
4042 gfc_free_statements (c
);